From 9ebf44d84754adc5b64fcf612c6816c02c80462d Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Sat, 2 Feb 2019 19:29:23 -0500 Subject: Imported Upstream version 8.9.0 --- plugins/.merlin | 1 - plugins/.merlin.in | 1 + plugins/btauto/Algebra.v | 24 +- plugins/btauto/g_btauto.ml4 | 18 - plugins/btauto/g_btauto.mlg | 22 + plugins/btauto/refl_btauto.ml | 30 +- plugins/cc/ccalgo.ml | 20 +- plugins/cc/cctac.ml | 15 +- plugins/cc/g_congruence.ml4 | 29 - plugins/cc/g_congruence.mlg | 33 + plugins/derive/derive.ml | 2 +- plugins/extraction/ExtrHaskellString.v | 2 + plugins/extraction/ExtrOcamlString.v | 1 + plugins/extraction/common.mli | 3 +- plugins/extraction/extract_env.ml | 15 +- plugins/extraction/extract_env.mli | 11 +- plugins/extraction/extraction.ml | 22 +- plugins/extraction/miniml.ml | 25 +- plugins/extraction/miniml.mli | 25 +- plugins/extraction/mlutil.ml | 26 +- plugins/extraction/mlutil.mli | 5 +- plugins/extraction/modutil.ml | 2 +- plugins/extraction/modutil.mli | 7 +- plugins/extraction/table.ml | 8 +- plugins/extraction/table.mli | 77 +- plugins/firstorder/formula.ml | 2 +- plugins/firstorder/formula.mli | 8 +- plugins/firstorder/g_ground.ml4 | 3 +- plugins/firstorder/ground.ml | 16 +- plugins/firstorder/instances.ml | 7 +- plugins/firstorder/instances.mli | 4 +- plugins/firstorder/rules.ml | 4 +- plugins/firstorder/rules.mli | 9 +- plugins/firstorder/sequent.ml | 32 +- plugins/firstorder/sequent.mli | 22 +- plugins/firstorder/unify.ml | 6 +- plugins/fourier/Fourier.v | 20 - plugins/fourier/Fourier_util.v | 222 ---- plugins/fourier/fourier.ml | 204 ---- plugins/fourier/fourierR.ml | 644 ---------- plugins/fourier/fourier_plugin.mlpack | 3 - plugins/fourier/g_fourier.ml4 | 18 - plugins/funind/functional_principles_proofs.ml | 60 +- plugins/funind/functional_principles_types.ml | 36 +- plugins/funind/functional_principles_types.mli | 4 +- plugins/funind/g_indfun.ml4 | 15 +- plugins/funind/glob_term_to_relation.ml | 11 +- plugins/funind/glob_termops.ml | 25 +- plugins/funind/glob_termops.mli | 2 +- plugins/funind/indfun.ml | 63 +- plugins/funind/indfun.mli | 5 +- plugins/funind/indfun_common.ml | 38 +- plugins/funind/indfun_common.mli | 14 +- plugins/funind/invfun.ml | 32 +- plugins/funind/invfun.mli | 4 +- plugins/funind/recdef.ml | 52 +- plugins/funind/recdef.mli | 2 +- plugins/ltac/coretactics.ml4 | 366 ------ plugins/ltac/coretactics.mlg | 388 +++++++ plugins/ltac/evar_tactics.ml | 10 +- plugins/ltac/extraargs.ml4 | 51 +- plugins/ltac/extraargs.mli | 23 +- plugins/ltac/extratactics.ml4 | 137 +-- plugins/ltac/g_auto.ml4 | 9 +- plugins/ltac/g_eqdecide.ml4 | 28 - plugins/ltac/g_eqdecide.mlg | 32 + plugins/ltac/g_ltac.ml4 | 69 +- plugins/ltac/g_obligations.ml4 | 5 +- plugins/ltac/g_rewrite.ml4 | 8 +- plugins/ltac/g_tactic.ml4 | 698 ----------- plugins/ltac/g_tactic.mlg | 706 +++++++++++ plugins/ltac/pltac.ml | 9 +- plugins/ltac/pltac.mli | 40 +- plugins/ltac/pptactic.ml | 83 +- plugins/ltac/pptactic.mli | 10 +- plugins/ltac/rewrite.ml | 60 +- plugins/ltac/rewrite.mli | 4 +- plugins/ltac/tacarg.ml | 8 + plugins/ltac/tacarg.mli | 34 +- plugins/ltac/taccoerce.ml | 38 +- plugins/ltac/taccoerce.mli | 18 +- plugins/ltac/tacentries.ml | 87 +- plugins/ltac/tacentries.mli | 21 +- plugins/ltac/tacenv.ml | 49 +- plugins/ltac/tacenv.mli | 18 +- plugins/ltac/tacexpr.ml | 54 +- plugins/ltac/tacexpr.mli | 54 +- plugins/ltac/tacintern.ml | 164 +-- plugins/ltac/tacintern.mli | 2 +- plugins/ltac/tacinterp.ml | 99 +- plugins/ltac/tacinterp.mli | 5 +- plugins/ltac/tacsubst.ml | 7 +- plugins/ltac/tacsubst.mli | 2 +- plugins/ltac/tactic_debug.ml | 18 +- plugins/ltac/tactic_debug.mli | 2 +- plugins/ltac/tactic_matching.ml | 2 +- plugins/ltac/tauto.ml | 11 +- plugins/micromega/Fourier.v | 5 + plugins/micromega/Fourier_util.v | 31 + plugins/micromega/Tauto.v | 4 +- plugins/micromega/certificate.ml | 194 +--- plugins/micromega/certificate.mli | 22 + plugins/micromega/coq_micromega.ml | 323 +----- plugins/micromega/coq_micromega.mli | 22 + plugins/micromega/csdpcert.ml | 36 +- plugins/micromega/csdpcert.mli | 9 + plugins/micromega/g_micromega.ml4 | 85 -- plugins/micromega/g_micromega.mlg | 89 ++ plugins/micromega/g_micromega.mli | 9 + plugins/micromega/mfourier.ml | 85 +- plugins/micromega/mfourier.mli | 49 + plugins/micromega/mutils.ml | 109 -- plugins/micromega/mutils.mli | 70 ++ plugins/micromega/persistent_cache.mli | 47 + plugins/micromega/polynomial.ml | 68 +- plugins/micromega/polynomial.mli | 118 ++ plugins/micromega/sos.ml | 616 +--------- plugins/micromega/sos_lib.ml | 105 +- plugins/micromega/sos_lib.mli | 79 ++ plugins/nsatz/g_nsatz.ml4 | 18 - plugins/nsatz/g_nsatz.mlg | 22 + plugins/nsatz/nsatz.ml | 2 +- plugins/omega/PreOmega.v | 8 +- plugins/omega/coq_omega.ml | 23 +- plugins/omega/g_omega.ml4 | 56 - plugins/omega/g_omega.mlg | 59 + plugins/omega/omega.ml | 2 +- plugins/quote/g_quote.ml4 | 39 - plugins/quote/g_quote.mlg | 46 + plugins/quote/quote.ml | 2 +- plugins/romega/const_omega.ml | 10 +- plugins/romega/g_romega.ml4 | 51 - plugins/romega/g_romega.mlg | 63 + plugins/romega/refl_omega.ml | 5 +- plugins/rtauto/g_rtauto.ml4 | 19 - plugins/rtauto/g_rtauto.mlg | 22 + plugins/rtauto/refl_tauto.ml | 8 +- plugins/setoid_ring/g_newring.ml4 | 9 +- plugins/setoid_ring/newring.ml | 196 ++-- plugins/setoid_ring/newring.mli | 3 - plugins/setoid_ring/newring_ast.ml | 2 +- plugins/setoid_ring/newring_ast.mli | 2 +- plugins/ssr/ssrast.mli | 6 +- plugins/ssr/ssrbool.v | 936 +++++++-------- plugins/ssr/ssrcommon.ml | 43 +- plugins/ssr/ssrcommon.mli | 4 +- plugins/ssr/ssreflect.v | 439 +++---- plugins/ssr/ssrelim.ml | 7 +- plugins/ssr/ssrequality.ml | 32 +- plugins/ssr/ssrfun.v | 487 ++++---- plugins/ssr/ssrfwd.ml | 15 +- plugins/ssr/ssripats.ml | 85 +- plugins/ssr/ssrparser.ml4 | 74 +- plugins/ssr/ssrparser.mli | 8 +- plugins/ssr/ssrprinters.ml | 5 +- plugins/ssr/ssrtacticals.ml | 15 +- plugins/ssr/ssrtacticals.mli | 4 +- plugins/ssr/ssrvernac.ml4 | 38 +- plugins/ssr/ssrview.ml | 99 +- plugins/ssr/ssrview.mli | 6 +- plugins/ssrmatching/g_ssrmatching.ml4 | 101 ++ plugins/ssrmatching/ssrmatching.ml | 1428 +++++++++++++++++++++++ plugins/ssrmatching/ssrmatching.ml4 | 1484 ------------------------ plugins/ssrmatching/ssrmatching.mli | 258 ++++ plugins/ssrmatching/ssrmatching.v | 36 + plugins/ssrmatching/ssrmatching_plugin.mlpack | 1 + plugins/syntax/ascii_syntax.ml | 20 +- plugins/syntax/g_numeral.ml4 | 38 + plugins/syntax/int31_syntax.ml | 23 +- plugins/syntax/nat_syntax.ml | 84 -- plugins/syntax/nat_syntax_plugin.mlpack | 1 - plugins/syntax/numeral.ml | 142 +++ plugins/syntax/numeral.mli | 17 + plugins/syntax/numeral_notation_plugin.mlpack | 2 + plugins/syntax/r_syntax.ml | 28 +- plugins/syntax/string_syntax.ml | 25 +- plugins/syntax/z_syntax.ml | 202 ---- plugins/syntax/z_syntax_plugin.mlpack | 1 - 178 files changed, 6506 insertions(+), 7970 deletions(-) delete mode 100644 plugins/.merlin create mode 100644 plugins/.merlin.in delete mode 100644 plugins/btauto/g_btauto.ml4 create mode 100644 plugins/btauto/g_btauto.mlg delete mode 100644 plugins/cc/g_congruence.ml4 create mode 100644 plugins/cc/g_congruence.mlg delete mode 100644 plugins/fourier/Fourier.v delete mode 100644 plugins/fourier/Fourier_util.v delete mode 100644 plugins/fourier/fourier.ml delete mode 100644 plugins/fourier/fourierR.ml delete mode 100644 plugins/fourier/fourier_plugin.mlpack delete mode 100644 plugins/fourier/g_fourier.ml4 delete mode 100644 plugins/ltac/coretactics.ml4 create mode 100644 plugins/ltac/coretactics.mlg delete mode 100644 plugins/ltac/g_eqdecide.ml4 create mode 100644 plugins/ltac/g_eqdecide.mlg delete mode 100644 plugins/ltac/g_tactic.ml4 create mode 100644 plugins/ltac/g_tactic.mlg create mode 100644 plugins/micromega/Fourier.v create mode 100644 plugins/micromega/Fourier_util.v create mode 100644 plugins/micromega/certificate.mli create mode 100644 plugins/micromega/coq_micromega.mli create mode 100644 plugins/micromega/csdpcert.mli delete mode 100644 plugins/micromega/g_micromega.ml4 create mode 100644 plugins/micromega/g_micromega.mlg create mode 100644 plugins/micromega/g_micromega.mli create mode 100644 plugins/micromega/mfourier.mli create mode 100644 plugins/micromega/mutils.mli create mode 100644 plugins/micromega/persistent_cache.mli create mode 100644 plugins/micromega/polynomial.mli create mode 100644 plugins/micromega/sos_lib.mli delete mode 100644 plugins/nsatz/g_nsatz.ml4 create mode 100644 plugins/nsatz/g_nsatz.mlg delete mode 100644 plugins/omega/g_omega.ml4 create mode 100644 plugins/omega/g_omega.mlg delete mode 100644 plugins/quote/g_quote.ml4 create mode 100644 plugins/quote/g_quote.mlg delete mode 100644 plugins/romega/g_romega.ml4 create mode 100644 plugins/romega/g_romega.mlg delete mode 100644 plugins/rtauto/g_rtauto.ml4 create mode 100644 plugins/rtauto/g_rtauto.mlg create mode 100644 plugins/ssrmatching/g_ssrmatching.ml4 create mode 100644 plugins/ssrmatching/ssrmatching.ml delete mode 100644 plugins/ssrmatching/ssrmatching.ml4 create mode 100644 plugins/ssrmatching/ssrmatching.mli create mode 100644 plugins/ssrmatching/ssrmatching.v create mode 100644 plugins/syntax/g_numeral.ml4 delete mode 100644 plugins/syntax/nat_syntax.ml delete mode 100644 plugins/syntax/nat_syntax_plugin.mlpack create mode 100644 plugins/syntax/numeral.ml create mode 100644 plugins/syntax/numeral.mli create mode 100644 plugins/syntax/numeral_notation_plugin.mlpack delete mode 100644 plugins/syntax/z_syntax.ml delete mode 100644 plugins/syntax/z_syntax_plugin.mlpack (limited to 'plugins') diff --git a/plugins/.merlin b/plugins/.merlin deleted file mode 100644 index 2ba61696..00000000 --- a/plugins/.merlin +++ /dev/null @@ -1 +0,0 @@ -REC diff --git a/plugins/.merlin.in b/plugins/.merlin.in new file mode 100644 index 00000000..2ba61696 --- /dev/null +++ b/plugins/.merlin.in @@ -0,0 +1 @@ +REC diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index ee7341a4..f1095fc9 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -1,4 +1,4 @@ -Require Import Bool PArith DecidableClass Omega ROmega. +Require Import Bool PArith DecidableClass Omega Lia. Ltac bool := repeat match goal with @@ -84,9 +84,9 @@ Ltac case_decide := match goal with let H := fresh "H" in define (@decide P D) b H; destruct b; try_decide | [ |- context [Pos.compare ?x ?y] ] => - destruct (Pos.compare_spec x y); try (exfalso; zify; romega) + destruct (Pos.compare_spec x y); try lia | [ X : context [Pos.compare ?x ?y] |- _ ] => - destruct (Pos.compare_spec x y); try (exfalso; zify; romega) + destruct (Pos.compare_spec x y); try lia end. Section Definitions. @@ -325,13 +325,13 @@ Qed. Lemma linear_le_compat : forall k l p, linear k p -> (k <= l)%positive -> linear l p. Proof. -intros k l p H; revert l; induction H; constructor; eauto; zify; romega. +intros k l p H; revert l; induction H; constructor; eauto; lia. Qed. Lemma linear_valid_incl : forall k p, linear k p -> valid k p. Proof. intros k p H; induction H; constructor; auto. -eapply valid_le_compat; eauto; zify; romega. +eapply valid_le_compat; eauto; lia. Qed. End Validity. @@ -417,13 +417,13 @@ Qed. Hint Extern 5 => match goal with | [ |- (Pos.max ?x ?y <= ?z)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | [ |- (?z <= Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | [ |- (Pos.max ?x ?y < ?z)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | [ |- (?z < Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | _ => zify; omega end. Hint Resolve Pos.le_max_r Pos.le_max_l. @@ -445,8 +445,8 @@ intros kl kr pl pr Hl Hr; revert kr pr Hr; induction Hl; intros kr pr Hr; simpl. now rewrite <- (Pos.max_id i); intuition. destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. - + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; zify; romega. - + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; zify; romega. + + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; lia. + + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; lia. + apply (valid_le_compat (Pos.max (Pos.succ i) i0)); intuition. + apply (valid_le_compat (Pos.max i (Pos.succ i0))); intuition. } @@ -456,7 +456,7 @@ Lemma poly_mul_cst_valid_compat : forall k v p, valid k p -> valid k (poly_mul_c Proof. intros k v p H; induction H; simpl; [now auto|]. case_decide; [|now auto]. -eapply (valid_le_compat i); [now auto|zify; romega]. +eapply (valid_le_compat i); [now auto|lia]. Qed. Lemma poly_mul_mon_null_compat : forall i p, null (poly_mul_mon i p) -> null p. diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4 deleted file mode 100644 index 3ae0f45c..00000000 --- a/plugins/btauto/g_btauto.ml4 +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* [ Refl_btauto.Btauto.tac ] -END - diff --git a/plugins/btauto/g_btauto.mlg b/plugins/btauto/g_btauto.mlg new file mode 100644 index 00000000..312ef1e5 --- /dev/null +++ b/plugins/btauto/g_btauto.mlg @@ -0,0 +1,22 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* { Refl_btauto.Btauto.tac } +END + diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index a09abfa1..c2bc8c07 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -1,12 +1,24 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* + | App (head, args) -> if head === andb && Array.length args = 2 then Andb (aux args.(0), aux args.(1)) else if head === orb && Array.length args = 2 then @@ -116,9 +128,9 @@ module Bool = struct else if head === negb && Array.length args = 1 then Negb (aux args.(0)) else Var (Env.add env c) - | Term.Case (info, r, arg, pats) -> + | Case (info, r, arg, pats) -> let is_bool = - let i = info.Term.ci_ind in + let i = info.ci_ind in Names.eq_ind i (Lazy.force ind) in if is_bool then @@ -176,9 +188,9 @@ module Btauto = struct let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in let var = EConstr.Unsafe.to_constr var in let rec to_list l = match decomp_term (Tacmach.project gl) l with - | Term.App (c, _) + | App (c, _) when c === (Lazy.force CoqList._nil) -> [] - | Term.App (c, [|_; h; t|]) + | App (c, [|_; h; t|]) when c === (Lazy.force CoqList._cons) -> if h === (Lazy.force Bool.trueb) then (true :: to_list t) else if h === (Lazy.force Bool.falseb) then (false :: to_list t) @@ -218,7 +230,7 @@ module Btauto = struct 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 -> + | App (c, [|typ; p; _|]) when c === eq -> (* should be an equality [@eq poly ?p (Cst false)] *) let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (Proofview.V82.tactic (print_counterexample p env)) in tac @@ -236,7 +248,7 @@ module Btauto = struct let bool = Lazy.force Bool.typ in let t = decomp_term sigma concl in match t with - | Term.App (c, [|typ; tl; tr|]) + | App (c, [|typ; tl; tr|]) when typ === bool && c === eq -> let env = Env.empty () in let fl = Bool.quote env sigma tl in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 8e53a044..f26ec0f4 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -26,6 +26,10 @@ let init_size=5 let cc_verbose=ref false +let print_constr t = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_econstr_env env sigma t + let debug x = if !cc_verbose then Feedback.msg_debug (x ()) @@ -130,8 +134,8 @@ type cinfo= ci_nhyps: int} (* # projectable args *) let family_eq f1 f2 = match f1, f2 with - | Prop Pos, Prop Pos - | Prop Null, Prop Null + | Set, Set + | Prop, Prop | Type _, Type _ -> true | _ -> false @@ -457,10 +461,10 @@ let rec canonize_name sigma c = | LetIn (na,b,t,ct) -> mkLetIn (na, func b,func t,func ct) | App (ct,l) -> - mkApp (func ct,Array.smartmap func l) + mkApp (func ct,Array.Smart.map func l) | Proj(p,c) -> let p' = Projection.map (fun kn -> - Constant.make1 (Constant.canonical kn)) p in + MutInd.make1 (MutInd.canonical kn)) p in (mkProj (p', func c)) | _ -> c @@ -483,10 +487,10 @@ let rec inst_pattern subst = function args t let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++ - Termops.print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" + print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" let pr_term t = str "[" ++ - Termops.print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" + print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" let rec add_term state t= let uf=state.uf in @@ -601,7 +605,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 (EConstr.of_constr prf) ++ str " : " ++ + (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " == " ++ pr_term t ++ str "]")); add_equality state prf s t end @@ -609,7 +613,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 (EConstr.of_constr prf) ++ str " : " ++ + (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")); add_disequality state (Hyp prf) s t end diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index d19817e7..2eaa6146 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -49,7 +49,7 @@ let whd_delta env sigma t = (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) -let sf_of env sigma c = e_sort_of env (ref sigma) c +let sf_of env sigma c = snd (sort_of env sigma c) let rec decompose_term env sigma t= match EConstr.kind sigma (whd env sigma t) with @@ -84,13 +84,13 @@ let rec decompose_term env sigma t= let canon_const = Constant.make1 (Constant.canonical c) in (Symb (Constr.mkConstU (canon_const,u))) | Proj (p, c) -> - let canon_const kn = Constant.make1 (Constant.canonical kn) in - let p' = Projection.map canon_const p in + let canon_mind kn = MutInd.make1 (MutInd.canonical kn) in + let p' = Projection.map canon_mind p in let c = Retyping.expand_projection env sigma p' c [] in decompose_term env sigma c | _ -> let t = Termops.strip_outer_cast sigma t in - if closed0 sigma t then Symb (EConstr.to_constr sigma t) else raise Not_found + if closed0 sigma t then Symb (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) else raise Not_found (* decompose equality in members and type *) open Termops @@ -264,9 +264,8 @@ let app_global_with_holes f args n = 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 - (!evdref, ans) + let sigma = Typing.check env sigma ans concl in + (sigma, ans) end end @@ -444,7 +443,7 @@ let cc_tactic depth additionnal_terms = let open Glob_term in let env = Proofview.Goal.env gl in let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in + let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in let pr_missing (c, missing) = let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in let holes = List.init missing (fun _ -> hole) in diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 deleted file mode 100644 index fb013ac1..00000000 --- a/plugins/cc/g_congruence.ml4 +++ /dev/null @@ -1,29 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* [ congruence_tac 1000 [] ] - |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] - |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] - |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> - [ congruence_tac n l ] -END - -TACTIC EXTEND f_equal - [ "f_equal" ] -> [ f_equal ] -END diff --git a/plugins/cc/g_congruence.mlg b/plugins/cc/g_congruence.mlg new file mode 100644 index 00000000..68505929 --- /dev/null +++ b/plugins/cc/g_congruence.mlg @@ -0,0 +1,33 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* { congruence_tac 1000 [] } +| [ "congruence" integer(n) ] -> { congruence_tac n [] } +| [ "congruence" "with" ne_constr_list(l) ] -> { congruence_tac 1000 l } + |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> + { congruence_tac n l } +END + +TACTIC EXTEND f_equal +| [ "f_equal" ] -> { f_equal } +END diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 8a55538b..480819eb 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -61,7 +61,7 @@ let start_deriving f suchthat lemma = | Proved (opaque, None, obj) -> match Proof_global.(obj.entries) with | [_;f_def;lemma_def] -> - opaque <> Vernacexpr.Transparent , f_def , lemma_def + opaque <> Proof_global.Transparent , f_def , lemma_def | _ -> assert false in (** The opacity of [f_def] is adjusted to be [false], as it diff --git a/plugins/extraction/ExtrHaskellString.v b/plugins/extraction/ExtrHaskellString.v index ac1f6f91..a4a40d3c 100644 --- a/plugins/extraction/ExtrHaskellString.v +++ b/plugins/extraction/ExtrHaskellString.v @@ -35,6 +35,8 @@ Extract Inductive ascii => "Prelude.Char" (Data.Bits.testBit (Data.Char.ord a) 6) (Data.Bits.testBit (Data.Char.ord a) 7))". Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)". +Extract Inlined Constant Ascii.eqb => "(Prelude.==)". Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. Extract Inlined Constant String.string_dec => "(Prelude.==)". +Extract Inlined Constant String.eqb => "(Prelude.==)". diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index 030b486b..a2a6a8fe 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -33,6 +33,7 @@ Extract Constant shift => "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". Extract Inlined Constant ascii_dec => "(=)". +Extract Inlined Constant Ascii.eqb => "(=)". Extract Inductive string => "char list" [ "[]" "(::)" ]. diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 78545c8b..07237d75 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Miniml (** By default, in module Format, you can do horizontal placing of blocks @@ -54,7 +53,7 @@ val opened_libraries : unit -> ModPath.t list type kind = Term | Type | Cons | Mod -val pp_global : kind -> global_reference -> string +val pp_global : kind -> GlobRef.t -> string val pp_module : ModPath.t -> string val top_visible_mp : unit -> ModPath.t diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 397cb292..4ede11b5 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -79,7 +79,7 @@ module type VISIT = sig (* Add reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) - val add_ref : global_reference -> unit + val add_ref : GlobRef.t -> unit val add_kn : KerName.t -> unit val add_decl_deps : ml_decl -> unit val add_spec_deps : ml_spec -> unit @@ -596,19 +596,18 @@ let warns () = let rec locate_ref = function | [] -> [],[] - | r::l -> - let q = qualid_of_reference r in - let mpo = try Some (Nametab.locate_module q.CAst.v) with Not_found -> None + | qid::l -> + let mpo = try Some (Nametab.locate_module qid) with Not_found -> None and ro = - try Some (Smartlocate.global_with_alias r) + try Some (Smartlocate.global_with_alias qid) with Nametab.GlobalizationError _ | UserError _ -> None in match mpo, ro with - | None, None -> Nametab.error_global_not_found q + | None, None -> Nametab.error_global_not_found qid | None, Some r -> let refs,mps = locate_ref l in r::refs,mps | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps | Some mp, Some r -> - warning_ambiguous_name (q.CAst.v,mp,r); + warning_ambiguous_name (qid,mp,r); let refs,mps = locate_ref l in refs,mp::mps (*s Recursive extraction in the Coq toplevel. The vernacular command is @@ -646,7 +645,7 @@ let separate_extraction lr = is \verb!Extraction! [qualid]. *) let simple_extraction r = - Vernacentries.dump_global CAst.(make (Misctypes.AN r)); + Vernacentries.dump_global CAst.(make (Constrexpr.AN r)); match locate_ref [r] with | ([], [mp]) as p -> full_extr None p | [r],[] -> diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 591d3bb8..54fde2ca 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -12,21 +12,20 @@ open Names open Libnames -open Globnames -val simple_extraction : reference -> unit -val full_extraction : string option -> reference list -> unit -val separate_extraction : reference list -> unit +val simple_extraction : qualid -> unit +val full_extraction : string option -> qualid list -> unit +val separate_extraction : qualid list -> unit val extraction_library : bool -> Id.t -> unit (* For the test-suite : extraction to a temporary file + ocamlc on it *) -val extract_and_compile : reference list -> unit +val extract_and_compile : qualid list -> unit (* For debug / external output via coqtop.byte + Drop : *) val mono_environment : - global_reference list -> ModPath.t list -> Miniml.ml_structure + GlobRef.t list -> ModPath.t list -> Miniml.ml_structure (* Used by the Relation Extraction plugin *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index f25f6362..67c605ea 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -431,7 +431,7 @@ and extract_really_ind env kn mib = let packets = Array.mapi (fun i mip -> - let (_,u),_ = Universes.fresh_inductive_instance env (kn,i) in + let (_,u),_ = UnivGen.fresh_inductive_instance env (kn,i) in let ar = Inductive.type_of_inductive env ((mib,mip),u) in let ar = EConstr.of_constr ar in let info = (fst (flag_of_type env sg ar) = Info) in @@ -488,7 +488,7 @@ and extract_really_ind env kn mib = Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); if List.is_empty l then raise (I Standard); - if Option.is_empty mib.mind_record then raise (I Standard); + if mib.mind_record == Declarations.NotRecord then raise (I Standard); (* Now we're sure it's a record. *) (* First, we find its field names. *) let rec names_prod t = match Constr.kind t with @@ -1065,9 +1065,14 @@ let extract_constant env kn cb = (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () | Def c -> - (match cb.const_proj with + (match Recordops.find_primitive_projection kn with | None -> mk_typ (get_body c) - | Some pb -> mk_typ (EConstr.of_constr pb.proj_body)) + | Some p -> + let p = Projection.make p false in + let ind = Projection.inductive p in + let bodies = Inductiveops.legacy_match_projection env ind in + let body = bodies.(Projection.arg p) in + mk_typ (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_typ (get_opaque env c) @@ -1076,9 +1081,14 @@ let extract_constant env kn cb = (match cb.const_body with | Undef _ -> warn_info (); mk_ax () | Def c -> - (match cb.const_proj with + (match Recordops.find_primitive_projection kn with | None -> mk_def (get_body c) - | Some pb -> mk_def (EConstr.of_constr pb.proj_body)) + | Some p -> + let p = Projection.make p false in + let ind = Projection.inductive p in + let bodies = Inductiveops.legacy_match_projection env ind in + let body = bodies.(Projection.arg p) in + mk_def (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_def (get_opaque env c) diff --git a/plugins/extraction/miniml.ml b/plugins/extraction/miniml.ml index e1e49d92..ce920ad6 100644 --- a/plugins/extraction/miniml.ml +++ b/plugins/extraction/miniml.ml @@ -11,7 +11,6 @@ (*s Target language for extraction: a core ML called MiniML. *) open Names -open Globnames (* The [signature] type is used to know how many arguments a CIC object expects, and what these arguments will become in the ML @@ -26,7 +25,7 @@ open Globnames type kill_reason = | Ktype | Kprop - | Kimplicit of global_reference * int (* n-th arg of a cst or construct *) + | Kimplicit of GlobRef.t * int (* n-th arg of a cst or construct *) type sign = Keep | Kill of kill_reason @@ -39,7 +38,7 @@ type signature = sign list type ml_type = | Tarr of ml_type * ml_type - | Tglob of global_reference * ml_type list + | Tglob of GlobRef.t * ml_type list | Tvar of int | Tvar' of int (* same as Tvar, used to avoid clash *) | Tmeta of ml_meta (* used during ML type reconstruction *) @@ -60,7 +59,7 @@ type inductive_kind = | Singleton | Coinductive | Standard - | Record of global_reference option list (* None for anonymous field *) + | Record of GlobRef.t option list (* None for anonymous field *) (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. If the inductive is logical ([ip_logical = false]), then all other fields @@ -118,8 +117,8 @@ and ml_ast = | MLapp of ml_ast * ml_ast list | MLlam of ml_ident * ml_ast | MLletin of ml_ident * ml_ast * ml_ast - | MLglob of global_reference - | MLcons of ml_type * global_reference * ml_ast list + | MLglob of GlobRef.t + | MLcons of ml_type * GlobRef.t * ml_ast list | MLtuple of ml_ast list | MLcase of ml_type * ml_ast * ml_branch array | MLfix of int * Id.t array * ml_ast array @@ -129,24 +128,24 @@ and ml_ast = | MLmagic of ml_ast and ml_pattern = - | Pcons of global_reference * ml_pattern list + | Pcons of GlobRef.t * ml_pattern list | Ptuple of ml_pattern list | Prel of int (** Cf. the idents in the branch. [Prel 1] is the last one. *) | Pwild - | Pusual of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) + | Pusual of GlobRef.t (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) (*s ML declarations. *) type ml_decl = | Dind of MutInd.t * ml_ind - | Dtype of global_reference * Id.t list * ml_type - | Dterm of global_reference * ml_ast * ml_type - | Dfix of global_reference array * ml_ast array * ml_type array + | Dtype of GlobRef.t * Id.t list * ml_type + | Dterm of GlobRef.t * ml_ast * ml_type + | Dfix of GlobRef.t array * ml_ast array * ml_type array type ml_spec = | Sind of MutInd.t * ml_ind - | Stype of global_reference * Id.t list * ml_type option - | Sval of global_reference * ml_type + | Stype of GlobRef.t * Id.t list * ml_type option + | Sval of GlobRef.t * ml_type type ml_specif = | Spec of ml_spec diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index e1e49d92..ce920ad6 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -11,7 +11,6 @@ (*s Target language for extraction: a core ML called MiniML. *) open Names -open Globnames (* The [signature] type is used to know how many arguments a CIC object expects, and what these arguments will become in the ML @@ -26,7 +25,7 @@ open Globnames type kill_reason = | Ktype | Kprop - | Kimplicit of global_reference * int (* n-th arg of a cst or construct *) + | Kimplicit of GlobRef.t * int (* n-th arg of a cst or construct *) type sign = Keep | Kill of kill_reason @@ -39,7 +38,7 @@ type signature = sign list type ml_type = | Tarr of ml_type * ml_type - | Tglob of global_reference * ml_type list + | Tglob of GlobRef.t * ml_type list | Tvar of int | Tvar' of int (* same as Tvar, used to avoid clash *) | Tmeta of ml_meta (* used during ML type reconstruction *) @@ -60,7 +59,7 @@ type inductive_kind = | Singleton | Coinductive | Standard - | Record of global_reference option list (* None for anonymous field *) + | Record of GlobRef.t option list (* None for anonymous field *) (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. If the inductive is logical ([ip_logical = false]), then all other fields @@ -118,8 +117,8 @@ and ml_ast = | MLapp of ml_ast * ml_ast list | MLlam of ml_ident * ml_ast | MLletin of ml_ident * ml_ast * ml_ast - | MLglob of global_reference - | MLcons of ml_type * global_reference * ml_ast list + | MLglob of GlobRef.t + | MLcons of ml_type * GlobRef.t * ml_ast list | MLtuple of ml_ast list | MLcase of ml_type * ml_ast * ml_branch array | MLfix of int * Id.t array * ml_ast array @@ -129,24 +128,24 @@ and ml_ast = | MLmagic of ml_ast and ml_pattern = - | Pcons of global_reference * ml_pattern list + | Pcons of GlobRef.t * ml_pattern list | Ptuple of ml_pattern list | Prel of int (** Cf. the idents in the branch. [Prel 1] is the last one. *) | Pwild - | Pusual of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) + | Pusual of GlobRef.t (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) (*s ML declarations. *) type ml_decl = | Dind of MutInd.t * ml_ind - | Dtype of global_reference * Id.t list * ml_type - | Dterm of global_reference * ml_ast * ml_type - | Dfix of global_reference array * ml_ast array * ml_type array + | Dtype of GlobRef.t * Id.t list * ml_type + | Dterm of GlobRef.t * ml_ast * ml_type + | Dfix of GlobRef.t array * ml_ast array * ml_type array type ml_spec = | Sind of MutInd.t * ml_ind - | Stype of global_reference * Id.t list * ml_type option - | Sval of global_reference * ml_type + | Stype of GlobRef.t * Id.t list * ml_type option + | Sval of GlobRef.t * ml_type type ml_specif = | Spec of ml_spec diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 0656d487..9f5c1f1a 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -59,7 +59,7 @@ let rec eq_ml_type t1 t2 = match t1, t2 with | Tarr (tl1, tr1), Tarr (tl2, tr2) -> eq_ml_type tl1 tl2 && eq_ml_type tr1 tr2 | Tglob (gr1, t1), Tglob (gr2, t2) -> - eq_gr gr1 gr2 && List.equal eq_ml_type t1 t2 + GlobRef.equal gr1 gr2 && List.equal eq_ml_type t1 t2 | Tvar i1, Tvar i2 -> Int.equal i1 i2 | Tvar' i1, Tvar' i2 -> Int.equal i1 i2 | Tmeta m1, Tmeta m2 -> eq_ml_meta m1 m2 @@ -120,7 +120,7 @@ let rec mgu = function | None -> m.contents <- Some t) | Tarr(a, b), Tarr(a', b') -> mgu (a, a'); mgu (b, b') - | Tglob (r,l), Tglob (r',l') when Globnames.eq_gr r r' -> + | Tglob (r,l), Tglob (r',l') when GlobRef.equal r r' -> List.iter mgu (List.combine l l') | Tdummy _, Tdummy _ -> () | Tvar i, Tvar j when Int.equal i j -> () @@ -270,7 +270,7 @@ let rec var2var' = function | Tglob (r,l) -> Tglob (r, List.map var2var' l) | a -> a -type abbrev_map = global_reference -> ml_type option +type abbrev_map = GlobRef.t -> ml_type option (*s Delta-reduction of type constants everywhere in a ML type [t]. [env] is a function of type [ml_type_env]. *) @@ -381,9 +381,9 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with eq_ml_ident na1 na2 && eq_ml_ast t1 t2 | MLletin (na1, c1, t1), MLletin (na2, c2, t2) -> eq_ml_ident na1 na2 && eq_ml_ast c1 c2 && eq_ml_ast t1 t2 -| MLglob gr1, MLglob gr2 -> eq_gr gr1 gr2 +| MLglob gr1, MLglob gr2 -> GlobRef.equal gr1 gr2 | MLcons (t1, gr1, c1), MLcons (t2, gr2, c2) -> - eq_ml_type t1 t2 && eq_gr gr1 gr2 && List.equal eq_ml_ast c1 c2 + eq_ml_type t1 t2 && GlobRef.equal gr1 gr2 && List.equal eq_ml_ast c1 c2 | MLtuple t1, MLtuple t2 -> List.equal eq_ml_ast t1 t2 | MLcase (t1, c1, p1), MLcase (t2, c2, p2) -> @@ -398,13 +398,13 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with and eq_ml_pattern p1 p2 = match p1, p2 with | Pcons (gr1, p1), Pcons (gr2, p2) -> - eq_gr gr1 gr2 && List.equal eq_ml_pattern p1 p2 + GlobRef.equal gr1 gr2 && List.equal eq_ml_pattern p1 p2 | Ptuple p1, Ptuple p2 -> List.equal eq_ml_pattern p1 p2 | Prel i1, Prel i2 -> Int.equal i1 i2 | Pwild, Pwild -> true -| Pusual gr1, Pusual gr2 -> eq_gr gr1 gr2 +| Pusual gr1, Pusual gr2 -> GlobRef.equal gr1 gr2 | _ -> false and eq_ml_branch (id1, p1, t1) (id2, p2, t2) = @@ -541,24 +541,24 @@ let dump_unused_vars a = | MLcase (t,e,br) -> let e' = ren env e in - let br' = Array.smartmap (ren_branch env) br in + let br' = Array.Smart.map (ren_branch env) br in if e' == e && br' == br then a else MLcase (t,e',br') | MLfix (i,ids,v) -> let env' = List.init (Array.length ids) (fun _ -> ref false) @ env in - let v' = Array.smartmap (ren env') v in + let v' = Array.Smart.map (ren env') v in if v' == v then a else MLfix (i,ids,v') | MLapp (b,l) -> - let b' = ren env b and l' = List.smartmap (ren env) l in + let b' = ren env b and l' = List.Smart.map (ren env) l in if b' == b && l' == l then a else MLapp (b',l') | MLcons(t,r,l) -> - let l' = List.smartmap (ren env) l in + let l' = List.Smart.map (ren env) l in if l' == l then a else MLcons (t,r,l') | MLtuple l -> - let l' = List.smartmap (ren env) l in + let l' = List.Smart.map (ren env) l in if l' == l then a else MLtuple l' | MLmagic b -> @@ -984,7 +984,7 @@ let rec iota_red i lift br ((typ,r,a) as cons) = if i >= Array.length br then raise Impossible; let (ids,p,c) = br.(i) in match p with - | Pusual r' | Pcons (r',_) when not (Globnames.eq_gr r' r) -> iota_red (i+1) lift br cons + | Pusual r' | Pcons (r',_) when not (GlobRef.equal r' r) -> iota_red (i+1) lift br cons | Pusual r' -> let c = named_lams (List.rev ids) c in let c = ast_lift lift c diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 55a1ee89..d23fdb3d 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Miniml open Table @@ -59,7 +58,7 @@ val type_recomp : ml_type list * ml_type -> ml_type val var2var' : ml_type -> ml_type -type abbrev_map = global_reference -> ml_type option +type abbrev_map = GlobRef.t -> ml_type option val type_expand : abbrev_map -> ml_type -> ml_type val type_simpl : ml_type -> ml_type @@ -117,7 +116,7 @@ val dump_unused_vars : ml_ast -> ml_ast val normalize : ml_ast -> ml_ast val optimize_fix : ml_ast -> ml_ast -val inline : global_reference -> ml_ast -> bool +val inline : GlobRef.t -> ml_ast -> bool val is_basic_pattern : ml_pattern -> bool val has_deep_pattern : ml_branch array -> bool diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index f33a59ed..b398bc07 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -76,7 +76,7 @@ let struct_iter do_decl do_spec do_mp s = (*s Apply some fonctions upon all references in [ml_type], [ml_ast], [ml_decl], [ml_spec] and [ml_structure]. *) -type do_ref = global_reference -> unit +type do_ref = GlobRef.t -> unit let record_iter_references do_term = function | Record l -> List.iter (Option.iter do_term) l diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index 6a81f270..f45773f0 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Miniml (*s Functions upon ML modules. *) @@ -17,7 +16,7 @@ open Miniml val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool val struct_type_search : (ml_type -> bool) -> ml_structure -> bool -type do_ref = global_reference -> unit +type do_ref = GlobRef.t -> unit val type_iter_references : do_ref -> ml_type -> unit val ast_iter_references : do_ref -> do_ref -> do_ref -> ml_ast -> unit @@ -30,7 +29,7 @@ val mtyp_of_mexpr : ml_module_expr -> ml_module_type val msid_of_mt : ml_module_type -> ModPath.t -val get_decl_in_structure : global_reference -> ml_structure -> ml_decl +val get_decl_in_structure : GlobRef.t -> ml_structure -> ml_decl (* Some transformations of ML terms. [optimize_struct] simplify all beta redexes (when the argument does not occur, it is just @@ -39,5 +38,5 @@ val get_decl_in_structure : global_reference -> ml_structure -> ml_decl optimizations. The first argument is the list of objects we want to appear. *) -val optimize_struct : global_reference list * ModPath.t list -> +val optimize_struct : GlobRef.t list * ModPath.t list -> ml_structure -> ml_structure diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 54c6d9d7..c3f4cfe6 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -652,7 +652,7 @@ let add_inline_entries b l = (* Registration of operations for rollback. *) -let inline_extraction : bool * global_reference list -> obj = +let inline_extraction : bool * GlobRef.t list -> obj = declare_object {(default_object "Extraction Inline") with cache_function = (fun (_,(b,l)) -> add_inline_entries b l); @@ -736,7 +736,7 @@ let add_implicits r l = (* Registration of operations for rollback. *) -let implicit_extraction : global_reference * int_or_id list -> obj = +let implicit_extraction : GlobRef.t * int_or_id list -> obj = declare_object {(default_object "Extraction Implicit") with cache_function = (fun (_,(r,l)) -> add_implicits r l); @@ -857,7 +857,7 @@ let find_custom_match pv = (* Registration of operations for rollback. *) -let in_customs : global_reference * string list * string -> obj = +let in_customs : GlobRef.t * string list * string -> obj = declare_object {(default_object "ML extractions") with cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); @@ -867,7 +867,7 @@ let in_customs : global_reference * string list * string -> obj = (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) } -let in_custom_matchs : global_reference * string -> obj = +let in_custom_matchs : GlobRef.t * string -> obj = declare_object {(default_object "ML extractions custom matchs") with cache_function = (fun (_,(r,s)) -> add_custom_match r s); diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 906dfd96..a8baeaf1 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -10,31 +10,30 @@ open Names open Libnames -open Globnames open Miniml open Declarations -module Refset' : CSig.SetS with type elt = global_reference -module Refmap' : CSig.MapS with type key = global_reference +module Refset' : CSig.SetS with type elt = GlobRef.t +module Refmap' : CSig.MapS with type key = GlobRef.t -val safe_basename_of_global : global_reference -> Id.t +val safe_basename_of_global : GlobRef.t -> Id.t (*s Warning and Error messages. *) val warning_axioms : unit -> unit val warning_opaques : bool -> unit -val warning_ambiguous_name : ?loc:Loc.t -> qualid * ModPath.t * global_reference -> unit +val warning_ambiguous_name : ?loc:Loc.t -> qualid * ModPath.t * GlobRef.t -> unit val warning_id : string -> unit -val error_axiom_scheme : global_reference -> int -> 'a -val error_constant : global_reference -> 'a -val error_inductive : global_reference -> 'a +val error_axiom_scheme : GlobRef.t -> int -> 'a +val error_constant : GlobRef.t -> 'a +val error_inductive : GlobRef.t -> 'a val error_nb_cons : unit -> 'a val error_module_clash : ModPath.t -> ModPath.t -> 'a val error_no_module_expr : ModPath.t -> 'a -val error_singleton_become_prop : Id.t -> global_reference option -> 'a +val error_singleton_become_prop : Id.t -> GlobRef.t option -> 'a val error_unknown_module : qualid -> 'a val error_scheme : unit -> 'a -val error_not_visible : global_reference -> 'a +val error_not_visible : GlobRef.t -> 'a val error_MPfile_as_mod : ModPath.t -> bool -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit @@ -44,12 +43,12 @@ val err_or_warn_remaining_implicit : kill_reason -> unit val info_file : string -> unit -(*s utilities about [module_path] and [kernel_names] and [global_reference] *) +(*s utilities about [module_path] and [kernel_names] and [GlobRef.t] *) -val occur_kn_in_ref : MutInd.t -> global_reference -> bool -val repr_of_r : global_reference -> ModPath.t * DirPath.t * Label.t -val modpath_of_r : global_reference -> ModPath.t -val label_of_r : global_reference -> Label.t +val occur_kn_in_ref : MutInd.t -> GlobRef.t -> bool +val repr_of_r : GlobRef.t -> ModPath.t * DirPath.t * Label.t +val modpath_of_r : GlobRef.t -> ModPath.t +val label_of_r : GlobRef.t -> Label.t val base_mp : ModPath.t -> ModPath.t val is_modfile : ModPath.t -> bool val string_of_modfile : ModPath.t -> string @@ -61,7 +60,7 @@ val prefixes_mp : ModPath.t -> MPset.t val common_prefix_from_list : ModPath.t -> ModPath.t list -> ModPath.t option val get_nth_label_mp : int -> ModPath.t -> Label.t -val labels_of_ref : global_reference -> ModPath.t * Label.t list +val labels_of_ref : GlobRef.t -> ModPath.t * Label.t list (*s Some table-related operations *) @@ -83,27 +82,27 @@ val add_ind : MutInd.t -> mutual_inductive_body -> ml_ind -> unit val lookup_ind : MutInd.t -> mutual_inductive_body -> ml_ind option val add_inductive_kind : MutInd.t -> inductive_kind -> unit -val is_coinductive : global_reference -> bool +val is_coinductive : GlobRef.t -> bool val is_coinductive_type : ml_type -> bool (* What are the fields of a record (empty for a non-record) *) val get_record_fields : - global_reference -> global_reference option list -val record_fields_of_type : ml_type -> global_reference option list + GlobRef.t -> GlobRef.t option list +val record_fields_of_type : ml_type -> GlobRef.t option list val add_recursors : Environ.env -> MutInd.t -> unit -val is_recursor : global_reference -> bool +val is_recursor : GlobRef.t -> bool val add_projection : int -> Constant.t -> inductive -> unit -val is_projection : global_reference -> bool -val projection_arity : global_reference -> int -val projection_info : global_reference -> inductive * int (* arity *) +val is_projection : GlobRef.t -> bool +val projection_arity : GlobRef.t -> int +val projection_info : GlobRef.t -> inductive * int (* arity *) -val add_info_axiom : global_reference -> unit -val remove_info_axiom : global_reference -> unit -val add_log_axiom : global_reference -> unit +val add_info_axiom : GlobRef.t -> unit +val remove_info_axiom : GlobRef.t -> unit +val add_log_axiom : GlobRef.t -> unit -val add_opaque : global_reference -> unit -val remove_opaque : global_reference -> unit +val add_opaque : GlobRef.t -> unit +val remove_opaque : GlobRef.t -> unit val reset_tables : unit -> unit @@ -172,22 +171,22 @@ val is_extrcompute : unit -> bool (*s Table for custom inlining *) -val to_inline : global_reference -> bool -val to_keep : global_reference -> bool +val to_inline : GlobRef.t -> bool +val to_keep : GlobRef.t -> bool (*s Table for implicits arguments *) -val implicits_of_global : global_reference -> Int.Set.t +val implicits_of_global : GlobRef.t -> Int.Set.t (*s Table for user-given custom ML extractions. *) (* UGLY HACK: registration of a function defined in [extraction.ml] *) val type_scheme_nb_args_hook : (Environ.env -> Constr.t -> int) Hook.t -val is_custom : global_reference -> bool -val is_inline_custom : global_reference -> bool -val find_custom : global_reference -> string -val find_type_custom : global_reference -> string list * string +val is_custom : GlobRef.t -> bool +val is_inline_custom : GlobRef.t -> bool +val find_custom : GlobRef.t -> string +val find_type_custom : GlobRef.t -> string list * string val is_custom_match : ml_branch array -> bool val find_custom_match : ml_branch array -> string @@ -195,17 +194,17 @@ val find_custom_match : ml_branch array -> string (*s Extraction commands. *) val extraction_language : lang -> unit -val extraction_inline : bool -> reference list -> unit +val extraction_inline : bool -> qualid list -> unit val print_extraction_inline : unit -> Pp.t val reset_extraction_inline : unit -> unit val extract_constant_inline : - bool -> reference -> string list -> string -> unit + bool -> qualid -> string list -> string -> unit val extract_inductive : - reference -> string -> string list -> string option -> unit + qualid -> string -> string list -> string option -> unit type int_or_id = ArgInt of int | ArgId of Id.t -val extraction_implicit : reference -> int_or_id list -> unit +val extraction_implicit : qualid -> int_or_id list -> unit (*s Table of blacklisted filenames *) diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 047fc9fb..a60a966c 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -211,7 +211,7 @@ type left_pattern= | Lexists of pinductive | LA of constr*left_arrow_pattern -type t={id:global_reference; +type t={id:GlobRef.t; constr:constr; pat:(left_pattern,right_pattern) sum; atoms:atoms} diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 2962d923..e2c6f1c4 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -8,9 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open Constr open EConstr -open Globnames val qflag : bool ref @@ -35,7 +35,7 @@ type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint -val dummy_id: global_reference +val dummy_id: GlobRef.t val build_atoms : Environ.env -> Evd.evar_map -> counter -> side -> constr -> bool * atoms @@ -65,13 +65,13 @@ type left_pattern= | Lexists of pinductive | LA of constr*left_arrow_pattern -type t={id: global_reference; +type t={id: GlobRef.t; constr: constr; pat: (left_pattern,right_pattern) sum; atoms: atoms} (*exception Is_atom of constr*) -val build_formula : Environ.env -> Evd.evar_map -> side -> global_reference -> types -> +val build_formula : Environ.env -> Evd.evar_map -> side -> GlobRef.t -> types -> counter -> (t,types) sum diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 30deb6f4..7e54bc8a 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -17,7 +17,6 @@ open Goptions open Tacmach.New open Tacticals.New open Tacinterp -open Libnames open Stdarg open Tacarg open Pcoq.Prim @@ -127,7 +126,7 @@ let normalize_evaluables= open Genarg open Ppconstr open Printer -let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_reference +let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_qualid let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (pr_or_var (fun x -> pr_global (snd x))) let pr_firstorder_using_typed _ _ _ = Pptactic.pr_auto_using pr_global diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 4e3ba573..516b04ea 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -13,23 +13,21 @@ open Formula open Sequent open Rules open Instances -open Constr open Tacmach.New open Tacticals.New +open Globnames let update_flags ()= - let predref=ref Names.Cpred.empty in - let f coe= - try - let kn= fst (destConst (Classops.get_coercion_value coe)) in - predref:=Names.Cpred.add kn !predref - with DestKO -> () + let f acc coe = + match coe.Classops.coe_value with + | ConstRef c -> Names.Cpred.add c acc + | _ -> acc in - List.iter f (Classops.coercions ()); + let pred = List.fold_left f Names.Cpred.empty (Classops.coercions ()) in red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta - (Names.Id.Pred.full,Names.Cpred.complement !predref) + (Names.Id.Pred.full,Names.Cpred.complement pred) let ground_tac solver startseq = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index e8c0b927..85f49395 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -22,7 +22,6 @@ open Reductionops open Formula open Sequent open Names -open Misctypes open Context.Rel.Declaration let compare_instance inst1 inst2= @@ -43,7 +42,7 @@ let compare_gr id1 id2 = module OrderedInstance= struct - type t=instance * Globnames.global_reference + type t=instance * GlobRef.t let compare (inst1,id1) (inst2,id2)= (compare_instance =? compare_gr) inst2 inst1 id2 id1 (* we want a __decreasing__ total order *) @@ -184,12 +183,12 @@ let right_instance_tac inst continue seq= [introf; Proofview.Goal.enter begin fun gl -> let id0 = List.nth (pf_ids_of_hyps gl) 0 in - split (ImplicitBindings [mkVar id0]) + split (Tactypes.ImplicitBindings [mkVar id0]) end; tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY assumption] | Real ((0,t),_) -> - (tclTHEN (split (ImplicitBindings [t])) + (tclTHEN (split (Tactypes.ImplicitBindings [t])) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index 61786ffd..9f9ade3a 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -8,13 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Globnames +open Names open Rules val collect_quantified : Evd.evar_map -> Sequent.t -> Formula.t list * Sequent.t val give_instances : Evd.evar_map -> Formula.t list -> Sequent.t -> - (Unify.instance * global_reference) list + (Unify.instance * GlobRef.t) list val quantified_tac : Formula.t list -> seqtac with_backtracking diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index cfcd6561..b13580bc 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -29,7 +29,7 @@ type tactic = unit Proofview.tactic type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic -type lseqtac= global_reference -> seqtac +type lseqtac= GlobRef.t -> seqtac type 'a with_backtracking = tactic -> 'a @@ -233,7 +233,7 @@ let ll_forall_tac prod backtrack id continue seq= (* special for compatibility with old Intuition *) -let constant str = Universes.constr_of_global +let constant str = UnivGen.constr_of_global @@ Coqlib.coq_reference "User" ["Init";"Logic"] str let defined_connectives=lazy diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index 859388b3..924c2679 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -11,21 +11,20 @@ open Names open Constr open EConstr -open Globnames type tactic = unit Proofview.tactic type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic -type lseqtac= global_reference -> seqtac +type lseqtac= GlobRef.t -> seqtac type 'a with_backtracking = tactic -> 'a val wrap : int -> bool -> seqtac -val basename_of_global: global_reference -> Id.t +val basename_of_global: GlobRef.t -> Id.t -val clear_global: global_reference -> tactic +val clear_global: GlobRef.t -> tactic val axiom_tac : constr -> Sequent.t -> tactic @@ -41,7 +40,7 @@ val left_and_tac : pinductive -> lseqtac with_backtracking val left_or_tac : pinductive -> lseqtac with_backtracking -val left_false_tac : global_reference -> tactic +val left_false_tac : GlobRef.t -> tactic val ll_ind_tac : pinductive -> constr list -> lseqtac with_backtracking diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 28599179..2a527da9 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -8,13 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open EConstr -open CErrors open Util +open Pp +open CErrors +open Names +open EConstr open Formula open Unify -open Globnames -open Pp let newcnt ()= let cnt=ref (-1) in @@ -56,7 +56,7 @@ struct (priority e1.pat) - (priority e2.pat) end -type h_item = global_reference * (int*Constr.t) option +type h_item = GlobRef.t * (int*Constr.t) option module Hitem= struct @@ -77,17 +77,17 @@ module CM=Map.Make(Constr) module History=Set.Make(Hitem) let cm_add sigma typ nam cm= - let typ = EConstr.to_constr sigma typ in + let typ = EConstr.to_constr ~abort_on_undefined_evars:false 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 sigma typ nam cm= - let typ = EConstr.to_constr sigma typ in + let typ = EConstr.to_constr ~abort_on_undefined_evars:false 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 + let l0=List.filter (fun id-> not (GlobRef.equal id nam)) l in match l0 with []->CM.remove typ cm | _ ->CM.add typ l0 cm @@ -97,7 +97,7 @@ module HP=Heap.Functional(OrderedFormula) type t= {redexes:HP.t; - context:(global_reference list) CM.t; + context:(GlobRef.t list) CM.t; latoms:constr list; gl:types; glatom:constr option; @@ -117,7 +117,7 @@ let lookup sigma item seq= let p (id2,o)= match o with None -> false - | Some (m2, t2)-> Globnames.eq_gr id id2 && m2>m && more_general sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in + | Some (m2, t2)-> GlobRef.equal 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 env sigma side nam t seq = @@ -152,7 +152,7 @@ let re_add_formula_list sigma lf seq= redexes=List.fold_right HP.add lf seq.redexes; context=List.fold_right do_one lf seq.context} -let find_left sigma t seq=List.hd (CM.find (EConstr.to_constr sigma t) seq.context) +let find_left sigma t seq=List.hd (CM.find (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) seq.context) (*let rev_left seq= try @@ -187,9 +187,9 @@ let empty_seq depth= let expand_constructor_hints = List.map_append (function - | IndRef ind -> + | GlobRef.IndRef ind -> List.init (Inductiveops.nconstructors ind) - (fun i -> ConstructRef (ind,i+1)) + (fun i -> GlobRef.ConstructRef (ind,i+1)) | gr -> [gr]) @@ -197,7 +197,7 @@ let extend_with_ref_list env sigma l seq = let l = expand_constructor_hints l in 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 + let sigma, typ= Typing.type_of env sigma c in (add_formula env sigma Hyp gr typ seq, sigma) in List.fold_right f l (seq, sigma) @@ -229,7 +229,9 @@ let extend_with_auto_hints env sigma l seq = let print_cmap map= let print_entry c l s= - let xc=Constrextern.extern_constr false (Global.env ()) Evd.empty (EConstr.of_constr c) in + let env = Global.env () in + let sigma = Evd.from_env env in + let xc=Constrextern.extern_constr false env sigma (EConstr.of_constr c) in str "| " ++ prlist Printer.pr_global l ++ str " : " ++ diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index c4ed3e21..709b278e 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -8,26 +8,26 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open EConstr open Formula -open Globnames module CM: CSig.MapS with type key=Constr.t -type h_item = global_reference * (int*Constr.t) option +type h_item = GlobRef.t * (int*Constr.t) option module History: Set.S with type elt = h_item -val cm_add : Evd.evar_map -> constr -> global_reference -> global_reference list CM.t -> - global_reference list CM.t +val cm_add : Evd.evar_map -> constr -> GlobRef.t -> GlobRef.t list CM.t -> + GlobRef.t list CM.t -val cm_remove : Evd.evar_map -> constr -> global_reference -> global_reference list CM.t -> - global_reference list CM.t +val cm_remove : Evd.evar_map -> constr -> GlobRef.t -> GlobRef.t list CM.t -> + GlobRef.t list CM.t module HP: Heap.S with type elt=Formula.t type t = {redexes:HP.t; - context: global_reference list CM.t; + context: GlobRef.t list CM.t; latoms:constr list; gl:types; glatom:constr option; @@ -41,20 +41,20 @@ val record: h_item -> t -> t val lookup: Evd.evar_map -> h_item -> t -> bool -val add_formula : Environ.env -> Evd.evar_map -> side -> global_reference -> constr -> t -> t +val add_formula : Environ.env -> Evd.evar_map -> side -> GlobRef.t -> constr -> t -> t val re_add_formula_list : Evd.evar_map -> Formula.t list -> t -> t -val find_left : Evd.evar_map -> constr -> t -> global_reference +val find_left : Evd.evar_map -> constr -> t -> GlobRef.t val take_formula : Evd.evar_map -> t -> Formula.t * t val empty_seq : int -> t -val extend_with_ref_list : Environ.env -> Evd.evar_map -> global_reference list -> +val extend_with_ref_list : Environ.env -> Evd.evar_map -> GlobRef.t list -> t -> t * Evd.evar_map 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.t +val print_cmap: GlobRef.t list CM.t -> Pp.t diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index b869c04a..d63fe9d7 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -9,7 +9,7 @@ (************************************************************************) open Util -open Term +open Constr open EConstr open Vars open Termops @@ -56,12 +56,12 @@ let unif evd t1 t2= | Meta i,_ -> let t=subst_meta !sigma nt2 in if Int.Set.is_empty (free_rels evd t) && - not (dependent evd (EConstr.mkMeta i) t) then + not (occur_metavariable evd 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 evd t) && - not (dependent evd (EConstr.mkMeta i) t) then + not (occur_metavariable evd i t) then bind i t else raise (UFAIL(nt1,nt2)) | Cast(_,_,_),_->Queue.add (strip_outer_cast evd nt1,nt2) bige | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v deleted file mode 100644 index 07f32be8..00000000 --- a/plugins/fourier/Fourier.v +++ /dev/null @@ -1,20 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* 0 < a -> a * x1 < a * y1. -intros; apply Rmult_lt_compat_l; assumption. -Qed. - -Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. -red. -intros. -case H; auto with real. -Qed. - -Lemma Rfourier_lt_lt : - forall x1 y1 x2 y2 a:R, - x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -apply Rplus_lt_compat. -try exact H. -apply Rfourier_lt. -try exact H0. -try exact H1. -Qed. - -Lemma Rfourier_lt_le : - forall x1 y1 x2 y2 a:R, - x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H0; intros. -apply Rplus_lt_compat. -try exact H. -apply Rfourier_lt; auto with real. -rewrite H2. -rewrite (Rplus_comm y1 (a * y2)). -rewrite (Rplus_comm x1 (a * y2)). -apply Rplus_lt_compat_l. -try exact H. -Qed. - -Lemma Rfourier_le_lt : - forall x1 y1 x2 y2 a:R, - x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H; intros. -apply Rfourier_lt_le; auto with real. -rewrite H2. -apply Rplus_lt_compat_l. -apply Rfourier_lt; auto with real. -Qed. - -Lemma Rfourier_le_le : - forall x1 y1 x2 y2 a:R, - x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H0; intros. -red. -left; try assumption. -apply Rfourier_le_lt; auto with real. -rewrite H2. -case H; intros. -red. -left; try assumption. -rewrite (Rplus_comm x1 (a * y2)). -rewrite (Rplus_comm y1 (a * y2)). -apply Rplus_lt_compat_l. -try exact H3. -rewrite H3. -red. -right; try assumption. -auto with real. -Qed. - -Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. -intros x H; try assumption. -rewrite Rplus_comm. -apply Rle_lt_0_plus_1. -red; auto with real. -Qed. - -Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. -intros x y H H0; try assumption. -replace 0 with (x * 0). -apply Rmult_lt_compat_l; auto with real. -ring. -Qed. - -Lemma Rlt_zero_1 : 0 < 1. -exact Rlt_0_1. -Qed. - -Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. -intros x H; try assumption. -case H; intros. -red. -left; try assumption. -apply Rlt_zero_pos_plus1; auto with real. -rewrite <- H0. -replace (1 + 0) with 1. -red; left. -exact Rlt_zero_1. -ring. -Qed. - -Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. -intros x y H H0; try assumption. -case H; intros. -red; left. -apply Rlt_mult_inv_pos; auto with real. -rewrite <- H1. -red; right; ring. -Qed. - -Lemma Rle_zero_1 : 0 <= 1. -red; left. -exact Rlt_zero_1. -Qed. - -Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. -intros n d H; red; intros H0; try exact H0. -generalize (Rgt_not_le 0 (n * / d)). -intros H1; elim H1; try assumption. -replace (n * / d) with (- - (n * / d)). -replace 0 with (- -0). -replace (- (n * / d)) with (- n * / d). -replace (-0) with 0. -red. -apply Ropp_gt_lt_contravar. -red. -exact H0. -ring. -ring. -ring. -ring. -Qed. - -Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. -intros x; try assumption. -replace (0 * x) with 0. -apply Rlt_irrefl. -ring. -Qed. - -Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. -intros n d H; try assumption. -apply Rgt_not_le. -replace 0 with (-0). -replace (- n * / d) with (- (n * / d)). -apply Ropp_lt_gt_contravar. -try exact H. -ring. -ring. -Qed. - -Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. -unfold not; intros. -apply H. -apply Rplus_lt_reg_l with x. -replace (x + 0) with x. -replace (x + (y - x)) with y. -try exact H0. -ring. -ring. -Qed. - -Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. -unfold not; intros. -apply H. -case H0; intros. -left. -apply Rplus_lt_reg_l with x. -replace (x + 0) with x. -replace (x + (y - x)) with y. -try exact H1. -ring. -ring. -right. -rewrite H1; ring. -Qed. - -Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. -unfold Rgt; intros; assumption. -Qed. - -Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. -intros x y; exact (Rge_le y x). -Qed. - -Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. -exact Req_le. -Qed. - -Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. -exact Req_le_sym. -Qed. - -Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. -exact Rnot_ge_lt. -Qed. - -Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. -exact Rnot_gt_le. -Qed. - -Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. -exact Rnot_le_lt. -Qed. - -Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. -exact Rnot_lt_ge. -Qed. diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml deleted file mode 100644 index bee2b3b5..00000000 --- a/plugins/fourier/fourier.ml +++ /dev/null @@ -1,204 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* match ie.coef with - [] -> raise (Failure "empty ineq") - |(c::r) -> if rinf c r0 - then pop ie lneg - else if rinf r0 c then pop ie lpos - else pop ie lnul) - s; - [!lneg;!lnul;!lpos] -;; -(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!): -(add_hist [(equation 1, s1);...;(équation n, sn)]) -= -[{équation 1, [1;0;...;0], s1}; - {équation 2, [0;1;...;0], s2}; - ... - {équation n, [0;0;...;1], sn}] -*) -let add_hist le = - let n = List.length le in - let i = ref 0 in - List.map (fun (ie,s) -> - let h = ref [] in - for _k = 1 to (n - (!i) - 1) do pop r0 h; done; - pop r1 h; - for _k = 1 to !i do pop r0 h; done; - i:=!i+1; - {coef=ie;hist=(!h);strict=s}) - le -;; -(* additionne deux inéquations *) -let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; - hist=List.map2 rplus ie1.hist ie2.hist; - strict=ie1.strict || ie2.strict} -;; -(* multiplication d'une inéquation par un rationnel (positif) *) -let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef; - hist=List.map (fun x -> rmult a x) ie.hist; - strict= ie.strict} -;; -(* on enlève le premier coefficient *) -let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict} -;; -(* le premier coefficient: "tête" de l'inéquation *) -let hd_coef ie = List.hd ie.coef -;; - -(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient. -*) -let deduce_add lneg lpos = - let res=ref [] in - List.iter (fun i1 -> - List.iter (fun i2 -> - let a = rop (hd_coef i1) in - let b = hd_coef i2 in - pop (ie_tl (ie_add (ie_emult b i1) - (ie_emult a i2))) res) - lpos) - lneg; - !res -;; -(* élimination de la première variable à partir d'une liste d'inéquations: -opération qu'on itère dans l'algorithme de Fourier. -*) -let deduce1 s = - match (partitionne s) with - [lneg;lnul;lpos] -> - let lnew = deduce_add lneg lpos in - (List.map ie_tl lnul)@lnew - |_->assert false -;; -(* algorithme de Fourier: on élimine successivement toutes les variables. -*) -let deduce lie = - let n = List.length (fst (List.hd lie)) in - let lie=ref (add_hist lie) in - for _i = 1 to n - 1 do - lie:= deduce1 !lie; - done; - !lie -;; - -(* donne [] si le système a des solutions, -sinon donne [c,s,lc] -où lc est la combinaison linéaire des inéquations de départ -qui donne 0 < c si s=true - ou 0 <= c sinon -cette inéquation étant absurde. -*) - -exception Contradiction of (rational * bool * rational list) list - -let unsolvable lie = - let lr = deduce lie in - let check = function - | {coef=[c];hist=lc;strict=s} -> - if (rinf c r0 && (not s)) || (rinfeq c r0 && s) - then raise (Contradiction [c,s,lc]) - |_->assert false - in - try List.iter check lr; [] - with Contradiction l -> l - -(* Exemples: - -let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];; -deduce test1;; -unsolvable test1;; - -let test2=[ -[r1;r1;r0;r0;r0],false; -[r0;r1;r1;r0;r0],false; -[r0;r0;r1;r1;r0],false; -[r0;r0;r0;r1;r1],false; -[r1;r0;r0;r0;r1],false; -[rop r1;rop r1;r0;r0;r0],false; -[r0;rop r1;rop r1;r0;r0],false; -[r0;r0;rop r1;rop r1;r0],false; -[r0;r0;r0;rop r1;rop r1],false; -[rop r1;r0;r0;r0;rop r1],false -];; -deduce test2;; -unsolvable test2;; - -*) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml deleted file mode 100644 index b1c003de..00000000 --- a/plugins/fourier/fourierR.ml +++ /dev/null @@ -1,644 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* r0;; - -let flin_add f x c = - let cx = flin_coef f x in - Constrhash.replace f.fhom x (rplus cx c); - f -;; -let flin_add_cste f c = - {fhom=f.fhom; - fcste=rplus f.fcste c} -;; - -let flin_one () = flin_add_cste (flin_zero()) r1;; - -let flin_plus f1 f2 = - let f3 = flin_zero() in - Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; -;; - -let flin_minus f1 f2 = - let f3 = flin_zero() in - Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Constrhash.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste); -;; -let flin_emult a f = - let f2 = flin_zero() in - Constrhash.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; - flin_add_cste f2 (rmult a f.fcste); -;; - -(*****************************************************************************) - -type ineq = Rlt | Rle | Rgt | Rge - -let string_of_R_constant kn = - match Constant.repr3 kn with - | ModPath.MPfile dir, sec_dir, id when - sec_dir = DirPath.empty && - DirPath.to_string dir = "Coq.Reals.Rdefinitions" - -> Label.to_string id - | _ -> "constant_not_of_R" - -let rec string_of_R_constr c = - match Constr.kind c with - Cast (c,_,_) -> string_of_R_constr c - |Const (c,_) -> string_of_R_constant c - | _ -> "not_of_constant" - -exception NoRational - -let rec rational_of_constr c = - match Constr.kind c with - | Cast (c,_,_) -> (rational_of_constr c) - | App (c,args) -> - (match (string_of_R_constr c) with - | "Ropp" -> - rop (rational_of_constr args.(0)) - | "Rinv" -> - rinv (rational_of_constr args.(0)) - | "Rmult" -> - rmult (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rdiv" -> - rdiv (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rplus" -> - rplus (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rminus" -> - rminus (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | _ -> raise NoRational) - | Const (kn,_) -> - (match (string_of_R_constant kn) with - "R1" -> r1 - |"R0" -> r0 - | _ -> raise NoRational) - | _ -> raise NoRational -;; - -exception NoLinear - -let rec flin_of_constr c = - try( - match Constr.kind c with - | Cast (c,_,_) -> (flin_of_constr c) - | App (c,args) -> - (match (string_of_R_constr c) with - "Ropp" -> - flin_emult (rop r1) (flin_of_constr args.(0)) - | "Rplus"-> - flin_plus (flin_of_constr args.(0)) - (flin_of_constr args.(1)) - | "Rminus"-> - flin_minus (flin_of_constr args.(0)) - (flin_of_constr args.(1)) - | "Rmult"-> - (try - let a = rational_of_constr args.(0) in - try - let b = rational_of_constr args.(1) in - flin_add_cste (flin_zero()) (rmult a b) - with NoRational -> - flin_add (flin_zero()) args.(1) a - with NoRational -> - flin_add (flin_zero()) args.(0) - (rational_of_constr args.(1))) - | "Rinv"-> - let a = rational_of_constr args.(0) in - flin_add_cste (flin_zero()) (rinv a) - | "Rdiv"-> - (let b = rational_of_constr args.(1) in - try - let a = rational_of_constr args.(0) in - flin_add_cste (flin_zero()) (rdiv a b) - with NoRational -> - flin_add (flin_zero()) args.(0) (rinv b)) - |_-> raise NoLinear) - | Const (c,_) -> - (match (string_of_R_constant c) with - "R1" -> flin_one () - |"R0" -> flin_zero () - |_-> raise NoLinear) - |_-> raise NoLinear) - with NoRational | NoLinear -> flin_add (flin_zero()) c r1 -;; - -let flin_to_alist f = - let res=ref [] in - Constrhash.iter (fun x c -> res:=(c,x)::(!res)) f; - !res -;; - -(* Représentation des hypothèses qui sont des inéquations ou des équations. -*) -type hineq={hname:constr; (* le nom de l'hypothèse *) - htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) - hleft:constr; - hright:constr; - hflin:flin; - hstrict:bool} -;; - -(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 -*) - -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 (Constr.kind t) with - | App (f,args) -> - (match Constr.kind f with - | Const (c,_) when Array.length args = 2 -> - let t1= args.(0) in - let t2= args.(1) in - (match (string_of_R_constant c) with - |"Rlt" -> [{hname=h; - htype="Rlt"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=true}] - |"Rgt" -> [{hname=h; - htype="Rgt"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=true}] - |"Rle" -> [{hname=h; - htype="Rle"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=false}] - |"Rge" -> [{hname=h; - htype="Rge"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=false}] - |_-> raise NoIneq) - | Ind ((kn,i),_) -> - if not (eq_gr (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq; - let t0= args.(0) in - let t1= args.(1) in - let t2= args.(2) in - (match (Constr.kind t0) with - | Const (c,_) -> - (match (string_of_R_constant c) with - | "R"-> - [{hname=h; - htype="eqTLR"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=false}; - {hname=h; - htype="eqTRL"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=false}] - |_-> raise NoIneq) - |_-> raise NoIneq) - |_-> raise NoIneq) - |_-> raise NoIneq -;; - -(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) -*) - -let fourier_lineq lineq1 = - let nvar=ref (-1) in - let hvar=Constrhash.create 50 in (* la table des variables des inéquations *) - List.iter (fun f -> - Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin - nvar:=(!nvar)+1; - Constrhash.add hvar x (!nvar) - end) - f.hflin.fhom) - lineq1; - let sys= List.map (fun h-> - let v=Array.make ((!nvar)+1) r0 in - Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c) - h.hflin.fhom; - ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) - lineq1 in - unsolvable sys -;; - -(*********************************************************************) -(* Defined constants *) - -let get = Lazy.force -let cget = get -let eget c = EConstr.of_constr (Lazy.force c) -let constant path s = Universes.constr_of_global @@ - Coqlib.coq_reference "Fourier" path s - -(* Standard library *) -open Coqlib -let coq_sym_eqT = lazy (build_coq_eq_sym ()) -let coq_False = lazy (Universes.constr_of_global @@ build_coq_False ()) -let coq_not = lazy (Universes.constr_of_global @@ build_coq_not ()) -let coq_eq = lazy (Universes.constr_of_global @@ build_coq_eq ()) - -(* Rdefinitions *) -let constant_real = constant ["Reals";"Rdefinitions"] - -let coq_Rlt = lazy (constant_real "Rlt") -let coq_Rgt = lazy (constant_real "Rgt") -let coq_Rle = lazy (constant_real "Rle") -let coq_Rge = lazy (constant_real "Rge") -let coq_R = lazy (constant_real "R") -let coq_Rminus = lazy (constant_real "Rminus") -let coq_Rmult = lazy (constant_real "Rmult") -let coq_Rplus = lazy (constant_real "Rplus") -let coq_Ropp = lazy (constant_real "Ropp") -let coq_Rinv = lazy (constant_real "Rinv") -let coq_R0 = lazy (constant_real "R0") -let coq_R1 = lazy (constant_real "R1") - -(* RIneq *) -let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1") - -(* Fourier_util *) -let constant_fourier = constant ["fourier";"Fourier_util"] - -let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1") -let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1") -let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1") -let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos") -let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero") -let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1") -let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos") -let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0") -let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt") -let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt") -let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le") -let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le") -let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le") - -let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt") -let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le") -let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt") -let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge") -let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt") -let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le") -let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt") -let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le") -let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt") -let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le") -let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt") -let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le") -let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp") - -(****************************************************************************** -Construction de la preuve en cas de succès de la méthode de Fourier, -i.e. on obtient une contradiction. -*) -let is_int x = (x.den)=1 -;; - -(* fraction = couple (num,den) *) -let rational_to_fraction x= (x.num,x.den) -;; - -(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) -*) -let int_to_real n = - let nn=abs n in - if nn=0 - then get coq_R0 - else - (let s=ref (get coq_R1) in - for _i = 1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done; - if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s) -;; -(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1))) -*) -let rational_to_real x = - let (n,d)=rational_to_fraction x in - mkApp (get coq_Rmult, - [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|]) -;; - -(* preuve que 0 False -*) -let tac_zero_inf_false gl (n,d) = - 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))) -;; - -(* 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))) -;; - -let exact = exact_check;; - -let tac_use h = - let get = eget in - let tac = exact (EConstr.of_constr h.hname) in - match h.htype with - "Rlt" -> tac - |"Rle" -> tac - |"Rgt" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_gt_to_lt)) tac) - |"Rge" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_ge_to_le)) tac) - |"eqTLR" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) tac) - |"eqTRL" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) tac) - |_->assert false -;; - -(* -let is_ineq (h,t) = - match (Constr.kind t) with - App (f,args) -> - (match (string_of_R_constr f) with - "Rlt" -> true - | "Rgt" -> true - | "Rle" -> true - | "Rge" -> true -(* Wrong:not in Rdefinitions: *) | "eqT" -> - (match (string_of_R_constr args.(0)) with - "R" -> true - | _ -> false) - | _ ->false) - |_->false -;; -*) - -let list_of_sign s = - let open Context.Named.Declaration in - List.map (function LocalAssum (name, typ) -> name, typ - | LocalDef (name, _, typ) -> name, typ) - s;; - -let mkAppL a = - let l = Array.to_list a in - mkApp(List.hd l, Array.of_list (List.tl l)) -;; - -exception GoalDone - -(* Résolution d'inéquations linéaires dans R *) -let rec fourier () = - Proofview.Goal.nf_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 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 (Constr.kind goal) with - App (f,args) -> - let get = eget in - (match (string_of_R_constr f) with - "Rlt" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_ge_lt)) - (intro_using fhyp)) - (fourier ())) - |"Rle" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_gt_le)) - (intro_using fhyp)) - (fourier ())) - |"Rgt" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_le_gt)) - (intro_using fhyp)) - (fourier ())) - |"Rge" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_lt_ge)) - (intro_using fhyp)) - (fourier ())) - |_-> raise GoalDone) - |_-> raise GoalDone - with GoalDone -> - (* les hypothèses *) - 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)) - with NoIneq -> ()) - hyps; - (* lineq = les inéquations découlant des hypothèses *) - if !lineq=[] then CErrors.user_err Pp.(str "No inequalities"); - let res=fourier_lineq (!lineq) in - let tac=ref (Proofview.tclUNIT ()) in - if res=[] - then CErrors.user_err Pp.(str "fourier failed") - (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) - else (match res with - [(cres,sres,lc)]-> - (* lc=coefficients multiplicateurs des inéquations - qui donnent 0 - if c<>r0 - then (lutil:=(h,c)::(!lutil)(*; - print_rational(c);print_string " "*))) - (List.combine (!lineq) lc); - (* on construit la combinaison linéaire des inéquation *) - (match (!lutil) with - (h1,c1)::lutil -> - let s=ref (h1.hstrict) in - let t1=ref (mkAppL [|get coq_Rmult; - rational_to_real c1; - h1.hleft|]) in - let t2=ref (mkAppL [|get coq_Rmult; - rational_to_real c1; - h1.hright|]) in - List.iter (fun (h,c) -> - s:=(!s)||(h.hstrict); - t1:=(mkAppL [|get coq_Rplus; - !t1; - mkAppL [|get coq_Rmult; - rational_to_real c; - h.hleft|] |]); - t2:=(mkAppL [|get coq_Rplus; - !t2; - mkAppL [|get coq_Rmult; - rational_to_real c; - h.hright|] |])) - lutil; - let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle; - !t1; - !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; - tac_zero_inf_pos gl - (rational_to_fraction c1)]) - else (Tacticals.New.tclTHENS (apply (get coq_Rfourier_le)) - [tac_use h1; - tac_zero_inf_pos gl - (rational_to_fraction c1)])) in - s:=h1.hstrict; - List.iter (fun (h,c)-> - (if (!s) - then (if h.hstrict - then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_lt)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]) - else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_le)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)])) - else (if h.hstrict - then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_lt)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]) - else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_le)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]))); - s:=(!s)||(h.hstrict)) - lutil; - let tac2= if sres - 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 (EConstr.of_constr ineq)) - [Tacticals.New.tclTHEN (change_concl - (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 - (EConstr.of_constr (mkAppL [|cget coq_Rminus;!t2;!t1|] - )) - (EConstr.of_constr tc)) - [tac2; - (Tacticals.New.tclTHENS - (Equality.replace - (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 (cget coq_sym_eqT) >>= fun symeq -> - (Tacticals.New.tclTHEN (apply symeq) - (apply (get coq_Rinv_1)))] - - ) - ])); - !tac1]); - tac:=(Tacticals.New.tclTHENS (cut (get coq_False)) - [Tacticals.New.tclTHEN intro (contradiction None); - !tac]) - |_-> assert false) |_-> assert false - ); -(* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) - !tac -(* ((tclABSTRACT None !tac) gl) *) - end -;; - -(* -let fourier_tac x gl = - fourier gl -;; - -let v_fourier = add_tactic "Fourier" fourier_tac -*) - diff --git a/plugins/fourier/fourier_plugin.mlpack b/plugins/fourier/fourier_plugin.mlpack deleted file mode 100644 index b6262f8a..00000000 --- a/plugins/fourier/fourier_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Fourier -FourierR -G_fourier diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 deleted file mode 100644 index 44560ac1..00000000 --- a/plugins/fourier/g_fourier.ml4 +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* [ fourier () ] -END diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index d04887a4..268a012b 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -230,7 +230,7 @@ let isAppConstruct ?(env=Global.env ()) sigma t = with Not_found -> false let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env @@ Evd.from_env Environ.empty_env exception NoChange @@ -243,7 +243,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = raise NoChange; end in - let eq_constr c1 c2 = Evarconv.e_conv env (ref sigma) c1 c2 in + let eq_constr c1 c2 = Option.has_some (Evarconv.conv env 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 sigma t) then nochange "not an equality"; @@ -414,9 +414,9 @@ 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 = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ()) in - let coq_True = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ()) in - let coq_I = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) in + let coq_False = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_False ()) in + let coq_True = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_True ()) in + let coq_I = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_I ()) in let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in @@ -598,7 +598,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = Proofview.V82.of_tactic (intro_using heq_id); onLastHypId (fun heq_id -> tclTHENLIST [ (* Then the new hypothesis *) - tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps; + tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in @@ -638,11 +638,11 @@ let my_orelse tac1 tac2 g = (* observe (str "using snd tac since : " ++ CErrors.print e); *) tac2 g -let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = +let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = let args = Array.of_list (List.map mkVar args_id) in - let instanciate_one_hyp hid = + let instantiate_one_hyp hid = my_orelse - ( (* we instanciate the hyp if possible *) + ( (* we instantiate the hyp if possible *) fun g -> let prov_hid = pf_get_new_id hid g in let c = mkApp(mkVar hid,args) in @@ -678,7 +678,7 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - tclMAP instanciate_one_hyp hyps; + tclMAP instantiate_one_hyp hyps; (fun g -> let all_g_hyps_id = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty @@ -722,11 +722,11 @@ let build_proof tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); (fun g' -> let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instanciate_partial = g'_nb_prod - g_nb_prod in + let nb_instantiate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" (treat_new_case ptes_infos - nb_instanciate_partial + nb_instantiate_partial (build_proof do_finalize) t dyn_infos) @@ -760,7 +760,7 @@ let build_proof nb_rec_hyps = List.length new_hyps } in -(* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' +(* observe_tac "Lambda" *) (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' (* build_proof do_finalize new_infos g' *) ) g | _ -> @@ -1013,7 +1013,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num lemma_type (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); - Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None))); + Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None))); evd @@ -1050,9 +1050,9 @@ 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 + evd:=evd'; + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in + evd := sigma; res in let nb_intro_to_do = nb_prod (project g) (pf_concl g) in @@ -1099,10 +1099,12 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let get_body const = match Global.body_of_constant const with | Some (body, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.empty) + env + sigma (EConstr.of_constr body) | None -> user_err Pp.(str "Cannot define a principle over an axiom ") in @@ -1118,7 +1120,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in (full_params, (* real params *) princ_params, (* the params of the principle which are not params of the function *) - substl (* function instanciated with real params *) + substl (* function instantiated with real params *) (List.map var_of_decl full_params) f_body ) @@ -1128,7 +1130,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let f_body = compose_lam f_ctxt_other f_body in (princ_info.params, (* real params *) [],(* all params are full params *) - substl (* function instanciated with real params *) + substl (* function instantiated with real params *) (List.map var_of_decl princ_info.params) f_body ) @@ -1242,7 +1244,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam if this_fix_info.idx + 1 = 0 then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) else - observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix (Some this_fix_info.name) (this_fix_info.idx +1))) + observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) @@ -1319,7 +1321,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) (* ); *) - (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac + (* observe_tac "instancing" *) (instantiate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id)) ] @@ -1340,7 +1342,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 (pf_env g) Evd.empty + Reductionops.nf_betaiota (pf_env g) (project g) (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) @@ -1369,7 +1371,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam do_prove dyn_infos in - instanciate_hyps_with_args prove_tac + instantiate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id) ] @@ -1603,7 +1605,7 @@ let prove_principle_for_gen match !tcc_lemma_ref with | Undefined -> user_err Pp.(str "No tcc proof !!") | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) + | Not_needed -> EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_I ()) in (* let rec list_diff del_list check_list = *) (* match del_list with *) @@ -1657,7 +1659,7 @@ let prove_principle_for_gen (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) (* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) - (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix (Some fix_id) (List.length args_ids + 1))); + (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); @@ -1726,8 +1728,8 @@ let prove_principle_for_gen ptes_info (body_info rec_hyps) in - (* observe_tac "instanciate_hyps_with_args" *) - (instanciate_hyps_with_args + (* observe_tac "instantiate_hyps_with_args" *) + (instantiate_hyps_with_args make_proof (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) (List.rev args_ids) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 804548ce..b2a528a1 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -266,7 +266,7 @@ let change_property_sort evd toSort princ princName = (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in let init = let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in - mkApp(princName_as_constr, + mkApp(EConstr.Unsafe.to_constr princName_as_constr, Array.init nargs (fun i -> mkRel (nargs - i ))) in @@ -291,7 +291,8 @@ 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_________") Id.Set.empty in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr new_principle_type) in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in + evd := sigma; let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof @@ -321,8 +322,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) try let f = funs.(i) in - let env = Global.env () in - let type_sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd InType in + let type_sort = Evarutil.evd_comb1 Evd.fresh_sort_in_family evd InType in let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) @@ -343,7 +343,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in + let evd',s = Evd.fresh_sort_in_family 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' (EConstr.of_constr value)) in @@ -353,7 +353,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) Evd.const_univ_entry ~poly evd' in let ce = Declare.definition_entry ~univs value in - ignore( + ignore( Declare.declare_constant name (DefinitionEntry ce, @@ -507,8 +507,8 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd x - ) + Evarutil.evd_comb1 Evd.fresh_sort_in_family evd x + ) fas in (* We create the first priciple by tactic *) @@ -626,15 +626,19 @@ let build_scheme fas = Smartlocate.global_with_alias f with Not_found -> user_err ~hdr:"FunInd.build_scheme" - (str "Cannot find " ++ Libnames.pr_reference f) + (str "Cannot find " ++ Libnames.pr_qualid f) 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 (EConstr.of_constr f) in - if isConst f - then (destConst f,sort) - else user_err Pp.(pr_constr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") - ) + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in + evd := sigma; + let c, u = + try EConstr.destConst !evd f + with DestKO -> + user_err Pp.(pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") + in + (c, EConstr.EInstance.kind !evd u), sort + ) fas ) in let bodies_types = @@ -663,7 +667,7 @@ let build_case_scheme fa = try fst (Global.constr_of_global_in_context (Global.env ()) (Smartlocate.global_with_alias f)) with Not_found -> user_err ~hdr:"FunInd.build_case_scheme" - (str "Cannot find " ++ Libnames.pr_reference f) in + (str "Cannot find " ++ Libnames.pr_qualid f) in let first_fun,u = destConst funs in let funs_mp,funs_dp,_ = Constant.repr3 first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in @@ -684,7 +688,7 @@ let build_case_scheme fa = 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 x + UnivGen.new_sort_in_family x ) fa in diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 33aeafef..97f9acdb 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -36,5 +36,5 @@ exception No_graph_found val make_scheme : Evd.evar_map ref -> (pconstant*Sorts.family) list -> Safe_typing.private_constants Entries.definition_entry list -val build_scheme : (Id.t*Libnames.reference*Sorts.family) list -> unit -val build_case_scheme : (Id.t*Libnames.reference*Sorts.family) -> unit +val build_scheme : (Id.t*Libnames.qualid*Sorts.family) list -> unit +val build_case_scheme : (Id.t*Libnames.qualid*Sorts.family) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 90af20b4..a2d31780 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -15,7 +15,8 @@ open Indfun_common open Indfun open Genarg open Stdarg -open Misctypes +open Tacarg +open Tactypes open Pcoq open Pcoq.Prim open Pcoq.Constr @@ -38,7 +39,9 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> - let (_, b) = b (Global.env ()) Evd.empty in + let env = Global.env () in + let evd = Evd.from_env env in + let (_, b) = b env evd in spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) @@ -123,7 +126,7 @@ ARGUMENT EXTEND auto_using' END module Gram = Pcoq.Gram -module Vernac = Pcoq.Vernac_ +module Vernac = Pvernac.Vernac_ module Tactic = Pltac type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located @@ -165,7 +168,7 @@ END let pr_fun_scheme_arg (princ_name,fun_name,s) = Names.Id.print princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ - Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ + Libnames.pr_qualid fun_name ++ spc() ++ str "Sort " ++ Termops.pr_sort_family s VERNAC ARGUMENT EXTEND fun_scheme_arg @@ -178,11 +181,11 @@ let warning_error names e = let (e, _) = ExplainErr.process_vernac_interp_error (e, Exninfo.null) in match e with | Building_graph e -> - let names = pr_enum Libnames.pr_reference names in + let names = pr_enum Libnames.pr_qualid names in let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in warn_cannot_define_graph (names,error) | Defining_principle e -> - let names = pr_enum Libnames.pr_reference names in + let names = pr_enum Libnames.pr_qualid names in let error = if do_observe () then CErrors.print e else mt () in warn_cannot_define_principle (names,error) | _ -> raise e diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 04006453..926a2056 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -10,7 +10,6 @@ open Indfun_common open CErrors open Util open Glob_termops -open Misctypes module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -883,7 +882,7 @@ let is_res r = match DAst.get r with | _ -> false let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let is_gvar c = match DAst.get c with @@ -892,7 +891,7 @@ let is_gvar c = match DAst.get c with let same_raw_term rt1 rt2 = match DAst.get rt1, DAst.get rt2 with - | GRef(r1,_), GRef (r2,_) -> Globnames.eq_gr r1 r2 + | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = @@ -1498,7 +1497,7 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false)) + (Flags.silently (ComInductive.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with | UserError(s,msg) as e -> @@ -1510,7 +1509,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ msg in @@ -1525,7 +1524,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 769fcc1c..f81de82d 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,10 +1,10 @@ open Pp +open Constr open Glob_term open CErrors open Util open Names open Decl_kinds -open Misctypes (* Some basic functions to rebuild glob_constr @@ -16,8 +16,8 @@ let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) -let mkGCases(rto,l,brl) = DAst.make @@ GCases(Term.RegularStyle,rto,l,brl) -let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) +let mkGCases(rto,l,brl) = DAst.make @@ GCases(RegularStyle,rto,l,brl) +let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) (* Some basic functions to decompose glob_constrs @@ -108,7 +108,7 @@ let change_vars = | GHole _ as x -> x | GCast(b,c) -> GCast(change_vars mapping b, - Miscops.map_cast_type (change_vars mapping) c) + Glob_ops.map_cast_type (change_vars mapping) c) ) rt and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in @@ -288,7 +288,7 @@ let rec alpha_rt excluded rt = | GHole _ as rt -> rt | GCast (b,c) -> GCast(alpha_rt excluded b, - Miscops.map_cast_type (alpha_rt excluded) c) + Glob_ops.map_cast_type (alpha_rt excluded) c) | GApp(f,args) -> GApp(alpha_rt excluded f, List.map (alpha_rt excluded) args @@ -436,7 +436,7 @@ let replace_var_by_term x_id term = | GHole _ as rt -> rt | GCast(b,c) -> GCast(replace_var_by_pattern b, - Miscops.map_cast_type replace_var_by_pattern c) + Glob_ops.map_cast_type replace_var_by_pattern c) ) x and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) = if List.exists (fun id -> Id.compare id x_id == 0) idl @@ -536,7 +536,7 @@ let expand_as = | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast(b,c) -> GCast(expand_as map b, - Miscops.map_cast_type (expand_as map) c) + Glob_ops.map_cast_type (expand_as map) c) | GCases(sty,po,el,brl) -> GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) @@ -557,7 +557,8 @@ let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expect (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in - let ctx, f = Evarutil.nf_evars_and_universes ctx in + let ctx = Evd.minimize_universes ctx in + let f c = EConstr.of_constr (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) in (* then we map [rt] to replace the implicit holes by their values *) let rec change rt = @@ -569,7 +570,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas (fun _ evi _ -> match evi.evar_source with | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) -> - if Globnames.eq_gr grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi + if GlobRef.equal grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi then raise (Found evi) | _ -> () ) @@ -580,8 +581,8 @@ If someone knows how to prevent solved existantial removal in understand, pleas with Found evi -> (* we found the evar corresponding to this hole *) match evi.evar_body with | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) @@ -603,7 +604,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas match evi.evar_body with | Evar_defined c -> (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) in res diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 7088ae59..481a8be3 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -13,7 +13,7 @@ val pattern_to_term : cases_pattern -> glob_constr Some basic functions to rebuild glob_constr In each of them the location is Util.Loc.ghost *) -val mkGRef : Globnames.global_reference -> glob_constr +val mkGRef : GlobRef.t -> glob_constr 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 diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 57863ee6..9eda19a8 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -10,7 +10,7 @@ open Libnames open Globnames open Glob_term open Declarations -open Misctypes +open Tactypes open Decl_kinds module RelDecl = Context.Rel.Declaration @@ -77,8 +77,7 @@ let functional_induction with_clean c princl pat = user_err (str "Cannot find induction principle for " ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in - let princ = EConstr.of_constr princ in - (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') + (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)) -> @@ -99,7 +98,7 @@ let functional_induction with_clean c princl pat = List.map2 (fun c pat -> ((None, - Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), + Tactics.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), (None,pat), None)) (args@c_list) @@ -260,7 +259,6 @@ let derive_inversion fix_names = let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - let c = EConstr.of_constr c in let (cst, u) = destConst evd c in evd, (cst, EInstance.kind evd u) :: l ) @@ -282,8 +280,7 @@ let derive_inversion fix_names = (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) in - let id = EConstr.of_constr id in - evd,(fst (destInd evd id))::l + evd,(fst (destInd evd id))::l ) fix_names (evd',[]) @@ -364,17 +361,17 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : do_built i*) - let f_R_mut = CAst.make @@ Ident (mk_rel_id (List.nth names 0)) in + let f_R_mut = qualid_of_ident @@ mk_rel_id (List.nth names 0) in let ind_kn = fst (locate_with_msg - (pr_reference f_R_mut++str ": Not an inductive type!") + (pr_qualid f_R_mut++str ": Not an inductive type!") locate_ind f_R_mut) in let fname_kn (((fname,_),_,_,_,_),_) = - let f_ref = CAst.map (fun n -> Ident n) fname in - locate_with_msg - (pr_reference f_ref++str ": Not an inductive type!") + let f_ref = qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in + locate_with_msg + (pr_qualid f_ref++str ": Not an inductive type!") locate_constant f_ref in @@ -387,7 +384,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 (EConstr.of_constr uprinc) in + let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in + evd := sigma; let princ_type = EConstr.Unsafe.to_constr princ_type in Functional_principles_types.generate_functional_principle evd @@ -424,7 +422,6 @@ 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 - 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) @@ -441,7 +438,6 @@ 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 - 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) @@ -480,7 +476,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas let unbounded_eq = let f_app_args = CAst.make @@ Constrexpr.CAppExpl( - (None,CAst.make @@ Ident fname,None) , + (None,qualid_of_ident fname,None) , (List.map (function | {CAst.v=Anonymous} -> assert false @@ -490,7 +486,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas ) ) in - CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (CAst.make @@ Qualid (qualid_of_string "Logic.eq"))), + CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (qualid_of_string "Logic.eq")), [(f_app_args,None);(body,None)]) in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in @@ -547,9 +543,9 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in - CAst.make @@ Libnames.Qualid (Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof"))) - in + Libnames.qualid_of_path + (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) + in let fun_from_mes = let applied_mes = Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in @@ -730,12 +726,10 @@ let do_generate_principle pconstants on_error register_built interactive_proof () let rec add_args id new_args = CAst.map (function - | CRef (r,_) as b -> - begin match r with - | {CAst.v=Libnames.Ident fname} when Id.equal fname id -> - CAppExpl((None,r,None),new_args) - | _ -> b - end + | CRef (qid,_) as b -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl((None,qid,None),new_args) + else b | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo.") | CProdN(nal,b1) -> CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) @@ -749,13 +743,10 @@ let rec add_args id new_args = CAst.map (function add_args id new_args b1) | CLetIn(na,b1,t,b2) -> CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) - | CAppExpl((pf,r,us),exprl) -> - begin - match r with - | {CAst.v=Libnames.Ident fname} when Id.equal fname id -> - CAppExpl((pf,r,us),new_args@(List.map (add_args id new_args) exprl)) - | _ -> CAppExpl((pf,r,us),List.map (add_args id new_args) exprl) - end + | CAppExpl((pf,qid,us),exprl) -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) + else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) | CApp((pf,b),bl) -> CApp((pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) @@ -785,7 +776,7 @@ let rec add_args id new_args = CAst.map (function | CSort _ as b -> b | CCast(b1,b2) -> CCast(add_args id new_args b1, - Miscops.map_cast_type (add_args id new_args) b2) + Glob_ops.map_cast_type (add_args id new_args) b2) | CRecord pars -> CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation.") @@ -849,7 +840,7 @@ let rec get_args b t : Constrexpr.local_binder_expr list * | _ -> [],b,t -let make_graph (f_ref:global_reference) = +let make_graph (f_ref : GlobRef.t) = let c,c_body = match f_ref with | ConstRef c -> @@ -890,7 +881,7 @@ let make_graph (f_ref:global_reference) = | Constrexpr.CLocalAssum (nal,_,_) -> List.map (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(CAst.make ?loc @@ Libnames.Ident(Nameops.Name.get_id n),None)) + CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) nal | Constrexpr.CLocalPattern _ -> assert false ) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index dcc1c2ea..f209fb19 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,4 +1,5 @@ -open Misctypes +open Names +open Tactypes val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit @@ -18,4 +19,4 @@ val functional_induction : Goal.goal Evd.sigma -> Goal.goal list Evd.sigma -val make_graph : Globnames.global_reference -> unit +val make_graph : GlobRef.t -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index a0b9217c..4eee2c7a 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -31,9 +31,7 @@ let id_of_name = function Name id -> id | _ -> raise Not_found -let locate ref = - let {CAst.v=qid} = qualid_of_reference ref in - Nametab.locate qid +let locate qid = Nametab.locate qid let locate_ind ref = match locate ref with @@ -109,7 +107,7 @@ let const_of_id id = let def_of_const t = match Constr.kind t with - Term.Const sp -> + Const sp -> (try (match Environ.constant_opt_value_in (Global.env()) sp with | Some c -> c | _ -> assert false) @@ -117,7 +115,7 @@ let def_of_const t = |_ -> assert false let coq_constant s = - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s;; @@ -269,12 +267,12 @@ let subst_Function (subst,finfos) = in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in - let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in - let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in - let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in - let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in - let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in + let equation_lemma' = Option.Smart.map do_subst_con finfos.equation_lemma in + let correctness_lemma' = Option.Smart.map do_subst_con finfos.correctness_lemma in + let completeness_lemma' = Option.Smart.map do_subst_con finfos.completeness_lemma in + let rect_lemma' = Option.Smart.map do_subst_con finfos.rect_lemma in + let rec_lemma' = Option.Smart.map do_subst_con finfos.rec_lemma in + let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && @@ -302,12 +300,12 @@ let classify_Function infos = Libobject.Substitute infos let discharge_Function (_,finfos) = let function_constant' = Lib.discharge_con finfos.function_constant and graph_ind' = Lib.discharge_inductive finfos.graph_ind - and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma - and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma - and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma - and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma - and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma - and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma + and equation_lemma' = Option.Smart.map Lib.discharge_con finfos.equation_lemma + and correctness_lemma' = Option.Smart.map Lib.discharge_con finfos.correctness_lemma + and completeness_lemma' = Option.Smart.map Lib.discharge_con finfos.completeness_lemma + and rect_lemma' = Option.Smart.map Lib.discharge_con finfos.rect_lemma + and rec_lemma' = Option.Smart.map Lib.discharge_con finfos.rec_lemma + and prop_lemma' = Option.Smart.map Lib.discharge_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && @@ -471,7 +469,7 @@ let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq" with e when CErrors.noncritical e -> raise (ToShow e) @@ -479,7 +477,7 @@ let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq_refl" with e when CErrors.noncritical e -> raise (ToShow e) @@ -492,7 +490,7 @@ 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 () = EConstr.of_constr @@ Universes.constr_of_global @@ +let well_founded_ltof () = EConstr.of_constr @@ UnivGen.constr_of_global @@ Coqlib.coq_reference "" ["Arith";"Wf_nat"] "well_founded_ltof" let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 5cc7163a..7e52ee22 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -20,11 +20,11 @@ val array_get_start : 'a array -> 'a array val id_of_name : Name.t -> Id.t -val locate_ind : Libnames.reference -> inductive -val locate_constant : Libnames.reference -> Constant.t +val locate_ind : Libnames.qualid -> inductive +val locate_constant : Libnames.qualid -> Constant.t val locate_with_msg : - Pp.t -> (Libnames.reference -> 'a) -> - Libnames.reference -> 'a + Pp.t -> (Libnames.qualid -> 'a) -> + Libnames.qualid -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list val list_union_eq : @@ -41,7 +41,7 @@ val chop_rprod_n : int -> Glob_term.glob_constr -> val def_of_const : Constr.t -> Constr.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 const_of_id: Id.t -> GlobRef.t(* constantyes *) val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr @@ -107,11 +107,11 @@ val h_intros: Names.Id.t list -> Tacmach.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t val acc_inv_id : EConstr.constr Util.delayed -val ltof_ref : Globnames.global_reference Util.delayed +val ltof_ref : GlobRef.t 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 evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index bed95740..ad11f853 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -23,7 +23,7 @@ open Tacticals open Tactics open Indfun_common open Tacmach -open Misctypes +open Tactypes open Termops open Context.Rel.Declaration @@ -67,7 +67,7 @@ let observe_tac s tac g = let nf_zeta = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) Environ.empty_env - Evd.empty + (Evd.from_env Environ.empty_env) let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl @@ -81,7 +81,7 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl let make_eq () = try - EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) + EConstr.of_constr (UnivGen.constr_of_global (Coqlib.build_coq_eq ())) with _ -> assert false @@ -102,9 +102,9 @@ let generate_type evd g_to_f f graph i = let evd',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 sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in + evd := sigma; let ctxt,_ = decompose_prod_assum !evd graph_arity in let fun_ctxt,res_type = match ctxt with @@ -172,7 +172,6 @@ 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 @@ -240,7 +239,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i List.map (fun decl -> List.map - (fun id -> CAst.make @@ IntroNaming (IntroIdentifier id)) + (fun id -> CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) ) branches @@ -258,7 +257,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i List.fold_right (fun {CAst.v=pat} acc -> match pat with - | IntroNaming (IntroIdentifier id) -> id::acc + | IntroNaming (Namegen.IntroIdentifier id) -> id::acc | _ -> anomaly (Pp.str "Not an identifier.") ) (List.nth intro_pats (pred i)) @@ -513,7 +512,7 @@ and intros_with_rewrite_aux : Tacmach.tactic = intros_with_rewrite ] g end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ())) -> + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_False ())) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENLIST[ @@ -771,7 +770,8 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; 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 sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in + evd := sigma; let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info @@ -818,13 +818,12 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") (proving_tac i)))); - (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); + (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); let finfo = find_Function_infos (fst f_as_constant) in (* 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_constr = EConstr.of_constr lem_cst_constr in - let (lem_cst,_) = destConst !evd lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with correctness_lemma = Some lem_cst}; ) @@ -880,12 +879,11 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i)))) ; - (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); + (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); 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_constr = EConstr.of_constr lem_cst_constr in - let (lem_cst,_) = destConst !evd lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) @@ -969,7 +967,7 @@ let functional_inversion kn hid fconst f_correct : Tacmach.tactic = Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid)); + Proofview.V82.of_tactic (Inv.inv Inv.FullInversion None (NamedHyp hid)); (fun g -> let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli index ad306ab2..3ddc6092 100644 --- a/plugins/funind/invfun.mli +++ b/plugins/funind/invfun.mli @@ -9,8 +9,8 @@ (************************************************************************) val invfun : - Misctypes.quantified_hypothesis -> - Globnames.global_reference option -> + Tactypes.quantified_hypothesis -> + Names.GlobRef.t option -> Evar.t Evd.sigma -> Evar.t list Evd.sigma val derive_correctness : (Evd.evar_map ref -> diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index fb9ae64b..e9e8fcb6 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -37,7 +37,7 @@ open Glob_term open Pretyping open Termops open Constrintern -open Misctypes +open Tactypes open Genredexpr open Equality @@ -49,7 +49,7 @@ open Context.Rel.Declaration (* Ugly things which should not be here *) -let coq_constant m s = EConstr.of_constr @@ Universes.constr_of_global @@ +let coq_constant m s = EConstr.of_constr @@ UnivGen.constr_of_global @@ Coqlib.coq_reference "RecursiveDefinition" m s let arith_Nat = ["Arith";"PeanoNat";"Nat"] @@ -61,7 +61,7 @@ let pr_leconstr_rd = let coq_init_constant s = EConstr.of_constr ( - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s) let find_reference sl s = @@ -72,7 +72,7 @@ let declare_fun f_id kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Transparent,None))) +let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Proof_global.Transparent,None))) let def_of_const t = match (Constr.kind t) with @@ -106,12 +106,12 @@ let const_of_ref = function let nf_zeta env = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env - Evd.empty + env (Evd.from_env env) let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env + (Evd.from_env Environ.empty_env) @@ -181,7 +181,7 @@ let simpl_iter clause = clause (* Others ugly things ... *) -let (value_f: Constr.t list -> global_reference -> Constr.t) = +let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = let open Term in let open Constr in fun al fterm -> @@ -215,7 +215,7 @@ let (value_f: Constr.t list -> global_reference -> Constr.t) = let body = EConstr.Unsafe.to_constr body in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> logical_kind -> Constr.t list -> global_reference -> global_reference) = +let (declare_f : Id.t -> logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; @@ -356,7 +356,7 @@ type 'a infos = f_id : Id.t; (* function name *) f_constr : constr; (* function term *) f_terminate : constr; (* termination proof term *) - func : global_reference; (* functional reference *) + func : GlobRef.t; (* functional reference *) info : 'a; is_main_branch : bool; (* on the main branch or on a matched expression *) is_final : bool; (* final first order term or not *) @@ -713,7 +713,7 @@ let mkDestructEq : observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> - let changefun patvars sigma = + let changefun patvars env sigma = pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in Proofview.V82.of_tactic (change_in_concl None changefun) g2); @@ -1152,7 +1152,7 @@ let termination_proof_header is_mes input_type ids args_id relation tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; - observe_tac (str "fix") (Proofview.V82.of_tactic (fix (Some hrec) (nargs+1))); + observe_tac (str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); h_intros args_id; Proofview.V82.of_tactic (Simple.intro wf_rec_arg); observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) @@ -1241,7 +1241,7 @@ let get_current_subgoals_types () = exception EmptySubgoals let build_and_l sigma l = - let and_constr = Universes.constr_of_global @@ Coqlib.build_coq_and () in + let and_constr = UnivGen.constr_of_global @@ Coqlib.build_coq_and () in let conj_constr = coq_conj () in let mk_and p1 p2 = mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in @@ -1306,9 +1306,9 @@ let build_new_goal_type () = let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Vernacexpr.Opaque - | Declarations.Undef _ -> Vernacexpr.Opaque - | Declarations.Def _ -> Vernacexpr.Transparent + | Declarations.OpaqueDef _ -> Proof_global.Opaque + | Declarations.Undef _ -> Proof_global.Opaque + | Declarations.Def _ -> Proof_global.Transparent let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) @@ -1318,14 +1318,14 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp | None -> try add_suffix current_proof_name "_subproof" with e when CErrors.noncritical e -> - anomaly (Pp.str "open_new_goal with an unamed theorem.") + anomaly (Pp.str "open_new_goal with an unnamed theorem.") in let na = next_global_ident_away name Id.Set.empty in if Termops.occur_existential sigma gls_type then CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials"); let hook _ _ = let opacity = - let na_ref = CAst.make @@ Libnames.Ident na in + let na_ref = qualid_of_ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with ConstRef c -> is_opaque_constant c @@ -1456,7 +1456,7 @@ let com_terminate -let start_equation (f:global_reference) (term_f:global_reference) +let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in @@ -1473,7 +1473,7 @@ let start_equation (f:global_reference) (term_f:global_reference) observe_tac (str "prove_eq") (cont_tactic x)]) g;; let (com_eqn : int -> Id.t -> - global_reference -> global_reference -> global_reference + GlobRef.t -> GlobRef.t -> GlobRef.t -> Constr.t -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> let open CVars in @@ -1533,14 +1533,12 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let env = Global.env() in let evd = Evd.from_env env in let evd, 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 + let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let evd, ty = interp_type_evars env evd ~impls:rec_impls eq in - let ty = EConstr.Unsafe.to_constr ty in - let evd, nf = Evarutil.nf_evars_and_universes evd in - let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in - let function_type = nf function_type in + let evd = Evd.minimize_universes evd in + let equation_lemma_type = nf_betaiotazeta (Evarutil.nf_evar evd ty) in + let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd 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 @@ -1579,7 +1577,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in - let _ = Extraction_plugin.Table.extraction_inline true [CAst.make @@ Ident term_id] in + let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] in (* message "start second proof"; *) let stop = try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index b95d64ce..549f1fc0 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -14,6 +14,6 @@ bool -> int -> Constrexpr.constr_expr -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> 'a) -> Constrexpr.constr_expr list -> unit + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> unit diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 deleted file mode 100644 index 931633e1..00000000 --- a/plugins/ltac/coretactics.ml4 +++ /dev/null @@ -1,366 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* [ 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 -| [] -> fun _ sigma -> (sigma, []) -| x :: l -> - fun env sigma -> - let (sigma, x) = x env sigma in - let (sigma, l) = delayed_list l env sigma in - (sigma, x :: l) - -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 *) - -let simple_induct h = - Tacticals.New.tclTHEN (Tactics.intros_until h) - (Tacticals.New.onLastHyp Tactics.simplest_elim) - -TACTIC EXTEND simple_induction - [ "simple" "induction" quantified_hypothesis(h) ] -> [ simple_induct h ] -END - -let simple_destruct h = - Tacticals.New.tclTHEN (Tactics.intros_until h) - (Tacticals.New.onLastHyp Tactics.simplest_case) - -TACTIC EXTEND simple_destruct - [ "simple" "destruct" quantified_hypothesis(h) ] -> [ 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 nocl = {onhyps=Some[];concl_occs=AllOccurrences} in - let iter (s, t) = - let body = TacAtom (Loc.tag t) in - Tacenv.register_ltac false false (Names.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 (Names.Id.of_string s) t in - List.iter iter - [ "idtac",TacId []; - "fail", TacFail(TacLocal,ArgArg 0,[]); - "fresh", TacArg(Loc.tag @@ TacFreshId []) - ] - -let () = Mltop.declare_cache_obj initial_atomic "ltac_plugin" - -(* First-class Ltac access to primitive blocks *) - -let initial_name s = { mltac_plugin = "ltac_plugin"; mltac_tactic = s; } -let initial_entry s = { mltac_name = initial_name s; mltac_index = 0; } - -let register_list_tactical name f = - let tac args ist = match args with - | [v] -> - begin match Tacinterp.Value.to_list v with - | None -> Tacticals.New.tclZEROMSG (Pp.str "Expected a list") - | Some tacs -> - let tacs = List.map (fun tac -> Tacinterp.tactic_of_value ist tac) tacs in - f tacs - end - | _ -> assert false - in - Tacenv.register_ml_tactic (initial_name name) [|tac|] - -let () = register_list_tactical "first" Tacticals.New.tclFIRST -let () = register_list_tactical "solve" Tacticals.New.tclSOLVE - -let initial_tacticals () = - let idn n = Id.of_string (Printf.sprintf "_%i" n) in - let varn n = Reference (ArgVar (CAst.make (idn n))) in - let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in - List.iter iter [ - "first", TacFun ([Name (idn 0)], TacML (None, (initial_entry "first", [varn 0]))); - "solve", TacFun ([Name (idn 0)], TacML (None, (initial_entry "solve", [varn 0]))); - ] - -let () = Mltop.declare_cache_obj initial_tacticals "ltac_plugin" diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg new file mode 100644 index 00000000..6388906f --- /dev/null +++ b/plugins/ltac/coretactics.mlg @@ -0,0 +1,388 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* { 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 +| [] -> fun _ sigma -> (sigma, []) +| x :: l -> + fun env sigma -> + let (sigma, x) = x env sigma in + let (sigma, l) = delayed_list l env sigma in + (sigma, x :: l) + +} + +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 *) + +{ + +let simple_induct h = + Tacticals.New.tclTHEN (Tactics.intros_until h) + (Tacticals.New.onLastHyp Tactics.simplest_elim) + +} + +TACTIC EXTEND simple_induction +| [ "simple" "induction" quantified_hypothesis(h) ] -> { simple_induct h } +END + +{ + +let simple_destruct h = + Tacticals.New.tclTHEN (Tactics.intros_until h) + (Tacticals.New.onLastHyp Tactics.simplest_case) + +} + +TACTIC EXTEND simple_destruct +| [ "simple" "destruct" quantified_hypothesis(h) ] -> { 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" ident(id) natural(n) ] -> { Tactics.fix id n } +END + +(* Cofix *) + +TACTIC EXTEND cofix +| [ "cofix" ident(id) ] -> { Tactics.cofix 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 nocl = {onhyps=Some[];concl_occs=AllOccurrences} in + let iter (s, t) = + let body = TacAtom (Loc.tag t) in + Tacenv.register_ltac false false (Names.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 (Names.Id.of_string s) t in + List.iter iter + [ "idtac",TacId []; + "fail", TacFail(TacLocal,ArgArg 0,[]); + "fresh", TacArg(Loc.tag @@ TacFreshId []) + ] + +let () = Mltop.declare_cache_obj initial_atomic "ltac_plugin" + +(* First-class Ltac access to primitive blocks *) + +let initial_name s = { mltac_plugin = "ltac_plugin"; mltac_tactic = s; } +let initial_entry s = { mltac_name = initial_name s; mltac_index = 0; } + +let register_list_tactical name f = + let tac args ist = match args with + | [v] -> + begin match Tacinterp.Value.to_list v with + | None -> Tacticals.New.tclZEROMSG (Pp.str "Expected a list") + | Some tacs -> + let tacs = List.map (fun tac -> Tacinterp.tactic_of_value ist tac) tacs in + f tacs + end + | _ -> assert false + in + Tacenv.register_ml_tactic (initial_name name) [|tac|] + +let () = register_list_tactical "first" Tacticals.New.tclFIRST +let () = register_list_tactical "solve" Tacticals.New.tclSOLVE + +let initial_tacticals () = + let idn n = Id.of_string (Printf.sprintf "_%i" n) in + let varn n = Reference (ArgVar (CAst.make (idn n))) in + let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in + List.iter iter [ + "first", TacFun ([Name (idn 0)], TacML (None, (initial_entry "first", [varn 0]))); + "solve", TacFun ([Name (idn 0)], TacML (None, (initial_entry "solve", [varn 0]))); + ] + +let () = Mltop.declare_cache_obj initial_tacticals "ltac_plugin" + +} diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 9382f567..84f13d21 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -10,7 +10,7 @@ open Util open Names -open Term +open Constr open CErrors open Evar_refiner open Tacmach @@ -52,7 +52,7 @@ let instantiate_tac n c ido = 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 + let decl = Environ.lookup_named id (pf_env gl) in match hloc with InHyp -> (match decl with @@ -85,16 +85,14 @@ let let_evar name typ = Proofview.Goal.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 sigma, _ = Typing.sort_of env sigma typ in let id = match name with | Name.Anonymous -> let id = Namegen.id_of_name_using_hdchar env sigma typ name in Namegen.next_ident_away_in_goal id (Termops.vars_of_env env) | Name.Name id -> id in - let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Namegen.IntroFresh id) typ in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.letin_tac None (Name.Name id) evar None Locusops.nowhere) end diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index 702b8303..d7799511 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -19,7 +19,6 @@ open Tacmach open Tacexpr open Taccoerce open Tacinterp -open Misctypes open Locus (** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *) @@ -35,7 +34,7 @@ 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 "ipattern" Pltac.simple_intropattern 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 @@ -53,8 +52,11 @@ let () = (* Rewriting orientation *) -let _ = Metasyntax.add_token_obj "<-" -let _ = Metasyntax.add_token_obj "->" +let _ = + Mltop.declare_cache_obj + (fun () -> Metasyntax.add_token_obj "<-"; + Metasyntax.add_token_obj "->") + "ltac_plugin" let pr_orient _prc _prlc _prt = function | true -> Pp.mt () @@ -251,7 +253,7 @@ END 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,Notation_term.E) t) + | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_gram.E) t) ARGUMENT EXTEND by_arg_tac TYPED AS tactic_opt @@ -298,25 +300,6 @@ 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 @@ -354,26 +337,6 @@ let pr_retroknowledge_field f = | 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 ] diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index e5a4f090..e477b12c 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -12,17 +12,16 @@ 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 orient : bool Pcoq.Entry.t val pr_orient : bool -> Pp.t 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.t +val occurrences : (int list Locus.or_var) Pcoq.Entry.t +val wit_occurrences : (int list Locus.or_var, int list Locus.or_var, int list) Genarg.genarg_type +val pr_occurrences : int list Locus.or_var -> Pp.t val occurrences_of : int list -> Locus.occurrences val wit_natural : int Genarg.uniform_genarg_type @@ -47,8 +46,8 @@ val wit_casted_constr : Tacexpr.glob_constr_and_expr, EConstr.t) Genarg.genarg_type -val glob : constr_expr Pcoq.Gram.entry -val lglob : constr_expr Pcoq.Gram.entry +val glob : constr_expr Pcoq.Entry.t +val lglob : constr_expr Pcoq.Entry.t type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location @@ -56,26 +55,26 @@ type loc_place = lident 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 hloc : loc_place Pcoq.Entry.t val pr_hloc : loc_place -> Pp.t -val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry +val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Entry.t 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 * Notation_term.parenRelation -> raw_tactic_expr -> Pp.t) -> + (int * Notation_gram.parenRelation -> raw_tactic_expr -> Pp.t) -> raw_tactic_expr option -> Pp.t -val test_lpar_id_colon : unit Pcoq.Gram.entry +val test_lpar_id_colon : unit Pcoq.Entry.t val wit_test_lpar_id_colon : (unit, unit, unit) Genarg.genarg_type (** Spiwack: Primitive for retroknowledge registration *) -val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry +val retroknowledge_field : Retroknowledge.field Pcoq.Entry.t val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type val wit_in_clause : diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 2e90ce90..31695fc7 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -9,6 +9,7 @@ (************************************************************************) open Pp +open Constr open Genarg open Stdarg open Tacarg @@ -23,7 +24,9 @@ open CErrors open Util open Termops open Equality -open Misctypes +open Namegen +open Tactypes +open Tactics open Proofview.Notations open Vernacinterp @@ -283,80 +286,6 @@ VERNAC COMMAND FUNCTIONAL EXTEND HintRewrite CLASSIFIED BY classify_hint [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o (Some t) l; st ] END -(**********************************************************************) -(* Hint Resolve *) - -open Term -open EConstr -open Vars -open Coqlib - -let project_hint ~poly 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 sigma, p = Evd.fresh_global env sigma p 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.const_univ_entry ~poly sigma in - let c = EConstr.to_constr sigma c in - let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in - let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in - (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) - -let add_hints_iff ~atts l2r lc n bl = - let open Vernacinterp in - Hints.add_hints (Locality.make_module_locality atts.locality) bl - (Hints.HintsResolveEntry (List.map (project_hint ~poly:atts.polymorphic n l2r) lc)) - -VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) - ":" preident_list(bl) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts true lc n bl; - st - end - ] -| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts true lc n ["core"]; - st - end - ] -END - -VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) - ":" preident_list(bl) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts false lc n bl; - st - end - ] -| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts false lc n ["core"]; - st - end - ] -END - (**********************************************************************) (* Refine *) @@ -365,7 +294,7 @@ open Vars let constr_flags () = { Pretyping.use_typeclasses = true; - Pretyping.solve_unification_constraints = true; + Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); Pretyping.use_hook = Pfedit.solve_by_implicit_tactic (); Pretyping.fail_evar = false; Pretyping.expand_evars = true } @@ -596,10 +525,16 @@ let inImplicitTactic : glob_tactic_expr option -> obj = subst_function = subst_implicit_tactic; classify_function = (fun o -> Dispose)} +let warn_deprecated_implicit_tactic = + CWarnings.create ~name:"deprecated-implicit-tactic" ~category:"deprecated" + (fun () -> strbrk "Implicit tactics are deprecated") + let declare_implicit_tactic tac = + let () = warn_deprecated_implicit_tactic () in Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) let clear_implicit_tactic () = + let () = warn_deprecated_implicit_tactic () in Lib.add_anonymous_leaf (inImplicitTactic None) VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF @@ -615,10 +550,12 @@ END 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 - let tc = EConstr.to_constr Evd.empty tc in - let tb = EConstr.to_constr Evd.empty tb in + [ let env = Global.env () in + let evd = Evd.from_env env in + let tc,_ctx = Constrintern.interp_constr env evd c in + let tb,_ctx(*FIXME*) = Constrintern.interp_constr env evd b in + let tc = EConstr.to_constr evd tc in + let tb = EConstr.to_constr evd tb in Global.register f tc tb ] END @@ -668,8 +605,11 @@ let subst_var_with_hole occ tid t = else (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ - GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous), - Misctypes.IntroAnonymous, None))) + GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=Evar_kinds.Define true; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=None; + }, IntroAnonymous, None))) else x | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t @@ -680,13 +620,21 @@ let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in let rec substrec c = match DAst.get c with - | GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) -> + | GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=Evar_kinds.Define true; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=None; + }, IntroAnonymous, s) -> decr occref; if Int.equal !occref 0 then tc else (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ - GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s)) + GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=Evar_kinds.Define true; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=None; + },IntroAnonymous,s)) | _ -> map_glob_constr_left_to_right substrec c in substrec t @@ -781,7 +729,7 @@ let mkCaseEq a : unit Proofview.tactic = 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 (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl in + let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env (Evd.from_env env) concl in change_concl c end; simplest_case a] @@ -857,17 +805,12 @@ END (* ********************************************************************* *) -let eq_constr x y = - Proofview.Goal.enter begin fun gl -> - let env = Tacmach.New.pf_env gl in - let evd = Tacmach.New.project gl in - match EConstr.eq_constr_universes env 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 ] +| [ "constr_eq" constr(x) constr(y) ] -> [ Tactics.constr_eq ~strict:false x y ] +END + +TACTIC EXTEND constr_eq_strict +| [ "constr_eq_strict" constr(x) constr(y) ] -> [ Tactics.constr_eq ~strict:true x y ] END TACTIC EXTEND constr_eq_nounivs @@ -1108,7 +1051,9 @@ END 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 env = Global.env () in + let evd = Evd.from_env env in + let (evd, c) = Constrintern.interp_open_constr env evd c in let kind c = EConstr.kind evd c in Keys.constr_key kind c in diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 643f7e99..35ed14fc 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -9,6 +9,7 @@ (************************************************************************) open Pp +open Constr open Genarg open Stdarg open Pcoq.Prim @@ -169,10 +170,10 @@ END TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] +| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x DEFAULTcast ] END -let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference +let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_qualid let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global let glob_hints_path_atom ist = Hints.glob_hints_path_atom @@ -188,7 +189,7 @@ ARGUMENT EXTEND hints_path_atom 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 pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_qualid c let glob_hints_path ist = Hints.glob_hints_path ARGUMENT EXTEND hints_path @@ -219,7 +220,7 @@ VERNAC COMMAND FUNCTIONAL EXTEND HintCut CLASSIFIED AS SIDEFF fun ~atts ~st -> begin let open Vernacinterp in let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in - Hints.add_hints (Locality.make_section_locality atts.locality) + Hints.add_hints ~local:(Locality.make_section_locality atts.locality) (match dbnames with None -> ["core"] | Some l -> l) entry; st end diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4 deleted file mode 100644 index 2251a662..00000000 --- a/plugins/ltac/g_eqdecide.ml4 +++ /dev/null @@ -1,28 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* [ decideEqualityGoal ] -END - -TACTIC EXTEND compare -| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] -END diff --git a/plugins/ltac/g_eqdecide.mlg b/plugins/ltac/g_eqdecide.mlg new file mode 100644 index 00000000..e57afe3e --- /dev/null +++ b/plugins/ltac/g_eqdecide.mlg @@ -0,0 +1,32 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* { 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 index 0c42a8bb..929390b1 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -12,21 +12,22 @@ DECLARE PLUGIN "ltac_plugin" open Util open Pp +open Glob_term open Constrexpr open Tacexpr -open Misctypes +open Namegen open Genarg open Genredexpr open Tok (* necessary for camlp5 *) open Names open Pcoq -open Pcoq.Constr -open Pcoq.Vernac_ open Pcoq.Prim +open Pcoq.Constr +open Pvernac.Vernac_ open Pltac -let fail_default_value = ArgArg 0 +let fail_default_value = Locus.ArgArg 0 let arg_of_expr = function TacArg (loc,a) -> a @@ -34,20 +35,21 @@ let arg_of_expr = function 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_ipattern pat = in_gen (rawwit Tacarg.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 = CAst.map_with_loc (fun ?loc -> function - | Libnames.Ident id -> id - | Libnames.Qualid _ -> - CErrors.user_err ?loc - (str "This expression should be a simple identifier.")) +let reference_to_id qid = + if Libnames.qualid_is_ident qid then + CAst.make ?loc:qid.CAst.loc @@ Libnames.qualid_basename qid + else + CErrors.user_err ?loc:qid.CAst.loc + (str "This expression should be a simple identifier.") -let tactic_mode = Gram.entry_create "vernac:tactic_command" +let tactic_mode = Entry.create "vernac:tactic_command" let new_entry name = - let e = Gram.entry_create name in + let e = Entry.create name in e let toplevel_selector = new_entry "vernac:toplevel_selector" @@ -58,8 +60,8 @@ let tacdef_body = new_entry "tactic:tacdef_body" let _ = let mode = { Proof_global.name = "Classic"; - set = (fun () -> set_command_entry tactic_mode); - reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + set = (fun () -> Pvernac.set_command_entry tactic_mode); + reset = (fun () -> Pvernac.(set_command_entry noedit_mode)); } in Proof_global.register_proof_mode mode @@ -197,9 +199,8 @@ GEXTEND Gram 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 qid.CAst.v in - ArgVar (CAst.make ~loc:!@loc id) ] ] + [ [ s = STRING -> Locus.ArgArg s (*| id = ident -> Locus.ArgVar (!@loc,id)*) + | qid = qualid -> Locus.ArgVar (CAst.make ~loc:!@loc @@ Libnames.qualid_basename qid) ] ] ; constr_eval: [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> @@ -286,12 +287,14 @@ GEXTEND Gram (* Definitions for tactics *) tacdef_body: - [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> + [ [ 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 -> + | 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 @@ -311,21 +314,23 @@ GEXTEND Gram range_selector_or_nth: [ [ n = natural ; "-" ; m = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - SelectList ((n, m) :: Option.default [] l) + Goal_select.SelectList ((n, m) :: Option.default [] l) | n = natural; l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + let open Goal_select in 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 ] ] + | test_bracket_ident; "["; id = ident; "]" -> Goal_select.SelectId id ] ] ; selector: [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] ; toplevel_selector: [ [ sel = selector_body; ":" -> sel - | IDENT "all"; ":" -> SelectAll ] ] + | "!"; ":" -> Goal_select.SelectAlreadyFocused + | IDENT "all"; ":" -> Goal_select.SelectAll ] ] ; tactic_mode: [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g @@ -342,7 +347,7 @@ GEXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] + Hints.HintsExtern (n,c, in_tac tac) ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> @@ -369,6 +374,7 @@ let _ = declare_int_option { } let vernac_solve n info tcom b = + let open Goal_select in 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 @@ -415,7 +421,7 @@ 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_bullet.get_default_goal_selector ()) g in + let g = Option.default (Goal_select.get_default_goal_selector ()) g in vernac_solve g n t def ] | [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => @@ -428,7 +434,7 @@ VERNAC tactic_mode EXTEND VernacSolve VtLater ] -> [ let t = rm_abstract t in - vernac_solve SelectAll n t def + vernac_solve Goal_select.SelectAll n t def ] END @@ -466,14 +472,15 @@ VERNAC COMMAND FUNCTIONAL EXTEND VernacTacticNotation [ VtSideff [], VtNow ] -> [ fun ~atts ~st -> let open Vernacinterp in let n = Option.default 0 n in - Tacentries.add_tactic_notation (Locality.make_module_locality atts.locality) n r e; + let deprecation = atts.deprecated in + Tacentries.add_tactic_notation (Locality.make_module_locality atts.locality) n ?deprecation r e; st ] END VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY | [ "Print" "Ltac" reference(r) ] -> - [ Feedback.msg_notice (Tacintern.print_ltac (Libnames.qualid_of_reference r).CAst.v) ] + [ Feedback.msg_notice (Tacintern.print_ltac r) ] END VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY @@ -481,7 +488,7 @@ VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY [ Tacentries.print_located_tactic r ] END -let pr_ltac_ref = Libnames.pr_reference +let pr_ltac_ref = Libnames.pr_qualid let pr_tacdef_body tacdef_body = let id, redef, body = @@ -508,10 +515,10 @@ VERNAC COMMAND FUNCTIONAL EXTEND VernacDeclareTacticDefinition | [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ VtSideff (List.map (function | TacticDefinition ({CAst.v=r},_) -> r - | TacticRedefinition ({CAst.v=Ident r},_) -> r - | TacticRedefinition ({CAst.v=Qualid q},_) -> snd(repr_qualid q)) l), VtLater + | TacticRedefinition (qid,_) -> qualid_basename qid) l), VtLater ] -> [ fun ~atts ~st -> let open Vernacinterp in - Tacentries.register_ltac (Locality.make_module_locality atts.locality) l; + let deprecation = atts.deprecated in + Tacentries.register_ltac (Locality.make_module_locality atts.locality) ?deprecation l; st ] END diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 index 352e92c2..1f56244c 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.ml4 @@ -12,7 +12,6 @@ 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 @@ -49,7 +48,7 @@ module Tactic = Pltac open Pcoq -let sigref = mkRefC (CAst.make @@ Qualid (Libnames.qualid_of_string "Coq.Init.Specif.sig")) +let sigref loc = mkRefC (Libnames.qualid_of_string ~loc "Coq.Init.Specif.sig") type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type @@ -68,7 +67,7 @@ GEXTEND Gram Constr.closed_binder: [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> - let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in + let typ = mkAppC (sigref !@loc, [mkLambdaC ([id], default_binder_kind, t, c)]) in [CLocalAssum ([id], default_binder_kind, typ)] ] ]; diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index fbaa2e58..f1634f15 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -11,7 +11,6 @@ (* Syntax for rewriting with strategies *) open Names -open Misctypes open Locus open Constrexpr open Glob_term @@ -20,9 +19,10 @@ open Extraargs open Tacmach open Rewrite open Stdarg -open Pcoq.Vernac_ +open Tactypes open Pcoq.Prim open Pcoq.Constr +open Pvernac.Vernac_ open Pltac DECLARE PLUGIN "ltac_plugin" @@ -67,13 +67,13 @@ let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "" 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 + let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_qualid, 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, + Pputils.pr_or_by_notation Libnames.pr_qualid, Ppconstr.pr_constr_expr) in Rewrite.pr_strategy prc prr s diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 deleted file mode 100644 index 7534e279..00000000 --- a/plugins/ltac/g_tactic.ml4 +++ /dev/null @@ -1,698 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* "; "<-" ; "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) *) -open Extraargs - -(* 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 (fun x -> x.CAst.v) (List.flatten (List.map (fun (nal,_,_) -> nal) bl)) in - (try List.index Names.Name.equal x.CAst.v ids - with Not_found -> user_err Pp.(str "No such fix variable.")) - | _ -> user_err Pp.(str "Cannot guess decreasing argument of fix.") in - let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in - (id,n, CAst.make ~loc @@ CProdN(bl,ty)) - -let mk_cofix_tac (loc,id,bl,ann,ty) = - let _ = Option.map (fun { CAst.loc = aloc } -> - user_err ?loc:aloc - ~hdr:"Constr:mk_cofix_tac" - (Pp.str"Annotation forbidden in cofix expression.")) ann in - let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in - (id,CAst.make ~loc @@ CProdN(bl,ty)) - -(* Functions overloaded by quotifier *) -let destruction_arg_of_constr (c,lbind as clbind) = match lbind with - | NoBindings -> - begin - try ElimOnIdent (CAst.make ?loc:(Constrexpr_ops.constr_loc c) (Constrexpr_ops.coerce_to_id c).CAst.v) - with e when CErrors.noncritical e -> ElimOnConstr clbind - end - | _ -> ElimOnConstr clbind - -let mkNumeral n = Numeral (string_of_int (abs n), 0<=n) - -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,(CAst.make @@ CPrim (mkNumeral 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,(CAst.make @@ CRef (CAst.make ?loc:id.CAst.loc @@ Ident id.CAst.v,None),NoBindings))) - | ic -> - if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) - then - user_err Pp.(str "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 - | ({CAst.loc = loc1}::_ as idl,bk,t) :: bll -> - CAst.make ?loc @@ CLambdaN ([CLocalAssum (idl,bk,t)],mkCLambdaN_simple_loc ?loc:(Loc.merge_opt 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_opt (List.hd (pi1 h)).CAst.loc (Constrexpr_ops.constr_loc c) in - mkCLambdaN_simple_loc ?loc bl c - -let loc_of_ne_list l = Loc.merge_opt (List.hd l).CAst.loc (List.last l).CAst.loc - -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; CAst.make ?loc:(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 - | "*" -> CAst.make ~loc:!@loc @@ IntroForthcoming true - | "**" -> CAst.make ~loc:!@loc @@ IntroForthcoming false ]] - ; - simple_intropattern: - [ [ pat = simple_intropattern_closed; - l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> - let {CAst.loc=loc0;v=pat} = pat in - let f c pat = - let loc1 = Constrexpr_ops.constr_loc c in - let loc = Loc.merge_opt loc0 loc1 in - IntroAction (IntroApplyOn (CAst.(make ?loc:loc1 c),CAst.(make ?loc pat))) in - CAst.make ~loc:!@loc @@ List.fold_right f l pat ] ] - ; - simple_intropattern_closed: - [ [ pat = or_and_intropattern -> CAst.make ~loc:!@loc @@ IntroAction (IntroOrAndPattern pat) - | pat = equality_intropattern -> CAst.make ~loc:!@loc @@ IntroAction pat - | "_" -> CAst.make ~loc:!@loc @@ IntroAction IntroWildcard - | pat = naming_intropattern -> CAst.make ~loc:!@loc @@ IntroNaming pat ] ] - ; - simple_binding: - [ [ "("; id = ident; ":="; c = lconstr; ")" -> CAst.make ~loc:!@loc (NamedHyp id, c) - | "("; n = natural; ":="; c = lconstr; ")" -> CAst.make ~loc:!@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 -> - let id : Misctypes.lident = id in - id,InHyp - | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> - let id : Misctypes.lident = id in - id,InHypTypeOnly - | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> - let id : Misctypes.lident = id in - id,InHypValueOnly - ] ] - ; - hypident_occ: - [ [ (id,l)=hypident; occs=occs -> - let id : Misctypes.lident = id in - ((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, CAst.make ~loc:!@loc @@ - CHole (Some (Evar_kinds.BinderType na.CAst.v), 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 (CAst.make ~loc:!@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 (CAst.make ~loc:!@loc pat) - | IDENT "_eqn"; ":"; pat = naming_intropattern -> - let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "H"; Some (CAst.make ~loc pat) - | IDENT "_eqn" -> - let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "?"; Some (CAst.make ~loc IntroAnonymous) - | -> None ] ] - ; - as_name: - [ [ "as"; id = ident ->Names.Name.Name id | -> Names.Name.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.tag ~loc:!@loc @@ TacIntroPattern (false,pl)) - | IDENT "intros" -> - TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (false,[CAst.make ~loc:!@loc @@IntroForthcoming false])) - | IDENT "eintros"; pl = ne_intropatterns -> - TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (true,pl)) - - | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (true,false,cl,inhyp)) - | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (true,true,cl,inhyp)) - | IDENT "simple"; IDENT "apply"; - cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (false,false,cl,inhyp)) - | IDENT "simple"; IDENT "eapply"; - cl = LIST1 constr_with_bindings_arg SEP","; - inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (false,true,cl,inhyp)) - | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - TacAtom (Loc.tag ~loc:!@loc @@ TacElim (false,cl,el)) - | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - TacAtom (Loc.tag ~loc:!@loc @@ TacElim (true,cl,el)) - | IDENT "case"; icl = induction_clause_list -> TacAtom (Loc.tag ~loc:!@loc @@ mkTacCase false icl) - | IDENT "ecase"; icl = induction_clause_list -> TacAtom (Loc.tag ~loc:!@loc @@ mkTacCase true icl) - | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) - | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) - - | IDENT "pose"; (id,b) = bindings_with_parameters -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) - | IDENT "pose"; b = constr; na = as_name -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) - | IDENT "epose"; (id,b) = bindings_with_parameters -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) - | IDENT "epose"; b = constr; na = as_name -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) - | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) - | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,true,None)) - | IDENT "eset"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) - | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,true,None)) - | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; - p = clause_dft_all -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,false,e)) - | IDENT "eremember"; c = constr; na = as_name; e = eqn_ipat; - p = clause_dft_all -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,false,e)) - - (* Alternative syntax for "pose proof c as id" *) - | IDENT "assert"; test_lpar_id_coloneq; "("; lid = identref; ":="; - c = lconstr; ")" -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) - | IDENT "eassert"; test_lpar_id_coloneq; "("; lid = identref; ":="; - c = lconstr; ")" -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) - - (* Alternative syntax for "assert c as id by tac" *) - | IDENT "assert"; test_lpar_id_colon; "("; lid = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) - | IDENT "eassert"; test_lpar_id_colon; "("; lid = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) - - (* Alternative syntax for "enough c as id by tac" *) - | IDENT "enough"; test_lpar_id_colon; "("; lid = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) - | IDENT "eenough"; test_lpar_id_colon; "("; lid = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) - - | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,Some tac,ipat,c)) - | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,Some tac,ipat,c)) - | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,None,ipat,c)) - | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,None,ipat,c)) - | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,false,Some tac,ipat,c)) - | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,false,Some tac,ipat,c)) - - | IDENT "generalize"; c = constr -> - TacAtom (Loc.tag ~loc:!@loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) - | IDENT "generalize"; c = constr; l = LIST1 constr -> - let gen_everywhere c = ((AllOccurrences,c),Names.Name.Anonymous) in - TacAtom (Loc.tag ~loc:!@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.tag ~loc:!@loc @@ TacGeneralize (((nl,c),na)::l)) - - (* Derived basic tactics *) - | IDENT "induction"; ic = induction_clause_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct (true,false,ic)) - | IDENT "einduction"; ic = induction_clause_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct(true,true,ic)) - | IDENT "destruct"; icl = induction_clause_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct(false,false,icl)) - | IDENT "edestruct"; icl = induction_clause_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct(false,true,icl)) - - (* Equality and inversion *) - | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (Loc.tag ~loc:!@loc @@ TacRewrite (false,l,cl,t)) - | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (Loc.tag ~loc:!@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.tag ~loc:!@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.tag ~loc:!@loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) - | IDENT "inversion"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) - | IDENT "inversion_clear"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) - | IDENT "inversion"; hyp = quantified_hypothesis; - "using"; c = constr; cl = in_hyp_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (InversionUsing (c,cl), hyp)) - - (* Conversion *) - | IDENT "red"; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Red false, cl)) - | IDENT "hnf"; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Hnf, cl)) - | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Simpl (all_with d, po), cl)) - | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Cbv s, cl)) - | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Cbn s, cl)) - | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Lazy s, cl)) - | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Cbv (all_with delta), cl)) - | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (CbvVm po, cl)) - | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (CbvNative po, cl)) - | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Unfold ul, cl)) - | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Fold l, cl)) - | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@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.tag ~loc:!@loc @@ TacChange (p,c,cl)) - ] ] - ; -END;; diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg new file mode 100644 index 00000000..571595be --- /dev/null +++ b/plugins/ltac/g_tactic.mlg @@ -0,0 +1,706 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* "; "<-" ; "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) *) +open Extraargs + +(* 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 (fun x -> x.CAst.v) (List.flatten (List.map (fun (nal,_,_) -> nal) bl)) in + (try List.index Names.Name.equal x.CAst.v ids + with Not_found -> user_err Pp.(str "No such fix variable.")) + | _ -> user_err Pp.(str "Cannot guess decreasing argument of fix.") in + let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in + (id,n, CAst.make ~loc @@ CProdN(bl,ty)) + +let mk_cofix_tac (loc,id,bl,ann,ty) = + let _ = Option.map (fun { CAst.loc = aloc } -> + user_err ?loc:aloc + ~hdr:"Constr:mk_cofix_tac" + (Pp.str"Annotation forbidden in cofix expression.")) ann in + let bl = List.map (fun (nal,bk,t) -> CLocalAssum (nal,bk,t)) bl in + (id,CAst.make ~loc @@ CProdN(bl,ty)) + +(* Functions overloaded by quotifier *) +let destruction_arg_of_constr (c,lbind as clbind) = match lbind with + | NoBindings -> + begin + try ElimOnIdent (CAst.make ?loc:(Constrexpr_ops.constr_loc c) (Constrexpr_ops.coerce_to_id c).CAst.v) + with e when CErrors.noncritical e -> ElimOnConstr clbind + end + | _ -> ElimOnConstr clbind + +let mkNumeral n = Numeral (string_of_int (abs n), 0<=n) + +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,(CAst.make @@ CPrim (mkNumeral 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,(CAst.make @@ CRef (qualid_of_ident ?loc:id.CAst.loc id.CAst.v,None),NoBindings))) + | ic -> + if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) + then + user_err Pp.(str "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 + | ({CAst.loc = loc1}::_ as idl,bk,t) :: bll -> + CAst.make ?loc @@ CLambdaN ([CLocalAssum (idl,bk,t)],mkCLambdaN_simple_loc ?loc:(Loc.merge_opt 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_opt (List.hd (pi1 h)).CAst.loc (Constrexpr_ops.constr_loc c) in + mkCLambdaN_simple_loc ?loc bl c + +let loc_of_ne_list l = Loc.merge_opt (List.hd l).CAst.loc (List.last l).CAst.loc + +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 Pvernac.Vernac_ + +} + +GRAMMAR EXTEND 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; CAst.make ?loc:(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 } + | "*" -> { CAst.make ~loc @@ IntroForthcoming true } + | "**" -> { CAst.make ~loc @@ IntroForthcoming false } ] ] + ; + simple_intropattern: + [ [ pat = simple_intropattern_closed; + l = LIST0 ["%"; c = operconstr LEVEL "0" -> { c } ] -> + { let {CAst.loc=loc0;v=pat} = pat in + let f c pat = + let loc1 = Constrexpr_ops.constr_loc c in + let loc = Loc.merge_opt loc0 loc1 in + IntroAction (IntroApplyOn (CAst.(make ?loc:loc1 c),CAst.(make ?loc pat))) in + CAst.make ~loc @@ List.fold_right f l pat } ] ] + ; + simple_intropattern_closed: + [ [ pat = or_and_intropattern -> { CAst.make ~loc @@ IntroAction (IntroOrAndPattern pat) } + | pat = equality_intropattern -> { CAst.make ~loc @@ IntroAction pat } + | "_" -> { CAst.make ~loc @@ IntroAction IntroWildcard } + | pat = naming_intropattern -> { CAst.make ~loc @@ IntroNaming pat } ] ] + ; + simple_binding: + [ [ "("; id = ident; ":="; c = lconstr; ")" -> { CAst.make ~loc (NamedHyp id, c) } + | "("; n = natural; ":="; c = lconstr; ")" -> { CAst.make ~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 -> + { let id : lident = id in + id,InHyp } + | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> + { let id : lident = id in + id,InHypTypeOnly } + | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> + { let id : lident = id in + id,InHypValueOnly } + ] ] + ; + hypident_occ: + [ [ h=hypident; occs=occs -> + { let (id,l) = h in + let id : lident = id in + ((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, CAst.make ~loc @@ + CHole (Some (Evar_kinds.BinderType na.CAst.v), 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 (CAst.make ~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 (CAst.make ~loc pat) } + | IDENT "_eqn"; ":"; pat = naming_intropattern -> + { warn_deprecated_eqn_syntax ~loc "H"; Some (CAst.make ~loc pat) } + | IDENT "_eqn" -> + { warn_deprecated_eqn_syntax ~loc "?"; Some (CAst.make ~loc IntroAnonymous) } + | -> { None } ] ] + ; + as_name: + [ [ "as"; id = ident -> { Names.Name.Name id } | -> { Names.Name.Anonymous } ] ] + ; + by_tactic: + [ [ "by"; tac = tactic_expr LEVEL "3" -> { Some tac } + | -> { None } ] ] + ; + rewriter : + [ [ "!"; c = constr_with_bindings_arg -> { (Equality.RepeatPlus,c) } + | ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings_arg -> { (Equality.RepeatStar,c) } + | n = natural; "!"; c = constr_with_bindings_arg -> { (Equality.Precisely n,c) } + | n = natural; ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings_arg -> { (Equality.UpTo n,c) } + | n = natural; c = constr_with_bindings_arg -> { (Equality.Precisely n,c) } + | c = constr_with_bindings_arg -> { (Equality.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.tag ~loc @@ TacIntroPattern (false,pl)) } + | IDENT "intros" -> + { TacAtom (Loc.tag ~loc @@ TacIntroPattern (false,[CAst.make ~loc @@IntroForthcoming false])) } + | IDENT "eintros"; pl = ne_intropatterns -> + { TacAtom (Loc.tag ~loc @@ TacIntroPattern (true,pl)) } + + | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (true,false,cl,inhyp)) } + | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (true,true,cl,inhyp)) } + | IDENT "simple"; IDENT "apply"; + cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (false,false,cl,inhyp)) } + | IDENT "simple"; IDENT "eapply"; + cl = LIST1 constr_with_bindings_arg SEP","; + inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (false,true,cl,inhyp)) } + | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + { TacAtom (Loc.tag ~loc @@ TacElim (false,cl,el)) } + | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + { TacAtom (Loc.tag ~loc @@ TacElim (true,cl,el)) } + | IDENT "case"; icl = induction_clause_list -> { TacAtom (Loc.tag ~loc @@ mkTacCase false icl) } + | IDENT "ecase"; icl = induction_clause_list -> { TacAtom (Loc.tag ~loc @@ mkTacCase true icl) } + | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> + { TacAtom (Loc.tag ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } + | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> + { TacAtom (Loc.tag ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } + + | IDENT "pose"; bl = bindings_with_parameters -> + { let (id,b) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } + | IDENT "pose"; b = constr; na = as_name -> + { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } + | IDENT "epose"; bl = bindings_with_parameters -> + { let (id,b) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } + | IDENT "epose"; b = constr; na = as_name -> + { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } + | IDENT "set"; bl = bindings_with_parameters; p = clause_dft_concl -> + { let (id,c) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } + | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,c,p,true,None)) } + | IDENT "eset"; bl = bindings_with_parameters; p = clause_dft_concl -> + { let (id,c) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } + | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,c,p,true,None)) } + | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; + p = clause_dft_all -> + { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,c,p,false,e)) } + | IDENT "eremember"; c = constr; na = as_name; e = eqn_ipat; + p = clause_dft_all -> + { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,c,p,false,e)) } + + (* Alternative syntax for "pose proof c as id" *) + | IDENT "assert"; test_lpar_id_coloneq; "("; lid = identref; ":="; + c = lconstr; ")" -> + { let { CAst.loc = loc; v = id } = lid in + TacAtom (Loc.tag ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + | IDENT "eassert"; test_lpar_id_coloneq; "("; lid = identref; ":="; + c = lconstr; ")" -> + { let { CAst.loc = loc; v = id } = lid in + TacAtom (Loc.tag ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + + (* Alternative syntax for "assert c as id by tac" *) + | IDENT "assert"; test_lpar_id_colon; "("; lid = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + { let { CAst.loc = loc; v = id } = lid in + TacAtom (Loc.tag ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + | IDENT "eassert"; test_lpar_id_colon; "("; lid = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + { let { CAst.loc = loc; v = id } = lid in + TacAtom (Loc.tag ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + + (* Alternative syntax for "enough c as id by tac" *) + | IDENT "enough"; test_lpar_id_colon; "("; lid = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + { let { CAst.loc = loc; v = id } = lid in + TacAtom (Loc.tag ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + | IDENT "eenough"; test_lpar_id_colon; "("; lid = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + { let { CAst.loc = loc; v = id } = lid in + TacAtom (Loc.tag ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + + | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> + { TacAtom (Loc.tag ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } + | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> + { TacAtom (Loc.tag ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } + | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> + { TacAtom (Loc.tag ~loc @@ TacAssert (false,true,None,ipat,c)) } + | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> + { TacAtom (Loc.tag ~loc @@ TacAssert (true,true,None,ipat,c)) } + | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> + { TacAtom (Loc.tag ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } + | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic -> + { TacAtom (Loc.tag ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } + + | IDENT "generalize"; c = constr -> + { TacAtom (Loc.tag ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } + | IDENT "generalize"; c = constr; l = LIST1 constr -> + { let gen_everywhere c = ((AllOccurrences,c),Names.Name.Anonymous) in + TacAtom (Loc.tag ~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.tag ~loc @@ TacGeneralize (((nl,c),na)::l)) } + + (* Derived basic tactics *) + | IDENT "induction"; ic = induction_clause_list -> + { TacAtom (Loc.tag ~loc @@ TacInductionDestruct (true,false,ic)) } + | IDENT "einduction"; ic = induction_clause_list -> + { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(true,true,ic)) } + | IDENT "destruct"; icl = induction_clause_list -> + { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(false,false,icl)) } + | IDENT "edestruct"; icl = induction_clause_list -> + { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(false,true,icl)) } + + (* Equality and inversion *) + | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; + cl = clause_dft_concl; t=by_tactic -> { TacAtom (Loc.tag ~loc @@ TacRewrite (false,l,cl,t)) } + | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; + cl = clause_dft_concl; t=by_tactic -> { TacAtom (Loc.tag ~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.tag ~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.tag ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } + | IDENT "inversion"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } + | IDENT "inversion_clear"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } + | IDENT "inversion"; hyp = quantified_hypothesis; + "using"; c = constr; cl = in_hyp_list -> + { TacAtom (Loc.tag ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } + + (* Conversion *) + | IDENT "red"; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Red false, cl)) } + | IDENT "hnf"; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Hnf, cl)) } + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Simpl (all_with d, po), cl)) } + | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Cbv s, cl)) } + | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Cbn s, cl)) } + | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Lazy s, cl)) } + | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Cbv (all_with delta), cl)) } + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (CbvVm po, cl)) } + | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (CbvNative po, cl)) } + | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Unfold ul, cl)) } + | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Fold l, cl)) } + | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> + { TacAtom (Loc.tag ~loc @@ TacReduce (Pattern pl, cl)) } + + (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) + | IDENT "change"; c = conversion; cl = clause_dft_concl -> + { let (oc, c) = c in + let p,cl = merge_occurrences loc cl oc in + TacAtom (Loc.tag ~loc @@ TacChange (p,c,cl)) } + ] ] + ; +END diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index e9711268..759bb62f 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -11,11 +11,10 @@ open Pcoq (* Main entry for extensions *) -let simple_tactic = Gram.entry_create "tactic:simple_tactic" +let simple_tactic = Entry.create "tactic:simple_tactic" -let make_gen_entry _ name = Gram.entry_create ("tactic:" ^ name) +let make_gen_entry _ name = 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" @@ -23,7 +22,7 @@ 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 hypident = 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 = @@ -40,7 +39,7 @@ let clause_dft_concl = (* Main entries for ltac *) -let tactic_arg = Gram.entry_create "tactic:tactic_arg" +let tactic_arg = Entry.create "tactic:tactic_arg" let tactic_expr = make_gen_entry utactic "tactic_expr" let binder_tactic = make_gen_entry utactic "binder_tactic" diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 6637de74..9bff98b6 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -15,24 +15,24 @@ open Libnames open Constrexpr open Tacexpr open Genredexpr -open Misctypes +open Tactypes -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 : (lident * 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 CAst.t Gram.entry -val in_clause : lident Locus.clause_expr Gram.entry -val clause_dft_concl : lident 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 +val open_constr : constr_expr Entry.t +val constr_with_bindings : constr_expr with_bindings Entry.t +val bindings : constr_expr bindings Entry.t +val hypident : (Names.lident * Locus.hyp_location_flag) Entry.t +val constr_may_eval : (constr_expr,qualid or_by_notation,constr_expr) may_eval Entry.t +val constr_eval : (constr_expr,qualid or_by_notation,constr_expr) may_eval Entry.t +val uconstr : constr_expr Entry.t +val quantified_hypothesis : quantified_hypothesis Entry.t +val destruction_arg : constr_expr with_bindings Tactics.destruction_arg Entry.t +val int_or_var : int Locus.or_var Entry.t +val simple_tactic : raw_tactic_expr Entry.t +val simple_intropattern : constr_expr intro_pattern_expr CAst.t Entry.t +val in_clause : Names.lident Locus.clause_expr Entry.t +val clause_dft_concl : Names.lident Locus.clause_expr Entry.t +val tactic_arg : raw_tactic_arg Entry.t +val tactic_expr : raw_tactic_expr Entry.t +val binder_tactic : raw_tactic_expr Entry.t +val tactic : raw_tactic_expr Entry.t +val tactic_eoi : raw_tactic_expr Entry.t diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 11bb7a23..b219ee25 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -17,9 +17,8 @@ open Constrexpr open Genarg open Geninterp open Stdarg -open Libnames -open Notation_term -open Misctypes +open Notation_gram +open Tactypes open Locus open Decl_kinds open Genredexpr @@ -29,6 +28,7 @@ open Printer open Tacexpr open Tacarg +open Tactics module Tag = struct @@ -116,7 +116,7 @@ let string_of_genarg_arg (ArgumentType arg) = 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 + let has_type (Val.Dyn (tag, _)) t = match Val.eq tag t with | None -> false | Some _ -> true @@ -149,9 +149,12 @@ let string_of_genarg_arg (ArgumentType arg) = let open Genprint in match generic_top_print (in_gen (Topwit wit) x) with | TopPrinterBasic pr -> pr () - | TopPrinterNeedsContext pr -> pr (Global.env()) Evd.empty + | TopPrinterNeedsContext pr -> + let env = Global.env() in + pr env (Evd.from_env env) | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> - printer (Global.env()) Evd.empty default_ensure_surrounded + let env = Global.env() in + printer env (Evd.from_env env) default_ensure_surrounded end | _ -> default @@ -186,7 +189,7 @@ let string_of_genarg_arg (ArgumentType arg) = | 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_located pr (_,x) = pr x let pr_evaluable_reference = function | EvalVarRef id -> pr_id id @@ -238,7 +241,7 @@ let string_of_genarg_arg (ArgumentType arg) = in pr_sequence (fun x -> x) l - let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = + let pr_extend_gen pr_gen _ { mltac_name = s; mltac_index = i } l = let name = str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++ str "@" ++ int i @@ -258,7 +261,7 @@ let string_of_genarg_arg (ArgumentType arg) = | Extend.Uentry tag -> let ArgT.Any tag = tag in ArgT.repr tag - | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl + | Extend.Uentryl (_, lvl) -> "tactic" ^ string_of_int lvl let pr_alias_key key = try @@ -269,6 +272,8 @@ let string_of_genarg_arg (ArgumentType arg) = in pr_sequence pr prods with Not_found -> + (* FIXME: This key, moreover printed with a low-level printer, + has no meaning user-side *) KerName.print key let pr_alias_gen pr_gen lev key l = @@ -286,7 +291,7 @@ let string_of_genarg_arg (ArgumentType arg) = 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 + let pr _ = str "_" in KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.tag arg)) @@ -339,14 +344,14 @@ let string_of_genarg_arg (ArgumentType arg) = pr_any_arg pr symb arg | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - let pr_raw_extend_rec prc prlc prtac prpat = + let pr_raw_extend_rec prtac = pr_extend_gen (pr_farg prtac) - let pr_glob_extend_rec prc prlc prtac prpat = + let pr_glob_extend_rec prtac = pr_extend_gen (pr_farg prtac) - let pr_raw_alias prc prlc prtac prpat lev key args = + let pr_raw_alias prtac lev key args = pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args - let pr_glob_alias prc prlc prtac prpat lev key args = + let pr_glob_alias prtac lev key args = pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args (**********************************************************************) @@ -490,7 +495,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_orient b = if b then mt () else str "<- " - let pr_multi = function + let pr_multi = let open Equality in function | Precisely 1 -> mt () | Precisely n -> int n ++ str "!" | UpTo n -> int n ++ str "?" @@ -505,7 +510,7 @@ let string_of_genarg_arg (ArgumentType arg) = 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 + let pr_inversion_kind = let open Inv in function | SimpleInversion -> primitive "simple inversion" | FullInversion -> primitive "inversion" | FullInversionClear -> primitive "inversion_clear" @@ -514,7 +519,8 @@ let string_of_genarg_arg (ArgumentType arg) = if Int.equal i j then int i else int i ++ str "-" ++ int j -let pr_goal_selector toplevel = function +let pr_goal_selector toplevel = let open Goal_select in function + | SelectAlreadyFocused -> str "!:" | SelectNth i -> int i ++ str ":" | SelectList l -> prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ str ":" | SelectId id -> str "[" ++ Id.print id ++ str "]:" @@ -740,12 +746,12 @@ let pr_goal_selector ~toplevel s = (* Main tactic printer *) and pr_atom1 a = tag_atom a (match a with (* Basic tactics *) - | TacIntroPattern (ev,[]) as t -> + | TacIntroPattern (_,[]) as t -> pr_atom0 t | TacIntroPattern (ev,(_::_ as p)) -> hov 1 (primitive (if ev then "eintros" else "intros") ++ (match p with - | [{CAst.v=Misctypes.IntroForthcoming false}] -> mt () + | [{CAst.v=IntroForthcoming false}] -> mt () | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)) | TacApply (a,ev,cb,inhyp) -> hov 1 ( @@ -1051,7 +1057,7 @@ let pr_goal_selector ~toplevel s = primitive "fresh" ++ pr_fresh_ids l, latom | TacArg(_,TacGeneric arg) -> pr.pr_generic arg, latom - | TacArg(_,TacCall(loc,(f,[]))) -> + | TacArg(_,TacCall(_,(f,[]))) -> pr.pr_reference f, latom | TacArg(_,TacCall(loc,(f,l))) -> pr_with_comments ?loc (hov 1 ( @@ -1105,12 +1111,12 @@ let pr_goal_selector ~toplevel s = 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_constant = pr_or_by_notation pr_qualid; + pr_reference = pr_qualid; 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; + pr_extend = pr_raw_extend_rec pr_raw_tactic_level; + pr_alias = pr_raw_alias pr_raw_tactic_level; } in make_pr_tac pr raw_printers @@ -1139,12 +1145,8 @@ let pr_goal_selector ~toplevel s = 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)); + pr_extend = pr_glob_extend_rec prtac; + pr_alias = pr_glob_alias prtac; } in make_pr_tac pr glob_printers @@ -1165,8 +1167,8 @@ let pr_goal_selector ~toplevel s = | _ -> user_err Pp.(str "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_atomic_tactic_level env sigma t = + let prtac (t:atomic_tactic_expr) = let pr = { pr_tactic = (fun _ _ -> str ""); pr_constr = (fun c -> pr_econstr_env env sigma c); @@ -1185,18 +1187,15 @@ let pr_goal_selector ~toplevel s = in pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t in - prtac n t + prtac 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_raw_extend _ = pr_raw_extend_rec pr_raw_tactic_level - 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_glob_extend env = pr_glob_extend_rec (pr_glob_tactic_level env) let pr_alias pr lev key args = pr_alias_gen (fun _ arg -> pr arg) lev key args @@ -1204,14 +1203,14 @@ let pr_goal_selector ~toplevel s = 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 pr_atomic_tactic env sigma c = pr_atomic_tactic_level env sigma 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 -> () + | ExtraArg _ -> () | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") end; let f x = @@ -1319,7 +1318,7 @@ let () = let open Genprint in register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; register_basic_print0 wit_ref - pr_reference (pr_or_var (pr_located pr_global)) pr_global; + pr_qualid (pr_or_var (pr_located pr_global)) pr_global; register_basic_print0 wit_ident pr_id pr_id pr_id; register_basic_print0 wit_var pr_lident pr_lident pr_id; register_print0 @@ -1353,7 +1352,7 @@ let () = ; Genprint.register_print0 wit_red_expr - (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))) + (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_qualid, pr_constr_pattern_expr))) (lift (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac))) pr_red_expr_env ; diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 5951f2b1..6c09e447 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -14,11 +14,11 @@ open Genarg open Geninterp open Names -open Misctypes open Environ open Constrexpr -open Notation_term +open Notation_gram open Tacexpr +open Tactypes type 'a grammar_tactic_prod_item_expr = | TacTerm of string @@ -84,7 +84,7 @@ type pp_tactic = { pptac_prods : grammar_terminals; } -val pr_goal_selector : toplevel:bool -> goal_selector -> Pp.t +val pr_goal_selector : toplevel:bool -> Goal_select.t -> Pp.t val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit @@ -97,7 +97,7 @@ val pr_may_eval : ('a -> Pp.t) -> ('a -> Pp.t) -> ('b -> Pp.t) -> ('c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t -val pr_and_short_name : ('a -> Pp.t) -> 'a and_short_name -> Pp.t +val pr_and_short_name : ('a -> Pp.t) -> 'a Stdarg.and_short_name -> Pp.t val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t @@ -153,5 +153,5 @@ val pr_value : tolerability -> Val.t -> Pp.t val ltop : tolerability -val make_constr_printer : (env -> Evd.evar_map -> Notation_term.tolerability -> 'a -> Pp.t) -> +val make_constr_printer : (env -> Evd.evar_map -> tolerability -> 'a -> Pp.t) -> 'a Genprint.top_printer diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index d32a2fae..9f8cd2fc 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -26,7 +26,7 @@ open Classes open Constrexpr open Globnames open Evd -open Misctypes +open Tactypes open Locus open Locusops open Decl_kinds @@ -104,9 +104,8 @@ let extends_undefined evars evars' = 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 evars, t = Typing.solve_evars env evars (mkApp (fc, args)) in + (evars, cstrs), t let app_poly_nocheck env evars f args = let evars, fc = f evars in @@ -410,7 +409,7 @@ module TypeGlobal = struct let inverse env (evd,cstrs) car rel = - let (evd, sort) = Evarutil.new_Type ~rigid:Evd.univ_flexible env evd in + let (evd, sort) = Evarutil.new_Type ~rigid:Evd.univ_flexible evd in app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] end @@ -428,7 +427,8 @@ let split_head = function | [] -> 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 equal x y = Constr.equal (EConstr.Unsafe.to_constr x) (EConstr.Unsafe.to_constr y) in + pb == pb' || (ty == ty' && equal x x' && equal y y') let problem_inclusion x y = List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x @@ -626,9 +626,9 @@ let solve_remaining_by env sigma holes by = (** 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 ty = evi.evar_concl in let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in - Evd.define evk c sigma + Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep @@ -1468,8 +1468,8 @@ exception RewriteFailure of Pp.t 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 sigma, sort = Typing.sort_of env sigma concl in 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) = @@ -1773,11 +1773,11 @@ let rec strategy_of_ast = function (* By default the strategy for "rewrite_db" is top-down *) -let mkappc s l = CAst.make @@ CAppExpl ((None,CAst.make @@ Libnames.Ident (Id.of_string s),None),l) +let mkappc s l = CAst.make @@ CAppExpl ((None,qualid_of_ident (Id.of_string s),None),l) let declare_an_instance n s args = (((CAst.make @@ Name n),None), Explicit, - CAst.make @@ CAppExpl ((None, CAst.make @@ Qualid (qualid_of_string s),None), args)) + CAst.make @@ CAppExpl ((None, qualid_of_string s,None), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] @@ -1791,17 +1791,17 @@ let anew_instance global binders instance fields = 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 - [(CAst.make @@ Ident (Id.of_string "reflexivity"),lemma)] + [(qualid_of_ident (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 - [(CAst.make @@ Ident (Id.of_string "symmetry"),lemma)] + [(qualid_of_ident (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 - [(CAst.make @@ Ident (Id.of_string "transitivity"),lemma)] + [(qualid_of_ident (Id.of_string "transitivity"),lemma)] let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = init_setoid (); @@ -1825,16 +1825,16 @@ let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "PreOrder_Reflexive"), lemma1); - (CAst.make @@ Ident (Id.of_string "PreOrder_Transitive"),lemma3)]) + [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); + (qualid_of_ident (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 - [(CAst.make @@ Ident (Id.of_string "PER_Symmetric"), lemma2); - (CAst.make @@ Ident (Id.of_string "PER_Transitive"),lemma3)]) + [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); + (qualid_of_ident (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 @@ -1842,11 +1842,11 @@ let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "Equivalence_Reflexive"), lemma1); - (CAst.make @@ Ident (Id.of_string "Equivalence_Symmetric"), lemma2); - (CAst.make @@ Ident (Id.of_string "Equivalence_Transitive"), lemma3)]) + [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); + (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)]) -let cHole = CAst.make @@ CHole (None, Misctypes.IntroAnonymous, None) +let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) let proper_projection sigma r ty = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) in @@ -1862,7 +1862,6 @@ let declare_projection n instance_id r = 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 @@ -1923,7 +1922,7 @@ let build_morphism_signature env sigma m = let evd = solve_constraints env !evd in let evd = Evd.minimize_universes 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); + Pretyping.check_evars env (Evd.from_env env) evd (EConstr.of_constr m); Evd.evar_universe_context evd, m let default_morphism sign m = @@ -1950,16 +1949,15 @@ let add_setoid global binders a aeq t n = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); - (CAst.make @@ Ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (CAst.make @@ Ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) let make_tactic name = let open Tacexpr in - let tacpath = Libnames.qualid_of_string name in - let tacname = CAst.make @@ Qualid tacpath in - TacArg (Loc.tag @@ (TacCall (Loc.tag (tacname, [])))) + let tacqid = Libnames.qualid_of_string name in + TacArg (Loc.tag @@ (TacCall (Loc.tag (tacqid, [])))) let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> @@ -2009,7 +2007,7 @@ let add_morphism glob binders m s n = let instance = (((CAst.make @@ Name instance_id),None), Explicit, CAst.make @@ CAppExpl ( - (None, CAst.make @@ Qualid (Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), + (None, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper",None), [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 1e3d4733..0d014a0b 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -12,9 +12,9 @@ open Names open Environ open EConstr open Constrexpr -open Tacexpr -open Misctypes open Evd +open Tactypes +open Tacexpr open Tacinterp (** TODO: document and clean me! *) diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml index 6eb482b1..8a25d485 100644 --- a/plugins/ltac/tacarg.ml +++ b/plugins/ltac/tacarg.ml @@ -19,6 +19,14 @@ let make0 ?dyn name = let () = Geninterp.register_val0 wit dyn in wit +let wit_intro_pattern = make0 "intropattern" +let wit_quant_hyp = make0 "quant_hyp" +let wit_constr_with_bindings = make0 "constr_with_bindings" +let wit_open_constr_with_bindings = make0 "open_constr_with_bindings" +let wit_bindings = make0 "bindings" +let wit_quantified_hypothesis = wit_quant_hyp +let wit_intropattern = wit_intro_pattern + let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = make0 "tactic" diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli index 5347eda7..bdb0be03 100644 --- a/plugins/ltac/tacarg.mli +++ b/plugins/ltac/tacarg.mli @@ -9,9 +9,33 @@ (************************************************************************) open Genarg -open Tacexpr +open EConstr open Constrexpr -open Misctypes +open Tactypes +open Tacexpr + +(** Tactic related witnesses, could also live in tactics/ if other users *) +val wit_intro_pattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type + +val wit_quant_hyp : quantified_hypothesis uniform_genarg_type + +val wit_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings delayed_open) genarg_type + +val wit_open_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings delayed_open) genarg_type + +val wit_bindings : + (constr_expr bindings, + glob_constr_and_expr bindings, + constr bindings delayed_open) genarg_type + +val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type +val wit_intropattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type (** Generic arguments based on Ltac. *) @@ -23,7 +47,7 @@ val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_typ 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 + (constr_expr with_bindings Tactics.destruction_arg, + glob_constr_and_expr with_bindings Tactics.destruction_arg, + delayed_open_constr_with_bindings Tactics.destruction_arg) genarg_type diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 3812a2ba..026c00b8 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -12,9 +12,11 @@ open Util open Names open Constr open EConstr -open Misctypes +open Namegen +open Tactypes open Genarg open Stdarg +open Tacarg open Geninterp open Pp @@ -163,8 +165,7 @@ let coerce_var_to_ident fresh env sigma v = (* 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 coerce_to_ident_not_fresh sigma v = let id_of_name = function | Name.Anonymous -> Id.of_string "x" | Name.Name x -> x in @@ -181,9 +182,9 @@ let id_of_name = function | Some c -> match EConstr.kind sigma c with | Var id -> id - | Meta m -> id_of_name (Evd.meta_name g m) + | Meta m -> id_of_name (Evd.meta_name sigma m) | Evar (kn,_) -> - begin match Evd.evar_ident kn g with + begin match Evd.evar_ident kn sigma with | None -> fail () | Some id -> id end @@ -197,15 +198,16 @@ let id_of_name = function let basename = Nametab.basename_of_global ref in basename | Sort s -> - begin + begin match ESorts.kind sigma s with - | Sorts.Prop _ -> Label.to_id (Label.make "Prop") - | Sorts.Type _ -> Label.to_id (Label.make "Type") - end + | Sorts.Prop -> Label.to_id (Label.make "Prop") + | Sorts.Set -> Label.to_id (Label.make "Set") + | Sorts.Type _ -> Label.to_id (Label.make "Type") + end | _ -> fail() -let coerce_to_intro_pattern env sigma v = +let coerce_to_intro_pattern sigma v = if has_type v (topwit wit_intro_pattern) then (out_gen (topwit wit_intro_pattern) v).CAst.v else if has_type v (topwit wit_var) then @@ -218,8 +220,8 @@ let coerce_to_intro_pattern env sigma v = 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 +let coerce_to_intro_pattern_naming sigma v = + match coerce_to_intro_pattern sigma v with | IntroNaming pat -> pat | _ -> raise (CannotCoerceTo "a naming introduction pattern") @@ -252,7 +254,7 @@ let coerce_to_constr env v = (try [], constr_of_id env id with Not_found -> fail ()) else fail () -let coerce_to_uconstr env v = +let coerce_to_uconstr v = if has_type v (topwit wit_uconstr) then out_gen (topwit wit_uconstr) v else @@ -296,11 +298,11 @@ let coerce_to_constr_list env v = List.map map l | None -> raise (CannotCoerceTo "a term list") -let coerce_to_intro_pattern_list ?loc env sigma v = +let coerce_to_intro_pattern_list ?loc sigma v = match Value.to_list v with | None -> raise (CannotCoerceTo "an intro pattern list") | Some l -> - let map v = CAst.make ?loc @@ coerce_to_intro_pattern env sigma v in + let map v = CAst.make ?loc @@ coerce_to_intro_pattern sigma v in List.map map l let coerce_to_hyp env sigma v = @@ -325,7 +327,7 @@ let coerce_to_hyp_list env sigma v = | None -> raise (CannotCoerceTo "a variable list") (* Interprets a qualified name *) -let coerce_to_reference env sigma v = +let coerce_to_reference sigma v = match Value.to_constr v with | Some c -> begin @@ -353,7 +355,7 @@ let coerce_to_quantified_hypothesis sigma v = (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) -let coerce_to_decl_or_quant_hyp env sigma v = +let coerce_to_decl_or_quant_hyp sigma v = if has_type v (topwit wit_int) then AnonHyp (out_gen (topwit wit_int) v) else @@ -365,7 +367,7 @@ 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 + let map n = Locus.ArgArg (coerce_to_int n) in List.map map l (** Abstract application, to print ltac functions *) diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index 1fa5e3c0..d2ae92f6 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -11,9 +11,9 @@ open Util open Names open EConstr -open Misctypes open Genarg open Geninterp +open Tactypes (** Coercions from highest level generic arguments to actual data used by Ltac interpretation. Those functions examinate dynamic types and try to return @@ -51,12 +51,12 @@ 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_ident_not_fresh : 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 : 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 + Evd.evar_map -> Value.t -> Namegen.intro_pattern_naming_expr val coerce_to_hint_base : Value.t -> string @@ -64,7 +64,7 @@ val coerce_to_int : Value.t -> int val coerce_to_constr : Environ.env -> Value.t -> Ltac_pretype.constr_under_binders -val coerce_to_uconstr : Environ.env -> Value.t -> Ltac_pretype.closed_glob_constr +val coerce_to_uconstr : Value.t -> Ltac_pretype.closed_glob_constr val coerce_to_closed_constr : Environ.env -> Value.t -> constr @@ -74,19 +74,19 @@ val coerce_to_evaluable_ref : val coerce_to_constr_list : Environ.env -> Value.t -> constr list val coerce_to_intro_pattern_list : - ?loc:Loc.t -> Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.intro_patterns + ?loc:Loc.t -> 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_reference : Evd.evar_map -> Value.t -> GlobRef.t 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_decl_or_quant_hyp : Evd.evar_map -> Value.t -> quantified_hypothesis -val coerce_to_int_or_var_list : Value.t -> int or_var list +val coerce_to_int_or_var_list : Value.t -> int Locus.or_var list (** {5 Missing generic arguments} *) diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index e510b9f5..636cb8eb 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -45,7 +45,7 @@ let coincide s pat off = let atactic n = if n = 5 then Aentry Pltac.binder_tactic - else Aentryl (Pltac.tactic_expr, n) + else Aentryl (Pltac.tactic_expr, string_of_int n) type entry_name = EntryName : 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name @@ -252,7 +252,7 @@ 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_body : Tacenv.alias_tactic; tacobj_forml : bool; } @@ -288,10 +288,11 @@ let load_tactic_notation i (_, tobj) = extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram let subst_tactic_notation (subst, tobj) = - let (ids, body) = tobj.tacobj_body in + let open Tacenv in + let alias = tobj.tacobj_body in { tobj with tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; - tacobj_body = (ids, Tacsubst.subst_tactic subst body); + tacobj_body = { alias with alias_body = Tacsubst.subst_tactic subst alias.alias_body }; } let classify_tactic_notation tacobj = Substitute tacobj @@ -308,25 +309,26 @@ let cons_production_parameter = function | TacTerm _ -> None | TacNonTerm (_, (_, ido)) -> ido -let add_glob_tactic_notation local ~level prods forml ids tac = +let add_glob_tactic_notation local ~level ?deprecation prods forml ids tac = let parule = { tacgram_level = level; tacgram_prods = prods; } in + let open Tacenv in let tacobj = { tacobj_key = make_fresh_key prods; tacobj_local = local; tacobj_tacgram = parule; - tacobj_body = (ids, tac); + tacobj_body = { alias_args = ids; alias_body = tac; alias_deprecation = deprecation }; tacobj_forml = forml; } in Lib.add_anonymous_leaf (inTacticGrammar tacobj) -let add_tactic_notation local n prods e = +let add_tactic_notation local n ?deprecation 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 ~level:n prods false ids tac + add_glob_tactic_notation local ~level:n ?deprecation prods false ids tac (**********************************************************************) (* ML Tactic entries *) @@ -366,7 +368,7 @@ let extend_atomic_tactic name entries = in List.iteri add_atomic entries -let add_ml_tactic_notation name ~level prods = +let add_ml_tactic_notation name ~level ?deprecation prods = let len = List.length prods in let iter i prods = let open Tacexpr in @@ -376,9 +378,9 @@ let add_ml_tactic_notation name ~level prods = 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 (CAst.make id)) in + let map id = Reference (Locus.ArgVar (CAst.make id)) in let tac = TacML (Loc.tag (entry, List.map map ids)) in - add_glob_tactic_notation false ~level prods true ids tac + add_glob_tactic_notation false ~level ?deprecation prods true ids tac in List.iteri iter (List.rev prods); (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at @@ -398,7 +400,7 @@ let create_ltac_quotation name cast (e, l) = let () = ltac_quotations := String.Set.add name !ltac_quotations in let entry = match l with | None -> Aentry e - | Some l -> Aentryl (e, l) + | Some l -> Aentryl (e, string_of_int l) in (* let level = Some "1" in *) let level = None in @@ -430,7 +432,7 @@ let warn_unusable_identifier = (fun id -> strbrk "The Ltac name" ++ spc () ++ Id.print id ++ spc () ++ strbrk "may be unusable because of a conflict with a notation.") -let register_ltac local tacl = +let register_ltac local ?deprecation tacl = let map tactic_body = match tactic_body with | Tacexpr.TacticDefinition ({CAst.loc;v=id}, body) -> @@ -449,12 +451,12 @@ let register_ltac local tacl = in let () = if is_shadowed then warn_unusable_identifier id in NewTac id, body - | Tacexpr.TacticRedefinition (ident, body) -> + | Tacexpr.TacticRedefinition (qid, body) -> let kn = - try Tacenv.locate_tactic (qualid_of_reference ident).CAst.v + try Tacenv.locate_tactic qid with Not_found -> - CErrors.user_err ?loc:ident.CAst.loc - (str "There is no Ltac named " ++ pr_reference ident ++ str ".") + CErrors.user_err ?loc:qid.CAst.loc + (str "There is no Ltac named " ++ pr_qualid qid ++ str ".") in UpdateTac kn, body in @@ -483,10 +485,10 @@ let register_ltac local tacl = let defs = States.with_state_protection defs () in let iter (def, tac) = match def with | NewTac id -> - Tacenv.register_ltac false local id tac; + Tacenv.register_ltac false local id tac ?deprecation; Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined") | UpdateTac kn -> - Tacenv.redefine_ltac local kn tac; + Tacenv.redefine_ltac local kn tac ?deprecation; let name = Tacenv.shortest_qualid_of_tactic kn in Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") in @@ -554,13 +556,18 @@ let () = ] in register_grammars_by_name "tactic" entries +let get_identifier id = + (** Workaround for badly-designed generic arguments lacking a closure *) + Names.Id.of_string_soft ("$" ^ id) + + type _ ty_sig = | TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig | TyIdent : string * 'r ty_sig -> 'r ty_sig | TyArg : - (('a, 'b, 'c) Extend.ty_user_symbol * Id.t) Loc.located * 'r ty_sig -> ('c -> 'r) ty_sig + ('a, 'b, 'c) Extend.ty_user_symbol * string * 'r ty_sig -> ('c -> 'r) ty_sig | TyAnonArg : - ('a, 'b, 'c) Extend.ty_user_symbol Loc.located * 'r ty_sig -> 'r ty_sig + ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> 'r ty_sig type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml @@ -578,23 +585,15 @@ let rec clause_of_sign : type a. a ty_sig -> Genarg.ArgT.any Extend.user_symbol fun sign -> match sign with | TyNil -> [] | TyIdent (s, sig') -> TacTerm s :: clause_of_sign sig' - | TyArg ((loc,(a,id)),sig') -> - TacNonTerm (loc,(untype_user_symbol a,Some id)) :: clause_of_sign sig' - | TyAnonArg ((loc,a),sig') -> - TacNonTerm (loc,(untype_user_symbol a,None)) :: clause_of_sign sig' + | TyArg (a, id, sig') -> + let id = get_identifier id in + TacNonTerm (None,(untype_user_symbol a,Some id)) :: clause_of_sign sig' + | TyAnonArg (a, sig') -> + TacNonTerm (None,(untype_user_symbol a,None)) :: clause_of_sign sig' let clause_of_ty_ml = function | TyML (t,_) -> clause_of_sign t -let rec prj : type a b c. (a,b,c) Extend.ty_user_symbol -> (a,b,c) genarg_type = function - | TUentry a -> ExtraArg a - | TUentryl (a,l) -> ExtraArg a - | TUopt(o) -> OptArg (prj o) - | TUlist1 l -> ListArg (prj l) - | TUlist1sep (l,_) -> ListArg (prj l) - | TUlist0 l -> ListArg (prj l) - | TUlist0sep (l,_) -> ListArg (prj l) - let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = fun sign tac -> match sign with @@ -604,15 +603,15 @@ let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.i | _ :: _ -> assert false end | TyIdent (s, sig') -> eval_sign sig' tac - | TyArg ((_loc,(a,id)), sig') -> + | TyArg (a, _, sig') -> let f = eval_sign sig' in begin fun tac vals ist -> match vals with | [] -> assert false | v :: vals -> - let v' = Taccoerce.Value.cast (topwit (prj a)) v in + let v' = Taccoerce.Value.cast (topwit (Egramml.proj_symbol a)) v in f (tac v') vals ist end tac - | TyAnonArg ((_loc,a), sig') -> eval_sign sig' tac + | TyAnonArg (a, sig') -> eval_sign sig' tac let eval : ty_ml -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = function | TyML (t,tac) -> eval_sign t tac @@ -624,14 +623,14 @@ let is_constr_entry = function let rec only_constr : type a. a ty_sig -> bool = function | TyNil -> true | TyIdent(_,_) -> false -| TyArg((_,(u,_)),s) -> if is_constr_entry u then only_constr s else false -| TyAnonArg((_,u),s) -> if is_constr_entry u then only_constr s else false +| TyArg (u, _, s) -> if is_constr_entry u then only_constr s else false +| TyAnonArg (u, s) -> if is_constr_entry u then only_constr s else false let rec mk_sign_vars : type a. a ty_sig -> Name.t list = function | TyNil -> [] | TyIdent (_,s) -> mk_sign_vars s -| TyArg((_,(_,name)),s) -> Name name :: mk_sign_vars s -| TyAnonArg((_,_),s) -> Anonymous :: mk_sign_vars s +| TyArg (_, name, s) -> Name (get_identifier name) :: mk_sign_vars s +| TyAnonArg (_, s) -> Anonymous :: mk_sign_vars s let dummy_id = Id.of_string "_" @@ -652,7 +651,7 @@ let lift_constr_tac_to_ml_tac vars tac = end in tac -let tactic_extend plugin_name tacname ~level sign = +let tactic_extend plugin_name tacname ~level ?deprecation sign = let open Tacexpr in let ml_tactic_name = { mltac_tactic = tacname; @@ -681,10 +680,10 @@ let tactic_extend plugin_name tacname ~level sign = This is the rôle of the [lift_constr_tac_to_ml_tac] function. *) let body = Tacexpr.TacFun (vars, Tacexpr.TacML (Loc.tag (ml, [])))in let id = Names.Id.of_string name in - let obj () = Tacenv.register_ltac true false id body in + let obj () = Tacenv.register_ltac true false id body ?deprecation in let () = Tacenv.register_ml_tactic ml_tactic_name [|tac|] in Mltop.declare_cache_obj obj plugin_name | _ -> - let obj () = add_ml_tactic_notation ml_tactic_name ~level (List.map clause_of_ty_ml sign) in + let obj () = add_ml_tactic_notation ml_tactic_name ~level ?deprecation (List.map clause_of_ty_ml sign) in Tacenv.register_ml_tactic ml_tactic_name @@ Array.of_list (List.map eval sign); Mltop.declare_cache_obj obj plugin_name diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 3f804ee8..138a584e 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -12,10 +12,12 @@ open Vernacexpr open Tacexpr +open Vernacinterp (** {5 Tactic Definitions} *) -val register_ltac : locality_flag -> Tacexpr.tacdef_body list -> unit +val register_ltac : locality_flag -> ?deprecation:deprecation -> + Tacexpr.tacdef_body list -> unit (** Adds new Ltac definitions to the environment. *) (** {5 Tactic Notations} *) @@ -34,8 +36,8 @@ type argument = Genarg.ArgT.any Extend.user_symbol leaves. *) val add_tactic_notation : - locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list -> - raw_tactic_expr -> unit + locality_flag -> int -> ?deprecation:deprecation -> 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] *) @@ -47,7 +49,7 @@ val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type - to finding an argument by name (as in {!Genarg}) if there is none matching. *) -val add_ml_tactic_notation : ml_tactic_name -> level:int -> +val add_ml_tactic_notation : ml_tactic_name -> level:int -> ?deprecation:deprecation -> 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. *) @@ -55,7 +57,7 @@ val add_ml_tactic_notation : ml_tactic_name -> level:int -> (** {5 Tactic Quotations} *) val create_ltac_quotation : string -> - ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit + ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Entry.t * 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" ":" "(" ")"], and generates an argument using [f] on the entry parsed by [e]. *) @@ -65,17 +67,18 @@ val create_ltac_quotation : string -> val print_ltacs : unit -> unit (** Display the list of ltac definitions currently available. *) -val print_located_tactic : Libnames.reference -> unit +val print_located_tactic : Libnames.qualid -> unit (** Display the absolute name of a tactic. *) type _ ty_sig = | TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig | TyIdent : string * 'r ty_sig -> 'r ty_sig | TyArg : - (('a, 'b, 'c) Extend.ty_user_symbol * Names.Id.t) Loc.located * 'r ty_sig -> ('c -> 'r) ty_sig + ('a, 'b, 'c) Extend.ty_user_symbol * string * 'r ty_sig -> ('c -> 'r) ty_sig | TyAnonArg : - ('a, 'b, 'c) Extend.ty_user_symbol Loc.located * 'r ty_sig -> 'r ty_sig + ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> 'r ty_sig type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml -val tactic_extend : string -> string -> level:Int.t -> ty_ml list -> unit +val tactic_extend : string -> string -> level:Int.t -> + ?deprecation:deprecation -> ty_ml list -> unit diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index d5ab2d69..1f2c722b 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -52,7 +52,11 @@ let shortest_qualid_of_tactic kn = (** Tactic notations (TacAlias) *) type alias = KerName.t -type alias_tactic = Id.t list * glob_tactic_expr +type alias_tactic = + { alias_args: Id.t list; + alias_body: glob_tactic_expr; + alias_deprecation: Vernacinterp.deprecation option; + } let alias_map = Summary.ref ~name:"tactic-alias" (KNmap.empty : alias_tactic KNmap.t) @@ -118,6 +122,7 @@ type ltac_entry = { tac_for_ml : bool; tac_body : glob_tactic_expr; tac_redef : ModPath.t list; + tac_deprecation : Vernacinterp.deprecation option } let mactab = @@ -130,43 +135,51 @@ 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 +let add ~deprecation kn b t = + let entry = { tac_for_ml = b; + tac_body = t; + tac_redef = []; + tac_deprecation = deprecation; + } in mactab := KNmap.add kn entry !mactab let replace kn path t = - let (path, _, _) = KerName.repr path in + let path = KerName.modpath 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 +let tac_deprecation kn = + try (KNmap.find kn !mactab).tac_deprecation with Not_found -> None + +let load_md i ((sp, kn), (local, id, b, t, deprecation)) = match id with | None -> let () = if not local then push_tactic (Until i) sp kn in - add kn b t + add ~deprecation kn b t | Some kn0 -> replace kn0 kn t -let open_md i ((sp, kn), (local, id, b, t)) = match id with +let open_md i ((sp, kn), (local, id, b, t, deprecation)) = match id with | None -> let () = if not local then push_tactic (Exactly i) sp kn in - add kn b t + add ~deprecation kn b t | Some kn0 -> replace kn0 kn t -let cache_md ((sp, kn), (local, id ,b, t)) = match id with +let cache_md ((sp, kn), (local, id ,b, t, deprecation)) = match id with | None -> let () = push_tactic (Until 1) sp kn in - add kn b t + add ~deprecation 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 subst_md (subst, (local, id, b, t, deprecation)) = + (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t, deprecation) -let classify_md (local, _, _, _ as o) = Substitute o +let classify_md (local, _, _, _, _ as o) = Substitute o -let inMD : bool * ltac_constant option * bool * glob_tactic_expr -> obj = +let inMD : bool * ltac_constant option * bool * glob_tactic_expr * + Vernacinterp.deprecation option -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; @@ -174,8 +187,8 @@ let inMD : bool * ltac_constant option * bool * glob_tactic_expr -> obj = 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 register_ltac for_ml local ?deprecation id tac = + ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac, deprecation))) -let redefine_ltac local kn tac = - Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) +let redefine_ltac local ?deprecation kn tac = + Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac, deprecation)) diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index e0bac67d..d5d36c97 100644 --- a/plugins/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli @@ -12,6 +12,7 @@ open Names open Libnames open Tacexpr open Geninterp +open Vernacinterp (** This module centralizes the various ways of registering tactics. *) @@ -29,7 +30,11 @@ val shortest_qualid_of_tactic : ltac_constant -> qualid type alias = KerName.t (** Type of tactic alias, used in the [TacAlias] node. *) -type alias_tactic = Id.t list * glob_tactic_expr +type alias_tactic = + { alias_args: Id.t list; + alias_body: glob_tactic_expr; + alias_deprecation: Vernacinterp.deprecation option; + } (** Contents of a tactic notation *) val register_alias : alias -> alias_tactic -> unit @@ -43,7 +48,8 @@ val check_alias : alias -> bool (** {5 Coq tactic definitions} *) -val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit +val register_ltac : bool -> bool -> ?deprecation:deprecation -> 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 @@ -51,7 +57,8 @@ val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit 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 +val redefine_ltac : bool -> ?deprecation:deprecation -> 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. *) @@ -61,6 +68,9 @@ val interp_ltac : KerName.t -> glob_tactic_expr val is_ltac_for_ml_tactic : KerName.t -> bool (** Whether the tactic is defined from ML-side *) +val tac_deprecation : KerName.t -> deprecation option +(** The tactic deprecation notice, if any *) + type ltac_entry = { tac_for_ml : bool; (** Whether the tactic is defined from ML-side *) @@ -68,6 +78,8 @@ type ltac_entry = { (** The current body of the tactic *) tac_redef : ModPath.t list; (** List of modules redefining the tactic in reverse chronological order *) + tac_deprecation : deprecation option; + (** Deprecation notice to be printed when the tactic is used *) } val ltac_entries : unit -> ltac_entry KNmap.t diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 8b0c4404..11d13d3a 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -15,7 +15,7 @@ open Libnames open Genredexpr open Genarg open Pattern -open Misctypes +open Tactypes open Locus type ltac_constant = KerName.t @@ -35,30 +35,46 @@ 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 = +type goal_selector = Goal_select.t = + | SelectAlreadyFocused + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectNth of int + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectList of (int * int) list + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectId of Id.t + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectAll + [@ocaml.deprecated "Use constructors in [Goal_select]"] +[@@ocaml.deprecated "Use [Goal_select.t]"] -type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg = +type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = | ElimOnConstr of 'a + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnIdent of lident + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnAnonHyp of int + [@ocaml.deprecated "Use constructors in [Tactics]"] +[@@ocaml.deprecated "Use Tactics.core_destruction_arg"] type 'a destruction_arg = - clear_flag * 'a core_destruction_arg + clear_flag * 'a Tactics.core_destruction_arg +[@@ocaml.deprecated "Use Tactics.destruction_arg"] -type inversion_kind = Misctypes.inversion_kind = +type inversion_kind = Inv.inversion_kind = | SimpleInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversionClear + [@ocaml.deprecated "Use constructors in [Inv]"] +[@@ocaml.deprecated "Use Tactics.inversion_kind"] type ('c,'d,'id) inversion_strength = | NonDepInversion of - inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option + Inv.inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option | DepInversion of - inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option + Inv.inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option | InversionUsing of 'c * 'id list type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b @@ -69,8 +85,8 @@ type 'id message_token = | MsgIdent of 'id type ('dconstr,'id) induction_clause = - 'dconstr with_bindings destruction_arg * - (intro_pattern_naming_expr CAst.t option (* eqn:... *) + 'dconstr with_bindings Tactics.destruction_arg * + (Namegen.intro_pattern_naming_expr CAst.t option (* eqn:... *) * 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *) * 'id clause_expr option (* in ... *) @@ -112,7 +128,7 @@ type ml_tactic_entry = { (** Composite types *) -type glob_constr_and_expr = Tactypes.glob_constr_and_expr +type glob_constr_and_expr = Genintern.glob_constr_and_expr type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr @@ -129,7 +145,7 @@ type delayed_open_constr = EConstr.constr delayed_open type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t -type intro_pattern_naming = intro_pattern_naming_expr CAst.t +type intro_pattern_naming = Namegen.intro_pattern_naming_expr CAst.t (** Generic expressions for atomic tactics *) @@ -147,7 +163,7 @@ type 'a gen_atomic_tactic_expr = 'dtrm intro_pattern_expr CAst.t option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * - intro_pattern_naming_expr CAst.t option + Namegen.intro_pattern_naming_expr CAst.t option (* Derived basic tactics *) | TacInductionDestruct of @@ -159,7 +175,7 @@ type 'a gen_atomic_tactic_expr = (* Equality and inversion *) | TacRewrite of evars_flag * - (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (bool * Equality.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" @@ -265,7 +281,7 @@ and 'a gen_tactic_expr = ('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 + | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located (* For syntax extensions *) @@ -300,7 +316,7 @@ constraint 'a = < 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_cst = evaluable_global_reference Stdarg.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -328,8 +344,8 @@ type glob_tactic_arg = type r_trm = constr_expr type r_pat = constr_pattern_expr -type r_cst = reference or_by_notation -type r_ref = reference +type r_cst = qualid or_by_notation +type r_ref = qualid type r_nam = lident type r_lev = rlevel @@ -393,5 +409,5 @@ type ltac_call_kind = type ltac_trace = ltac_call_kind Loc.located list type tacdef_body = - | TacticDefinition of lident * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) - | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) + | TacticDefinition of lident * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of qualid * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 8b0c4404..6b131eda 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -15,8 +15,8 @@ open Libnames open Genredexpr open Genarg open Pattern -open Misctypes open Locus +open Tactypes type ltac_constant = KerName.t @@ -35,30 +35,46 @@ 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 = +type goal_selector = Goal_select.t = + | SelectAlreadyFocused + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectNth of int + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectList of (int * int) list + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectId of Id.t + [@ocaml.deprecated "Use constructors in [Goal_select]"] | SelectAll + [@ocaml.deprecated "Use constructors in [Goal_select]"] +[@@ocaml.deprecated "Use Vernacexpr.goal_selector"] -type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg = +type 'a core_destruction_arg = 'a Tactics.core_destruction_arg = | ElimOnConstr of 'a + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnIdent of lident + [@ocaml.deprecated "Use constructors in [Tactics]"] | ElimOnAnonHyp of int + [@ocaml.deprecated "Use constructors in [Tactics]"] +[@@ocaml.deprecated "Use Tactics.core_destruction_arg"] type 'a destruction_arg = - clear_flag * 'a core_destruction_arg + clear_flag * 'a Tactics.core_destruction_arg +[@@ocaml.deprecated "Use Tactics.destruction_arg"] -type inversion_kind = Misctypes.inversion_kind = +type inversion_kind = Inv.inversion_kind = | SimpleInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversion + [@ocaml.deprecated "Use constructors in [Inv]"] | FullInversionClear + [@ocaml.deprecated "Use constructors in [Inv]"] +[@@ocaml.deprecated "Use Tactics.inversion_kind"] type ('c,'d,'id) inversion_strength = | NonDepInversion of - inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option + Inv.inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option | DepInversion of - inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option + Inv.inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option | InversionUsing of 'c * 'id list type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b @@ -69,8 +85,8 @@ type 'id message_token = | MsgIdent of 'id type ('dconstr,'id) induction_clause = - 'dconstr with_bindings destruction_arg * - (intro_pattern_naming_expr CAst.t option (* eqn:... *) + 'dconstr with_bindings Tactics.destruction_arg * + (Namegen.intro_pattern_naming_expr CAst.t option (* eqn:... *) * 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *) * 'id clause_expr option (* in ... *) @@ -112,7 +128,7 @@ type ml_tactic_entry = { (** Composite types *) -type glob_constr_and_expr = Tactypes.glob_constr_and_expr +type glob_constr_and_expr = Genintern.glob_constr_and_expr type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr @@ -129,7 +145,7 @@ type delayed_open_constr = EConstr.constr delayed_open type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t -type intro_pattern_naming = intro_pattern_naming_expr CAst.t +type intro_pattern_naming = Namegen.intro_pattern_naming_expr CAst.t (** Generic expressions for atomic tactics *) @@ -147,7 +163,7 @@ type 'a gen_atomic_tactic_expr = 'dtrm intro_pattern_expr CAst.t option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * - intro_pattern_naming_expr CAst.t option + Namegen.intro_pattern_naming_expr CAst.t option (* Derived basic tactics *) | TacInductionDestruct of @@ -159,7 +175,7 @@ type 'a gen_atomic_tactic_expr = (* Equality and inversion *) | TacRewrite of evars_flag * - (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (bool * Equality.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" @@ -265,7 +281,7 @@ and 'a gen_tactic_expr = ('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 + | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located (* For syntax extensions *) @@ -300,7 +316,7 @@ constraint 'a = < 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_cst = evaluable_global_reference Stdarg.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -328,8 +344,8 @@ type glob_tactic_arg = type r_trm = constr_expr type r_pat = constr_pattern_expr -type r_cst = reference or_by_notation -type r_ref = reference +type r_cst = qualid or_by_notation +type r_ref = qualid type r_nam = lident type r_lev = rlevel @@ -393,5 +409,5 @@ type ltac_call_kind = type ltac_trace = ltac_call_kind Loc.located list type tacdef_body = - | TacticDefinition of lident * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) - | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) + | TacticDefinition of lident * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of qualid * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 9ad9e152..5501cf92 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -27,7 +27,9 @@ open Tacexpr open Genarg open Stdarg open Tacarg -open Misctypes +open Namegen +open Tactypes +open Tactics open Locus (** Globalization of tactic expressions : @@ -91,88 +93,104 @@ let intern_or_var f ist = function 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 - | {CAst.loc;v=Ident id} when find_var id ist -> - ArgVar (make ?loc id) - | r -> - let {CAst.loc} as lqid = qualid_of_reference r in - try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> error_global_not_found lqid - -let intern_ltac_variable ist = function - | {loc;v=Ident id} -> - if find_var id ist then - (* A local variable of any type *) - ArgVar (make ?loc id) - else raise Not_found - | _ -> - raise Not_found - -let intern_constr_reference strict ist = function - | {v=Ident id} as r when not strict && find_hyp id ist -> - (DAst.make @@ GVar id), Some (make @@ CRef (r,None)) - | {v=Ident id} as r when find_var id ist -> - (DAst.make @@ GVar id), if strict then None else Some (make @@ CRef (r,None)) - | r -> - let {loc} as lqid = qualid_of_reference r in - DAst.make @@ GRef (locate_global_with_alias lqid,None), - if strict then None else Some (make @@ CRef (r,None)) +let intern_global_reference ist qid = + if qualid_is_ident qid && find_var (qualid_basename qid) ist then + ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) + else + try ArgArg (qid.CAst.loc,locate_global_with_alias qid) + with Not_found -> error_global_not_found qid + +let intern_ltac_variable ist qid = + if qualid_is_ident qid && find_var (qualid_basename qid) ist then + (* A local variable of any type *) + ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) + else raise Not_found + +let intern_constr_reference strict ist qid = + let id = qualid_basename qid in + if qualid_is_ident qid && not strict && find_hyp (qualid_basename qid) ist then + (DAst.make @@ GVar id), Some (make @@ CRef (qid,None)) + else if qualid_is_ident qid && find_var (qualid_basename qid) ist then + (DAst.make @@ GVar id), if strict then None else Some (make @@ CRef (qid,None)) + else + DAst.make @@ GRef (locate_global_with_alias qid,None), + if strict then None else Some (make @@ CRef (qid,None)) (* Internalize an isolated reference in position of tactic *) -let intern_isolated_global_tactic_reference r = - let {loc;v=qid} = qualid_of_reference r in - TacCall (Loc.tag ?loc (ArgArg (loc,Tacenv.locate_tactic qid),[])) - -let intern_isolated_tactic_reference strict ist r = +let warn_deprecated_tactic = + CWarnings.create ~name:"deprecated-tactic" ~category:"deprecated" + (fun (qid,depr) -> str "Tactic " ++ pr_qualid qid ++ + strbrk " is deprecated" ++ + pr_opt (fun since -> str "since " ++ str since) depr.Vernacinterp.since ++ + str "." ++ pr_opt (fun note -> str note) depr.Vernacinterp.note) + +let warn_deprecated_alias = + CWarnings.create ~name:"deprecated-tactic-notation" ~category:"deprecated" + (fun (kn,depr) -> str "Tactic Notation " ++ Pptactic.pr_alias_key kn ++ + strbrk " is deprecated since" ++ + pr_opt (fun since -> str "since " ++ str since) depr.Vernacinterp.since ++ + str "." ++ pr_opt (fun note -> str note) depr.Vernacinterp.note) + +let intern_isolated_global_tactic_reference qid = + let loc = qid.CAst.loc in + let kn = Tacenv.locate_tactic qid in + Option.iter (fun depr -> warn_deprecated_tactic ?loc (qid,depr)) @@ + Tacenv.tac_deprecation kn; + TacCall (Loc.tag ?loc (ArgArg (loc,kn),[])) + +let intern_isolated_tactic_reference strict ist qid = (* An ltac reference *) - try Reference (intern_ltac_variable ist r) + try Reference (intern_ltac_variable ist qid) with Not_found -> (* A global tactic *) - try intern_isolated_global_tactic_reference r + try intern_isolated_global_tactic_reference qid with Not_found -> (* Tolerance for compatibility, allow not to use "constr:" *) - try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist qid)) with Not_found -> (* Reference not found *) - error_global_not_found (qualid_of_reference r) + error_global_not_found qid (* Internalize an applied tactic reference *) -let intern_applied_global_tactic_reference r = - let {loc;v=qid} = qualid_of_reference r in - ArgArg (loc,Tacenv.locate_tactic qid) +let intern_applied_global_tactic_reference qid = + let loc = qid.CAst.loc in + let kn = Tacenv.locate_tactic qid in + Option.iter (fun depr -> warn_deprecated_tactic ?loc (qid,depr)) @@ + Tacenv.tac_deprecation kn; + ArgArg (loc,kn) -let intern_applied_tactic_reference ist r = +let intern_applied_tactic_reference ist qid = (* An ltac reference *) - try intern_ltac_variable ist r + try intern_ltac_variable ist qid with Not_found -> (* A global tactic *) - try intern_applied_global_tactic_reference r + try intern_applied_global_tactic_reference qid with Not_found -> (* Reference not found *) - error_global_not_found (qualid_of_reference r) + error_global_not_found qid (* Intern a reference parsed in a non-tactic entry *) -let intern_non_tactic_reference strict ist r = +let intern_non_tactic_reference strict ist qid = (* An ltac reference *) - try Reference (intern_ltac_variable ist r) + try Reference (intern_ltac_variable ist qid) with Not_found -> (* A constr reference *) - try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist qid)) with Not_found -> (* Tolerance for compatibility, allow not to use "ltac:" *) - try intern_isolated_global_tactic_reference r + try intern_isolated_global_tactic_reference qid with Not_found -> (* By convention, use IntroIdentifier for unbound ident, when not in a def *) - match r with - | {loc;v=Ident id} when not strict -> - let ipat = in_gen (glbwit wit_intro_pattern) (make ?loc @@ IntroNaming (IntroIdentifier id)) in + if qualid_is_ident qid && not strict then + let id = qualid_basename qid in + let ipat = in_gen (glbwit wit_intro_pattern) (make ?loc:qid.CAst.loc @@ IntroNaming (IntroIdentifier id)) in TacGeneric ipat - | _ -> - (* Reference not found *) - error_global_not_found (qualid_of_reference r) + else + (* Reference not found *) + error_global_not_found qid let intern_message_token ist = function | (MsgString _ | MsgInt _ as x) -> x @@ -268,7 +286,7 @@ let intern_destruction_arg ist = function | clear,ElimOnIdent {loc;v=id} -> if !strict_check then (* If in a defined tactic, no intros-until *) - let c, p = intern_constr ist (make @@ CRef (make @@ Ident id, None)) in + let c, p = intern_constr ist (make @@ CRef (qualid_of_ident id, None)) in match DAst.get c with | GVar id -> clear,ElimOnIdent (make ?loc:c.loc id) | _ -> clear,ElimOnConstr ((c, p), NoBindings) @@ -276,16 +294,15 @@ let intern_destruction_arg ist = function clear,ElimOnIdent (make ?loc id) let short_name = function - | {v=AN {loc;v=Ident id}} when not !strict_check -> Some (make ?loc id) + | {v=AN qid} when qualid_is_ident qid && not !strict_check -> + Some (make ?loc:qid.CAst.loc @@ qualid_basename qid) | _ -> 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) +let intern_evaluable_global_reference ist qid = + try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true qid) with Not_found -> - match r with - | {loc;v=Ident id} when not !strict_check -> EvalVarRef id - | _ -> error_global_not_found lqid + if qualid_is_ident qid && not !strict_check then EvalVarRef (qualid_basename qid) + else error_global_not_found qid let intern_evaluable_reference_or_by_notation ist = function | {v=AN r} -> intern_evaluable_global_reference ist r @@ -295,14 +312,19 @@ let intern_evaluable_reference_or_by_notation ist = function (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) (* Globalize a reduction expression *) -let intern_evaluable ist = function - | {loc;v=AN {v=Ident id}} when find_var id ist -> ArgVar (make ?loc id) - | {loc;v=AN {v=Ident id}} when not !strict_check && find_hyp id ist -> - ArgArg (EvalVarRef id, Some (make ?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_evaluable ist r = + let f ist r = + let e = intern_evaluable_reference_or_by_notation ist r in + let na = short_name r in + ArgArg (e,na) + in + match r with + | {v=AN qid} when qualid_is_ident qid && find_var (qualid_basename qid) ist -> + ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) + | {v=AN qid} when qualid_is_ident qid && not !strict_check && find_hyp (qualid_basename qid) ist -> + let id = qualid_basename qid in + ArgArg (EvalVarRef id, Some (make ?loc:qid.CAst.loc id)) + | _ -> f ist r let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) @@ -355,7 +377,7 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = subterm matched when a pattern *) let r = match r with | {v=AN r} -> r - | {loc} -> make ?loc @@ Qualid (qualid_of_path (path_of_global (smart_global r))) in + | {loc} -> (qualid_of_path ?loc (path_of_global (smart_global r))) in let sign = { Constrintern.ltac_vars = ist.ltacvars; ltac_bound = Id.Set.empty; @@ -643,6 +665,8 @@ and intern_tactic_seq onlytac ist = function (* For extensions *) | TacAlias (loc,(s,l)) -> + let alias = Tacenv.interp_alias s in + Option.iter (fun o -> warn_deprecated_alias ?loc (s,o)) @@ alias.Tacenv.alias_deprecation; let l = List.map (intern_tacarg !strict_check false ist) l in ist.ltacvars, TacAlias (Loc.tag ?loc (s,l)) | TacML (loc,(opn,l)) -> diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index fb32508c..9146fced 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -12,7 +12,7 @@ open Names open Tacexpr open Genarg open Constrexpr -open Misctypes +open Tactypes (** Globalization of tactic expressions : Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index c6c4f469..b9e892e5 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -12,6 +12,7 @@ open Constrintern open Patternops open Pp open CAst +open Namegen open Genredexpr open Glob_term open Glob_ops @@ -35,7 +36,8 @@ open Stdarg open Tacarg open Printer open Pretyping -open Misctypes +open Tactypes +open Tactics open Locus open Tacintern open Taccoerce @@ -140,16 +142,6 @@ 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 - -end - let print_top_val env v = Pptactic.pr_value Pptactic.ltop v let catching_error call_trace fail (e, info) = @@ -291,6 +283,12 @@ let debugging_exception_step ist signal_anomaly e pp = debugging_step ist (fun () -> pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) +let ensure_freshness env = + (* We anonymize declarations which we know will not be used *) + (* This assumes that the original context had no rels *) + process_rel_context + (fun d e -> EConstr.push_rel (Context.Rel.Declaration.set_name Anonymous d) e) env + (* Raise Not_found if not in interpretation sign *) let try_interp_ltac_var coerce ist env {loc;v=id} = let v = Id.Map.find id ist.lfun in @@ -311,11 +309,11 @@ let interp_name ist env sigma = function | 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)) (make ?loc id) + try try_interp_ltac_var (coerce_to_intro_pattern sigma) ist (Some (env,sigma)) (make ?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)) (make ?loc id) + try try_interp_ltac_var (coerce_to_intro_pattern_naming sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> IntroIdentifier id let interp_int ist ({loc;v=id} as locid) = @@ -356,11 +354,11 @@ let interp_hyp_list ist env sigma l = let interp_reference ist env sigma = function | ArgArg (_,r) -> r | ArgVar {loc;v=id} -> - try try_interp_ltac_var (coerce_to_reference env sigma) ist (Some (env,sigma)) (make ?loc id) + try try_interp_ltac_var (coerce_to_reference sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> try VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found (make ?loc @@ qualid_of_ident id) + with Not_found -> error_global_not_found (qualid_of_ident ?loc id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in @@ -376,14 +374,14 @@ let interp_evaluable ist env sigma = function with Not_found -> match r with | EvalConstRef _ -> r - | _ -> error_global_not_found (make ?loc @@ qualid_of_ident id) + | _ -> error_global_not_found (qualid_of_ident ?loc id) end | ArgArg (r,None) -> r | ArgVar {loc;v=id} -> try try_interp_ltac_var (coerce_to_evaluable_ref env sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found (make ?loc @@ qualid_of_ident id) + with Not_found -> error_global_not_found (qualid_of_ident ?loc id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = @@ -450,7 +448,7 @@ 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) + try try_interp_ltac_var (coerce_to_ident_not_fresh sigma) ist (Some (env,sigma)) (make id) with Not_found -> id in let ids = List.map_filter (function ArgVar {v=id} -> Some id | _ -> None) l in @@ -473,7 +471,7 @@ let interp_fresh_id ist env sigma l = (* Extract the uconstr list from lfun *) let extract_ltac_constr_context ist env sigma = let add_uconstr id v map = - try Id.Map.add id (coerce_to_uconstr env v) map + try Id.Map.add id (coerce_to_uconstr v) map with CannotCoerceTo _ -> map in let add_constr id v map = @@ -642,7 +640,7 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = 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)) (make ?loc id) with Not_found -> - error_global_not_found (make ?loc @@ qualid_of_ident id)) + error_global_not_found (qualid_of_ident ?loc 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 @@ -689,13 +687,11 @@ let interp_may_eval f ist env sigma = function | ConstrContext ({loc;v=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 = try_interp_ltac_var coerce_to_constr_context ist (Some (env, sigma)) (make ?loc s) in let ctxt = EConstr.Unsafe.to_constr ctxt in - let evdref = ref sigma in - let ic = EConstr.Unsafe.to_constr ic 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 + Typing.solve_evars env sigma (EConstr.of_constr c) with | Not_found -> user_err ?loc ~hdr:"interp_may_eval" @@ -800,7 +796,7 @@ and interp_or_and_intro_pattern ist env sigma = function and interp_intro_pattern_list_as_list ist env sigma = function | [{loc;v=IntroNaming (IntroIdentifier id)}] as l -> - (try sigma, coerce_to_intro_pattern_list ?loc env sigma (Id.Map.find id ist.lfun) + (try sigma, coerce_to_intro_pattern_list ?loc sigma (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> List.fold_left_map (interp_intro_pattern ist env) sigma l) | l -> List.fold_left_map (interp_intro_pattern ist env) sigma l @@ -843,7 +839,7 @@ 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)) (make id) + (coerce_to_decl_or_quant_hyp sigma) ist (Some (env,sigma)) (make id) with Not_found -> NamedHyp id let interp_binding ist env sigma {loc;v=(b,c)} = @@ -926,7 +922,7 @@ let interp_destruction_arg ist gl arg = if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (make ?loc id) else - let c = (DAst.make ?loc @@ GVar id,Some (make @@ CRef (make ?loc @@ Ident id,None))) in + let c = (DAst.make ?loc @@ GVar id,Some (make @@ CRef (qualid_of_ident ?loc id,None))) in let f env sigma = let (sigma,c) = interp_open_constr ist env sigma c in (sigma, (c,NoBindings)) @@ -1126,17 +1122,17 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | 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 alias = 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 + let lfun = List.fold_right2 addvar alias.Tacenv.alias_args 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 -> + val_interp ist alias.Tacenv.alias_body >>= fun v -> Ftactic.lift (tactic_of_value ist v) in let tac = @@ -1148,7 +1144,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with some more elaborate solution will have to be used. *) in let tac = - let len1 = List.length ids in + let len1 = List.length alias.Tacenv.alias_args in let len2 = List.length l in if len1 = len2 then tac else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ @@ -1308,7 +1304,7 @@ and tactic_of_value ist vle = match appl with UnnamedAppl -> "An unnamed user-defined tactic" | GlbAppl apps -> - let nms = List.map (fun (kn,_) -> Names.KerName.to_string kn) apps in + let nms = List.map (fun (kn,_) -> string_of_qualid (Tacenv.shortest_qualid_of_tactic kn)) apps in match nms with [] -> assert false | kn::_ -> "The user-defined tactic \"" ^ kn ^ "\"" (* TODO: when do we not have a singleton? *) @@ -1748,15 +1744,15 @@ and interp_atomic ist tac : unit Proofview.tactic = | AllOccurrences | NoOccurrences -> true | _ -> false in - let c_interp patvars sigma = + let c_interp patvars env 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 if is_onhyps && is_onconcl - then interp_type ist (pf_env gl) sigma c - else interp_constr ist (pf_env gl) sigma c + then interp_type ist env sigma c + else interp_constr ist env sigma c in Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) end @@ -1769,11 +1765,12 @@ and interp_atomic ist tac : unit Proofview.tactic = 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 = + let c_interp patvars env sigma = let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in + let env = ensure_freshness env in let ist = { ist with lfun = lfun' } in try interp_constr ist env sigma c @@ -1861,6 +1858,31 @@ let eval_tactic_ist ist t = Proofview.tclLIFT db_initialize <*> interp_tactic ist t +(** FFI *) + +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 + + (** Apply toplevel tactic values *) + let apply (f : value) (args: value list) = + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar CAst.(make id)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in + let ist = { (default_ist ()) with lfun = lfun; } in + let tac = TacArg(Loc.tag @@ TacCall (Loc.tag (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + eval_tactic_ist ist tac + +end + (* globalization + interpretation *) @@ -2009,7 +2031,8 @@ let interp_redexp env sigma r = let _ = let eval lfun env sigma ty tac = - let ist = { lfun = lfun; extra = TacStore.empty; } in + let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in + let ist = { lfun = lfun; extra; } 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) diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index bd44bdbe..f9883e44 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -14,7 +14,7 @@ open EConstr open Tacexpr open Genarg open Redexpr -open Misctypes +open Tactypes val ltac_trace_info : ltac_trace Exninfo.t @@ -28,6 +28,7 @@ sig 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 + val apply : t -> t list -> unit Proofview.tactic end (** Values for interpretation *) @@ -131,7 +132,7 @@ val interp_ltac_var : (value -> 'a) -> interp_sign -> val interp_int : interp_sign -> lident -> int -val interp_int_or_var : interp_sign -> int or_var -> int +val interp_int_or_var : interp_sign -> int Locus.or_var -> int 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 index a1d8b087..4626378d 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -14,7 +14,8 @@ open Mod_subst open Genarg open Stdarg open Tacarg -open Misctypes +open Tactypes +open Tactics open Globnames open Genredexpr open Patternops @@ -75,7 +76,7 @@ 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 +let subst_or_var f = let open Locus in function | ArgVar _ as x -> x | ArgArg x -> ArgArg (f x) @@ -112,7 +113,7 @@ 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 + Redops.map_red_expr_gen (subst_glob_constr subst) (subst_evaluable subst) (subst_glob_constr_or_pattern subst) diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli index 0a894791..d406686c 100644 --- a/plugins/ltac/tacsubst.mli +++ b/plugins/ltac/tacsubst.mli @@ -11,7 +11,7 @@ open Tacexpr open Mod_subst open Genarg -open Misctypes +open Tactypes (** Substitution of tactics at module closing time *) diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index bb815dcb..b15a8d6a 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -12,7 +12,6 @@ open Util open Names open Pp open Tacexpr -open Termops let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () @@ -51,8 +50,8 @@ let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) 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 + let penv = Termops.Internal.print_named_context env in + let pc = Printer.pr_econstr_env env (Tacmach.New.project gl) concl in str" " ++ hv 0 (penv ++ fnl () ++ str "============================" ++ fnl () ++ str" " ++ pc) ++ fnl () @@ -243,7 +242,7 @@ 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) + msg_tac_debug (str "Evaluated term: " ++ Printer.pr_econstr_env env sigma c) else return () (* Prints the pattern rule *) @@ -268,7 +267,7 @@ let db_matched_hyp debug env sigma (id,_,c) ido = is_debug debug >>= fun db -> if db then msg_tac_debug (str "Hypothesis " ++ Id.print id ++ hyp_bound ido ++ - str " has been matched: " ++ print_constr_env env sigma c) + str " has been matched: " ++ Printer.pr_econstr_env env sigma c) else return () (* Prints the matched conclusion *) @@ -276,7 +275,7 @@ 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) + msg_tac_debug (str "Conclusion has been matched: " ++ Printer.pr_econstr_env env sigma c) else return () (* Prints a success message when the goal has been matched *) @@ -391,13 +390,10 @@ let explain_ltac_call_trace last trace loc = 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 _) :: _ -> + | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: tail -> (* Case of an ML defined tactic with entry of the form <<"foo" args>> *) (* see tacextend.mlp *) - [tac] - | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac] + tac :: aux tail | t :: tail -> t :: aux tail | [] -> [] in List.rev (aux (List.rev trace)) diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 734e76b5..175341df 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -76,7 +76,7 @@ val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t (** Prints a logic failure message for a rule *) val db_breakpoint : debug_info -> - Misctypes.lident message_token list -> unit Proofview.NonLogical.t + lident message_token list -> unit Proofview.NonLogical.t val extract_ltac_trace : ?loc:Loc.t -> Tacexpr.ltac_trace -> Pp.t option Loc.located diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index b6462c81..c949589e 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -46,7 +46,7 @@ let adjust : Constr_matching.bound_ident_map * Ltac_pretype.patvar_map -> (** 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 + | Some id -> Id.Map.add id (Lazy.force x) m | None -> m (** Adds a binding to a {!Id.Map.t} if the name is [Name id] *) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index a51c09ca..299bc7ea 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -8,12 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term +open Constr open EConstr open Hipattern open Names open Geninterp -open Misctypes open Ltac_plugin open Tacexpr open Tacinterp @@ -94,7 +93,7 @@ let clear id = Tactics.clear [id] let assumption = Tactics.assumption -let split = Tactics.split_with_bindings false [Misctypes.NoBindings] +let split = Tactics.split_with_bindings false [Tactypes.NoBindings] (** Test *) @@ -175,7 +174,7 @@ let flatten_contravariant_disj _ ist = | 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 ci = Tactics.constructor_tac false None (succ i) Tactypes.NoBindings in let by = tclTHENLIST [intro; apply hyp; ci; assumption] in assert_ ~by typ in @@ -187,7 +186,7 @@ let flatten_contravariant_disj _ ist = let make_unfold name = let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in let const = Constant.make2 (ModPath.MPfile dir) (Label.make name) in - (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) + Locus.(AllOccurrences, ArgArg (EvalConstRef const, None)) let u_not = make_unfold "not" @@ -245,7 +244,7 @@ let with_flags flags _ ist = let x = CAst.make @@ Id.of_string "x" in let arg = Val.Dyn (tag_tauto_flags, flags) in let ist = { ist with lfun = Id.Map.add x.CAst.v arg ist.lfun } in - eval_tactic_ist ist (TacArg (Loc.tag @@ TacCall (Loc.tag (ArgVar f, [Reference (ArgVar x)])))) + eval_tactic_ist ist (TacArg (Loc.tag @@ TacCall (Loc.tag (Locus.ArgVar f, [Reference (Locus.ArgVar x)])))) let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in diff --git a/plugins/micromega/Fourier.v b/plugins/micromega/Fourier.v new file mode 100644 index 00000000..0153de1d --- /dev/null +++ b/plugins/micromega/Fourier.v @@ -0,0 +1,5 @@ +Require Import Lra. +Require Export Fourier_util. + +#[deprecated(since = "8.9.0", note = "Use lra instead.")] +Ltac fourier := lra. diff --git a/plugins/micromega/Fourier_util.v b/plugins/micromega/Fourier_util.v new file mode 100644 index 00000000..b62153de --- /dev/null +++ b/plugins/micromega/Fourier_util.v @@ -0,0 +1,31 @@ +Require Export Rbase. +Require Import Lra. + +Open Scope R_scope. + +Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. +intros x y H H0; try assumption. +replace 0 with (x * 0). +apply Rmult_lt_compat_l; auto with real. +ring. +Qed. + +Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. +intros x H; try assumption. +rewrite Rplus_comm. +apply Rle_lt_0_plus_1. +red; auto with real. +Qed. + +Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. + intros; lra. +Qed. + +Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. +intros x y H H0; try assumption. +case H; intros. +red; left. +apply Rlt_mult_inv_pos; auto with real. +rewrite <- H1. +red; right; ring. +Qed. diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 31f55ae9..458844e1 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -211,7 +211,7 @@ Set Implicit Arguments. (* BC *) simpl. case_eq (deduce t t) ; auto. - intros until 0. + intros *. case_eq (unsat t0) ; auto. unfold eval_clause. rewrite make_conj_cons. @@ -263,7 +263,7 @@ Set Implicit Arguments. Proof. induction cl. simpl. tauto. - intros until 0. + intros *. simpl. assert (HH := add_term_correct env a cl'). case_eq (add_term a cl'). diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 9f39191f..3a9709b6 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -17,10 +17,9 @@ (* We take as input a list of polynomials [p1...pn] and return an unfeasibility certificate polynomial. *) -type var = int - - +let debug = false +open Util open Big_int open Num open Polynomial @@ -59,9 +58,6 @@ let q_spec = { eqb = Mc.qeq_bool } -let r_spec = z_spec - - let dev_form n_spec p = let rec dev_form p = match p with @@ -84,38 +80,6 @@ let dev_form n_spec p = pow n in dev_form p - -let monomial_to_polynomial mn = - Monomial.fold - (fun v i acc -> - let v = Ml2C.positive v in - let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in - if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *) - then mn - else Mc.PEmul(mn,acc)) - mn - (Mc.PEc (Mc.Zpos Mc.XH)) - - - -let list_to_polynomial vars l = - assert (List.for_all (fun x -> ceiling_num x =/ x) l); - let var x = monomial_to_polynomial (List.nth vars x) in - - let rec xtopoly p i = function - | [] -> p - | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l - else let c = Mc.PEc (Ml2C.bigint (numerator c)) in - let mn = - if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH)) - then var i - else Mc.PEmul (c,var i) in - let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else - Mc.PEadd (mn, p) in - xtopoly p' (i+1) l in - - xtopoly (Mc.PEc Mc.Z0) 0 l - let rec fixpoint f x = let y' = f x in if Pervasives.(=) y' x then y' @@ -135,15 +99,6 @@ let rec_simpl_cone n_spec e = let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c - -type cone_prod = - Const of cone -| Ideal of cone *cone -| Mult of cone * cone -| Other of cone -and cone = Mc.zWitness - - let factorise_linear_cone c = @@ -224,14 +179,6 @@ let positivity l = in xpositivity 0 l - -let string_of_op = function - | Mc.Strict -> "> 0" - | Mc.NonStrict -> ">= 0" - | Mc.Equal -> "= 0" - | Mc.NonEqual -> "<> 0" - - module MonSet = Set.Make(Monomial) (* If the certificate includes at least one strict inequality, @@ -261,9 +208,6 @@ let build_linear_system l = op = Ge ; cst = Big_int zero_big_int}::(strict::(positivity l)@s0) - -let big_int_to_z = Ml2C.bigint - (* For Q, this is a pity that the certificate has been scaled -- at a lower layer, certificates are using nums... *) let make_certificate n_spec (cert,li) = @@ -296,8 +240,6 @@ let make_certificate n_spec (cert,li) = (simplify_cone n_spec (scalar_product cert' li))) -exception Found of Monomial.t - exception Strict module MonMap = Map.Make(Monomial) @@ -367,7 +309,7 @@ let simple_linear_prover l = let linear_prover n_spec l = let build_system n_spec l = - let li = List.combine l (interval 0 (List.length l -1)) in + let li = List.combine l (CList.interval 0 (List.length l -1)) in let (l1,l') = List.partition (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in List.map @@ -397,7 +339,7 @@ let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth ; (* Assign a proof to the initial hypotheses *) - let sys = mapi (fun c i -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in + let sys = List.mapi (fun i c -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in (* Add all the product of hypotheses *) @@ -452,39 +394,6 @@ let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) = | Mc.PsatzZ -> Mc.PsatzZ in Some (map_psatz cert) - - -let make_linear_system l = - let l' = List.map fst l in - let monomials = List.fold_left (fun acc p -> Poly.addition p acc) - (Poly.constant (Int 0)) l' in - let monomials = Poly.fold - (fun mn _ l -> if Pervasives.(=) mn Monomial.const then l else mn::l) monomials [] in - (List.map (fun (c,op) -> - {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; - op = op ; - cst = minus_num ( (Poly.get Monomial.const c))}) l - ,monomials) - - -let pplus x y = Mc.PEadd(x,y) -let pmult x y = Mc.PEmul(x,y) -let pconst x = Mc.PEc x -let popp x = Mc.PEopp x - -(* keep track of enumerated vectors *) -let rec mem p x l = - match l with [] -> false | e::l -> if p x e then true else mem p x l - -let rec remove_assoc p x l = - match l with [] -> [] | e::l -> if p x (fst e) then - remove_assoc p x l else e::(remove_assoc p x l) - -let eq x y = Int.equal (Vect.compare x y) 0 - -let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l - - (* The prover is (probably) incomplete -- only searching for naive cutting planes *) @@ -494,38 +403,6 @@ let develop_constraint z_spec (e,k) = | Mc.Equal -> (dev_form z_spec e , Eq) | _ -> assert false - -let op_of_op_compat = function - | Ge -> Mc.NonStrict - | Eq -> Mc.Equal - - -let integer_vector coeffs = - let vars , coeffs = List.split coeffs in - List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs)) - -let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } = - let vars , coeffs = List.split coeffs in - match rats_to_ints (cst::coeffs) with - | cst :: coeffs -> - { - coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ; - op = op ; cst = Big_int cst} - | _ -> assert false - - -let pexpr_of_cstr_compat var cstr = - let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in - try - let expr = list_to_polynomial var (Vect.to_list coeffs) in - let d = Ml2C.bigint (denominator cst) in - let n = Ml2C.bigint (numerator cst) in - (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op) - with Failure _ -> failwith "pexpr_of_cstr_compat" - - - - open Sos_types let rec scale_term t = @@ -555,18 +432,6 @@ let scale_term t = let (s,t') = scale_term t in s,t' - -let get_index_of_ith_match f i l = - let rec get j res l = - match l with - | [] -> failwith "bad index" - | e::l -> if f e - then - (if Int.equal j i then res else get (j+1) (res+1) l ) - else get j (res+1) l in - get 0 0 l - - let rec scale_certificate pos = match pos with | Axiom_eq i -> unit_big_int , Axiom_eq i | Axiom_le i -> unit_big_int , Axiom_le i @@ -681,8 +546,6 @@ open Polynomial module Env = struct - type t = int list - let id_of_hyp hyp l = let rec xid_of_hyp i l = match l with @@ -749,9 +612,6 @@ let xlinear_prover sys = | Inl _ -> None -let output_num o n = output_string o (string_of_num n) -let output_bigint o n = output_string o (string_of_big_int n) - let proof_of_farkas prf cert = (* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *) let rec mk_farkas acc prf cert = @@ -894,23 +754,6 @@ let rec ext_gcd a b = let (s,t) = ext_gcd b r in (t, sub_big_int s (mult_big_int q t)) - -let pp_ext_gcd a b = - let a' = big_int_of_int a in - let b' = big_int_of_int b in - - let (x,y) = ext_gcd a' b' in - Printf.fprintf stdout "%s * %s + %s * %s = %s\n" - (string_of_big_int x) (string_of_big_int a') - (string_of_big_int y) (string_of_big_int b') - (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b'))) - -exception Result of (int * (proof * cstr_compat)) - -let split_equations psys = - List.partition (fun (c,p) -> c.op == Eq) - - let extract_coprime (c1,p1) (c2,p2) = let rec exist2 vect1 vect2 = match vect1 , vect2 with @@ -1058,29 +901,6 @@ let reduce_var_change psys = Some (apply_and_normalise pivot_eq sys) - - - -let reduce_pivot psys = - let is_equation (cstr,prf) = - if cstr.op == Eq - then - try - Some (fst (List.hd cstr.coeffs)) - with Not_found -> None - else None in - let (oeq,sys) = extract is_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some(v,pc) -> - if debug then - Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); - Some(pivot_sys v pc sys) - - - - - let iterate_until_stable f x = let rec iter x = match f x with @@ -1225,7 +1045,7 @@ let xlia (can_enum:bool) reduction_equations sys = | None -> None | Some prf -> (*Printf.printf "direct proof %a\n" output_proof prf ; *) - let env = mapi (fun _ i -> i) sys in + let env = List.mapi (fun i _ -> i) sys in let prf = compile_proof env prf in (*try if Mc.zChecker sys' prf then Some prf else @@ -1244,7 +1064,7 @@ let lia (can_enum:bool) (prfdepth:int) sys = max_nb_cstr := compute_max_nb_cstr sys prfdepth ; let sys = List.map (develop_constraint z_spec) sys in let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in - let sys = mapi (fun c i -> (c,Hyp i)) sys in + let sys = List.mapi (fun i c -> (c,Hyp i)) sys in xlia can_enum reduction_equations sys @@ -1252,7 +1072,7 @@ let nlia enum prfdepth sys = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth; let sys = List.map (develop_constraint z_spec) sys in - let sys = mapi (fun c i -> (c,Hyp i)) sys in + let sys = List.mapi (fun i c -> (c,Hyp i)) sys in let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli new file mode 100644 index 00000000..13d50d1e --- /dev/null +++ b/plugins/micromega/certificate.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* Mc.q Mc.psatz +val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz +val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option +val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option +val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Mc.psatz option +val linear_prover_with_cert : int -> 'a number_spec -> + ('a Mc.pExpr * Mc.op1) list -> 'a Mc.psatz option +val q_spec : Mc.q number_spec diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 168105e8..f22147f8 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -19,10 +19,11 @@ (************************************************************************) open Pp -open Mutils -open Goptions open Names +open Goptions +open Mutils open Constr +open Tactypes (** * Debug flag @@ -30,19 +31,6 @@ open Constr let debug = false -(** - * Time function - *) - -let time str f x = - let t0 = (Unix.times()).Unix.tms_utime in - let res = f x in - let t1 = (Unix.times()).Unix.tms_utime in - (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ; - flush stdout); - res - - (* Limit the proof search *) let max_depth = max_int @@ -305,8 +293,7 @@ let rec add_term t0 = function *) module ISet = Set.Make(Int) -module IMap = Map.Make(Int) - + (** * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of * elements of m that are at position i0,...,iN. @@ -373,7 +360,7 @@ struct * ZMicromega.v *) - let gen_constant_in_modules s m n = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) + let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module @@ -395,16 +382,10 @@ struct let coq_O = lazy (init_constant "O") let coq_S = lazy (init_constant "S") - let coq_nat = lazy (init_constant "nat") let coq_N0 = lazy (bin_constant "N0") let coq_Npos = lazy (bin_constant "Npos") - let coq_pair = lazy (init_constant "pair") - let coq_None = lazy (init_constant "None") - let coq_option = lazy (init_constant "option") - - let coq_positive = lazy (bin_constant "positive") let coq_xH = lazy (bin_constant "xH") let coq_xO = lazy (bin_constant "xO") let coq_xI = lazy (bin_constant "xI") @@ -417,8 +398,6 @@ struct let coq_Q = lazy (constant "Q") let coq_R = lazy (constant "R") - let coq_Build_Witness = lazy (constant "Build_Witness") - let coq_Qmake = lazy (constant "Qmake") let coq_Rcst = lazy (constant "Rcst") @@ -455,8 +434,6 @@ struct let coq_Zmult = lazy (z_constant "Z.mul") let coq_Zpower = lazy (z_constant "Z.pow") - let coq_Qgt = lazy (constant "Qgt") - let coq_Qge = lazy (constant "Qge") let coq_Qle = lazy (constant "Qle") let coq_Qlt = lazy (constant "Qlt") let coq_Qeq = lazy (constant "Qeq") @@ -476,7 +453,6 @@ struct let coq_Rminus = lazy (r_constant "Rminus") let coq_Ropp = lazy (r_constant "Ropp") let coq_Rmult = lazy (r_constant "Rmult") - let coq_Rdiv = lazy (r_constant "Rdiv") let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_IZR = lazy (r_constant "IZR") @@ -509,12 +485,6 @@ struct let coq_PsatzAdd = lazy (constant "PsatzAdd") let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") - let coq_coneMember = lazy (constant "coneMember") - - let coq_make_impl = lazy - (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") - let coq_make_conj = lazy - (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj") let coq_TT = lazy (gen_constant_in_modules "ZMicromega" @@ -552,13 +522,6 @@ struct let coq_QWitness = lazy (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "QMicromega"]] "QWitness") - let coq_ZWitness = lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") - - let coq_N_of_Z = lazy - (gen_constant_in_modules "ZArithRing" - [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") let coq_Build = lazy (gen_constant_in_modules "RingMicromega" @@ -577,34 +540,16 @@ struct * pp_* functions pretty-print Coq terms. *) - (* Error datastructures *) - - type parse_error = - | Ukn - | BadStr of string - | BadNum of int - | BadTerm of constr - | Msg of string - | Goal of (constr list ) * constr * parse_error - - let string_of_error = function - | Ukn -> "ukn" - | BadStr s -> s - | BadNum i -> string_of_int i - | BadTerm _ -> "BadTerm" - | Msg s -> s - | Goal _ -> "Goal" - exception ParseError (* A simple but useful getter function *) let get_left_construct sigma term = match EConstr.kind sigma term with - | Term.Construct((_,i),_) -> (i,[| |]) - | Term.App(l,rst) -> + | Construct((_,i),_) -> (i,[| |]) + | App(l,rst) -> (match EConstr.kind sigma l with - | Term.Construct((_,i),_) -> (i,rst) + | Construct((_,i),_) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError @@ -648,19 +593,6 @@ struct | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) - let rec dump_index x = - match x with - | Mc.XH -> Lazy.force coq_xH - | Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[| dump_index p |]) - | Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[| dump_index p |]) - - let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) - - let pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) - - let dump_pair t1 t2 dump_t1 dump_t2 (x,y) = - EConstr.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) - let parse_z sigma term = let (i,c) = get_left_construct sigma term in match i with @@ -677,18 +609,13 @@ struct let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) - let dump_num bd1 = - EConstr.mkApp(Lazy.force coq_Qmake, - [|dump_z (CamlToCoq.bigint (numerator bd1)) ; - dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) - let dump_q q = EConstr.mkApp(Lazy.force coq_Qmake, [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) let parse_q sigma term = match EConstr.kind sigma term with - | Term.App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then + | 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,29 +646,6 @@ struct | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) - 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 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 sigma parse_elt term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> [] - | 2 -> parse_elt sigma c.(1) :: parse_list sigma parse_elt c.(2) - | i -> raise ParseError - let rec dump_list typ dump_elt l = match l with | [] -> EConstr.mkApp(Lazy.force coq_nil,[| typ |]) @@ -756,22 +660,8 @@ struct | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in Printf.fprintf o "%s%a%s" op _pp l cl - let pp_var = pp_positive - let dump_var = dump_positive - let pp_expr pp_z o e = - let rec pp_expr o e = - match e with - | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n - | Mc.PEc z -> pp_z o z - | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2 - | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2 - | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e - | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2 - | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n in - pp_expr o e - let dump_expr typ dump_z e = let rec dump_expr e = match e with @@ -854,18 +744,6 @@ struct | Mc.OpGt-> Lazy.force coq_OpGt | Mc.OpLt-> Lazy.force coq_OpLt - let pp_op o e= - match e with - | Mc.OpEq-> Printf.fprintf o "=" - | Mc.OpNEq-> Printf.fprintf o "<>" - | Mc.OpLe -> Printf.fprintf o "=<" - | Mc.OpGe -> Printf.fprintf o ">=" - | Mc.OpGt-> Printf.fprintf o ">" - | Mc.OpLt-> Printf.fprintf o "<" - - let pp_cstr pp_z o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } = - Printf.fprintf o"(%a %a %a)" (pp_expr pp_z) l pp_op op (pp_expr pp_z) r - let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = EConstr.mkApp(Lazy.force coq_Build, [| typ; dump_expr typ dump_constant e1 ; @@ -904,8 +782,8 @@ struct let parse_zop gl (op,args) = let sigma = gl.sigma in match EConstr.kind sigma op with - | Term.Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) - | Term.Ind((n,0),_) -> + | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> 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 @@ -914,8 +792,8 @@ struct let parse_rop gl (op,args) = let sigma = gl.sigma in match EConstr.kind sigma op with - | Term.Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) - | Term.Ind((n,0),_) -> + | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> 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 @@ -924,11 +802,6 @@ struct let parse_qop gl (op,args) = (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) - let is_constant sigma t = (* This is an approx *) - match EConstr.kind sigma t with - | Term.Construct(i,_) -> true - | _ -> false - type 'a op = | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) | Opp @@ -947,8 +820,6 @@ struct module Env = struct - type t = EConstr.constr list - let compute_rank_add env sigma v = let rec _add env n v = match env with @@ -1011,10 +882,10 @@ struct try (Mc.PEc (parse_constant term) , env) with ParseError -> match EConstr.kind sigma term with - | Term.App(t,args) -> + | App(t,args) -> ( match EConstr.kind sigma t with - | Term.Const c -> + | Const c -> ( 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 @@ -1077,13 +948,13 @@ struct let rec rconstant sigma term = match EConstr.kind sigma term with - | Term.Const x -> + | Const x -> if EConstr.eq_constr sigma term (Lazy.force coq_R0) then Mc.C0 else if EConstr.eq_constr sigma term (Lazy.force coq_R1) then Mc.C1 else raise ParseError - | Term.App(op,args) -> + | App(op,args) -> begin try (* the evaluation order is important in the following *) @@ -1153,7 +1024,7 @@ struct if debug then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); match EConstr.kind sigma cstr with - | Term.App(op,args) -> + | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in let (e1,env) = parse_expr sigma env lhs in let (e2,env) = parse_expr sigma env rhs in @@ -1168,17 +1039,6 @@ struct (* generic parsing of arithmetic expressions *) - let rec f2f = function - | TT -> Mc.TT - | FF -> Mc.FF - | X _ -> Mc.X - | A (x,_,_) -> Mc.A x - | C (a,b) -> Mc.Cj(f2f a,f2f b) - | D (a,b) -> Mc.D(f2f a,f2f b) - | N (a) -> Mc.N(f2f a) - | I(a,_,b) -> Mc.I(f2f a,f2f b) - - let mkC f1 f2 = C(f1,f2) let mkD f1 f2 = D(f1,f2) let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) @@ -1208,7 +1068,7 @@ struct let rec xparse_formula env tg term = match EConstr.kind sigma term with - | Term.App(l,rst) -> + | App(l,rst) -> (match rst with | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_and) -> let f,env,tg = xparse_formula env tg a in @@ -1225,7 +1085,7 @@ struct let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) - | Term.Prod(typ,a,b) when EConstr.Vars.noccurn sigma 1 b -> + | Prod(typ,a,b) when EConstr.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 @@ -1323,31 +1183,6 @@ let dump_qexpr = lazy dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table } - let dump_positive_as_R p = - let mult = Lazy.force coq_Rmult in - let add = Lazy.force coq_Rplus in - - let one = Lazy.force coq_R1 in - let mk_add x y = EConstr.mkApp(add,[|x;y|]) in - let mk_mult x y = EConstr.mkApp(mult,[|x;y|]) in - - let two = mk_add one one in - - let rec dump_positive p = - match p with - | Mc.XH -> one - | Mc.XO p -> mk_mult two (dump_positive p) - | Mc.XI p -> mk_add one (mk_mult two (dump_positive p)) in - - dump_positive p - -let dump_n_as_R n = - let z = CoqToCaml.n n in - if z = 0 - then Lazy.force coq_R0 - else dump_positive_as_R (CamlToCoq.positive z) - - let rec dump_Rcst_as_R cst = match cst with | Mc.C0 -> Lazy.force coq_R0 @@ -1481,54 +1316,6 @@ end (** open M -let rec sig_of_cone = function - | Mc.PsatzIn n -> [CoqToCaml.nat n] - | Mc.PsatzMulE(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) - | Mc.PsatzMulC(w1,w2) -> (sig_of_cone w2) - | Mc.PsatzAdd(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) - | _ -> [] - -let same_proof sg cl1 cl2 = - let rec xsame_proof sg = - match sg with - | [] -> true - | n::sg -> - (try Int.equal (List.nth cl1 n) (List.nth cl2 n) with Invalid_argument _ -> false) - && (xsame_proof sg ) in - xsame_proof sg - -let tags_of_clause tgs wit clause = - let rec xtags tgs = function - | Mc.PsatzIn n -> Names.Id.Set.union tgs - (snd (List.nth clause (CoqToCaml.nat n) )) - | Mc.PsatzMulC(e,w) -> xtags tgs w - | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2 - | _ -> tgs in - xtags tgs wit - -(*let tags_of_cnf wits cnf = - List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) - Names.Id.Set.empty wits cnf *) - -let find_witness prover polys1 = try_any prover polys1 - -let rec witness prover l1 l2 = - match l2 with - | [] -> Some [] - | e :: l2 -> - match find_witness prover (e::l1) with - | None -> None - | Some w -> - (match witness prover l1 l2 with - | None -> None - | Some l -> Some (w::l) - ) - -let rec apply_ids t ids = - match ids with - | [] -> t - | i::ids -> apply_ids (mkApp(t,[| mkVar i |])) ids - let coq_Node = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") @@ -1559,15 +1346,6 @@ let vm_of_list env = List.fold_left (fun vm (c,i) -> Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env - -let rec pp_varmap o vm = - match vm with - | Mc.Empty -> output_string o "[]" - | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z - | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r - - - let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof | Micromega.RatProof(cone,rst) -> @@ -1662,45 +1440,11 @@ let qq_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } -let rcst_domain_spec = lazy { - typ = Lazy.force coq_R; - coeff = Lazy.force coq_Rcst; - dump_coeff = dump_Rcst; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q -} - (** Naive topological sort of constr according to the subterm-ordering *) (* An element is minimal x is minimal w.r.t y if x <= y or (x and y are incomparable) *) -let is_min le x y = - if le x y then true - else if le y x then false else true - -let is_minimal le l c = List.for_all (is_min le c) l - -let find_rem p l = - let rec xfind_rem acc l = - match l with - | [] -> (None, acc) - | x :: l -> if p x then (Some x, acc @ l) - else xfind_rem (x::acc) l in - xfind_rem [] l - -let find_minimal le l = find_rem (is_minimal le l) l - -let rec mk_topo_order le l = - match find_minimal le l with - | (None , _) -> [] - | (Some v,l') -> v :: (mk_topo_order le 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 - - (** * Instanciate the current Coq goal with a Micromega formula, a varmap, and a * witness. @@ -1778,13 +1522,6 @@ let witness_list prover l = let witness_list_tags = witness_list -(* *Deprecated* let is_singleton = function [] -> true | [e] -> true | _ -> false *) - -let pp_ml_list pp_elt o l = - output_string o "[" ; - List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; - output_string o "]" - (** * Prune the proof object, according to the 'diff' between two cnf formulas. *) @@ -1792,7 +1529,7 @@ let pp_ml_list pp_elt o l = let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in + let new_cl = List.mapi (fun i (f,_) -> (f,i)) new_cl in let remap i = let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in List.assoc formula new_cl in @@ -1991,7 +1728,7 @@ let micromega_gen 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 (CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in @@ -2106,7 +1843,7 @@ let micromega_genr prover tac = 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 (CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in @@ -2158,7 +1895,11 @@ let lift_ratproof prover l = | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list + +[@@@ocaml.warning "-37"] type csdp_certificate = S of Sos_types.positivstellensatz option | F of string +(* Used to read the result of the execution of csdpcert *) + type provername = string * int option (** @@ -2406,16 +2147,6 @@ let nlinear_Z = { pp_f = fun o x -> pp_pol pp_z o (fst x) } - - -let tauto_lia ff = - let prover = linear_Z in - let cnf_ff,_ = cnf Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce ff in - match witness_list_tags [prover] cnf_ff with - | None -> None - | Some l -> Some (List.map fst l) - - (** * Functions instantiating micromega_gen with the appropriate theories and * solvers diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli new file mode 100644 index 00000000..b91feb39 --- /dev/null +++ b/plugins/micromega/coq_micromega.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* unit Proofview.tactic -> unit Proofview.tactic +val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic +val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic +val xlia : unit Proofview.tactic -> unit Proofview.tactic +val xnlia : unit Proofview.tactic -> unit Proofview.tactic +val nra : unit Proofview.tactic -> unit Proofview.tactic +val nqa : unit Proofview.tactic -> unit Proofview.tactic +val sos_Z : unit Proofview.tactic -> unit Proofview.tactic +val sos_Q : unit Proofview.tactic -> unit Proofview.tactic +val sos_R : unit Proofview.tactic -> unit Proofview.tactic +val lra_Q : unit Proofview.tactic -> unit Proofview.tactic +val lra_R : unit Proofview.tactic -> unit Proofview.tactic diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index a1245b7c..9c1b4810 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -20,7 +20,6 @@ open Sos_types open Sos_lib module Mc = Micromega -module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list @@ -28,7 +27,6 @@ type csdp_certificate = S of Sos_types.positivstellensatz option | F of string type provername = string * int option -let debug = false let flags = [Open_append;Open_binary;Open_creat] let chan = open_out_gen flags 0o666 "trace" @@ -55,27 +53,6 @@ struct end open M -open Mutils - - - - -let canonical_sum_to_string = function s -> failwith "not implemented" - -let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) - -let print_list_term o l = - output_string o "print_list_term\n"; - List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;" - (string_of_poly (poly_of_term (expr_to_term e))) - (match k with - Mc.Equal -> "= " - | Mc.Strict -> "> " - | Mc.NonStrict -> ">= " - | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ; - output_string o "\n" - - let partition_expr l = let rec f i = function | [] -> ([],[],[]) @@ -125,7 +102,7 @@ let real_nonlinear_prover d l = (sets_of_list neq) in let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> - list_try_find (fun m -> let (ci,cc) = + tryfind (fun m -> let (ci,cc) = real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in (ci,cc,snd m)) monoids) 0 in @@ -144,7 +121,7 @@ let real_nonlinear_prover d l = | l -> Monoid l in List.fold_right (fun x y -> Product(x,y)) lt sq in - let proof = list_fold_right_elements + let proof = end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in S (Some proof) with @@ -158,7 +135,7 @@ let pure_sos l = (* If there is no strict inequality, I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) try - let l = List.combine l (interval 0 (List.length l -1)) in + let l = List.combine l (CList.interval 0 (List.length l -1)) in let (lt,i) = try (List.find (fun (x,_) -> Pervasives.(=) (snd x) Mc.Strict) l) with Not_found -> List.hd l in let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in @@ -183,13 +160,6 @@ let run_prover prover pb = | "pure_sos", None -> pure_sos pb | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) - -let output_csdp_certificate o = function - | S None -> output_string o "S None" - | S (Some p) -> Printf.fprintf o "S (Some %a)" output_psatz p - | F s -> Printf.fprintf o "F %s" s - - let main () = try let (prover,poly) = (input_value stdin : provername * micromega_polys) in diff --git a/plugins/micromega/csdpcert.mli b/plugins/micromega/csdpcert.mli new file mode 100644 index 00000000..7c3ee600 --- /dev/null +++ b/plugins/micromega/csdpcert.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* [ Tactics.red_in_concl ] -END - - - -TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_Z i - (Tacinterp.tactic_of_value ist t)) - ] -| [ "psatz_Z" tactic(t)] -> [ (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) ] -END - -TACTIC EXTEND Lia -[ "xlia" tactic(t) ] -> [ (Coq_micromega.xlia (Tacinterp.tactic_of_value ist t)) ] -END - -TACTIC EXTEND Nia -[ "xnlia" tactic(t) ] -> [ (Coq_micromega.xnlia (Tacinterp.tactic_of_value ist t)) ] -END - -TACTIC EXTEND NRA -[ "xnra" tactic(t) ] -> [ (Coq_micromega.nra (Tacinterp.tactic_of_value ist t))] -END - -TACTIC EXTEND NQA -[ "xnqa" tactic(t) ] -> [ (Coq_micromega.nqa (Tacinterp.tactic_of_value ist t))] -END - - - -TACTIC EXTEND Sos_Z -| [ "sos_Z" tactic(t) ] -> [ (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) ] - END - -TACTIC EXTEND Sos_Q -| [ "sos_Q" tactic(t) ] -> [ (Coq_micromega.sos_Q (Tacinterp.tactic_of_value ist t)) ] - END - -TACTIC EXTEND Sos_R -| [ "sos_R" tactic(t) ] -> [ (Coq_micromega.sos_R (Tacinterp.tactic_of_value ist t)) ] -END - -TACTIC EXTEND LRA_Q -[ "lra_Q" tactic(t) ] -> [ (Coq_micromega.lra_Q (Tacinterp.tactic_of_value ist t)) ] -END - -TACTIC EXTEND LRA_R -[ "lra_R" tactic(t) ] -> [ (Coq_micromega.lra_R (Tacinterp.tactic_of_value ist t)) ] -END - -TACTIC EXTEND PsatzR -| [ "psatz_R" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) ] -| [ "psatz_R" tactic(t) ] -> [ (Coq_micromega.psatz_R (-1) (Tacinterp.tactic_of_value ist t)) ] -END - -TACTIC EXTEND PsatzQ -| [ "psatz_Q" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) ] -| [ "psatz_Q" tactic(t) ] -> [ (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) ] -END - diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg new file mode 100644 index 00000000..21f0414e --- /dev/null +++ b/plugins/micromega/g_micromega.mlg @@ -0,0 +1,89 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* { Tactics.red_in_concl } +END + + + +TACTIC EXTEND PsatzZ +| [ "psatz_Z" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i + (Tacinterp.tactic_of_value ist t)) + } +| [ "psatz_Z" tactic(t)] -> { (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) } +END + +TACTIC EXTEND Lia +| [ "xlia" tactic(t) ] -> { (Coq_micromega.xlia (Tacinterp.tactic_of_value ist t)) } +END + +TACTIC EXTEND Nia +| [ "xnlia" tactic(t) ] -> { (Coq_micromega.xnlia (Tacinterp.tactic_of_value ist t)) } +END + +TACTIC EXTEND NRA +| [ "xnra" tactic(t) ] -> { (Coq_micromega.nra (Tacinterp.tactic_of_value ist t))} +END + +TACTIC EXTEND NQA +| [ "xnqa" tactic(t) ] -> { (Coq_micromega.nqa (Tacinterp.tactic_of_value ist t))} +END + + + +TACTIC EXTEND Sos_Z +| [ "sos_Z" tactic(t) ] -> { (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) } + END + +TACTIC EXTEND Sos_Q +| [ "sos_Q" tactic(t) ] -> { (Coq_micromega.sos_Q (Tacinterp.tactic_of_value ist t)) } + END + +TACTIC EXTEND Sos_R +| [ "sos_R" tactic(t) ] -> { (Coq_micromega.sos_R (Tacinterp.tactic_of_value ist t)) } +END + +TACTIC EXTEND LRA_Q +| [ "lra_Q" tactic(t) ] -> { (Coq_micromega.lra_Q (Tacinterp.tactic_of_value ist t)) } +END + +TACTIC EXTEND LRA_R +| [ "lra_R" tactic(t) ] -> { (Coq_micromega.lra_R (Tacinterp.tactic_of_value ist t)) } +END + +TACTIC EXTEND PsatzR +| [ "psatz_R" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) } +| [ "psatz_R" tactic(t) ] -> { (Coq_micromega.psatz_R (-1) (Tacinterp.tactic_of_value ist t)) } +END + +TACTIC EXTEND PsatzQ +| [ "psatz_Q" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) } +| [ "psatz_Q" tactic(t) ] -> { (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) } +END + diff --git a/plugins/micromega/g_micromega.mli b/plugins/micromega/g_micromega.mli new file mode 100644 index 00000000..7c3ee600 --- /dev/null +++ b/plugins/micromega/g_micromega.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* if a <=/ b then Some itv else None | _ -> Some itv - (** [opp_itv itv] computes the opposite interval *) - let opp_itv itv = - let (l,r) = itv in - (map_option minus_num r, map_option minus_num l) - - - - (** [inter i1 i2 = None] if the intersection of intervals is empty [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) let inter i1 i2 = @@ -92,10 +77,6 @@ type vector = Vect.t module ISet = Set.Make(Int) - -module PSet = ISet - - module System = Hashtbl.Make(Vect) type proof = @@ -131,14 +112,6 @@ and cstr_info = { (** To be thrown when a system has no solution *) exception SystemContradiction of proof -let hyps prf = - let rec hyps prf acc = - match prf with - | Assum i -> ISet.add i acc - | Elim(_,prf1,prf2) - | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in - hyps prf ISet.empty - (** Pretty printing *) let rec pp_proof o prf = @@ -147,26 +120,6 @@ let hyps prf = | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 -let pp_bound o = function - | None -> output_string o "oo" - | Some a -> output_string o (string_of_num a) - -let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r - - -let pp_iset o s = - output_string o "{" ; - ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" - -let pp_pset o s = - output_string o "{" ; - PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" - - -let pp_info o i = pp_itv o i.bound - let pp_cstr o (vect,bnd) = let (l,r) = bnd in (match l with @@ -183,11 +136,6 @@ let pp_system o sys= System.iter (fun vect ibnd -> pp_cstr o (vect,(!ibnd).bound)) sys - - -let pp_split_cstr o (vl,v,c,_) = - Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect v (string_of_num c) - (** [merge_cstr_info] takes: - the intersection of bounds and - the union of proofs @@ -243,8 +191,8 @@ let normalise_cstr vect cinfo = (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), let divn x = x // n in if Int.equal (sign_num n) 1 - then{cinfo with bound = (map_option divn l , map_option divn r) } - else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)}) + then{cinfo with bound = (Option.map divn l , Option.map divn r) } + else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (Option.map divn r , Option.map divn l)}) (** For compatibility, there is an external representation of constraints *) @@ -281,7 +229,7 @@ let load_system l = let sys = System.create 1000 in - let li = Mutils.mapi (fun e i -> (e,i)) l in + let li = List.mapi (fun i e -> (e,i)) l in let vars = List.fold_left (fun vrs (cstr,i) -> match norm_cstr cstr i with @@ -335,9 +283,6 @@ let add (v1,c1) (v2,c2) = (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) res -type tlr = (num * vector * cstr_info) list -type tm = (vector * cstr_info ) list - (** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) (** [split x vect info (l,m,r)] @@ -381,8 +326,8 @@ let project vr sys = let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1 and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in - let bnd1 = from_option (fst bound1) - and bnd2 = from_option (fst bound2) in + let bnd1 = Option.get (fst bound1) + and bnd2 = Option.get (fst bound2) in let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in @@ -419,13 +364,13 @@ let project_using_eq vr c vect bound prf (vect',info') = let bndres = let f x = cst +/ x // c2 in let (l,r) = info'.bound in - (map_option f l , map_option f r) in + (Option.map f l , Option.map f r) in (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) | None -> (vect',info') let elim_var_using_eq vr vect cst prf sys = - let c = from_option (get vr vect) in + let c = Option.get (get vr vect) in let elim_var = project_using_eq vr c vect cst prf in @@ -444,9 +389,7 @@ let elim_var_using_eq vr vect cst prf sys = (** [size sys] computes the number of entries in the system of constraints *) let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0 -module IMap = Map.Make(Int) - -let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map () +module IMap = CMap.Make(Int) (** [eval_vect map vect] evaluates vector [vect] using the values of [map]. If [map] binds all the variables of [vect], we get @@ -475,8 +418,8 @@ let restrict_bound n sum (itv:interval) = | 0 -> if in_bound itv sum then (None,None) (* redundant *) else failwith "SystemContradiction" - | 1 -> map_option f l , map_option f r - | _ -> map_option f r , map_option f l + | 1 -> Option.map f l , Option.map f r + | _ -> Option.map f r , Option.map f l (** [bound_of_variable map v sys] computes the interval of [v] in @@ -613,12 +556,6 @@ struct |(Some a, Some b) -> a =/ b | _ -> false - let eq_bound bnd c = - match bnd with - |(Some a, Some b) -> a =/ b && c =/ b - | _ -> false - - let rec unroll_until v l = match l with | [] -> (false,[]) diff --git a/plugins/micromega/mfourier.mli b/plugins/micromega/mfourier.mli new file mode 100644 index 00000000..f1d8edea --- /dev/null +++ b/plugins/micromega/mfourier.mli @@ -0,0 +1,49 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* Num.num option + val smaller_itv : interval -> interval -> bool + +end + +module IMap : CSig.MapS with type key = int + +type proof + +module Fourier : sig + + val find_point : Polynomial.cstr_compat list -> + ((IMap.key * Num.num) list, proof) Util.union + + val optimise : Polynomial.Vect.t -> + Polynomial.cstr_compat list -> + Itv.interval option + +end + +val pp_proof : out_channel -> proof -> unit + +module Proof : sig + + val mk_proof : Polynomial.cstr_compat list -> + proof -> (Polynomial.Vect.t * Polynomial.cstr_compat) list + + val add_op : Polynomial.op -> Polynomial.op -> Polynomial.op + +end + +val max_nb_cstr : int ref + +val eval_op : Polynomial.op -> Num.num -> Num.num -> bool + +exception TimeOut diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 82367c0b..9d03560b 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -19,8 +19,6 @@ (* *) (************************************************************************) -let debug = false - let rec pp_list f o l = match l with | [] -> () @@ -36,15 +34,6 @@ let finally f rst = with any -> raise reraise ); raise reraise -let map_option f x = - match x with - | None -> None - | Some v -> Some (f v) - -let from_option = function - | None -> failwith "from_option" - | Some v -> v - let rec try_any l x = match l with | [] -> None @@ -52,13 +41,6 @@ let rec try_any l x = | None -> try_any l x | x -> x -let iteri f l = - let rec xiter i l = - match l with - | [] -> () - | e::l -> f i e ; xiter (i+1) l in - xiter 0 l - let all_sym_pairs f l = let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in @@ -77,14 +59,6 @@ let all_pairs f l = | e::lx -> xpairs (pair_with acc e l) lx in xpairs [] l - - -let rec map3 f l1 l2 l3 = - match l1 , l2 ,l3 with - | [] , [] , [] -> [] - | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3) - | _ -> invalid_arg "map3" - let rec is_sublist f l1 l2 = match l1 ,l2 with | [] ,_ -> true @@ -93,26 +67,6 @@ let rec is_sublist f l1 l2 = if f e e' then is_sublist f l1' l2' else is_sublist f l1 l2' -let list_try_find f = - let rec try_find_f = function - | [] -> failwith "try_find" - | h::t -> try f h with Failure _ -> try_find_f t - in - try_find_f - -let list_fold_right_elements f l = - let rec aux = function - | [] -> invalid_arg "list_fold_right_elements" - | [x] -> x - | x::l -> f x (aux l) in - aux l - -let interval n m = - let rec interval_n (l,m) = - if n > m then l else interval_n (m::l,pred m) - in - interval_n ([],m) - let extract pred l = List.fold_left (fun (fd,sys) e -> match fd with @@ -163,51 +117,7 @@ let rats_to_ints l = List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) (denominator x))) l -(* Nasty reordering of lists - useful to trim certificate down *) -let mapi f l = - let rec xmapi i l = - match l with - | [] -> [] - | e::l -> (f e i)::(xmapi (i+1) l) in - xmapi 0 l - -let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) - (* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) -let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l)) - -let assoc_pos_assoc l = - let rec xpos i l = - match l with - | [] -> [] - | (x,l) ::rst -> let (l',j) = assoc_pos i l in - (x,l')::(xpos j rst) in - xpos 0 l - -let filter_pos f l = - (* Could sort ... take care of duplicates... *) - let rec xfilter l = - match l with - | [] -> [] - | (x,e)::l -> - if List.exists (fun ee -> List.mem ee f) (List.map snd e) - then (x,e)::(xfilter l) - else xfilter l in - xfilter l - -let select_pos lpos l = - let rec xselect i lpos l = - match lpos with - | [] -> [] - | j::rpos -> - match l with - | [] -> failwith "select_pos" - | e::l -> - if Int.equal i j - then e:: (xselect (i+1) rpos l) - else xselect (i+1) lpos l in - xselect 0 lpos l - (** * MODULE: Coq to Caml data-structure mappings *) @@ -238,12 +148,6 @@ struct | XI i -> 1+(2*(index i)) | XO i -> 2*(index i) - let z x = - match x with - | Z0 -> 0 - | Zpos p -> (positive p) - | Zneg p -> - (positive p) - open Big_int let rec positive_big_int p = @@ -258,8 +162,6 @@ struct | Zpos p -> (positive_big_int p) | Zneg p -> minus_big_int (positive_big_int p) - let num x = Num.Big_int (z_big_int x) - let q_to_num {qnum = x ; qden = y} = Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) @@ -352,17 +254,6 @@ struct let c = cmp e1 e2 in if Int.equal c 0 then compare_list cmp l1 l2 else c -(** - * hash_list takes a hash function and a list, and computes an integer which - * is the hash value of the list. - *) - let hash_list hash l = - let rec _hash_list l h = - match l with - | [] -> h lxor (Hashtbl.hash []) - | e::l -> _hash_list l ((hash e) lxor h) - in _hash_list l 0 - end (** diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli new file mode 100644 index 00000000..094429ea --- /dev/null +++ b/plugins/micromega/mutils.mli @@ -0,0 +1,70 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* Big_int.big_int +val denominator : Num.num -> Big_int.big_int + +module Cmp : sig + + val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int + val compare_lexical : (unit -> int) list -> int + +end + +module Tag : sig + + type t + + val pp : out_channel -> t -> unit + val next : t -> t + val from : int -> t + +end + +module TagSet : CSig.SetS with type elt = Tag.t + +val pp_list : (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit + +module CamlToCoq : sig + + val positive : int -> Micromega.positive + val bigint : Big_int.big_int -> Micromega.z + val n : int -> Micromega.n + val nat : int -> Micromega.nat + val q : Num.num -> Micromega.q + val index : int -> Micromega.positive + val z : int -> Micromega.z + val positive_big_int : Big_int.big_int -> Micromega.positive + +end + +module CoqToCaml : sig + + val z_big_int : Micromega.z -> Big_int.big_int + val q_to_num : Micromega.q -> Num.num + val positive : Micromega.positive -> int + val n : Micromega.n -> int + val nat : Micromega.nat -> int + val index : Micromega.positive -> int + +end + +val rats_to_ints : Num.num list -> Big_int.big_int list + +val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list +val all_sym_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list +val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option +val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + +val gcd_list : Num.num list -> Big_int.big_int + +val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list + +val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/persistent_cache.mli b/plugins/micromega/persistent_cache.mli new file mode 100644 index 00000000..240fa490 --- /dev/null +++ b/plugins/micromega/persistent_cache.mli @@ -0,0 +1,47 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* string -> 'a t + (** [create i f] creates an empty persistent table + with initial size i associated with file [f] *) + + + val open_in : string -> 'a t + (** [open_in f] rebuilds a table from the records stored in file [f]. + As marshaling is not type-safe, it migth segault. + *) + + val find : 'a t -> key -> 'a + (** find has the specification of Hashtable.find *) + + val add : 'a t -> key -> 'a -> unit + (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. + (and writes the binding to the file associated with [tbl].) + If [key] is already bound, raises KeyAlreadyBound *) + + val close : 'a t -> unit + (** [close tbl] is closing the table. + Once closed, a table cannot be used. + i.e, find,add will raise UnboundTable *) + + val memo : string -> (key -> 'a) -> (key -> 'a) + (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. + Note that the cache will only be loaded when the function is used for the first time *) + + end + +module PHashtable(Key:HashedType) : PHashtable with type key = Key.t diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index db8b73a2..1d18a26f 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -20,9 +20,9 @@ open Utils type var = int +let debug = false let (<+>) = add_num -let (<->) = minus_num let (<*>) = mult_num @@ -33,8 +33,6 @@ sig val is_const : t -> bool val var : var -> t val is_var : t -> bool - val find : var -> t -> int - val mult : var -> t -> t val prod : t -> t -> t val exp : t -> int -> t val div : t -> t -> t * int @@ -99,9 +97,6 @@ struct (* Get the degre of a variable in a monomial *) let find x m = try find x m with Not_found -> 0 - (* Multiply a monomial by a variable *) - let mult x m = add x ( (find x m) + 1) m - (* Product of monomials *) let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 @@ -145,14 +140,10 @@ sig val variable : var -> t val add : Monomial.t -> num -> t -> t val constant : num -> t - val mult : Monomial.t -> num -> t -> t val product : t -> t -> t val addition : t -> t -> t val uminus : t -> t val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a - val pp : out_channel -> t -> unit - val compare : t -> t -> int - val is_null : t -> bool val is_linear : t -> bool end = struct @@ -162,12 +153,6 @@ struct type t = num P.t - let pp o p = P.iter - (fun k v -> - if Monomial.compare Monomial.const k = 0 - then Printf.fprintf o "%s " (string_of_num v) - else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p - (* Get the coefficient of monomial mn *) let get : Monomial.t -> t -> num = fun mn p -> try find mn p with Not_found -> (Int 0) @@ -220,10 +205,6 @@ struct let fold = P.fold - let is_null p = fold (fun mn vl b -> b && sign_num vl = 0) p true - - let compare = compare compare_num - let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true (* let is_linear p = @@ -277,7 +258,6 @@ module Vect = xfrom_list 0 l let zero_num = Int 0 - let unit_num = Int 1 let to_list m = @@ -311,11 +291,6 @@ module Vect = | 1 -> (k,v) :: (set i n l) | _ -> failwith "compare_num" - let gcd m = - let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in - if Big_int.compare_big_int res Big_int.zero_big_int = 0 - then Big_int.unit_big_int else res - let mul z t = match z with | Int 0 -> [] @@ -345,7 +320,7 @@ module Vect = - let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical + let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical [ (fun () -> Int.compare (fst x) (fst y)); (fun () -> compare_num (snd x) (snd y))]) @@ -395,18 +370,8 @@ let opMult o1 o2 = | Eq , Ge | Ge , Eq -> Ge | Ge , Ge -> Ge -let opAdd o1 o2 = - match o1 , o2 with - | Eq , _ | _ , Eq -> Eq - | Ge , Ge -> Ge - - - - open Big_int -type index = int - type prf_rule = | Hyp of int | Def of int @@ -550,35 +515,6 @@ let mul_proof_ext (p,c) prf = | _ -> MulC((p,c),prf) - -(* - let rec scale_prf_rule = function - | Hyp i -> (unit_big_int, Hyp i) - | Def i -> (unit_big_int, Def i) - | Cst c -> (unit_big_int, Cst i) - | Zero -> (unit_big_int, Zero) - | Square p -> (unit_big_int,Square p) - | Div(c,pr) -> - let (bi,pr') = scale_prf_rule pr in - (mult_big_int c bi , pr') - | MulC(p,pr) -> - let bi,pr' = scale_prf_rule pr in - (bi,MulC p,pr') - | MulPrf(p1,p2) -> - let b1,p1 = scale_prf_rule p1 in - let b2,p2 = scale_prf_rule p2 in - - - | AddPrf(p1,p2) -> - let b1,p1 = scale_prf_rule p1 in - let b2,p2 = scale_prf_rule p2 in - let g = gcd_big_int -*) - - - - - module LinPoly = struct type t = Vect.t * num diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli new file mode 100644 index 00000000..4c095202 --- /dev/null +++ b/plugins/micromega/polynomial.mli @@ -0,0 +1,118 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* int -> 'a -> 'a) -> t -> 'a -> 'a + val const : t + val sqrt : t -> t option + val is_var : t -> bool + val div : t -> t -> t * int + + val compare : t -> t -> int + +end + +module Poly : sig + + type t + + val constant : Num.num -> t + val variable : var -> t + val addition : t -> t -> t + val product : t -> t -> t + val uminus : t -> t + val get : Monomial.t -> t -> Num.num + val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a + + val is_linear : t -> bool + + val add : Monomial.t -> Num.num -> t -> t + +end + +module Vect : sig + + type var = int + type t = (var * Num.num) list + val hash : t -> int + val equal : t -> t -> bool + val compare : t -> t -> int + val pp_vect : 'a -> t -> unit + + val get : var -> t -> Num.num option + val set : var -> Num.num -> t -> t + val fresh : (int * 'a) list -> int + val update : Int.t -> (Num.num -> Num.num) -> + (Int.t * Num.num) list -> (Int.t * Num.num) list + val null : t + + val from_list : Num.num list -> t + val to_list : t -> Num.num list + + val add : t -> t -> t + val mul : Num.num -> t -> t + +end + +type cstr_compat = {coeffs : Vect.t ; op : op ; cst : Num.num} +and op = Eq | Ge + +type prf_rule = + | Hyp of int + | Def of int + | Cst of Big_int.big_int + | Zero + | Square of (Vect.t * Num.num) + | MulC of (Vect.t * Num.num) * prf_rule + | Gcd of Big_int.big_int * prf_rule + | MulPrf of prf_rule * prf_rule + | AddPrf of prf_rule * prf_rule + | CutPrf of prf_rule + +type proof = + | Done + | Step of int * prf_rule * proof + | Enum of int * prf_rule * Vect.t * prf_rule * proof list + +val proof_max_id : proof -> int + +val normalise_proof : int -> proof -> int * proof + +val output_proof : out_channel -> proof -> unit + +val add_proof : prf_rule -> prf_rule -> prf_rule +val mul_proof : Big_int.big_int -> prf_rule -> prf_rule + +module LinPoly : sig + + type t = Vect.t * Num.num + + module MonT : sig + + val clear : unit -> unit + val retrieve : int -> Monomial.t + + end + + val pivot_eq : Vect.var -> + cstr_compat * prf_rule -> + cstr_compat * prf_rule -> (cstr_compat * prf_rule) option + + val linpol_of_pol : Poly.t -> t + +end + +val output_cstr : out_channel -> cstr_compat -> unit + +val opMult : op -> op -> op diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index e1ceabe9..42a41e17 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -95,7 +95,7 @@ let dim (v:vector) = fst v;; let vector_const c n = if c =/ Int 0 then vector_0 n - else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);; + else (n,List.fold_right (fun k -> k |-> c) (1--n) undefined :vector);; let vector_cmul c (v:vector) = let n = dim v in @@ -104,7 +104,7 @@ let vector_cmul c (v:vector) = let vector_of_list l = let n = List.length l in - (n,itlist2 (|->) (1--n) l undefined :vector);; + (n,List.fold_right2 (|->) (1--n) l undefined :vector);; (* ------------------------------------------------------------------------- *) (* Matrices; again rows and columns indexed from 1. *) @@ -242,7 +242,7 @@ let string_of_monomial m = if m = monomial_1 then "1" else let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a) (sort humanorder_varpow (graph m)) [] in - end_itlist (fun s t -> s^"*"^t) vps;; + String.concat "*" vps;; let string_of_cmonomial (c,m) = if m = monomial_1 then string_of_num c @@ -310,7 +310,7 @@ let rec poly_of_term t = match t with let sdpa_of_vector (v:vector) = let n = dim v in let strs = List.map (o (decimalize 20) (element v)) (1--n) in - end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; + String.concat " " strs ^ "\n";; (* ------------------------------------------------------------------------- *) (* String for a matrix numbered k, in SDPA sparse format. *) @@ -321,7 +321,7 @@ let sdpa_of_matrix k (m:matrix) = let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in - itlist (fun ((i,j),c) a -> + List.fold_right (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; @@ -340,7 +340,7 @@ let sdpa_of_problem comment obj mats = "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) @@ -489,11 +489,11 @@ let scale_then = and maximal_element amat acc = foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in fun solver obj mats -> - let cd1 = itlist common_denominator mats (Int 1) + let cd1 = List.fold_right common_denominator mats (Int 1) and cd2 = common_denominator (snd obj) (Int 1) in let mats' = List.map (mapf (fun x -> cd1 */ x)) mats and obj' = vector_cmul cd2 obj in - let max1 = itlist maximal_element mats' (Int 0) + let max1 = List.fold_right maximal_element mats' (Int 0) and max2 = maximal_element (snd obj') (Int 0) in let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0)) and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in @@ -551,7 +551,7 @@ let minimal_convex_hull = | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in let augment m ms = funpow 3 augment1 (m::ms) in fun mons -> - let mons' = itlist augment (List.tl mons) [List.hd mons] in + let mons' = List.fold_right augment (List.tl mons) [List.hd mons] in funpow (List.length mons') augment1 mons';; (* ------------------------------------------------------------------------- *) @@ -612,11 +612,11 @@ let newton_polytope pol = let vars = poly_variables pol in let mons = List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol) and ds = List.map (fun x -> (degree x pol + 1) / 2) vars in - let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] + let all = List.fold_right (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] and mons' = minimal_convex_hull mons in let all' = List.filter (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) all in - List.map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a) + List.map (fun m -> List.fold_right2 (fun v i a -> if i = 0 then a else (v |-> i) a) vars m monomial_1) (List.rev all');; (* ------------------------------------------------------------------------- *) @@ -657,8 +657,8 @@ let deration d = foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in (c // (a */ a)),mapa (fun x -> a */ x) l in let d' = List.map adj d in - let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // - itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in + let a = List.fold_right ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // + List.fold_right ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in (Int 1 // a),List.map (fun (c,l) -> (a */ c,l)) d';; (* ------------------------------------------------------------------------- *) @@ -719,7 +719,7 @@ let sdpa_of_blockdiagonal k m = let ents = foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in let entss = sort (increasing fst) ents in - itlist (fun ((b,i,j),c) a -> + List.fold_right (fun ((b,i,j),c) a -> pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; @@ -732,10 +732,10 @@ let sdpa_of_blockproblem comment nblocks blocksizes obj mats = "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ string_of_int nblocks ^ "\n" ^ - (end_itlist (fun s t -> s^" "^t) (List.map string_of_int blocksizes)) ^ + (String.concat " " (List.map string_of_int blocksizes)) ^ "\n" ^ sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) + List.fold_right2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) @@ -791,14 +791,14 @@ let blocks blocksizes bm = (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a) undefined bm in (((bs,bs),m):matrix)) - (zip blocksizes (1--List.length blocksizes));; + (List.combine blocksizes (1--List.length blocksizes));; (* ------------------------------------------------------------------------- *) (* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) (* ------------------------------------------------------------------------- *) let real_positivnullstellensatz_general linf d eqs leqs pol = - let vars = itlist ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in + let vars = List.fold_right ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in let monoid = if linf then (poly_const num_1,Rational_lt num_1):: @@ -808,16 +808,16 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = let mk_idmultiplier k p = let e = d - multidegree p in let mons = enumerate_monomials e vars in - let nons = zip mons (1--List.length mons) in + let nons = List.combine mons (1--List.length mons) in mons, - itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in + List.fold_right (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in let mk_sqmultiplier k (p,c) = let e = (d - multidegree p) / 2 in let mons = enumerate_monomials e vars in - let nons = zip mons (1--List.length mons) in + let nons = List.combine mons (1--List.length mons) in mons, - itlist (fun (m1,n1) -> - itlist (fun (m2,n2) a -> + List.fold_right (fun (m1,n1) -> + List.fold_right (fun (m2,n2) a -> let m = monomial_mul m1 m2 in if n1 > n2 then a else let c = if n1 = n2 then Int 1 else Int 2 in @@ -825,17 +825,17 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = (m |-> equation_add ((k,n1,n2) |=> c) e) a) nons) nons undefined in - let sqmonlist,sqs = unzip(List.map2 mk_sqmultiplier (1--List.length monoid) monoid) - and idmonlist,ids = unzip(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in + let sqmonlist,sqs = List.split(List.map2 mk_sqmultiplier (1--List.length monoid) monoid) + and idmonlist,ids = List.split(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in let blocksizes = List.map List.length sqmonlist in let bigsum = - itlist2 (fun p q a -> epoly_pmul p q a) eqs ids - (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs + List.fold_right2 (fun p q a -> epoly_pmul p q a) eqs ids + (List.fold_right2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs (epoly_of_poly(poly_neg pol))) in let eqns = foldl (fun a m e -> e::a) [] bigsum in let pvs,assig = eliminate_all_equations (0,0,0) eqns in let qvars = (0,0,0)::pvs in - let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let allassig = List.fold_right (fun v -> (v |-> (v |=> Int 1))) pvs assig in let mk_matrix v = foldl (fun m (b,i,j) ass -> if b < 0 then m else let c = tryapplyd ass v (Int 0) in @@ -858,8 +858,8 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = else ()); let vec = nice_vector d raw_vec in let blockmat = iter (1,dim vec) - (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a) - (bmatrix_neg (el 0 mats)) in + (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (List.nth mats i)) a) + (bmatrix_neg (List.nth mats 0)) in let allmats = blocks blocksizes blockmat in vec,List.map diag allmats in let vec,ratdias = @@ -867,7 +867,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = else tryfind find_rounding (List.map Num.num_of_int (1--31) @ List.map pow2 (5--66)) in let newassigs = - itlist (fun k -> el (k - 1) pvs |-> element vec k) + List.fold_right (fun k -> List.nth pvs (k - 1) |-> element vec k) (1--dim vec) ((0,0,0) |=> Int(-1)) in let finalassigs = foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs @@ -877,17 +877,17 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = undefined p in let mk_sos mons = let mk_sq (c,m) = - c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a) + c,List.fold_right (fun k a -> (List.nth mons (k - 1) |--> element m k) a) (1--List.length mons) undefined in List.map mk_sq in let sqs = List.map2 mk_sos sqmonlist ratdias and cfs = List.map poly_of_epoly ids in let msq = List.filter (fun (a,b) -> b <> []) (List.map2 (fun a b -> a,b) monoid sqs) in - let eval_sq sqs = itlist + let eval_sq sqs = List.fold_right (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in let sanity = - itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq - (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs + List.fold_right (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq + (List.fold_right2 (fun p q -> poly_add (poly_mul p q)) cfs eqs (poly_neg pol)) in if not(is_undefined sanity) then raise Sanity else cfs,List.map (fun (a,b) -> snd a,b) msq;; @@ -913,8 +913,8 @@ let monomial_order = fun m1 m2 -> if m2 = monomial_1 then true else if m1 = monomial_1 then false else let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in - let deg1 = itlist ((o) (+) snd) mon1 0 - and deg2 = itlist ((o) (+) snd) mon2 0 in + let deg1 = List.fold_right ((o) (+) snd) mon1 0 + and deg2 = List.fold_right ((o) (+) snd) mon2 0 in if deg1 < deg2 then false else if deg1 > deg2 then true else lexorder mon1 mon2;; @@ -929,7 +929,7 @@ let term_of_varpow = let term_of_monomial = fun m -> if m = monomial_1 then Const num_1 else let m' = dest_monomial m in - let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in + let vps = List.fold_right (fun (x,k) a -> term_of_varpow x k :: a) m' [] in end_itlist (fun s t -> Mul (s,t)) vps;; let term_of_cmonomial = @@ -952,203 +952,13 @@ let term_of_sos (pr,sqs) = if sqs = [] then pr else Product(pr,end_itlist (fun a b -> Sum(a,b)) (List.map term_of_sqterm sqs));; -(* ------------------------------------------------------------------------- *) -(* Interface to HOL. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_NONLINEAR_PROVER translator (eqs,les,lts) = - let eq0 = map (poly_of_term o lhand o concl) eqs - and le0 = map (poly_of_term o lhand o concl) les - and lt0 = map (poly_of_term o lhand o concl) lts in - let eqp0 = map (fun (t,i) -> t,Axiom_eq i) (zip eq0 (0--(length eq0 - 1))) - and lep0 = map (fun (t,i) -> t,Axiom_le i) (zip le0 (0--(length le0 - 1))) - and ltp0 = map (fun (t,i) -> t,Axiom_lt i) (zip lt0 (0--(length lt0 - 1))) in - let keq,eq = partition (fun (p,_) -> multidegree p = 0) eqp0 - and klep,lep = partition (fun (p,_) -> multidegree p = 0) lep0 - and kltp,ltp = partition (fun (p,_) -> multidegree p = 0) ltp0 in - let trivial_axiom (p,ax) = - match ax with - Axiom_eq n when eval undefined p <>/ num_0 -> el n eqs - | Axiom_le n when eval undefined p el n les - | Axiom_lt n when eval undefined p <=/ num_0 -> el n lts - | _ -> failwith "not a trivial axiom" in - try let th = tryfind trivial_axiom (keq @ klep @ kltp) in - CONV_RULE (LAND_CONV REAL_POLY_CONV THENC REAL_RAT_RED_CONV) th - with Failure _ -> - let pol = itlist poly_mul (map fst ltp) (poly_const num_1) in - let leq = lep @ ltp in - let tryall d = - let e = multidegree pol in - let k = if e = 0 then 0 else d / e in - let eq' = map fst eq in - tryfind (fun i -> d,i,real_positivnullstellensatz_general false d eq' leq - (poly_neg(poly_pow pol i))) - (0--k) in - let d,i,(cert_ideal,cert_cone) = deepen tryall 0 in - let proofs_ideal = - map2 (fun q (p,ax) -> Eqmul(term_of_poly q,ax)) cert_ideal eq - and proofs_cone = map term_of_sos cert_cone - and proof_ne = - if ltp = [] then Rational_lt num_1 else - let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in - funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in - let proof = end_itlist (fun s t -> Sum(s,t)) - (proof_ne :: proofs_ideal @ proofs_cone) in - print_string("Translating proof certificate to HOL"); - print_newline(); - translator (eqs,les,lts) proof;; -*) -(* ------------------------------------------------------------------------- *) -(* A wrapper that tries to substitute away variables first. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_NONLINEAR_SUBST_PROVER = - let zero = `&0:real` - and mul_tm = `( * ):real->real->real` - and shuffle1 = - CONV_RULE(REWR_CONV(REAL_ARITH `a + x = (y:real) <=> x = y - a`)) - and shuffle2 = - CONV_RULE(REWR_CONV(REAL_ARITH `x + a = (y:real) <=> x = y - a`)) in - let rec substitutable_monomial fvs tm = - match tm with - Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm - | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t)) - when is_ratconst c && not (mem t fvs) - -> rat_of_term c,t - | Comb(Comb(Const("real_add",_),s),t) -> - (try substitutable_monomial (union (frees t) fvs) s - with Failure _ -> substitutable_monomial (union (frees s) fvs) t) - | _ -> failwith "substitutable_monomial" - and isolate_variable v th = - match lhs(concl th) with - x when x = v -> th - | Comb(Comb(Const("real_add",_),(Var(_,Tyapp("real",[])) as x)),t) - when x = v -> shuffle2 th - | Comb(Comb(Const("real_add",_),s),t) -> - isolate_variable v(shuffle1 th) in - let make_substitution th = - let (c,v) = substitutable_monomial [] (lhs(concl th)) in - let th1 = AP_TERM (mk_comb(mul_tm,term_of_rat(Int 1 // c))) th in - let th2 = CONV_RULE(BINOP_CONV REAL_POLY_MUL_CONV) th1 in - CONV_RULE (RAND_CONV REAL_POLY_CONV) (isolate_variable v th2) in - fun translator -> - let rec substfirst(eqs,les,lts) = - try let eth = tryfind make_substitution eqs in - let modify = - CONV_RULE(LAND_CONV(SUBS_CONV[eth] THENC REAL_POLY_CONV)) in - substfirst(filter (fun t -> lhand(concl t) <> zero) (map modify eqs), - map modify les,map modify lts) - with Failure _ -> REAL_NONLINEAR_PROVER translator (eqs,les,lts) in - substfirst;; -*) -(* ------------------------------------------------------------------------- *) -(* Overall function. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_SOS = - let init = GEN_REWRITE_CONV ONCE_DEPTH_CONV [DECIMAL] - and pure = GEN_REAL_ARITH REAL_NONLINEAR_SUBST_PROVER in - fun tm -> let th = init tm in EQ_MP (SYM th) (pure(rand(concl th)));; -*) -(* ------------------------------------------------------------------------- *) -(* Add hacks for division. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_SOSFIELD = - let inv_tm = `inv:real->real` in - let prenex_conv = - TOP_DEPTH_CONV BETA_CONV THENC - PURE_REWRITE_CONV[FORALL_SIMP; EXISTS_SIMP; real_div; - REAL_INV_INV; REAL_INV_MUL; GSYM REAL_POW_INV] THENC - NNFC_CONV THENC DEPTH_BINOP_CONV `(/\)` CONDS_CELIM_CONV THENC - PRENEX_CONV - and setup_conv = NNF_CONV THENC WEAK_CNF_CONV THENC CONJ_CANON_CONV - and core_rule t = - try REAL_ARITH t - with Failure _ -> try REAL_RING t - with Failure _ -> REAL_SOS t - and is_inv = - let is_div = is_binop `(/):real->real->real` in - fun tm -> (is_div tm or (is_comb tm && rator tm = inv_tm)) && - not(is_ratconst(rand tm)) in - let BASIC_REAL_FIELD tm = - let is_freeinv t = is_inv t && free_in t tm in - let itms = setify(map rand (find_terms is_freeinv tm)) in - let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in - let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in - let itms' = map (curry mk_comb inv_tm) itms in - let gvs = map (genvar o type_of) itms' in - let tm'' = subst (zip gvs itms') tm' in - let th1 = setup_conv tm'' in - let cjs = conjuncts(rand(concl th1)) in - let ths = map core_rule cjs in - let th2 = EQ_MP (SYM th1) (end_itlist CONJ ths) in - rev_itlist (C MP) hyps (INST (zip itms' gvs) th2) in - fun tm -> - let th0 = prenex_conv tm in - let tm0 = rand(concl th0) in - let avs,bod = strip_forall tm0 in - let th1 = setup_conv bod in - let ths = map BASIC_REAL_FIELD (conjuncts(rand(concl th1))) in - EQ_MP (SYM th0) (GENL avs (EQ_MP (SYM th1) (end_itlist CONJ ths)));; -*) -(* ------------------------------------------------------------------------- *) -(* Integer version. *) -(* ------------------------------------------------------------------------- *) -(* -let INT_SOS = - let atom_CONV = - let pth = prove - (`(~(x <= y) <=> y + &1 <= x:int) /\ - (~(x < y) <=> y <= x) /\ - (~(x = y) <=> x + &1 <= y \/ y + &1 <= x) /\ - (x < y <=> x + &1 <= y)`, - REWRITE_TAC[INT_NOT_LE; INT_NOT_LT; INT_NOT_EQ; INT_LT_DISCRETE]) in - GEN_REWRITE_CONV I [pth] - and bub_CONV = GEN_REWRITE_CONV TOP_SWEEP_CONV - [int_eq; int_le; int_lt; int_ge; int_gt; - int_of_num_th; int_neg_th; int_add_th; int_mul_th; - int_sub_th; int_pow_th; int_abs_th; int_max_th; int_min_th] in - let base_CONV = TRY_CONV atom_CONV THENC bub_CONV in - let NNF_NORM_CONV = GEN_NNF_CONV false - (base_CONV,fun t -> base_CONV t,base_CONV(mk_neg t)) in - let init_CONV = - GEN_REWRITE_CONV DEPTH_CONV [FORALL_SIMP; EXISTS_SIMP] THENC - GEN_REWRITE_CONV DEPTH_CONV [INT_GT; INT_GE] THENC - CONDS_ELIM_CONV THENC NNF_NORM_CONV in - let p_tm = `p:bool` - and not_tm = `(~)` in - let pth = TAUT(mk_eq(mk_neg(mk_neg p_tm),p_tm)) in - fun tm -> - let th0 = INST [tm,p_tm] pth - and th1 = NNF_NORM_CONV(mk_neg tm) in - let th2 = REAL_SOS(mk_neg(rand(concl th1))) in - EQ_MP th0 (EQ_MP (AP_TERM not_tm (SYM th1)) th2);; -*) -(* ------------------------------------------------------------------------- *) -(* Natural number version. *) -(* ------------------------------------------------------------------------- *) -(* -let SOS_RULE tm = - let avs = frees tm in - let tm' = list_mk_forall(avs,tm) in - let th1 = NUM_TO_INT_CONV tm' in - let th2 = INT_SOS (rand(concl th1)) in - SPECL avs (EQ_MP (SYM th1) th2);; -*) -(* ------------------------------------------------------------------------- *) -(* Now pure SOS stuff. *) -(* ------------------------------------------------------------------------- *) - -(*prioritize_real();;*) - (* ------------------------------------------------------------------------- *) (* Some combinatorial helper functions. *) (* ------------------------------------------------------------------------- *) let rec allpermutations l = if l = [] then [[]] else - itlist (fun h acc -> List.map (fun t -> h::t) + List.fold_right (fun h acc -> List.map (fun t -> h::t) (allpermutations (subtract l [h])) @ acc) l [];; let changevariables_monomial zoln (m:monomial) = @@ -1165,14 +975,14 @@ let changevariables zoln pol = let sdpa_of_vector (v:vector) = let n = dim v in let strs = List.map (o (decimalize 20) (element v)) (1--n) in - end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; + String.concat " " strs ^ "\n";; let sdpa_of_matrix k (m:matrix) = let pfx = string_of_int k ^ " 1 " in let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in - itlist (fun ((i,j),c) a -> + List.fold_right (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; @@ -1184,7 +994,7 @@ let sdpa_of_problem comment obj mats = "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--List.length mats) mats "";; let run_csdp dbg obj mats = @@ -1224,9 +1034,9 @@ let sumofsquares_general_symmetry tool pol = let sym_eqs = let invariants = List.filter (fun vars' -> - is_undefined(poly_sub pol (changevariables (zip vars vars') pol))) + is_undefined(poly_sub pol (changevariables (List.combine vars vars') pol))) (allpermutations vars) in - let lpns = zip lpps (1--List.length lpps) in + let lpns = List.combine lpps (1--List.length lpps) in let lppcs = List.filter (fun (m,(n1,n2)) -> n1 <= n2) (allpairs @@ -1234,8 +1044,8 @@ let sumofsquares_general_symmetry tool pol = let clppcs = end_itlist (@) (List.map (fun ((m1,m2),(n1,n2)) -> List.map (fun vars' -> - (changevariables_monomial (zip vars vars') m1, - changevariables_monomial (zip vars vars') m2),(n1,n2)) + (changevariables_monomial (List.combine vars vars') m1, + changevariables_monomial (List.combine vars vars') m2),(n1,n2)) invariants) lppcs) in let clppcs_dom = setify(List.map fst clppcs) in @@ -1247,7 +1057,7 @@ let sumofsquares_general_symmetry tool pol = [] -> raise Sanity | [h] -> acc | h::t -> List.map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in - itlist mk_eq eqvcls [] in + List.fold_right mk_eq eqvcls [] in let eqs = foldl (fun a x y -> y::a) [] (itern 1 lpps (fun m1 n1 -> itern 1 lpps (fun m2 n2 f -> @@ -1259,7 +1069,7 @@ let sumofsquares_general_symmetry tool pol = undefined pol)) @ sym_eqs in let pvs,assig = eliminate_all_equations (0,0) eqs in - let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let allassig = List.fold_right (fun v -> (v |-> (v |=> Int 1))) pvs assig in let qvars = (0,0)::pvs in let diagents = end_itlist equation_add (List.map (fun i -> apply allassig (i,i)) (1--n)) in @@ -1281,18 +1091,18 @@ let sumofsquares_general_symmetry tool pol = else ()); let vec = nice_vector d raw_vec in let mat = iter (1,dim vec) - (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a) - (matrix_neg (el 0 mats)) in + (fun i a -> matrix_add (matrix_cmul (element vec i) (List.nth mats i)) a) + (matrix_neg (List.nth mats 0)) in deration(diag mat) in let rat,dia = if pvs = [] then - let mat = matrix_neg (el 0 mats) in + let mat = matrix_neg (List.nth mats 0) in deration(diag mat) else tryfind find_rounding (List.map Num.num_of_int (1--31) @ List.map pow2 (5--66)) in let poly_of_lin(d,v) = - d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in + d,foldl(fun a i c -> (List.nth lpps (i - 1) |-> c) a) undefined (snd v) in let lins = List.map poly_of_lin dia in let sqs = List.map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in let sos = poly_cmul rat (end_itlist poly_add sqs) in @@ -1300,325 +1110,3 @@ let sumofsquares_general_symmetry tool pol = let sumofsquares = sumofsquares_general_symmetry csdp;; -(* ------------------------------------------------------------------------- *) -(* Pure HOL SOS conversion. *) -(* ------------------------------------------------------------------------- *) -(* -let SOS_CONV = - let mk_square = - let pow_tm = `(pow)` and two_tm = `2` in - fun tm -> mk_comb(mk_comb(pow_tm,tm),two_tm) - and mk_prod = mk_binop `( * )` - and mk_sum = mk_binop `(+)` in - fun tm -> - let k,sos = sumofsquares(poly_of_term tm) in - let mk_sqtm(c,p) = - mk_prod (term_of_rat(k */ c)) (mk_square(term_of_poly p)) in - let tm' = end_itlist mk_sum (map mk_sqtm sos) in - let th = REAL_POLY_CONV tm and th' = REAL_POLY_CONV tm' in - TRANS th (SYM th');; -*) -(* ------------------------------------------------------------------------- *) -(* Attempt to prove &0 <= x by direct SOS decomposition. *) -(* ------------------------------------------------------------------------- *) -(* -let PURE_SOS_TAC = - let tac = - MATCH_ACCEPT_TAC(REWRITE_RULE[GSYM REAL_POW_2] REAL_LE_SQUARE) ORELSE - MATCH_ACCEPT_TAC REAL_LE_SQUARE ORELSE - (MATCH_MP_TAC REAL_LE_ADD THEN CONJ_TAC) ORELSE - (MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC) ORELSE - CONV_TAC(RAND_CONV REAL_RAT_REDUCE_CONV THENC REAL_RAT_LE_CONV) in - REPEAT GEN_TAC THEN REWRITE_TAC[real_ge] THEN - GEN_REWRITE_TAC I [GSYM REAL_SUB_LE] THEN - CONV_TAC(RAND_CONV SOS_CONV) THEN - REPEAT tac THEN NO_TAC;; - -let PURE_SOS tm = prove(tm,PURE_SOS_TAC);; -*) -(* ------------------------------------------------------------------------- *) -(* Examples. *) -(* ------------------------------------------------------------------------- *) - -(***** - -time REAL_SOS - `a1 >= &0 /\ a2 >= &0 /\ - (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + &2) /\ - (a1 * b1 + a2 * b2 = &0) - ==> a1 * a2 - b1 * b2 >= &0`;; - -time REAL_SOS `&3 * x + &7 * a < &4 /\ &3 < &2 * x ==> a < &0`;; - -time REAL_SOS - `b pow 2 < &4 * a * c ==> ~(a * x pow 2 + b * x + c = &0)`;; - -time REAL_SOS - `(a * x pow 2 + b * x + c = &0) ==> b pow 2 >= &4 * a * c`;; - -time REAL_SOS - `&0 <= x /\ x <= &1 /\ &0 <= y /\ y <= &1 - ==> x pow 2 + y pow 2 < &1 \/ - (x - &1) pow 2 + y pow 2 < &1 \/ - x pow 2 + (y - &1) pow 2 < &1 \/ - (x - &1) pow 2 + (y - &1) pow 2 < &1`;; - -time REAL_SOS - `&0 <= b /\ &0 <= c /\ &0 <= x /\ &0 <= y /\ - (x pow 2 = c) /\ (y pow 2 = a pow 2 * c + b) - ==> a * c <= y * x`;; - -time REAL_SOS - `&0 <= x /\ &0 <= y /\ &0 <= z /\ x + y + z <= &3 - ==> x * y + x * z + y * z >= &3 * x * y * z`;; - -time REAL_SOS - `(x pow 2 + y pow 2 + z pow 2 = &1) ==> (x + y + z) pow 2 <= &3`;; - -time REAL_SOS - `(w pow 2 + x pow 2 + y pow 2 + z pow 2 = &1) - ==> (w + x + y + z) pow 2 <= &4`;; - -time REAL_SOS - `x >= &1 /\ y >= &1 ==> x * y >= x + y - &1`;; - -time REAL_SOS - `x > &1 /\ y > &1 ==> x * y > x + y - &1`;; - -time REAL_SOS - `abs(x) <= &1 - ==> abs(&64 * x pow 7 - &112 * x pow 5 + &56 * x pow 3 - &7 * x) <= &1`;; - -time REAL_SOS - `abs(x - z) <= e /\ abs(y - z) <= e /\ &0 <= u /\ &0 <= v /\ (u + v = &1) - ==> abs((u * x + v * y) - z) <= e`;; - -(* ------------------------------------------------------------------------- *) -(* One component of denominator in dodecahedral example. *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&2 <= x /\ x <= &125841 / &50000 /\ - &2 <= y /\ y <= &125841 / &50000 /\ - &2 <= z /\ z <= &125841 / &50000 - ==> &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= &0`;; - -(* ------------------------------------------------------------------------- *) -(* Over a larger but simpler interval. *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 - ==> &0 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; - -(* ------------------------------------------------------------------------- *) -(* We can do 12. I think 12 is a sharp bound; see PP's certificate. *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 - ==> &12 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; - -(* ------------------------------------------------------------------------- *) -(* Gloptipoly example. *) -(* ------------------------------------------------------------------------- *) - -(*** This works but normalization takes minutes - -time REAL_SOS - `(x - y - &2 * x pow 4 = &0) /\ &0 <= x /\ x <= &2 /\ &0 <= y /\ y <= &3 - ==> y pow 2 - &7 * y - &12 * x + &17 >= &0`;; - - ***) - -(* ------------------------------------------------------------------------- *) -(* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&0 <= x /\ &0 <= y /\ (x * y = &1) - ==> x + y <= x pow 2 + y pow 2`;; - -time REAL_SOS - `&0 <= x /\ &0 <= y /\ (x * y = &1) - ==> x * y * (x + y) <= x pow 2 + y pow 2`;; - -time REAL_SOS - `&0 <= x /\ &0 <= y ==> x * y * (x + y) pow 2 <= (x pow 2 + y pow 2) pow 2`;; - -(* ------------------------------------------------------------------------- *) -(* Some examples over integers and natural numbers. *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE `!m n. 2 * m + n = (n + m) + m`;; -time SOS_RULE `!n. ~(n = 0) ==> (0 MOD n = 0)`;; -time SOS_RULE `!m n. m < n ==> (m DIV n = 0)`;; -time SOS_RULE `!n:num. n <= n * n`;; -time SOS_RULE `!m n. n * (m DIV n) <= m`;; -time SOS_RULE `!n. ~(n = 0) ==> (0 DIV n = 0)`;; -time SOS_RULE `!m n p. ~(p = 0) /\ m <= n ==> m DIV p <= n DIV p`;; -time SOS_RULE `!a b n. ~(a = 0) ==> (n <= b DIV a <=> a * n <= b)`;; - -(* ------------------------------------------------------------------------- *) -(* This is particularly gratifying --- cf hideous manual proof in arith.ml *) -(* ------------------------------------------------------------------------- *) - -(*** This doesn't now seem to work as well as it did; what changed? - -time SOS_RULE - `!a b c d. ~(b = 0) /\ b * c < (a + 1) * d ==> c DIV d <= a DIV b`;; - - ***) - -(* ------------------------------------------------------------------------- *) -(* Key lemma for injectivity of Cantor-type pairing functions. *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE - `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) - ==> (x1 + y1 = x2 + y2)`;; - -time SOS_RULE - `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) /\ - (x1 + y1 = x2 + y2) - ==> (x1 = x2) /\ (y1 = y2)`;; - -time SOS_RULE - `!x1 y1 x2 y2. - (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = - ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) - ==> (x1 + y1 = x2 + y2)`;; - -time SOS_RULE - `!x1 y1 x2 y2. - (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = - ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) /\ - (x1 + y1 = x2 + y2) - ==> (x1 = x2) /\ (y1 = y2)`;; - -(* ------------------------------------------------------------------------- *) -(* Reciprocal multiplication (actually just ARITH_RULE does these). *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE `x <= 127 ==> ((86 * x) DIV 256 = x DIV 3)`;; - -time SOS_RULE `x < 2 EXP 16 ==> ((104858 * x) DIV (2 EXP 20) = x DIV 10)`;; - -(* ------------------------------------------------------------------------- *) -(* This is more impressive since it's really nonlinear. See REMAINDER_DECODE *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE `0 < m /\ m < n ==> ((m * ((n * x) DIV m + 1)) DIV n = x)`;; - -(* ------------------------------------------------------------------------- *) -(* Some conversion examples. *) -(* ------------------------------------------------------------------------- *) - -time SOS_CONV - `&2 * x pow 4 + &2 * x pow 3 * y - x pow 2 * y pow 2 + &5 * y pow 4`;; - -time SOS_CONV - `x pow 4 - (&2 * y * z + &1) * x pow 2 + - (y pow 2 * z pow 2 + &2 * y * z + &2)`;; - -time SOS_CONV `&4 * x pow 4 + - &4 * x pow 3 * y - &7 * x pow 2 * y pow 2 - &2 * x * y pow 3 + - &10 * y pow 4`;; - -time SOS_CONV `&4 * x pow 4 * y pow 6 + x pow 2 - x * y pow 2 + y pow 2`;; - -time SOS_CONV - `&4096 * (x pow 4 + x pow 2 + z pow 6 - &3 * x pow 2 * z pow 2) + &729`;; - -time SOS_CONV - `&120 * x pow 2 - &63 * x pow 4 + &10 * x pow 6 + - &30 * x * y - &120 * y pow 2 + &120 * y pow 4 + &31`;; - -time SOS_CONV - `&9 * x pow 2 * y pow 4 + &9 * x pow 2 * z pow 4 + &36 * x pow 2 * y pow 3 + - &36 * x pow 2 * y pow 2 - &48 * x * y * z pow 2 + &4 * y pow 4 + - &4 * z pow 4 - &16 * y pow 3 + &16 * y pow 2`;; - -time SOS_CONV - `(x pow 2 + y pow 2 + z pow 2) * - (x pow 4 * y pow 2 + x pow 2 * y pow 4 + - z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2)`;; - -time SOS_CONV - `x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3`;; - -(*** I think this will work, but normalization is slow - -time SOS_CONV - `&100 * (x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z) + &212`;; - - ***) - -time SOS_CONV - `&100 * ((&2 * x - &2) pow 2 + (x pow 3 - &8 * x - &2) pow 2) - &588`;; - -time SOS_CONV - `x pow 2 * (&120 - &63 * x pow 2 + &10 * x pow 4) + &30 * x * y + - &30 * y pow 2 * (&4 * y pow 2 - &4) + &31`;; - -(* ------------------------------------------------------------------------- *) -(* Example of basic rule. *) -(* ------------------------------------------------------------------------- *) - -time PURE_SOS - `!x. x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3 - >= &1 / &7`;; - -time PURE_SOS - `&0 <= &98 * x pow 12 + - -- &980 * x pow 10 + - &3038 * x pow 8 + - -- &2968 * x pow 6 + - &1022 * x pow 4 + - -- &84 * x pow 2 + - &2`;; - -time PURE_SOS - `!x. &0 <= &2 * x pow 14 + - -- &84 * x pow 12 + - &1022 * x pow 10 + - -- &2968 * x pow 8 + - &3038 * x pow 6 + - -- &980 * x pow 4 + - &98 * x pow 2`;; - -(* ------------------------------------------------------------------------- *) -(* From Zeng et al, JSC vol 37 (2004), p83-99. *) -(* All of them work nicely with pure SOS_CONV, except (maybe) the one noted. *) -(* ------------------------------------------------------------------------- *) - -PURE_SOS - `x pow 6 + y pow 6 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2 >= &0`;; - -PURE_SOS `x pow 4 + y pow 4 + z pow 4 + &1 - &4*x*y*z >= &0`;; - -PURE_SOS `x pow 4 + &2*x pow 2*z + x pow 2 - &2*x*y*z + &2*y pow 2*z pow 2 + -&2*y*z pow 2 + &2*z pow 2 - &2*x + &2* y*z + &1 >= &0`;; - -(**** This is harder. Interestingly, this fails the pure SOS test, it seems. - Yet only on rounding(!?) Poor Newton polytope optimization or something? - But REAL_SOS does finally converge on the second run at level 12! - -REAL_SOS -`x pow 4*y pow 4 - &2*x pow 5*y pow 3*z pow 2 + x pow 6*y pow 2*z pow 4 + &2*x -pow 2*y pow 3*z - &4* x pow 3*y pow 2*z pow 3 + &2*x pow 4*y*z pow 5 + z pow -2*y pow 2 - &2*z pow 4*y*x + z pow 6*x pow 2 >= &0`;; - - ****) - -PURE_SOS -`x pow 4 + &4*x pow 2*y pow 2 + &2*x*y*z pow 2 + &2*x*y*w pow 2 + y pow 4 + z -pow 4 + w pow 4 + &2*z pow 2*w pow 2 + &2*x pow 2*w + &2*y pow 2*w + &2*x*y + -&3*w pow 2 + &2*z pow 2 + &1 >= &0`;; - -PURE_SOS -`w pow 6 + &2*z pow 2*w pow 3 + x pow 4 + y pow 4 + z pow 4 + &2*x pow 2*w + -&2*x pow 2*z + &3*x pow 2 + w pow 2 + &2*z*w + z pow 2 + &2*z + &2*w + &1 >= -&0`;; - -*****) diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index 6b8b820a..6aebc4ca 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -9,8 +9,6 @@ open Num -let debugging = ref false;; - (* ------------------------------------------------------------------------- *) (* Comparisons that are reflexive on NaN and also short-circuiting. *) (* ------------------------------------------------------------------------- *) @@ -21,7 +19,6 @@ let (=?) = fun x y -> cmp x y = 0;; let ( cmp x y < 0;; let (<=?) = fun x y -> cmp x y <= 0;; let (>?) = fun x y -> cmp x y > 0;; -let (>=?) = fun x y -> cmp x y >= 0;; (* ------------------------------------------------------------------------- *) (* Combinators. *) @@ -58,49 +55,30 @@ let lcm_num x y = else abs_num((x */ y) // gcd_num x y);; -(* ------------------------------------------------------------------------- *) -(* List basics. *) -(* ------------------------------------------------------------------------- *) - -let rec el n l = - if n = 0 then List.hd l else el (n - 1) (List.tl l);; - - (* ------------------------------------------------------------------------- *) (* Various versions of list iteration. *) (* ------------------------------------------------------------------------- *) -let rec itlist f l b = - match l with - [] -> b - | (h::t) -> f h (itlist f t b);; - let rec end_itlist f l = match l with [] -> failwith "end_itlist" | [x] -> x | (h::t) -> f h (end_itlist f t);; -let rec itlist2 f l1 l2 b = - match (l1,l2) with - ([],[]) -> b - | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b) - | _ -> failwith "itlist2";; - (* ------------------------------------------------------------------------- *) (* All pairs arising from applying a function over two lists. *) (* ------------------------------------------------------------------------- *) let rec allpairs f l1 l2 = match l1 with - h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) + h1::t1 -> List.fold_right (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) | [] -> [];; (* ------------------------------------------------------------------------- *) (* String operations (surely there is a better way...) *) (* ------------------------------------------------------------------------- *) -let implode l = itlist (^) l "";; +let implode l = List.fold_right (^) l "";; let explode s = let rec exap n l = @@ -109,13 +87,6 @@ let explode s = exap (String.length s - 1) [];; -(* ------------------------------------------------------------------------- *) -(* Attempting function or predicate applications. *) -(* ------------------------------------------------------------------------- *) - -let can f x = try (f x; true) with Failure _ -> false;; - - (* ------------------------------------------------------------------------- *) (* Repetition of a function. *) (* ------------------------------------------------------------------------- *) @@ -126,36 +97,20 @@ let rec funpow n f x = (* ------------------------------------------------------------------------- *) -(* Replication and sequences. *) +(* Sequences. *) (* ------------------------------------------------------------------------- *) -let rec replicate x n = - if n < 1 then [] - else x::(replicate x (n - 1));; - let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; (* ------------------------------------------------------------------------- *) (* Various useful list operations. *) (* ------------------------------------------------------------------------- *) -let rec forall p l = - match l with - [] -> true - | h::t -> p(h) && forall p t;; - let rec tryfind f l = match l with [] -> failwith "tryfind" | (h::t) -> try f h with Failure _ -> tryfind f t;; -let index x = - let rec ind n l = - match l with - [] -> failwith "index" - | (h::t) -> if x =? h then n else ind (n + 1) t in - ind 0;; - (* ------------------------------------------------------------------------- *) (* "Set" operations on lists. *) (* ------------------------------------------------------------------------- *) @@ -168,46 +123,16 @@ let rec mem x lis = let insert x l = if mem x l then l else x::l;; -let union l1 l2 = itlist insert l1 l2;; +let union l1 l2 = List.fold_right insert l1 l2;; let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1;; -(* ------------------------------------------------------------------------- *) -(* Merging and bottom-up mergesort. *) -(* ------------------------------------------------------------------------- *) - -let rec merge ord l1 l2 = - match l1 with - [] -> l2 - | h1::t1 -> match l2 with - [] -> l1 - | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) - else h2::(merge ord l1 t2);; - - (* ------------------------------------------------------------------------- *) (* Common measure predicates to use with "sort". *) (* ------------------------------------------------------------------------- *) let increasing f x y = f x ? f y;; - -(* ------------------------------------------------------------------------- *) -(* Zipping, unzipping etc. *) -(* ------------------------------------------------------------------------- *) - -let rec zip l1 l2 = - match (l1,l2) with - ([],[]) -> [] - | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) - | _ -> failwith "zip";; - -let rec unzip = - function [] -> [],[] - | ((a,b)::rest) -> let alist,blist = unzip rest in - (a::alist,b::blist);; - (* ------------------------------------------------------------------------- *) (* Iterating functions over lists. *) (* ------------------------------------------------------------------------- *) @@ -443,8 +368,6 @@ let apply f = applyd f (fun x -> failwith "apply");; let tryapplyd f a d = applyd f (fun x -> d) a;; -let defined f x = try apply f x; true with Failure _ -> false;; - (* ------------------------------------------------------------------------- *) (* Undefinition. *) (* ------------------------------------------------------------------------- *) @@ -490,8 +413,6 @@ let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; let dom f = setify(foldl (fun a x y -> x::a) [] f);; -let ran f = setify(foldl (fun a x y -> y::a) [] f);; - (* ------------------------------------------------------------------------- *) (* More parser basics. *) (* ------------------------------------------------------------------------- *) @@ -499,7 +420,7 @@ let ran f = setify(foldl (fun a x y -> y::a) [] f);; exception Noparse;; -let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = +let isspace,isnum = let charcode s = Char.code(String.get s 0) in let spaces = " \t\n\r" and separators = ",;" @@ -508,7 +429,7 @@ let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ" and nums = "0123456789" in let allchars = spaces^separators^brackets^symbs^alphas^nums in - let csetsize = itlist ((o) max charcode) (explode allchars) 256 in + let csetsize = List.fold_right ((o) max charcode) (explode allchars) 256 in let ctable = Array.make csetsize 0 in do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); @@ -517,13 +438,8 @@ let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); let isspace c = Array.get ctable (charcode c) = 1 - and issep c = Array.get ctable (charcode c) = 2 - and isbra c = Array.get ctable (charcode c) = 4 - and issymb c = Array.get ctable (charcode c) = 8 - and isalpha c = Array.get ctable (charcode c) = 16 - and isnum c = Array.get ctable (charcode c) = 32 - and isalnum c = Array.get ctable (charcode c) >= 16 in - isspace,issep,isbra,issymb,isalpha,isnum,isalnum;; + and isnum c = Array.get ctable (charcode c) = 32 in + isspace,isnum;; let parser_or parser1 parser2 input = try parser1 input @@ -566,9 +482,6 @@ let rec atleast n prs i = (if n <= 0 then many prs else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;; -let finished input = - if input = [] then 0,input else failwith "Unparsed input";; - (* ------------------------------------------------------------------------- *) let temp_path = Filename.get_temp_dir_name ();; @@ -589,7 +502,7 @@ let strings_of_file filename = (Pervasives.close_in fd; data);; let string_of_file filename = - end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);; + String.concat "\n" (strings_of_file filename);; let file_of_string filename s = let fd = Pervasives.open_out filename in diff --git a/plugins/micromega/sos_lib.mli b/plugins/micromega/sos_lib.mli new file mode 100644 index 00000000..8b53b815 --- /dev/null +++ b/plugins/micromega/sos_lib.mli @@ -0,0 +1,79 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* 'b) -> ('c -> 'a) -> 'c -> 'b + +val num_1 : Num.num +val pow10 : int -> Num.num +val pow2 : int -> Num.num + +val implode : string list -> string +val explode : string -> string list + +val funpow : int -> ('a -> 'a) -> 'a -> 'a +val tryfind : ('a -> 'b) -> 'a list -> 'b + +type ('a,'b) func = + | Empty + | Leaf of int * ('a*'b) list + | Branch of int * int * ('a,'b) func * ('a,'b) func + +val undefined : ('a, 'b) func +val is_undefined : ('a, 'b) func -> bool +val (|->) : 'a -> 'b -> ('a, 'b) func -> ('a, 'b) func +val (|=>) : 'a -> 'b -> ('a, 'b) func +val choose : ('a, 'b) func -> 'a * 'b +val combine : ('a -> 'a -> 'a) -> ('a -> bool) -> ('b, 'a) func -> ('b, 'a) func -> ('b, 'a) func +val (--) : int -> int -> int list + +val tryapplyd : ('a, 'b) func -> 'a -> 'b -> 'b +val apply : ('a, 'b) func -> 'a -> 'b + +val foldl : ('a -> 'b -> 'c -> 'a) -> 'a -> ('b, 'c) func -> 'a +val foldr : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) func -> 'c -> 'c +val mapf : ('a -> 'b) -> ('c, 'a) func -> ('c, 'b) func + +val undefine : 'a -> ('a, 'b) func -> ('a, 'b) func + +val dom : ('a, 'b) func -> 'a list +val graph : ('a, 'b) func -> ('a * 'b) list + +val union : 'a list -> 'a list -> 'a list +val subtract : 'a list -> 'a list -> 'a list +val sort : ('a -> 'a -> bool) -> 'a list -> 'a list +val setify : 'a list -> 'a list +val increasing : ('a -> 'b) -> 'a -> 'a -> bool +val allpairs : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + +val gcd_num : Num.num -> Num.num -> Num.num +val lcm_num : Num.num -> Num.num -> Num.num +val numerator : Num.num -> Num.num +val denominator : Num.num -> Num.num +val end_itlist : ('a -> 'a -> 'a) -> 'a list -> 'a + +val (>>) : ('a -> 'b * 'c) -> ('b -> 'd) -> 'a -> 'd * 'c +val (++) : ('a -> 'b * 'c) -> ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e + +val a : 'a -> 'a list -> 'a * 'a list +val many : ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val some : ('a -> bool) -> 'a list -> 'a * 'a list +val possibly : ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val isspace : string -> bool +val parser_or : ('a -> 'b) -> ('a -> 'b) -> 'a -> 'b +val isnum : string -> bool +val atleast : int -> ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val listof : ('a -> 'b * 'c) -> ('c -> 'd * 'a) -> string -> 'a -> 'b list * 'c + +val temp_path : string +val string_of_file : string -> string +val file_of_string : string -> string -> unit + +val deepen_until : int -> (int -> 'a) -> int -> 'a +exception TooDeep diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 deleted file mode 100644 index 4ac49adb..00000000 --- a/plugins/nsatz/g_nsatz.ml4 +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* [ Nsatz.nsatz_compute (EConstr.Unsafe.to_constr lt) ] -END diff --git a/plugins/nsatz/g_nsatz.mlg b/plugins/nsatz/g_nsatz.mlg new file mode 100644 index 00000000..16ff512e --- /dev/null +++ b/plugins/nsatz/g_nsatz.mlg @@ -0,0 +1,22 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* { Nsatz.nsatz_compute (EConstr.Unsafe.to_constr lt) } +END diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 81b44ffa..d2d4639d 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -136,7 +136,7 @@ let mul = function | (Const n,q) when eq_num n num_1 -> q | (p,q) -> Mul(p,q) -let gen_constant msg path s = Universes.constr_of_global @@ +let gen_constant msg path s = UnivGen.constr_of_global @@ coq_reference msg path s let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 59fd9b80..94a3d404 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -85,6 +85,7 @@ Ltac zify_binop t thm a b:= Ltac zify_op_1 := match goal with + | x := ?t : Z |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b @@ -114,6 +115,7 @@ Ltac hide_Z_of_nat t := Ltac zify_nat_rel := match goal with (* I: equalities *) + | x := ?t : nat |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *) | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H | |- context [ @eq nat ?a ?b ] => rewrite <- (Nat2Z.inj_iff a b) @@ -181,7 +183,7 @@ Ltac zify_nat_op := let t := eval compute in (Z.of_nat (S a)) in change (Z.of_nat (S a)) with t in H | _ => rewrite (Nat2Z.inj_succ a) in H - | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]), + | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), hide [Z.of_nat (S a)] in this one hypothesis *) change (Z.of_nat (S a)) with (Z_of_nat' (S a)) in H end @@ -192,7 +194,7 @@ Ltac zify_nat_op := let t := eval compute in (Z.of_nat (S a)) in change (Z.of_nat (S a)) with t | _ => rewrite (Nat2Z.inj_succ a) - | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]), + | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), hide [Z.of_nat (S a)] in the goal *) change (Z.of_nat (S a)) with (Z_of_nat' (S a)) end @@ -223,6 +225,7 @@ Ltac hide_Zpos t := Ltac zify_positive_rel := match goal with (* I: equalities *) + | x := ?t : positive |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- (@eq positive ?a ?b) => apply Pos2Z.inj | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H | |- context [ @eq positive ?a ?b ] => rewrite <- (Pos2Z.inj_iff a b) @@ -348,6 +351,7 @@ Ltac hide_Z_of_N t := Ltac zify_N_rel := match goal with (* I: equalities *) + | x := ?t : N |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *) | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H | |- context [ @eq N ?a ?b ] => rewrite <- (N2Z.inj_iff a b) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 51cd665f..e14c4e2e 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -18,8 +18,8 @@ open CErrors open Util open Names +open Constr open Nameops -open Term open EConstr open Tacticals.New open Tacmach.New @@ -29,7 +29,7 @@ open Libnames open Globnames open Nametab open Contradiction -open Misctypes +open Tactypes open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -38,15 +38,9 @@ open OmegaSolver (* Added by JCF, 09/03/98 *) -let elim_id id = - Proofview.Goal.enter begin fun gl -> - simplest_elim (mkVar id) - end -let resolve_id id = Proofview.Goal.enter begin fun gl -> - apply (mkVar id) -end +let elim_id id = simplest_elim (mkVar id) -let timing timer_name f arg = f arg +let resolve_id id = apply (mkVar id) let display_time_flag = ref false let display_system_flag = ref false @@ -206,7 +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 (Universes.constr_of_global @@ gen_reference_in_modules n m s) +let gen_constant_in_modules n m s = EConstr.of_constr (UnivGen.constr_of_global @@ gen_reference_in_modules n m s) let init_constant = gen_constant_in_modules "Omega" init_modules let constant = gen_constant_in_modules "Omega" coq_modules @@ -369,8 +363,11 @@ 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 EConstr.kind Evd.empty (Lazy.force c) with - | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> +let evaluable_ref_of_constr s c = + let env = Global.env () in + let evd = Evd.from_env env in + match EConstr.kind evd (Lazy.force c) with + | Const (kn,u) when Tacred.is_evaluable env (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant.")) diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 deleted file mode 100644 index 170b937c..00000000 --- a/plugins/omega/g_omega.ml4 +++ /dev/null @@ -1,56 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* eval_tactic "zify_nat" - | "positive" -> eval_tactic "zify_positive" - | "N" -> eval_tactic "zify_N" - | "Z" -> eval_tactic "zify_op" - | s -> CErrors.user_err Pp.(str ("No Omega knowledge base for type "^s))) - (Util.List.sort_uniquize String.compare l) - in - Tacticals.New.tclTHEN - (Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs)) - (omega_solver) - - -TACTIC EXTEND omega -| [ "omega" ] -> [ omega_tactic [] ] -END - -TACTIC EXTEND omega' -| [ "omega" "with" ne_ident_list(l) ] -> - [ omega_tactic (List.map Names.Id.to_string l) ] -| [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] -END - diff --git a/plugins/omega/g_omega.mlg b/plugins/omega/g_omega.mlg new file mode 100644 index 00000000..c3d063cf --- /dev/null +++ b/plugins/omega/g_omega.mlg @@ -0,0 +1,59 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* eval_tactic "zify_nat" + | "positive" -> eval_tactic "zify_positive" + | "N" -> eval_tactic "zify_N" + | "Z" -> eval_tactic "zify_op" + | s -> CErrors.user_err Pp.(str ("No Omega knowledge base for type "^s))) + (Util.List.sort_uniquize String.compare l) + in + Tacticals.New.tclTHEN + (Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs)) + (omega_solver) + +} + +TACTIC EXTEND omega +| [ "omega" ] -> { omega_tactic [] } +END + +TACTIC EXTEND omega' +| [ "omega" "with" ne_ident_list(l) ] -> + { omega_tactic (List.map Names.Id.to_string l) } +| [ "omega" "with" "*" ] -> { omega_tactic ["nat";"positive";"N";"Z"] } +END + diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index 2510c169..7bca7c70 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -178,7 +178,7 @@ let rec display_action print_var = function | DIVIDE_AND_APPROX (e1,e2,k,d) -> Printf.printf "Inequation E%d is divided by %s and the constant coefficient is \ - rounded by substracting %s.\n" e1.id (sbi k) (sbi d) + rounded by subtracting %s.\n" e1.id (sbi k) (sbi d) | NOT_EXACT_DIVIDE (e,k) -> Printf.printf "Constant in equation E%d is not divisible by the pgcd \ diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 deleted file mode 100644 index c35e0fe1..00000000 --- a/plugins/quote/g_quote.ml4 +++ /dev/null @@ -1,39 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* [ quote f [] ] -| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ] -| [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] -> - [ gen_quote (make_cont k) c f [] ] -| [ "quote" ident(f) "[" ne_ident_list(lc) "]" - "in" constr(c) "using" tactic(k) ] -> - [ gen_quote (make_cont k) c f lc ] -END diff --git a/plugins/quote/g_quote.mlg b/plugins/quote/g_quote.mlg new file mode 100644 index 00000000..749903c3 --- /dev/null +++ b/plugins/quote/g_quote.mlg @@ -0,0 +1,46 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* { quote f [] } +| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> { quote f lc } +| [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] -> + { gen_quote (make_cont k) c f [] } +| [ "quote" ident(f) "[" ne_ident_list(lc) "]" + "in" constr(c) "using" tactic(k) ] -> + { gen_quote (make_cont k) c f lc } +END diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 912429c3..7464b42d 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -120,7 +120,7 @@ open Proofview.Notations the constants are loaded in the environment *) let constant dir s = - EConstr.of_constr @@ Universes.constr_of_global @@ + EConstr.of_constr @@ UnivGen.constr_of_global @@ Coqlib.coq_reference "Quote" ("quote"::dir) s let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index ad3afafd..949cba2d 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -69,19 +69,19 @@ let z_module = [["Coq";"ZArith";"BinInt"]] let init_constant x = EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" Coqlib.init_modules x let constant x = EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" coq_modules x let z_constant x = EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" z_module x let bin_constant x = EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" bin_module x (* Logic *) @@ -170,7 +170,7 @@ let mk_list univ typ l = loop l let mk_plist = - let type1lev = Universes.new_univ_level () in + let type1lev = UnivGen.new_univ_level () in fun l -> mk_list type1lev EConstr.mkProp l let mk_list = mk_list Univ.Level.set diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 deleted file mode 100644 index 5b77d08d..00000000 --- a/plugins/romega/g_romega.ml4 +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - - -DECLARE PLUGIN "romega_plugin" - -open Ltac_plugin -open Names -open Refl_omega -open Stdarg - -let eval_tactic name = - let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in - let kn = KerName.make2 (ModPath.MPfile dp) (Label.make name) in - let tac = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic tac - -let romega_tactic unsafe l = - let tacs = List.map - (function - | "nat" -> eval_tactic "zify_nat" - | "positive" -> eval_tactic "zify_positive" - | "N" -> eval_tactic "zify_N" - | "Z" -> eval_tactic "zify_op" - | s -> CErrors.user_err Pp.(str ("No ROmega knowledge base for type "^s))) - (Util.List.sort_uniquize String.compare l) - in - Tacticals.New.tclTHEN - (Tacticals.New.tclREPEAT (Proofview.tclPROGRESS (Tacticals.New.tclTHENLIST tacs))) - (Tacticals.New.tclTHEN - (* because of the contradiction process in (r)omega, - we'd better leave as little as possible in the conclusion, - for an easier decidability argument. *) - (Tactics.intros) - (total_reflexive_omega_tactic unsafe)) - -TACTIC EXTEND romega -| [ "romega" ] -> [ romega_tactic false [] ] -| [ "unsafe_romega" ] -> [ romega_tactic true [] ] -END - -TACTIC EXTEND romega' -| [ "romega" "with" ne_ident_list(l) ] -> - [ romega_tactic false (List.map Names.Id.to_string l) ] -| [ "romega" "with" "*" ] -> [ romega_tactic false ["nat";"positive";"N";"Z"] ] -END diff --git a/plugins/romega/g_romega.mlg b/plugins/romega/g_romega.mlg new file mode 100644 index 00000000..ac4f30b1 --- /dev/null +++ b/plugins/romega/g_romega.mlg @@ -0,0 +1,63 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + + +DECLARE PLUGIN "romega_plugin" + +{ + +open Ltac_plugin +open Names +open Refl_omega +open Stdarg + +let eval_tactic name = + let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in + let kn = KerName.make2 (ModPath.MPfile dp) (Label.make name) in + let tac = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic tac + +let romega_tactic unsafe l = + let tacs = List.map + (function + | "nat" -> eval_tactic "zify_nat" + | "positive" -> eval_tactic "zify_positive" + | "N" -> eval_tactic "zify_N" + | "Z" -> eval_tactic "zify_op" + | s -> CErrors.user_err Pp.(str ("No ROmega knowledge base for type "^s))) + (Util.List.sort_uniquize String.compare l) + in + Tacticals.New.tclTHEN + (Tacticals.New.tclREPEAT (Proofview.tclPROGRESS (Tacticals.New.tclTHENLIST tacs))) + (Tacticals.New.tclTHEN + (* because of the contradiction process in (r)omega, + we'd better leave as little as possible in the conclusion, + for an easier decidability argument. *) + (Tactics.intros) + (total_reflexive_omega_tactic unsafe)) + +let romega_depr = + Vernacinterp.mk_deprecation + ~since:(Some "8.9") + ~note:(Some "Use lia instead.") + () + +} + +TACTIC EXTEND romega +DEPRECATED { romega_depr } +| [ "romega" ] -> { romega_tactic false [] } +| [ "unsafe_romega" ] -> { romega_tactic true [] } +END + +TACTIC EXTEND romega' +DEPRECATED { romega_depr } +| [ "romega" "with" ne_ident_list(l) ] -> + { romega_tactic false (List.map Names.Id.to_string l) } +| [ "romega" "with" "*" ] -> { romega_tactic false ["nat";"positive";"N";"Z"] } +END diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index d1824978..e6034806 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -8,6 +8,7 @@ open Pp open Util +open Constr open Const_omega module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -1036,13 +1037,13 @@ let resolution unsafe sigma env (reified_concl,reified_hyps) systems_list = let decompose_tactic = decompose_tree env context solution_tree in Tactics.generalize (l_generalize_arg @ l_reified_hypnames) >> - Tactics.convert_concl_no_check reified Term.DEFAULTcast >> + Tactics.convert_concl_no_check reified DEFAULTcast >> Tactics.apply (app coq_do_omega [|decompose_tactic|]) >> show_goal >> (if unsafe then (* Trust the produced term. Faster, but might fail later at Qed. Also handy when debugging, e.g. via a Show Proof after romega. *) - Tactics.convert_concl_no_check (Lazy.force coq_True) Term.VMcast + Tactics.convert_concl_no_check (Lazy.force coq_True) VMcast else Tactics.normalise_vm_in_concl) >> Tactics.apply (Lazy.force coq_I) diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4 deleted file mode 100644 index aa675763..00000000 --- a/plugins/rtauto/g_rtauto.ml4 +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* [ Proofview.V82.tactic (Refl_tauto.rtauto_tac) ] -END - diff --git a/plugins/rtauto/g_rtauto.mlg b/plugins/rtauto/g_rtauto.mlg new file mode 100644 index 00000000..9c9fdcfa --- /dev/null +++ b/plugins/rtauto/g_rtauto.mlg @@ -0,0 +1,22 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* { Proofview.V82.tactic (Refl_tauto.rtauto_tac) } +END + diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 946b6dff..8a0f48dc 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -26,27 +26,27 @@ let step_count = ref 0 let node_count = ref 0 -let logic_constant s = Universes.constr_of_global @@ +let logic_constant s = UnivGen.constr_of_global @@ Coqlib.coq_reference "refl_tauto" ["Init";"Logic"] s let li_False = lazy (destInd (logic_constant "False")) let li_and = lazy (destInd (logic_constant "and")) let li_or = lazy (destInd (logic_constant "or")) -let pos_constant s = Universes.constr_of_global @@ +let pos_constant s = UnivGen.constr_of_global @@ Coqlib.coq_reference "refl_tauto" ["Numbers";"BinNums"] s let l_xI = lazy (pos_constant "xI") let l_xO = lazy (pos_constant "xO") let l_xH = lazy (pos_constant "xH") -let store_constant s = Universes.constr_of_global @@ +let store_constant s = UnivGen.constr_of_global @@ Coqlib.coq_reference "refl_tauto" ["rtauto";"Bintree"] s let l_empty = lazy (store_constant "empty") let l_push = lazy (store_constant "push") -let constant s = Universes.constr_of_global @@ +let constant s = UnivGen.constr_of_global @@ Coqlib.coq_reference "refl_tauto" ["rtauto";"Rtauto"] s let l_Reflect = lazy (constant "Reflect") diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 5e4c9214..4ea0b30b 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -29,11 +29,6 @@ TACTIC EXTEND protect_fv [ protect_tac map ] END -TACTIC EXTEND closed_term - [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] -> - [ closed_term t l ] -END - open Pptactic open Ppconstr @@ -42,11 +37,11 @@ let pr_ring_mod = function | Ring_kind Abstract -> str "abstract" | Ring_kind (Morphism morph) -> str "morphism" ++ pr_arg pr_constr_expr morph | Const_tac (CstTac cst_tac) -> str "constants" ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]" - | Const_tac (Closed l) -> str "closed" ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]" + | Const_tac (Closed l) -> str "closed" ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid l ++ str "]" | Pre_tac t -> str "preprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]" | Post_tac t -> str "postprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]" | Setoid(sth,ext) -> str "setoid" ++ pr_arg pr_constr_expr sth ++ pr_arg pr_constr_expr ext - | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]" + | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid l ++ str "]" | Pow_spec(CstTac cst_tac,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]" | Sign_spec t -> str "sign" ++ pr_arg pr_constr_expr t | Div_spec t -> str "div" ++ pr_arg pr_constr_expr t diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 99bb8440..a736eec5 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -20,6 +20,7 @@ open Environ open Libnames open Globnames open Glob_term +open Locus open Tacexpr open Coqlib open Mod_subst @@ -29,7 +30,6 @@ open Printer open Declare open Decl_kinds open Entries -open Misctypes open Newring_ast open Proofview.Notations @@ -40,11 +40,7 @@ let error msg = CErrors.user_err Pp.(str msg) type protect_flag = Eval|Prot|Rec -let tag_arg tag_rec map subs i c = - match map i with - Eval -> mk_clos subs c - | Prot -> mk_atom c - | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c +type protection = Evd.evar_map -> EConstr.t -> GlobRef.t -> (Int.t -> protect_flag) option let global_head_of_constr sigma c = let f, args = decompose_app sigma c in @@ -55,32 +51,24 @@ let global_of_constr_nofail c = try global_of_constr 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 -> - (match Constr.kind t with - App(f,args) -> mk_clos_app_but f_map subs f args 0 - | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t - | _ -> mk_atom t) +let rec mk_clos_but f_map n t = + let (f, args) = Constr.decompose_appvect t in + match f_map (global_of_constr_nofail f) with + | Some tag -> + let map i t = tag_arg f_map n (tag i) t in + if Array.is_empty args then map (-1) f + else mk_red (FApp (map (-1) f, Array.mapi map args)) + | None -> mk_atom t -and mk_clos_app_but f_map subs f args n = - let open Constr in - if n >= Array.length args then mk_atom(mkApp(f, args)) - else - let fargs, args' = Array.chop n args in - let f' = mkApp(f,fargs) in - match f_map (global_of_constr_nofail f') with - | Some map -> - let f i t = tag_arg (mk_clos_but f_map subs) map subs i t in - mk_red (FApp (f (-1) f', Array.mapi f args')) - | None -> mk_atom (mkApp (f, args)) +and tag_arg f_map n tag c = match tag with +| Eval -> mk_clos (Esubst.subs_id n) c +| Prot -> mk_atom c +| Rec -> mk_clos_but f_map n c let interp_map l t = - try Some(List.assoc_f eq_gr t l) with Not_found -> None + try Some(List.assoc_f GlobRef.equal t l) with Not_found -> None -let protect_maps = ref String.Map.empty +let protect_maps : protection String.Map.t ref = ref String.Map.empty let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps @@ -90,8 +78,14 @@ let lookup_map map = 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) (create_tab ()) - (mk_clos_but (lookup_map map sigma c0) (Esubst.subs_id 0) c));; + let tab = create_tab () in + let infos = create_clos_infos ~evars all env in + let map = lookup_map map sigma c0 in + let rec eval n c = match Constr.kind c with + | Prod (na, t, u) -> Constr.mkProd (na, eval n t, eval (n + 1) u) + | _ -> kl infos tab (mk_clos_but map n c) + in + EConstr.of_constr (eval 0 c) let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None @@ -102,34 +96,36 @@ let protect_tac_in map id = (****************************************************************************) -let closed_term t l = - let open Quote_plugin in +let rec closed_under sigma cset t = + try + let (gr, _) = Termops.global_of_constr sigma t in + Refset_env.mem gr cset + with Not_found -> + 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 + +let closed_term args _ = match args with +| [t; l] -> + let t = Option.get (Value.to_constr t) in + let l = List.map (fun c -> Value.cast (Genarg.topwit Stdarg.wit_ref) c) (Option.get (Value.to_list l)) 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 sigma cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) - -(* TACTIC EXTEND echo -| [ "echo" constr(t) ] -> - [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] -END;;*) + let cs = List.fold_right Refset_env.add l Refset_env.empty in + if closed_under sigma cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) +| _ -> assert false -(* -let closed_term_ast l = - TacFun([Some(Id.of_string"t")], - TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term", - [Genarg.in_gen Constrarg.wit_constr (mkVar(Id.of_string"t")); - Genarg.in_gen (Genarg.wit_list Constrarg.wit_ref) l]))) -*) -let closed_term_ast l = +let closed_term_ast = let tacname = { mltac_plugin = "newring_plugin"; mltac_tactic = "closed_term"; } in + let () = Tacenv.register_ml_tactic tacname [|closed_term|] in let tacname = { mltac_name = tacname; mltac_index = 0; } in + fun l -> let l = List.map (fun gr -> ArgArg(Loc.tag gr)) l in TacFun([Name(Id.of_string"t")], TacML(Loc.tag (tacname, @@ -154,8 +150,7 @@ let ic_unsafe c = (*FIXME remove *) let decl_constant na univs c = let open Constr in - let env = Global.env () in - let vars = Univops.universes_of_constr env c in + let vars = Univops.universes_of_constr c in let univs = Univops.restrict_universe_context univs vars in let univs = Monomorphic_const_entry univs in mkConst(declare_constant (Id.of_string na) @@ -166,28 +161,13 @@ let decl_constant na univs c = let ltac_call tac (args:glob_tactic_arg list) = TacArg(Loc.tag @@ TacCall (Loc.tag (ArgArg(Loc.tag @@ Lazy.force tac),args))) -(* Calling a locally bound tactic *) -let ltac_lcall tac args = - TacArg(Loc.tag @@ TacCall (Loc.tag (ArgVar CAst.(make @@ Id.of_string tac),args))) - -let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = - let fold arg (i, vars, lfun) = - let id = Id.of_string ("x" ^ string_of_int i) in - let x = Reference (ArgVar CAst.(make id)) in - (succ i, x :: vars, Id.Map.add id arg lfun) - in - let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in - let lfun = Id.Map.add (Id.of_string "F") f lfun in - let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) - let dummy_goal env sigma = let (gl,_,sigma) = 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 -> EConstr.Unsafe.to_constr c +let constr_of evd v = match Value.to_constr v with + | Some c -> EConstr.to_constr evd c | None -> failwith "Ring.exec_tactic: anomaly" let tactic_res = ref [||] @@ -221,8 +201,8 @@ let exec_tactic env evd n f args = (** 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 - let nf c = nf (constr_of c) in + let evd = Evd.minimize_universes (Refiner.project gls) in + let nf c = constr_of evd c in Array.map nf !tactic_res, Evd.universe_context_set evd let stdlib_modules = @@ -233,7 +213,7 @@ let stdlib_modules = ] let coq_constant c = - lazy (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)) + lazy (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)) let coq_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) @@ -247,9 +227,10 @@ let coq_nil = coq_reference "nil" let lapp f args = mkApp(Lazy.force f,args) -let plapp evd f args = - let fc = Evarutil.e_new_global evd (Lazy.force f) in - mkApp(fc,args) +let plapp evdref f args = + let evd, fc = Evarutil.new_global !evdref (Lazy.force f) in + evdref := evd; + mkApp(fc,args) let dest_rel0 sigma t = match EConstr.kind sigma t with @@ -278,7 +259,7 @@ let plugin_modules = ] let my_constant c = - lazy (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" plugin_modules c)) + lazy (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" plugin_modules c)) let my_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) @@ -504,10 +485,12 @@ let ring_equality env evd (r,add,mul,opp,req) = let op_morph = match opp with Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] - | None -> plapp evd coq_eq_smorph [|r;add;mul|] in - let setoid = Typing.e_solve_evars env evd setoid in - let op_morph = Typing.e_solve_evars env evd op_morph in - (setoid,op_morph) + | None -> plapp evd coq_eq_smorph [|r;add;mul|] in + let sigma = !evd in + let sigma, setoid = Typing.solve_evars env sigma setoid in + let sigma, op_morph = Typing.solve_evars env sigma op_morph in + evd := sigma; + (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in @@ -586,48 +569,53 @@ let make_hyp env evd c = let t = Retyping.get_type_of env !evd c in plapp evd coq_mkhypo [|t;c|] -let make_hyp_list env evd lH = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let make_hyp_list env evdref lH = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; let l = List.fold_right - (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH - (plapp evd coq_nil [|carrier|]) + (fun c l -> plapp evdref coq_cons [|carrier; (make_hyp env evdref c); l|]) lH + (plapp evdref coq_nil [|carrier|]) in - let l' = Typing.e_solve_evars env evd l in + let sigma, l' = Typing.solve_evars env !evdref l in + evdref := sigma; let l' = EConstr.Unsafe.to_constr l' in - Evarutil.nf_evars_universes !evd l' + Evarutil.nf_evars_universes !evdref l' -let interp_power env evd pow = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let interp_power env evdref pow = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; match pow with | None -> let t = ArgArg(Loc.tag (Lazy.force ltac_inv_morph_nothing)) in - (TacArg(Loc.tag (TacCall(Loc.tag (t,[])))), plapp evd coq_None [|carrier|]) + (TacArg(Loc.tag (TacCall(Loc.tag (t,[])))), plapp evdref coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with | CstTac t -> Tacintern.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in - let spec = make_hyp env evd (ic_unsafe spec) in - (tac, plapp evd coq_Some [|carrier; spec|]) + let spec = make_hyp env evdref (ic_unsafe spec) in + (tac, plapp evdref coq_Some [|carrier; spec|]) -let interp_sign env evd sign = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let interp_sign env evdref sign = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; match sign with - | None -> plapp evd coq_None [|carrier|] + | None -> plapp evdref coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evd (ic_unsafe spec) in - plapp evd coq_Some [|carrier;spec|] + let spec = make_hyp env evdref (ic_unsafe spec) in + plapp evdref coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let interp_div env evd div = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let interp_div env evdref div = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; match div with - | None -> plapp evd coq_None [|carrier|] + | None -> plapp evdref coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evd (ic_unsafe spec) in - plapp evd coq_Some [|carrier;spec|] + let spec = make_hyp env evdref (ic_unsafe spec) in + plapp evdref coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div = @@ -728,7 +716,9 @@ let make_term_list env evd carrier rl = let l = List.fold_right (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl (plapp evd coq_nil [|carrier|]) - in Typing.e_solve_evars env evd l + in + let sigma, l = Typing.solve_evars env !evd l in + evd := sigma; l let carg c = Tacinterp.Value.of_constr (EConstr.of_constr c) let tacarg expr = @@ -760,7 +750,7 @@ let ring_lookup (f : Value.t) lH rl t = 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])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end @@ -917,7 +907,7 @@ let ftheory_to_obj : field_info -> obj = let field_equality evd r inv req = 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 = UnivGen.constr_of_global (Coqlib.build_coq_eq_data()).congr in let c = EConstr.of_constr c in mkApp(c,[|r;r;inv|]) | _ -> @@ -1046,6 +1036,6 @@ let field_lookup (f : Value.t) lH rl t = 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])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index 1d1557b1..fcd04a2e 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -11,7 +11,6 @@ open Names open EConstr open Libnames -open Globnames open Constrexpr open Newring_ast @@ -19,8 +18,6 @@ val protect_tac_in : string -> Id.t -> unit Proofview.tactic val protect_tac : string -> unit Proofview.tactic -val closed_term : EConstr.constr -> global_reference list -> unit Proofview.tactic - val add_theory : Id.t -> constr_expr -> diff --git a/plugins/setoid_ring/newring_ast.ml b/plugins/setoid_ring/newring_ast.ml index 3eb68b51..a83c79d1 100644 --- a/plugins/setoid_ring/newring_ast.ml +++ b/plugins/setoid_ring/newring_ast.ml @@ -22,7 +22,7 @@ type 'constr coeff_spec = type cst_tac_spec = CstTac of raw_tactic_expr - | Closed of reference list + | Closed of qualid list type 'constr ring_mod = Ring_kind of 'constr coeff_spec diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli index 3eb68b51..a83c79d1 100644 --- a/plugins/setoid_ring/newring_ast.mli +++ b/plugins/setoid_ring/newring_ast.mli @@ -22,7 +22,7 @@ type 'constr coeff_spec = type cst_tac_spec = CstTac of raw_tactic_expr - | Closed of reference list + | Closed of qualid list type 'constr ring_mod = Ring_kind of 'constr coeff_spec diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index 7f5f2f63..a786b995 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -37,7 +37,7 @@ type ssrmult = int * ssrmmod type ssrocc = (bool * int list) option (* index MAYBE REMOVE ONLY INTERNAL stuff between {} *) -type ssrindex = int Misctypes.or_var +type ssrindex = int Locus.or_var (* clear switch {H G} *) type ssrclear = ssrhyps @@ -84,11 +84,11 @@ type ssripat = | IPatId of (*TODO id_mod option * *) Id.t | IPatAnon of anon_iter (* inaccessible name *) (* TODO | IPatClearMark *) - | IPatDispatch of ssripatss (* /[..|..] *) + | IPatDispatch of bool (* ssr exception: accept a dispatch on the empty list even when there are subgoals *) * ssripatss (* (..|..) *) | IPatCase of (* ipats_mod option * *) ssripatss (* this is not equivalent to /case /[..|..] if there are already multiple goals *) | IPatInj of ssripatss | IPatRewrite of (*occurrence option * rewrite_pattern **) ssrocc * ssrdir - | IPatView of ssrview (* /view *) + | IPatView of bool * ssrview (* {}/view (true if the clear is present) *) | IPatClear of ssrclear (* {H1 H2} *) | IPatSimpl of ssrsimpl | IPatAbstractVars of Id.t list diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index 7d05b643..a618fc78 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -10,264 +10,266 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(** ## **) + Require Bool. Require Import ssreflect ssrfun. -(******************************************************************************) -(* A theory of boolean predicates and operators. A large part of this file is *) -(* concerned with boolean reflection. *) -(* Definitions and notations: *) -(* is_true b == the coercion of b : bool to Prop (:= b = true). *) -(* This is just input and displayed as `b''. *) -(* reflect P b == the reflection inductive predicate, asserting *) -(* that the logical proposition P : prop with the *) -(* formula b : bool. Lemmas asserting reflect P b *) -(* are often referred to as "views". *) -(* iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection *) -(* views: iffP is used to prove reflection from *) -(* logical equivalence, appP to compose views, and *) -(* sameP and rwP to perform boolean and setoid *) -(* rewriting. *) -(* elimT :: coercion reflect >-> Funclass, which allows the *) -(* direct application of `reflect' views to *) -(* boolean assertions. *) -(* decidable P <-> P is effectively decidable (:= {P} + {~ P}. *) -(* contra, contraL, ... :: contraposition lemmas. *) -(* altP my_viewP :: natural alternative for reflection; given *) -(* lemma myviewP: reflect my_Prop my_formula, *) -(* have [myP | not_myP] := altP my_viewP. *) -(* generates two subgoals, in which my_formula has *) -(* been replaced by true and false, resp., with *) -(* new assumptions myP : my_Prop and *) -(* not_myP: ~~ my_formula. *) -(* Caveat: my_formula must be an APPLICATION, not *) -(* a variable, constant, let-in, etc. (due to the *) -(* poor behaviour of dependent index matching). *) -(* boolP my_formula :: boolean disjunction, equivalent to *) -(* altP (idP my_formula) but circumventing the *) -(* dependent index capture issue; destructing *) -(* boolP my_formula generates two subgoals with *) -(* assumtions my_formula and ~~ myformula. As *) -(* with altP, my_formula must be an application. *) -(* \unless C, P <-> we can assume property P when a something that *) -(* holds under condition C (such as C itself). *) -(* := forall G : Prop, (C -> G) -> (P -> G) -> G. *) -(* This is just C \/ P or rather its impredicative *) -(* encoding, whose usage better fits the above *) -(* description: given a lemma UCP whose conclusion *) -(* is \unless C, P we can assume P by writing: *) -(* wlog hP: / P by apply/UCP; (prove C -> goal). *) -(* or even apply: UCP id _ => hP if the goal is C. *) -(* classically P <-> we can assume P when proving is_true b. *) -(* := forall b : bool, (P -> b) -> b. *) -(* This is equivalent to ~ (~ P) when P : Prop. *) -(* implies P Q == wrapper coinductive type that coerces to P -> Q *) -(* and can be used as a P -> Q view unambigously. *) -(* Useful to avoid spurious insertion of <-> views *) -(* when Q is a conjunction of foralls, as in Lemma *) -(* all_and2 below; conversely, avoids confusion in *) -(* apply views for impredicative properties, such *) -(* as \unless C, P. Also supports contrapositives. *) -(* a && b == the boolean conjunction of a and b. *) -(* a || b == the boolean disjunction of a and b. *) -(* a ==> b == the boolean implication of b by a. *) -(* ~~ a == the boolean negation of a. *) -(* a (+) b == the boolean exclusive or (or sum) of a and b. *) -(* [ /\ P1 , P2 & P3 ] == multiway logical conjunction, up to 5 terms. *) -(* [ \/ P1 , P2 | P3 ] == multiway logical disjunction, up to 4 terms. *) -(* [&& a, b, c & d] == iterated, right associative boolean conjunction *) -(* with arbitrary arity. *) -(* [|| a, b, c | d] == iterated, right associative boolean disjunction *) -(* with arbitrary arity. *) -(* [==> a, b, c => d] == iterated, right associative boolean implication *) -(* with arbitrary arity. *) -(* and3P, ... == specific reflection lemmas for iterated *) -(* connectives. *) -(* andTb, orbAC, ... == systematic names for boolean connective *) -(* properties (see suffix conventions below). *) -(* prop_congr == a tactic to move a boolean equality from *) -(* its coerced form in Prop to the equality *) -(* in bool. *) -(* bool_congr == resolution tactic for blindly weeding out *) -(* like terms from boolean equalities (can fail). *) -(* This file provides a theory of boolean predicates and relations: *) -(* pred T == the type of bool predicates (:= T -> bool). *) -(* simpl_pred T == the type of simplifying bool predicates, using *) -(* the simpl_fun from ssrfun.v. *) -(* rel T == the type of bool relations. *) -(* := T -> pred T or T -> T -> bool. *) -(* simpl_rel T == type of simplifying relations. *) -(* predType == the generic predicate interface, supported for *) -(* for lists and sets. *) -(* pred_class == a coercion class for the predType projection to *) -(* pred; declaring a coercion to pred_class is an *) -(* alternative way of equipping a type with a *) -(* predType structure, which interoperates better *) -(* with coercion subtyping. This is used, e.g., *) -(* for finite sets, so that finite groups inherit *) -(* the membership operation by coercing to sets. *) -(* If P is a predicate the proposition "x satisfies P" can be written *) -(* applicatively as (P x), or using an explicit connective as (x \in P); in *) -(* the latter case we say that P is a "collective" predicate. We use A, B *) -(* rather than P, Q for collective predicates: *) -(* x \in A == x satisfies the (collective) predicate A. *) -(* x \notin A == x doesn't satisfy the (collective) predicate A. *) -(* The pred T type can be used as a generic predicate type for either kind, *) -(* but the two kinds of predicates should not be confused. When a "generic" *) -(* pred T value of one type needs to be passed as the other the following *) -(* conversions should be used explicitly: *) -(* SimplPred P == a (simplifying) applicative equivalent of P. *) -(* mem A == an applicative equivalent of A: *) -(* mem A x simplifies to x \in A. *) -(* Alternatively one can use the syntax for explicit simplifying predicates *) -(* and relations (in the following x is bound in E): *) -(* [pred x | E] == simplifying (see ssrfun) predicate x => E. *) -(* [pred x : T | E] == predicate x => E, with a cast on the argument. *) -(* [pred : T | P] == constant predicate P on type T. *) -(* [pred x | E1 & E2] == [pred x | E1 && E2]; an x : T cast is allowed. *) -(* [pred x in A] == [pred x | x in A]. *) -(* [pred x in A | E] == [pred x | x in A & E]. *) -(* [pred x in A | E1 & E2] == [pred x in A | E1 && E2]. *) -(* [predU A & B] == union of two collective predicates A and B. *) -(* [predI A & B] == intersection of collective predicates A and B. *) -(* [predD A & B] == difference of collective predicates A and B. *) -(* [predC A] == complement of the collective predicate A. *) -(* [preim f of A] == preimage under f of the collective predicate A. *) -(* predU P Q, ... == union, etc of applicative predicates. *) -(* pred0 == the empty predicate. *) -(* predT == the total (always true) predicate. *) -(* if T : predArgType, then T coerces to predT. *) -(* {: T} == T cast to predArgType (e.g., {: bool * nat}) *) -(* In the following, x and y are bound in E: *) -(* [rel x y | E] == simplifying relation x, y => E. *) -(* [rel x y : T | E] == simplifying relation with arguments cast. *) -(* [rel x y in A & B | E] == [rel x y | [&& x \in A, y \in B & E]]. *) -(* [rel x y in A & B] == [rel x y | (x \in A) && (y \in B)]. *) -(* [rel x y in A | E] == [rel x y in A & A | E]. *) -(* [rel x y in A] == [rel x y in A & A]. *) -(* relU R S == union of relations R and S. *) -(* Explicit values of type pred T (i.e., lamdba terms) should always be used *) -(* applicatively, while values of collection types implementing the predType *) -(* interface, such as sequences or sets should always be used as collective *) -(* predicates. Defined constants and functions of type pred T or simpl_pred T *) -(* as well as the explicit simpl_pred T values described below, can generally *) -(* be used either way. Note however that x \in A will not auto-simplify when *) -(* A is an explicit simpl_pred T value; the generic simplification rule inE *) -(* must be used (when A : pred T, the unfold_in rule can be used). Constants *) -(* of type pred T with an explicit simpl_pred value do not auto-simplify when *) -(* used applicatively, but can still be expanded with inE. This behavior can *) -(* be controlled as follows: *) -(* Let A : collective_pred T := [pred x | ... ]. *) -(* The collective_pred T type is just an alias for pred T, but this cast *) -(* stops rewrite inE from expanding the definition of A, thus treating A *) -(* into an abstract collection (unfold_in or in_collective can be used to *) -(* expand manually). *) -(* Let A : applicative_pred T := [pred x | ...]. *) -(* This cast causes inE to turn x \in A into the applicative A x form; *) -(* A will then have to unfolded explicitly with the /A rule. This will *) -(* also apply to any definition that reduces to A (e.g., Let B := A). *) -(* Canonical A_app_pred := ApplicativePred A. *) -(* This declaration, given after definition of A, similarly causes inE to *) -(* turn x \in A into A x, but in addition allows the app_predE rule to *) -(* turn A x back into x \in A; it can be used for any definition of type *) -(* pred T, which makes it especially useful for ambivalent predicates *) -(* as the relational transitive closure connect, that are used in both *) -(* applicative and collective styles. *) -(* Purely for aesthetics, we provide a subtype of collective predicates: *) -(* qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T *) -(* coerces to pred_class and thus behaves as a collective *) -(* predicate, but x \in A and x \notin A are displayed as: *) -(* x \is A and x \isn't A when q = 0, *) -(* x \is a A and x \isn't a A when q = 1, *) -(* x \is an A and x \isn't an A when q = 2, respectively. *) -(* [qualify x | P] := Qualifier 0 (fun x => P), constructor for the above. *) -(* [qualify x : T | P], [qualify a x | P], [qualify an X | P], etc. *) -(* variants of the above with type constraints and different *) -(* values of q. *) -(* We provide an internal interface to support attaching properties (such as *) -(* being multiplicative) to predicates: *) -(* pred_key p == phantom type that will serve as a support for properties *) -(* to be attached to p : pred_class; instances should be *) -(* created with Fact/Qed so as to be opaque. *) -(* KeyedPred k_p == an instance of the interface structure that attaches *) -(* (k_p : pred_key P) to P; the structure projection is a *) -(* coercion to pred_class. *) -(* KeyedQualifier k_q == an instance of the interface structure that attaches *) -(* (k_q : pred_key q) to (q : qualifier n T). *) -(* DefaultPredKey p == a default value for pred_key p; the vernacular command *) -(* Import DefaultKeying attaches this key to all predicates *) -(* that are not explicitly keyed. *) -(* Keys can be used to attach properties to predicates, qualifiers and *) -(* generic nouns in a way that allows them to be used transparently. The key *) -(* projection of a predicate property structure such as unsignedPred should *) -(* be a pred_key, not a pred, and corresponding lemmas will have the form *) -(* Lemma rpredN R S (oppS : @opprPred R S) (kS : keyed_pred oppS) : *) -(* {mono -%R: x / x \in kS}. *) -(* Because x \in kS will be displayed as x \in S (or x \is S, etc), the *) -(* canonical instance of opprPred will not normally be exposed (it will also *) -(* be erased by /= simplification). In addition each predicate structure *) -(* should have a DefaultPredKey Canonical instance that simply issues the *) -(* property as a proof obligation (which can be caught by the Prop-irrelevant *) -(* feature of the ssreflect plugin). *) -(* Some properties of predicates and relations: *) -(* A =i B <-> A and B are extensionally equivalent. *) -(* {subset A <= B} <-> A is a (collective) subpredicate of B. *) -(* subpred P Q <-> P is an (applicative) subpredicate or Q. *) -(* subrel R S <-> R is a subrelation of S. *) -(* In the following R is in rel T: *) -(* reflexive R <-> R is reflexive. *) -(* irreflexive R <-> R is irreflexive. *) -(* symmetric R <-> R (in rel T) is symmetric (equation). *) -(* pre_symmetric R <-> R is symmetric (implication). *) -(* antisymmetric R <-> R is antisymmetric. *) -(* total R <-> R is total. *) -(* transitive R <-> R is transitive. *) -(* left_transitive R <-> R is a congruence on its left hand side. *) -(* right_transitive R <-> R is a congruence on its right hand side. *) -(* equivalence_rel R <-> R is an equivalence relation. *) -(* Localization of (Prop) predicates; if P1 is convertible to forall x, Qx, *) -(* P2 to forall x y, Qxy and P3 to forall x y z, Qxyz : *) -(* {for y, P1} <-> Qx{y / x}. *) -(* {in A, P1} <-> forall x, x \in A -> Qx. *) -(* {in A1 & A2, P2} <-> forall x y, x \in A1 -> y \in A2 -> Qxy. *) -(* {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. *) -(* {in A1 & A2 & A3, Q3} <-> forall x y z, *) -(* x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. *) -(* {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. *) -(* {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. *) -(* {in A &&, Q3} == {in A & A & A, Q3}. *) -(* {in A, bijective f} == f has a right inverse in A. *) -(* {on C, P1} == forall x, (f x) \in C -> Qx *) -(* when P1 is also convertible to Pf f. *) -(* {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy *) -(* when P2 is also convertible to Pf f. *) -(* {on C, P1' & g} == forall x, (f x) \in cd -> Qx *) -(* when P1' is convertible to Pf f *) -(* and P1' g is convertible to forall x, Qx. *) -(* {on C, bijective f} == f has a right inverse on C. *) -(* This file extends the lemma name suffix conventions of ssrfun as follows: *) -(* A -- associativity, as in andbA : associative andb. *) -(* AC -- right commutativity. *) -(* ACA -- self-interchange (inner commutativity), e.g., *) -(* orbACA : (a || b) || (c || d) = (a || c) || (b || d). *) -(* b -- a boolean argument, as in andbb : idempotent andb. *) -(* C -- commutativity, as in andbC : commutative andb, *) -(* or predicate complement, as in predC. *) -(* CA -- left commutativity. *) -(* D -- predicate difference, as in predD. *) -(* E -- elimination, as in negbFE : ~~ b = false -> b. *) -(* F or f -- boolean false, as in andbF : b && false = false. *) -(* I -- left/right injectivity, as in addbI : right_injective addb, *) -(* or predicate intersection, as in predI. *) -(* l -- a left-hand operation, as andb_orl : left_distributive andb orb. *) -(* N or n -- boolean negation, as in andbN : a && (~~ a) = false. *) -(* P -- a characteristic property, often a reflection lemma, as in *) -(* andP : reflect (a /\ b) (a && b). *) -(* r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. *) -(* T or t -- boolean truth, as in andbT: right_id true andb. *) -(* U -- predicate union, as in predU. *) -(* W -- weakening, as in in1W : {in D, forall x, P} -> forall x, P. *) -(******************************************************************************) +(** + A theory of boolean predicates and operators. A large part of this file is + concerned with boolean reflection. + Definitions and notations: + is_true b == the coercion of b : bool to Prop (:= b = true). + This is just input and displayed as `b''. + reflect P b == the reflection inductive predicate, asserting + that the logical proposition P : prop with the + formula b : bool. Lemmas asserting reflect P b + are often referred to as "views". + iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection + views: iffP is used to prove reflection from + logical equivalence, appP to compose views, and + sameP and rwP to perform boolean and setoid + rewriting. + elimT :: coercion reflect >-> Funclass, which allows the + direct application of `reflect' views to + boolean assertions. + decidable P <-> P is effectively decidable (:= {P} + {~ P}. + contra, contraL, ... :: contraposition lemmas. + altP my_viewP :: natural alternative for reflection; given + lemma myviewP: reflect my_Prop my_formula, + have #[#myP | not_myP#]# := altP my_viewP. + generates two subgoals, in which my_formula has + been replaced by true and false, resp., with + new assumptions myP : my_Prop and + not_myP: ~~ my_formula. + Caveat: my_formula must be an APPLICATION, not + a variable, constant, let-in, etc. (due to the + poor behaviour of dependent index matching). + boolP my_formula :: boolean disjunction, equivalent to + altP (idP my_formula) but circumventing the + dependent index capture issue; destructing + boolP my_formula generates two subgoals with + assumtions my_formula and ~~ myformula. As + with altP, my_formula must be an application. + \unless C, P <-> we can assume property P when a something that + holds under condition C (such as C itself). + := forall G : Prop, (C -> G) -> (P -> G) -> G. + This is just C \/ P or rather its impredicative + encoding, whose usage better fits the above + description: given a lemma UCP whose conclusion + is \unless C, P we can assume P by writing: + wlog hP: / P by apply/UCP; (prove C -> goal). + or even apply: UCP id _ => hP if the goal is C. + classically P <-> we can assume P when proving is_true b. + := forall b : bool, (P -> b) -> b. + This is equivalent to ~ (~ P) when P : Prop. + implies P Q == wrapper variant type that coerces to P -> Q and + can be used as a P -> Q view unambigously. + Useful to avoid spurious insertion of <-> views + when Q is a conjunction of foralls, as in Lemma + all_and2 below; conversely, avoids confusion in + apply views for impredicative properties, such + as \unless C, P. Also supports contrapositives. + a && b == the boolean conjunction of a and b. + a || b == the boolean disjunction of a and b. + a ==> b == the boolean implication of b by a. + ~~ a == the boolean negation of a. + a (+) b == the boolean exclusive or (or sum) of a and b. + #[# /\ P1 , P2 & P3 #]# == multiway logical conjunction, up to 5 terms. + #[# \/ P1 , P2 | P3 #]# == multiway logical disjunction, up to 4 terms. + #[#&& a, b, c & d#]# == iterated, right associative boolean conjunction + with arbitrary arity. + #[#|| a, b, c | d#]# == iterated, right associative boolean disjunction + with arbitrary arity. + #[#==> a, b, c => d#]# == iterated, right associative boolean implication + with arbitrary arity. + and3P, ... == specific reflection lemmas for iterated + connectives. + andTb, orbAC, ... == systematic names for boolean connective + properties (see suffix conventions below). + prop_congr == a tactic to move a boolean equality from + its coerced form in Prop to the equality + in bool. + bool_congr == resolution tactic for blindly weeding out + like terms from boolean equalities (can fail). + This file provides a theory of boolean predicates and relations: + pred T == the type of bool predicates (:= T -> bool). + simpl_pred T == the type of simplifying bool predicates, using + the simpl_fun from ssrfun.v. + rel T == the type of bool relations. + := T -> pred T or T -> T -> bool. + simpl_rel T == type of simplifying relations. + predType == the generic predicate interface, supported for + for lists and sets. + pred_class == a coercion class for the predType projection to + pred; declaring a coercion to pred_class is an + alternative way of equipping a type with a + predType structure, which interoperates better + with coercion subtyping. This is used, e.g., + for finite sets, so that finite groups inherit + the membership operation by coercing to sets. + If P is a predicate the proposition "x satisfies P" can be written + applicatively as (P x), or using an explicit connective as (x \in P); in + the latter case we say that P is a "collective" predicate. We use A, B + rather than P, Q for collective predicates: + x \in A == x satisfies the (collective) predicate A. + x \notin A == x doesn't satisfy the (collective) predicate A. + The pred T type can be used as a generic predicate type for either kind, + but the two kinds of predicates should not be confused. When a "generic" + pred T value of one type needs to be passed as the other the following + conversions should be used explicitly: + SimplPred P == a (simplifying) applicative equivalent of P. + mem A == an applicative equivalent of A: + mem A x simplifies to x \in A. + Alternatively one can use the syntax for explicit simplifying predicates + and relations (in the following x is bound in E): + #[#pred x | E#]# == simplifying (see ssrfun) predicate x => E. + #[#pred x : T | E#]# == predicate x => E, with a cast on the argument. + #[#pred : T | P#]# == constant predicate P on type T. + #[#pred x | E1 & E2#]# == #[#pred x | E1 && E2#]#; an x : T cast is allowed. + #[#pred x in A#]# == #[#pred x | x in A#]#. + #[#pred x in A | E#]# == #[#pred x | x in A & E#]#. + #[#pred x in A | E1 & E2#]# == #[#pred x in A | E1 && E2#]#. + #[#predU A & B#]# == union of two collective predicates A and B. + #[#predI A & B#]# == intersection of collective predicates A and B. + #[#predD A & B#]# == difference of collective predicates A and B. + #[#predC A#]# == complement of the collective predicate A. + #[#preim f of A#]# == preimage under f of the collective predicate A. + predU P Q, ... == union, etc of applicative predicates. + pred0 == the empty predicate. + predT == the total (always true) predicate. + if T : predArgType, then T coerces to predT. + {: T} == T cast to predArgType (e.g., {: bool * nat}) + In the following, x and y are bound in E: + #[#rel x y | E#]# == simplifying relation x, y => E. + #[#rel x y : T | E#]# == simplifying relation with arguments cast. + #[#rel x y in A & B | E#]# == #[#rel x y | #[#&& x \in A, y \in B & E#]# #]#. + #[#rel x y in A & B#]# == #[#rel x y | (x \in A) && (y \in B) #]#. + #[#rel x y in A | E#]# == #[#rel x y in A & A | E#]#. + #[#rel x y in A#]# == #[#rel x y in A & A#]#. + relU R S == union of relations R and S. + Explicit values of type pred T (i.e., lamdba terms) should always be used + applicatively, while values of collection types implementing the predType + interface, such as sequences or sets should always be used as collective + predicates. Defined constants and functions of type pred T or simpl_pred T + as well as the explicit simpl_pred T values described below, can generally + be used either way. Note however that x \in A will not auto-simplify when + A is an explicit simpl_pred T value; the generic simplification rule inE + must be used (when A : pred T, the unfold_in rule can be used). Constants + of type pred T with an explicit simpl_pred value do not auto-simplify when + used applicatively, but can still be expanded with inE. This behavior can + be controlled as follows: + Let A : collective_pred T := #[#pred x | ... #]#. + The collective_pred T type is just an alias for pred T, but this cast + stops rewrite inE from expanding the definition of A, thus treating A + into an abstract collection (unfold_in or in_collective can be used to + expand manually). + Let A : applicative_pred T := #[#pred x | ... #]#. + This cast causes inE to turn x \in A into the applicative A x form; + A will then have to unfolded explicitly with the /A rule. This will + also apply to any definition that reduces to A (e.g., Let B := A). + Canonical A_app_pred := ApplicativePred A. + This declaration, given after definition of A, similarly causes inE to + turn x \in A into A x, but in addition allows the app_predE rule to + turn A x back into x \in A; it can be used for any definition of type + pred T, which makes it especially useful for ambivalent predicates + as the relational transitive closure connect, that are used in both + applicative and collective styles. + Purely for aesthetics, we provide a subtype of collective predicates: + qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T + coerces to pred_class and thus behaves as a collective + predicate, but x \in A and x \notin A are displayed as: + x \is A and x \isn't A when q = 0, + x \is a A and x \isn't a A when q = 1, + x \is an A and x \isn't an A when q = 2, respectively. + #[#qualify x | P#]# := Qualifier 0 (fun x => P), constructor for the above. + #[#qualify x : T | P#]#, #[#qualify a x | P#]#, #[#qualify an X | P#]#, etc. + variants of the above with type constraints and different + values of q. + We provide an internal interface to support attaching properties (such as + being multiplicative) to predicates: + pred_key p == phantom type that will serve as a support for properties + to be attached to p : pred_class; instances should be + created with Fact/Qed so as to be opaque. + KeyedPred k_p == an instance of the interface structure that attaches + (k_p : pred_key P) to P; the structure projection is a + coercion to pred_class. + KeyedQualifier k_q == an instance of the interface structure that attaches + (k_q : pred_key q) to (q : qualifier n T). + DefaultPredKey p == a default value for pred_key p; the vernacular command + Import DefaultKeying attaches this key to all predicates + that are not explicitly keyed. + Keys can be used to attach properties to predicates, qualifiers and + generic nouns in a way that allows them to be used transparently. The key + projection of a predicate property structure such as unsignedPred should + be a pred_key, not a pred, and corresponding lemmas will have the form + Lemma rpredN R S (oppS : @opprPred R S) (kS : keyed_pred oppS) : + {mono -%%R: x / x \in kS}. + Because x \in kS will be displayed as x \in S (or x \is S, etc), the + canonical instance of opprPred will not normally be exposed (it will also + be erased by /= simplification). In addition each predicate structure + should have a DefaultPredKey Canonical instance that simply issues the + property as a proof obligation (which can be caught by the Prop-irrelevant + feature of the ssreflect plugin). + Some properties of predicates and relations: + A =i B <-> A and B are extensionally equivalent. + {subset A <= B} <-> A is a (collective) subpredicate of B. + subpred P Q <-> P is an (applicative) subpredicate or Q. + subrel R S <-> R is a subrelation of S. + In the following R is in rel T: + reflexive R <-> R is reflexive. + irreflexive R <-> R is irreflexive. + symmetric R <-> R (in rel T) is symmetric (equation). + pre_symmetric R <-> R is symmetric (implication). + antisymmetric R <-> R is antisymmetric. + total R <-> R is total. + transitive R <-> R is transitive. + left_transitive R <-> R is a congruence on its left hand side. + right_transitive R <-> R is a congruence on its right hand side. + equivalence_rel R <-> R is an equivalence relation. + Localization of (Prop) predicates; if P1 is convertible to forall x, Qx, + P2 to forall x y, Qxy and P3 to forall x y z, Qxyz : + {for y, P1} <-> Qx{y / x}. + {in A, P1} <-> forall x, x \in A -> Qx. + {in A1 & A2, P2} <-> forall x y, x \in A1 -> y \in A2 -> Qxy. + {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. + {in A1 & A2 & A3, Q3} <-> forall x y z, + x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. + {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. + {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. + {in A &&, Q3} == {in A & A & A, Q3}. + {in A, bijective f} == f has a right inverse in A. + {on C, P1} == forall x, (f x) \in C -> Qx + when P1 is also convertible to Pf f. + {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy + when P2 is also convertible to Pf f. + {on C, P1' & g} == forall x, (f x) \in cd -> Qx + when P1' is convertible to Pf f + and P1' g is convertible to forall x, Qx. + {on C, bijective f} == f has a right inverse on C. + This file extends the lemma name suffix conventions of ssrfun as follows: + A -- associativity, as in andbA : associative andb. + AC -- right commutativity. + ACA -- self-interchange (inner commutativity), e.g., + orbACA : (a || b) || (c || d) = (a || c) || (b || d). + b -- a boolean argument, as in andbb : idempotent andb. + C -- commutativity, as in andbC : commutative andb, + or predicate complement, as in predC. + CA -- left commutativity. + D -- predicate difference, as in predD. + E -- elimination, as in negbFE : ~~ b = false -> b. + F or f -- boolean false, as in andbF : b && false = false. + I -- left/right injectivity, as in addbI : right_injective addb, + or predicate intersection, as in predI. + l -- a left-hand operation, as andb_orl : left_distributive andb orb. + N or n -- boolean negation, as in andbN : a && (~~ a) = false. + P -- a characteristic property, often a reflection lemma, as in + andP : reflect (a /\ b) (a && b). + r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. + T or t -- boolean truth, as in andbT: right_id true andb. + U -- predicate union, as in predU. + W -- weakening, as in in1W : {in D, forall x, P} -> forall x, P. **) + Set Implicit Arguments. Unset Strict Implicit. @@ -288,23 +290,24 @@ Reserved Notation "x \notin A" Reserved Notation "p1 =i p2" (at level 70, format "'[hv' p1 '/ ' =i p2 ']'", no associativity). -(* We introduce a number of n-ary "list-style" notations that share a common *) -(* format, namely *) -(* [op arg1, arg2, ... last_separator last_arg] *) -(* This usually denotes a right-associative applications of op, e.g., *) -(* [&& a, b, c & d] denotes a && (b && (c && d)) *) -(* The last_separator must be a non-operator token. Here we use &, | or =>; *) -(* our default is &, but we try to match the intended meaning of op. The *) -(* separator is a workaround for limitations of the parsing engine; the same *) -(* limitations mean the separator cannot be omitted even when last_arg can. *) -(* The Notation declarations are complicated by the separate treatment for *) -(* some fixed arities (binary for bool operators, and all arities for Prop *) -(* operators). *) -(* We also use the square brackets in comprehension-style notations *) -(* [type var separator expr] *) -(* where "type" is the type of the comprehension (e.g., pred) and "separator" *) -(* is | or => . It is important that in other notations a leading square *) -(* bracket [ is always followed by an operator symbol or a fixed identifier. *) +(** + We introduce a number of n-ary "list-style" notations that share a common + format, namely + #[#op arg1, arg2, ... last_separator last_arg#]# + This usually denotes a right-associative applications of op, e.g., + #[#&& a, b, c & d#]# denotes a && (b && (c && d)) + The last_separator must be a non-operator token. Here we use &, | or =>; + our default is &, but we try to match the intended meaning of op. The + separator is a workaround for limitations of the parsing engine; the same + limitations mean the separator cannot be omitted even when last_arg can. + The Notation declarations are complicated by the separate treatment for + some fixed arities (binary for bool operators, and all arities for Prop + operators). + We also use the square brackets in comprehension-style notations + #[#type var separator expr#]# + where "type" is the type of the comprehension (e.g., pred) and "separator" + is | or => . It is important that in other notations a leading square + bracket #[# is always followed by an operator symbol or a fixed identifier. **) Reserved Notation "[ /\ P1 & P2 ]" (at level 0, only parsing). Reserved Notation "[ /\ P1 , P2 & P3 ]" (at level 0, format @@ -344,19 +347,19 @@ Reserved Notation "[ 'rel' x y => E ]" (at level 0, x, y at level 8, format Reserved Notation "[ 'rel' x y : T => E ]" (at level 0, x, y at level 8, format "'[hv' [ 'rel' x y : T => '/ ' E ] ']'"). -(* Shorter delimiter *) +(** Shorter delimiter **) Delimit Scope bool_scope with B. Open Scope bool_scope. -(* An alternative to xorb that behaves somewhat better wrt simplification. *) +(** An alternative to xorb that behaves somewhat better wrt simplification. **) Definition addb b := if b then negb else id. -(* Notation for && and || is declared in Init.Datatypes. *) +(** Notation for && and || is declared in Init.Datatypes. **) Notation "~~ b" := (negb b) : bool_scope. Notation "b ==> c" := (implb b c) : bool_scope. Notation "b1 (+) b2" := (addb b1 b2) : bool_scope. -(* Constant is_true b := b = true is defined in Init.Datatypes. *) +(** Constant is_true b := b = true is defined in Init.Datatypes. **) Coercion is_true : bool >-> Sortclass. (* Prop *) Lemma prop_congr : forall b b' : bool, b = b' -> b = b' :> Prop. @@ -364,21 +367,22 @@ Proof. by move=> b b' ->. Qed. Ltac prop_congr := apply: prop_congr. -(* Lemmas for trivial. *) +(** Lemmas for trivial. **) Lemma is_true_true : true. Proof. by []. Qed. Lemma not_false_is_true : ~ false. Proof. by []. Qed. Lemma is_true_locked_true : locked true. Proof. by unlock. Qed. Hint Resolve is_true_true not_false_is_true is_true_locked_true. -(* Shorter names. *) +(** Shorter names. **) Definition isT := is_true_true. Definition notF := not_false_is_true. -(* Negation lemmas. *) +(** Negation lemmas. **) -(* We generally take NEGATION as the standard form of a false condition: *) -(* negative boolean hypotheses should be of the form ~~ b, rather than ~ b or *) -(* b = false, as much as possible. *) +(** + We generally take NEGATION as the standard form of a false condition: + negative boolean hypotheses should be of the form ~~ b, rather than ~ b or + b = false, as much as possible. **) Lemma negbT b : b = false -> ~~ b. Proof. by case: b. Qed. Lemma negbTE b : ~~ b -> b = false. Proof. by case: b. Qed. @@ -426,8 +430,9 @@ Proof. by move/contra=> notb_notc /notb_notc/negbTE. Qed. Lemma contraFF (c b : bool) : (c -> b) -> b = false -> c = false. Proof. by move/contraFN=> bF_notc /bF_notc/negbTE. Qed. -(* Coercion of sum-style datatypes into bool, which makes it possible *) -(* to use ssr's boolean if rather than Coq's "generic" if. *) +(** + Coercion of sum-style datatypes into bool, which makes it possible + to use ssr's boolean if rather than Coq's "generic" if. **) Coercion isSome T (u : option T) := if u is Some _ then true else false. @@ -441,22 +446,23 @@ Prenex Implicits isSome is_inl is_left is_inleft. Definition decidable P := {P} + {~ P}. -(* Lemmas for ifs with large conditions, which allow reasoning about the *) -(* condition without repeating it inside the proof (the latter IS *) -(* preferable when the condition is short). *) -(* Usage : *) -(* if the goal contains (if cond then ...) = ... *) -(* case: ifP => Hcond. *) -(* generates two subgoal, with the assumption Hcond : cond = true/false *) -(* Rewrite if_same eliminates redundant ifs *) -(* Rewrite (fun_if f) moves a function f inside an if *) -(* Rewrite if_arg moves an argument inside a function-valued if *) +(** + Lemmas for ifs with large conditions, which allow reasoning about the + condition without repeating it inside the proof (the latter IS + preferable when the condition is short). + Usage : + if the goal contains (if cond then ...) = ... + case: ifP => Hcond. + generates two subgoal, with the assumption Hcond : cond = true/false + Rewrite if_same eliminates redundant ifs + Rewrite (fun_if f) moves a function f inside an if + Rewrite if_arg moves an argument inside a function-valued if **) Section BoolIf. Variables (A B : Type) (x : A) (f : A -> B) (b : bool) (vT vF : A). -CoInductive if_spec (not_b : Prop) : bool -> A -> Set := +Variant if_spec (not_b : Prop) : bool -> A -> Set := | IfSpecTrue of b : if_spec not_b true vT | IfSpecFalse of not_b : if_spec not_b false vF. @@ -483,13 +489,13 @@ Lemma if_arg (fT fF : A -> B) : (if b then fT else fF) x = if b then fT x else fF x. Proof. by case b. Qed. -(* Turning a boolean "if" form into an application. *) +(** Turning a boolean "if" form into an application. **) Definition if_expr := if b then vT else vF. Lemma ifE : (if b then vT else vF) = if_expr. Proof. by []. Qed. End BoolIf. -(* Core (internal) reflection lemmas, used for the three kinds of views. *) +(** Core (internal) reflection lemmas, used for the three kinds of views. **) Section ReflectCore. @@ -517,7 +523,7 @@ Proof. by case Hb => [? _ H ? | ? H _]; case: H. Qed. End ReflectCore. -(* Internal negated reflection lemmas *) +(** Internal negated reflection lemmas **) Section ReflectNegCore. Variables (P Q : Prop) (b c : bool). @@ -537,7 +543,7 @@ Proof. by rewrite -if_neg; apply: xorPif. Qed. End ReflectNegCore. -(* User-oriented reflection lemmas *) +(** User-oriented reflection lemmas **) Section Reflect. Variables (P Q : Prop) (b b' c : bool). @@ -584,8 +590,8 @@ Lemma rwP : P <-> b. Proof. by split; [apply: introT | apply: elimT]. Qed. Lemma rwP2 : reflect Q b -> (P <-> Q). Proof. by move=> Qb; split=> ?; [apply: appP | apply: elimT; case: Qb]. Qed. -(* Predicate family to reflect excluded middle in bool. *) -CoInductive alt_spec : bool -> Type := +(** Predicate family to reflect excluded middle in bool. **) +Variant alt_spec : bool -> Type := | AltTrue of P : alt_spec true | AltFalse of ~~ b : alt_spec false. @@ -600,10 +606,10 @@ Hint View for apply/ introTF|3 introNTF|3 introTFn|3 elimT|2 elimTn|2 elimN|2. Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. -(* Allow the direct application of a reflection lemma to a boolean assertion. *) +(** Allow the direct application of a reflection lemma to a boolean assertion. **) Coercion elimT : reflect >-> Funclass. -CoInductive implies P Q := Implies of P -> Q. +Variant implies P Q := Implies of P -> Q. Lemma impliesP P Q : implies P Q -> P -> Q. Proof. by case. Qed. Lemma impliesPn (P Q : Prop) : implies P Q -> ~ Q -> ~ P. Proof. by case=> iP ? /iP. Qed. @@ -611,7 +617,7 @@ Coercion impliesP : implies >-> Funclass. Hint View for move/ impliesPn|2 impliesP|2. Hint View for apply/ impliesPn|2 impliesP|2. -(* Impredicative or, which can emulate a classical not-implies. *) +(** Impredicative or, which can emulate a classical not-implies. **) Definition unless condition property : Prop := forall goal : Prop, (condition -> goal) -> (property -> goal) -> goal. @@ -637,8 +643,9 @@ Proof. by split; apply=> [hC|hP]; [apply/unlessL/unlessL | apply/unlessR]. Qed. Lemma unless_contra b C : implies (~~ b -> C) (\unless C, b). Proof. by split; case: b => [_ | hC]; [apply/unlessR | apply/unlessL/hC]. Qed. -(* Classical reasoning becomes directly accessible for any bool subgoal. *) -(* Note that we cannot use "unless" here for lack of universe polymorphism. *) +(** + Classical reasoning becomes directly accessible for any bool subgoal. + Note that we cannot use "unless" here for lack of universe polymorphism. **) Definition classically P : Prop := forall b : bool, (P -> b) -> b. Lemma classicP (P : Prop) : classically P <-> ~ ~ P. @@ -669,11 +676,12 @@ move=> iPQ []// notPQ; apply/notPQ=> /iPQ-cQ. by case: notF; apply: cQ => hQ; apply: notPQ. Qed. -(* List notations for wider connectives; the Prop connectives have a fixed *) -(* width so as to avoid iterated destruction (we go up to width 5 for /\, and *) -(* width 4 for or). The bool connectives have arbitrary widths, but denote *) -(* expressions that associate to the RIGHT. This is consistent with the right *) -(* associativity of list expressions and thus more convenient in most proofs. *) +(** + List notations for wider connectives; the Prop connectives have a fixed + width so as to avoid iterated destruction (we go up to width 5 for /\, and + width 4 for or). The bool connectives have arbitrary widths, but denote + expressions that associate to the RIGHT. This is consistent with the right + associativity of list expressions and thus more convenient in most proofs. **) Inductive and3 (P1 P2 P3 : Prop) : Prop := And3 of P1 & P2 & P3. @@ -822,7 +830,7 @@ Arguments implyP [b1 b2]. Prenex Implicits idP idPn negP negPn negPf. Prenex Implicits andP and3P and4P and5P orP or3P or4P nandP norP implyP. -(* Shorter, more systematic names for the boolean connectives laws. *) +(** Shorter, more systematic names for the boolean connectives laws. **) Lemma andTb : left_id true andb. Proof. by []. Qed. Lemma andFb : left_zero false andb. Proof. by []. Qed. @@ -880,14 +888,14 @@ Proof. by case: a; case: b. Qed. Lemma negb_or (a b : bool) : ~~ (a || b) = ~~ a && ~~ b. Proof. by case: a; case: b. Qed. -(* Pseudo-cancellation -- i.e, absorbtion *) +(** Pseudo-cancellation -- i.e, absorbtion **) Lemma andbK a b : a && b || a = a. Proof. by case: a; case: b. Qed. Lemma andKb a b : a || b && a = a. Proof. by case: a; case: b. Qed. Lemma orbK a b : (a || b) && a = a. Proof. by case: a; case: b. Qed. Lemma orKb a b : a && (b || a) = a. Proof. by case: a; case: b. Qed. -(* Imply *) +(** Imply **) Lemma implybT b : b ==> true. Proof. by case: b. Qed. Lemma implybF b : (b ==> false) = ~~ b. Proof. by case: b. Qed. @@ -917,7 +925,7 @@ Proof. by case: a; case: b => // ->. Qed. Lemma implyb_id2l (a b c : bool) : (a -> b = c) -> (a ==> b) = (a ==> c). Proof. by case: a; case: b; case: c => // ->. Qed. -(* Addition (xor) *) +(** Addition (xor) **) Lemma addFb : left_id false addb. Proof. by []. Qed. Lemma addbF : right_id false addb. Proof. by case. Qed. @@ -946,9 +954,10 @@ Lemma addbP a b : reflect (~~ a = b) (a (+) b). Proof. by case: a; case: b; constructor. Qed. Arguments addbP [a b]. -(* Resolution tactic for blindly weeding out common terms from boolean *) -(* equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b3 *) -(* they will try to locate b1 in b3 and remove it. This can fail! *) +(** + Resolution tactic for blindly weeding out common terms from boolean + equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b3 + they will try to locate b1 in b3 and remove it. This can fail! **) Ltac bool_congr := match goal with @@ -963,100 +972,101 @@ Ltac bool_congr := | |- (~~ ?X1 = ?X2) => congr 1 negb end. -(******************************************************************************) -(* Predicates, i.e., packaged functions to bool. *) -(* - pred T, the basic type for predicates over a type T, is simply an alias *) -(* for T -> bool. *) -(* We actually distinguish two kinds of predicates, which we call applicative *) -(* and collective, based on the syntax used to test them at some x in T: *) -(* - For an applicative predicate P, one uses prefix syntax: *) -(* P x *) -(* Also, most operations on applicative predicates use prefix syntax as *) -(* well (e.g., predI P Q). *) -(* - For a collective predicate A, one uses infix syntax: *) -(* x \in A *) -(* and all operations on collective predicates use infix syntax as well *) -(* (e.g., [predI A & B]). *) -(* There are only two kinds of applicative predicates: *) -(* - pred T, the alias for T -> bool mentioned above *) -(* - simpl_pred T, an alias for simpl_fun T bool with a coercion to pred T *) -(* that auto-simplifies on application (see ssrfun). *) -(* On the other hand, the set of collective predicate types is open-ended via *) -(* - predType T, a Structure that can be used to put Canonical collective *) -(* predicate interpretation on other types, such as lists, tuples, *) -(* finite sets, etc. *) -(* Indeed, we define such interpretations for applicative predicate types, *) -(* which can therefore also be used with the infix syntax, e.g., *) -(* x \in predI P Q *) -(* Moreover these infix forms are convertible to their prefix counterpart *) -(* (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse *) -(* is not true, however; collective predicate types cannot, in general, be *) -(* general, be used applicatively, because of the "uniform inheritance" *) -(* restriction on implicit coercions. *) -(* However, we do define an explicit generic coercion *) -(* - mem : forall (pT : predType), pT -> mem_pred T *) -(* where mem_pred T is a variant of simpl_pred T that preserves the infix *) -(* syntax, i.e., mem A x auto-simplifies to x \in A. *) -(* Indeed, the infix "collective" operators are notation for a prefix *) -(* operator with arguments of type mem_pred T or pred T, applied to coerced *) -(* collective predicates, e.g., *) -(* Notation "x \in A" := (in_mem x (mem A)). *) -(* This prevents the variability in the predicate type from interfering with *) -(* the application of generic lemmas. Moreover this also makes it much easier *) -(* to define generic lemmas, because the simplest type -- pred T -- can be *) -(* used as the type of generic collective predicates, provided one takes care *) -(* not to use it applicatively; this avoids the burden of having to declare a *) -(* different predicate type for each predicate parameter of each section or *) -(* lemma. *) -(* This trick is made possible by the fact that the constructor of the *) -(* mem_pred T type aligns the unification process, forcing a generic *) -(* "collective" predicate A : pred T to unify with the actual collective B, *) -(* which mem has coerced to pred T via an internal, hidden implicit coercion, *) -(* supplied by the predType structure for B. Users should take care not to *) -(* inadvertently "strip" (mem B) down to the coerced B, since this will *) -(* expose the internal coercion: Coq will display a term B x that cannot be *) -(* typed as such. The topredE lemma can be used to restore the x \in B *) -(* syntax in this case. While -topredE can conversely be used to change *) -(* x \in P into P x, it is safer to use the inE and memE lemmas instead, as *) -(* they do not run the risk of exposing internal coercions. As a consequence *) -(* it is better to explicitly cast a generic applicative pred T to simpl_pred *) -(* using the SimplPred constructor, when it is used as a collective predicate *) -(* (see, e.g., Lemma eq_big in bigop). *) -(* We also sometimes "instantiate" the predType structure by defining a *) -(* coercion to the sort of the predPredType structure. This works better for *) -(* types such as {set T} that have subtypes that coerce to them, since the *) -(* same coercion will be inserted by the application of mem. It also lets us *) -(* turn any Type aT : predArgType into the total predicate over that type, *) -(* i.e., fun _: aT => true. This allows us to write, e.g., #|'I_n| for the *) -(* cardinal of the (finite) type of integers less than n. *) -(* Collective predicates have a specific extensional equality, *) -(* - A =i B, *) -(* while applicative predicates use the extensional equality of functions, *) -(* - P =1 Q *) -(* The two forms are convertible, however. *) -(* We lift boolean operations to predicates, defining: *) -(* - predU (union), predI (intersection), predC (complement), *) -(* predD (difference), and preim (preimage, i.e., composition) *) -(* For each operation we define three forms, typically: *) -(* - predU : pred T -> pred T -> simpl_pred T *) -(* - [predU A & B], a Notation for predU (mem A) (mem B) *) -(* - xpredU, a Notation for the lambda-expression inside predU, *) -(* which is mostly useful as an argument of =1, since it exposes the head *) -(* head constant of the expression to the ssreflect matching algorithm. *) -(* The syntax for the preimage of a collective predicate A is *) -(* - [preim f of A] *) -(* Finally, the generic syntax for defining a simpl_pred T is *) -(* - [pred x : T | P(x)], [pred x | P(x)], [pred x in A | P(x)], etc. *) -(* We also support boolean relations, but only the applicative form, with *) -(* types *) -(* - rel T, an alias for T -> pred T *) -(* - simpl_rel T, an auto-simplifying version, and syntax *) -(* [rel x y | P(x,y)], [rel x y in A & B | P(x,y)], etc. *) -(* The notation [rel of fA] can be used to coerce a function returning a *) -(* collective predicate to one returning pred T. *) -(* Finally, note that there is specific support for ambivalent predicates *) -(* that can work in either style, as per this file's head descriptor. *) -(******************************************************************************) + +(** + Predicates, i.e., packaged functions to bool. + - pred T, the basic type for predicates over a type T, is simply an alias + for T -> bool. + We actually distinguish two kinds of predicates, which we call applicative + and collective, based on the syntax used to test them at some x in T: + - For an applicative predicate P, one uses prefix syntax: + P x + Also, most operations on applicative predicates use prefix syntax as + well (e.g., predI P Q). + - For a collective predicate A, one uses infix syntax: + x \in A + and all operations on collective predicates use infix syntax as well + (e.g., #[#predI A & B#]#). + There are only two kinds of applicative predicates: + - pred T, the alias for T -> bool mentioned above + - simpl_pred T, an alias for simpl_fun T bool with a coercion to pred T + that auto-simplifies on application (see ssrfun). + On the other hand, the set of collective predicate types is open-ended via + - predType T, a Structure that can be used to put Canonical collective + predicate interpretation on other types, such as lists, tuples, + finite sets, etc. + Indeed, we define such interpretations for applicative predicate types, + which can therefore also be used with the infix syntax, e.g., + x \in predI P Q + Moreover these infix forms are convertible to their prefix counterpart + (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse + is not true, however; collective predicate types cannot, in general, be + general, be used applicatively, because of the "uniform inheritance" + restriction on implicit coercions. + However, we do define an explicit generic coercion + - mem : forall (pT : predType), pT -> mem_pred T + where mem_pred T is a variant of simpl_pred T that preserves the infix + syntax, i.e., mem A x auto-simplifies to x \in A. + Indeed, the infix "collective" operators are notation for a prefix + operator with arguments of type mem_pred T or pred T, applied to coerced + collective predicates, e.g., + Notation "x \in A" := (in_mem x (mem A)). + This prevents the variability in the predicate type from interfering with + the application of generic lemmas. Moreover this also makes it much easier + to define generic lemmas, because the simplest type -- pred T -- can be + used as the type of generic collective predicates, provided one takes care + not to use it applicatively; this avoids the burden of having to declare a + different predicate type for each predicate parameter of each section or + lemma. + This trick is made possible by the fact that the constructor of the + mem_pred T type aligns the unification process, forcing a generic + "collective" predicate A : pred T to unify with the actual collective B, + which mem has coerced to pred T via an internal, hidden implicit coercion, + supplied by the predType structure for B. Users should take care not to + inadvertently "strip" (mem B) down to the coerced B, since this will + expose the internal coercion: Coq will display a term B x that cannot be + typed as such. The topredE lemma can be used to restore the x \in B + syntax in this case. While -topredE can conversely be used to change + x \in P into P x, it is safer to use the inE and memE lemmas instead, as + they do not run the risk of exposing internal coercions. As a consequence + it is better to explicitly cast a generic applicative pred T to simpl_pred + using the SimplPred constructor, when it is used as a collective predicate + (see, e.g., Lemma eq_big in bigop). + We also sometimes "instantiate" the predType structure by defining a + coercion to the sort of the predPredType structure. This works better for + types such as {set T} that have subtypes that coerce to them, since the + same coercion will be inserted by the application of mem. It also lets us + turn any Type aT : predArgType into the total predicate over that type, + i.e., fun _: aT => true. This allows us to write, e.g., ##|'I_n| for the + cardinal of the (finite) type of integers less than n. + Collective predicates have a specific extensional equality, + - A =i B, + while applicative predicates use the extensional equality of functions, + - P =1 Q + The two forms are convertible, however. + We lift boolean operations to predicates, defining: + - predU (union), predI (intersection), predC (complement), + predD (difference), and preim (preimage, i.e., composition) + For each operation we define three forms, typically: + - predU : pred T -> pred T -> simpl_pred T + - #[#predU A & B#]#, a Notation for predU (mem A) (mem B) + - xpredU, a Notation for the lambda-expression inside predU, + which is mostly useful as an argument of =1, since it exposes the head + head constant of the expression to the ssreflect matching algorithm. + The syntax for the preimage of a collective predicate A is + - #[#preim f of A#]# + Finally, the generic syntax for defining a simpl_pred T is + - #[#pred x : T | P(x) #]#, #[#pred x | P(x) #]#, #[#pred x in A | P(x) #]#, etc. + We also support boolean relations, but only the applicative form, with + types + - rel T, an alias for T -> pred T + - simpl_rel T, an auto-simplifying version, and syntax + #[#rel x y | P(x,y) #]#, #[#rel x y in A & B | P(x,y) #]#, etc. + The notation #[#rel of fA#]# can be used to coerce a function returning a + collective predicate to one returning pred T. + Finally, note that there is specific support for ambivalent predicates + that can work in either style, as per this file's head descriptor. **) + Definition pred T := T -> bool. @@ -1094,8 +1104,9 @@ Coercion applicative_pred_of_simpl (p : simpl_pred) : applicative_pred := fun_of_simpl p. Coercion collective_pred_of_simpl (p : simpl_pred) : collective_pred := fun x => (let: SimplFun f := p in fun _ => f x) x. -(* Note: applicative_of_simpl is convertible to pred_of_simpl, while *) -(* collective_of_simpl is not. *) +(** + Note: applicative_of_simpl is convertible to pred_of_simpl, while + collective_of_simpl is not. **) Definition pred0 := SimplPred xpred0. Definition predT := SimplPred xpredT. @@ -1119,7 +1130,7 @@ Proof. by move=> *; apply/orP; left. Qed. Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). Proof. by move=> *; apply/orP; right. Qed. -CoInductive mem_pred := Mem of pred T. +Variant mem_pred := Mem of pred T. Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). @@ -1166,19 +1177,21 @@ Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ _ id) (at level 0, format "[ 'predType' 'of' T ]") : form_scope. -(* This redundant coercion lets us "inherit" the simpl_predType canonical *) -(* instance by declaring a coercion to simpl_pred. This hack is the only way *) -(* to put a predType structure on a predArgType. We use simpl_pred rather *) -(* than pred to ensure that /= removes the identity coercion. Note that the *) -(* coercion will never be used directly for simpl_pred, since the canonical *) -(* instance should always be resolved. *) +(** + This redundant coercion lets us "inherit" the simpl_predType canonical + instance by declaring a coercion to simpl_pred. This hack is the only way + to put a predType structure on a predArgType. We use simpl_pred rather + than pred to ensure that /= removes the identity coercion. Note that the + coercion will never be used directly for simpl_pred, since the canonical + instance should always be resolved. **) Notation pred_class := (pred_sort (predPredType _)). Coercion sort_of_simpl_pred T (p : simpl_pred T) : pred_class := p : pred T. -(* This lets us use some types as a synonym for their universal predicate. *) -(* Unfortunately, this won't work for existing types like bool, unless we *) -(* redefine bool, true, false and all bool ops. *) +(** + This lets us use some types as a synonym for their universal predicate. + Unfortunately, this won't work for existing types like bool, unless we + redefine bool, true, false and all bool ops. **) Definition predArgType := Type. Bind Scope type_scope with predArgType. Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. @@ -1187,8 +1200,9 @@ Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. Notation "{ : T }" := (T%type : predArgType) (at level 0, format "{ : T }") : type_scope. -(* These must be defined outside a Section because "cooking" kills the *) -(* nosimpl tag. *) +(** + These must be defined outside a Section because "cooking" kills the + nosimpl tag. **) Definition mem T (pT : predType T) : pT -> mem_pred T := nosimpl (let: @PredType _ _ _ (exist _ mem _) := pT return pT -> _ in mem). @@ -1254,12 +1268,13 @@ Section simpl_mem. Variables (T : Type) (pT : predType T). Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). -(* Bespoke structures that provide fine-grained control over matching the *) -(* various forms of the \in predicate; note in particular the different forms *) -(* of hoisting that are used. We had to work around several bugs in the *) -(* implementation of unification, notably improper expansion of telescope *) -(* projections and overwriting of a variable assignment by a later *) -(* unification (probably due to conversion cache cross-talk). *) +(** + Bespoke structures that provide fine-grained control over matching the + various forms of the \in predicate; note in particular the different forms + of hoisting that are used. We had to work around several bugs in the + implementation of unification, notably improper expansion of telescope + projections and overwriting of a variable assignment by a later + unification (probably due to conversion cache cross-talk). **) Structure manifest_applicative_pred p := ManifestApplicativePred { manifest_applicative_pred_value :> pred T; _ : manifest_applicative_pred_value = p @@ -1305,10 +1320,11 @@ Lemma in_simpl x p (msp : manifest_simpl_pred p) : in_mem x (Mem [eta fun_of_simpl (msp : simpl_pred T)]) = p x. Proof. by case: msp => _ /= ->. Qed. -(* Because of the explicit eta expansion in the left-hand side, this lemma *) -(* should only be used in a right-to-left direction. The 8.3 hack allowing *) -(* partial right-to-left use does not work with the improved expansion *) -(* heuristics in 8.4. *) +(** + Because of the explicit eta expansion in the left-hand side, this lemma + should only be used in a right-to-left direction. The 8.3 hack allowing + partial right-to-left use does not work with the improved expansion + heuristics in 8.4. **) Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. Proof. by []. Qed. @@ -1327,9 +1343,9 @@ Proof. by rewrite -mem_topred. Qed. End simpl_mem. -(* Qualifiers and keyed predicates. *) +(** Qualifiers and keyed predicates. **) -CoInductive qualifier (q : nat) T := Qualifier of predPredType T. +Variant qualifier (q : nat) T := Qualifier of predPredType T. Coercion has_quality n T (q : qualifier n T) : pred_class := fun x => let: Qualifier _ p := q in p x. @@ -1371,12 +1387,12 @@ Notation "[ 'qualify' 'an' x | P ]" := (Qualifier 2 (fun x => P%B)) Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) (at level 0, x at level 99, only parsing) : form_scope. -(* Keyed predicates: support for property-bearing predicate interfaces. *) +(** Keyed predicates: support for property-bearing predicate interfaces. **) Section KeyPred. Variable T : Type. -CoInductive pred_key (p : predPredType T) := DefaultPredKey. +Variant pred_key (p : predPredType T) := DefaultPredKey. Variable p : predPredType T. Structure keyed_pred (k : pred_key p) := @@ -1388,13 +1404,14 @@ Definition KeyedPred := @PackKeyedPred k p (frefl _). Variable k_p : keyed_pred k. Lemma keyed_predE : k_p =i p. Proof. by case: k_p. Qed. -(* Instances that strip the mem cast; the first one has "pred_of_mem" as its *) -(* projection head value, while the second has "pred_of_simpl". The latter *) -(* has the side benefit of preempting accidental misdeclarations. *) -(* Note: pred_of_mem is the registered mem >-> pred_class coercion, while *) -(* simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We *) -(* must write down the coercions explicitly as the Canonical head constant *) -(* computation does not strip casts !! *) +(** + Instances that strip the mem cast; the first one has "pred_of_mem" as its + projection head value, while the second has "pred_of_simpl". The latter + has the side benefit of preempting accidental misdeclarations. + Note: pred_of_mem is the registered mem >-> pred_class coercion, while + simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We + must write down the coercions explicitly as the Canonical head constant + computation does not strip casts !! **) Canonical keyed_mem := @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. Canonical keyed_mem_simpl := @@ -1434,7 +1451,7 @@ Canonical default_keyed_qualifier T n (q : qualifier n T) := End DefaultKeying. -(* Skolemizing with conditions. *) +(** Skolemizing with conditions. **) Lemma all_tag_cond_dep I T (C : pred I) U : (forall x, T x) -> (forall x, C x -> {y : T x & U x y}) -> @@ -1461,8 +1478,9 @@ Proof. by move=> y0; apply: all_sig_cond_dep. Qed. Section RelationProperties. -(* Caveat: reflexive should not be used to state lemmas, as auto and trivial *) -(* will not expand the constant. *) +(** + Caveat: reflexive should not be used to state lemmas, as auto and trivial + will not expand the constant. **) Variable T : Type. @@ -1496,8 +1514,9 @@ Proof. by move=> x y /sym_left_transitive Rxy z; rewrite !(symR z) Rxy. Qed. End PER. -(* We define the equivalence property with prenex quantification so that it *) -(* can be localized using the {in ..., ..} form defined below. *) +(** + We define the equivalence property with prenex quantification so that it + can be localized using the {in ..., ..} form defined below. **) Definition equivalence_rel := forall x y z, R z z * (R x y -> R x z = R y z). @@ -1512,7 +1531,7 @@ End RelationProperties. Lemma rev_trans T (R : rel T) : transitive R -> transitive (fun x y => R y x). Proof. by move=> trR x y z Ryx Rzy; apply: trR Rzy Ryx. Qed. -(* Property localization *) +(** Property localization **) Local Notation "{ 'all1' P }" := (forall x, P x : Prop) (at level 0). Local Notation "{ 'all2' P }" := (forall x y, P x y : Prop) (at level 0). @@ -1626,11 +1645,12 @@ Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) (at level 0, f at level 8, format "{ 'on' cd , 'bijective' f }") : type_scope. -(* Weakening and monotonicity lemmas for localized predicates. *) -(* Note that using these lemmas in backward reasoning will force expansion of *) -(* the predicate definition, as Coq needs to expose the quantifier to apply *) -(* these lemmas. We define a few specialized variants to avoid this for some *) -(* of the ssrfun predicates. *) +(** + Weakening and monotonicity lemmas for localized predicates. + Note that using these lemmas in backward reasoning will force expansion of + the predicate definition, as Coq needs to expose the quantifier to apply + these lemmas. We define a few specialized variants to avoid this for some + of the ssrfun predicates. **) Section LocalGlobal. diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 82cae439..c94039a6 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -181,10 +181,9 @@ let option_assert_get o msg = (** Constructors for rawconstr *) open Glob_term open Globnames -open Misctypes open Decl_kinds -let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None) +let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] let rec isRHoles cl = match cl with @@ -254,7 +253,7 @@ let interp_refine ist gl rc = let interp_open_constr ist gl gc = - let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, Misctypes.NoBindings) in + let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, Tactypes.NoBindings) in (project gl, (sigma, c)) let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) @@ -423,12 +422,12 @@ let mk_anon_id t gl_ids = (set s i (Char.chr (Char.code (get s i) + 1)); s) in Id.of_bytes (loop (n - 1)) -let convert_concl_no_check t = Tactics.convert_concl_no_check t Term.DEFAULTcast -let convert_concl t = Tactics.convert_concl t Term.DEFAULTcast +let convert_concl_no_check t = Tactics.convert_concl_no_check t DEFAULTcast +let convert_concl t = Tactics.convert_concl t DEFAULTcast let rename_hd_prod orig_name_ref gl = match EConstr.kind (project gl) (pf_concl gl) with - | Term.Prod(_,src,tgt) -> + | Prod(_,src,tgt) -> Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkProd (!orig_name_ref,src,tgt))) gl | _ -> CErrors.anomaly (str "gentac creates no product") @@ -504,16 +503,17 @@ let nf_evar sigma t = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr t)) let pf_abs_evars2 gl rigid (sigma, c0) = - let c0 = EConstr.to_constr sigma c0 in + let c0 = EConstr.to_constr ~abort_on_undefined_evars:false sigma c0 in let sigma0, ucst = project gl, Evd.evar_universe_context sigma in let nenv = env_size (pf_env gl) in let abs_evar n k = let evi = Evd.find sigma k in - let dc = CList.firstn n (evar_filtered_context evi) in + let concl = EConstr.Unsafe.to_constr evi.evar_concl in + let dc = EConstr.Unsafe.to_named_context (CList.firstn n (evar_filtered_context evi)) in let abs_dc c = function | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in - let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma t in let rec put evlist c = match Constr.kind c with | Evar (k, a) -> @@ -569,11 +569,12 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let nenv = env_size (pf_env gl) in let abs_evar n k = let evi = Evd.find sigma k in - let dc = CList.firstn n (evar_filtered_context evi) in + let concl = EConstr.Unsafe.to_constr evi.evar_concl in + let dc = EConstr.Unsafe.to_named_context (CList.firstn n (evar_filtered_context evi)) in let abs_dc c = function | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in - let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma0 (nf_evar sigma t) in let rec put evlist c = match Constr.kind c with | Evar (k, a) -> @@ -581,7 +582,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let n = max 0 (Array.length a - nenv) in let k_ty = Retyping.get_sort_family_of - (pf_env gl) sigma (EConstr.of_constr (Evd.evar_concl (Evd.find sigma k))) in + (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in let is_prop = k_ty = InProp in let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t | _ -> Constr.fold put evlist c in @@ -746,7 +747,7 @@ let pf_mkSsrConst name gl = let pf_fresh_global name gl = let sigma, env, it = project gl, pf_env gl, sig_it gl in let sigma,t = Evd.fresh_global env sigma name in - t, re_sig it sigma + EConstr.Unsafe.to_constr t, re_sig it sigma let mkProt t c gl = let prot, gl = pf_mkSsrConst "protect_term" gl in @@ -802,7 +803,7 @@ let rec is_name_in_ipats name = function | IPatId id :: tl -> id = name || is_name_in_ipats name tl | IPatAbstractVars ids :: tl -> CList.mem_f Id.equal name ids || is_name_in_ipats name tl - | (IPatCase l | IPatDispatch l | IPatInj l) :: tl -> + | (IPatCase l | IPatDispatch (_,l) | IPatInj l) :: tl -> List.exists (is_name_in_ipats name) l || is_name_in_ipats name tl | (IPatView _ | IPatAnon _ | IPatSimpl _ | IPatRewrite _ | IPatTac _ | IPatNoop) :: tl -> is_name_in_ipats name tl | [] -> false @@ -857,10 +858,10 @@ open Util (** Constructors for constr_expr *) let mkCProp loc = CAst.make ?loc @@ CSort GProp let mkCType loc = CAst.make ?loc @@ CSort (GType []) -let mkCVar ?loc id = CAst.make ?loc @@ CRef (CAst.make ?loc @@ Ident id, None) +let mkCVar ?loc id = CAst.make ?loc @@ CRef (qualid_of_ident ?loc id, None) let rec mkCHoles ?loc n = - if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) -let mkCHole loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) + if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, Namegen.IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) +let mkCHole loc = CAst.make ?loc @@ CHole (None, Namegen.IntroAnonymous, None) let mkCLambda ?loc name ty t = CAst.make ?loc @@ CLambdaN ([CLocalAssum([CAst.make ?loc name], Default Explicit, ty)], t) let mkCArrow ?loc ty t = CAst.make ?loc @@ @@ -983,7 +984,7 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = if not (EConstr.Vars.closed0 sigma ty) then raise dependent_apply_error; let m = Evarutil.new_meta () in - loop (meta_declare m (EConstr.Unsafe.to_constr ty) sigma) bo ((EConstr.mkMeta m)::args) (n-1) + loop (meta_declare m ty sigma) bo ((EConstr.mkMeta m)::args) (n-1) | _ -> assert false in loop sigma t [] n in pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); @@ -1219,7 +1220,7 @@ let genclrtac cl cs clr = (fun type_err gl -> tclTHEN (tclTHEN (Proofview.V82.of_tactic (Tactics.elim_type (EConstr.of_constr - (Universes.constr_of_global @@ Coqlib.build_coq_False ())))) (old_cleartac clr)) + (UnivGen.constr_of_global @@ Coqlib.build_coq_False ())))) (old_cleartac clr)) (fun gl -> raise type_err) gl)) (old_cleartac clr) @@ -1444,7 +1445,7 @@ let tclINTRO_ANON = tclINTRO ~id:None ~conclusion:return let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> let convert_concl_no_check t = - Tactics.convert_concl_no_check t Term.DEFAULTcast in + Tactics.convert_concl_no_check t DEFAULTcast in let concl = Goal.concl gl in let sigma = Goal.sigma gl in match EConstr.kind sigma concl with @@ -1503,7 +1504,7 @@ let tclOPTION o d = let tacIS_INJECTION_CASE ?ty t = begin tclOPTION ty (tacTYPEOF t) >>= fun ty -> tacREDUCE_TO_QUANTIFIED_IND ty >>= fun ((mind,_),_) -> - tclUNIT (Globnames.eq_gr (Globnames.IndRef mind) (Coqlib.build_coq_eq ())) + tclUNIT (GlobRef.equal (GlobRef.IndRef mind) (Coqlib.build_coq_eq ())) end let tclWITHTOP tac = Goal.enter begin fun gl -> diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 2b8f1d54..9ba23467 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -212,7 +212,7 @@ val pf_abs_prod : EConstr.t -> Goal.goal Evd.sigma * EConstr.types val mkSsrRRef : string -> Glob_term.glob_constr * 'a option -val mkSsrRef : string -> Globnames.global_reference +val mkSsrRef : string -> GlobRef.t val mkSsrConst : string -> env -> evar_map -> evar_map * EConstr.t @@ -224,7 +224,7 @@ val new_wild_id : tac_ctx -> Names.Id.t * tac_ctx val pf_fresh_global : - Globnames.global_reference -> + GlobRef.t -> Goal.goal Evd.sigma -> Constr.constr * Goal.goal Evd.sigma diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index b0a94413..bebbd4ad 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -10,50 +10,53 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(** ## **) + Require Import Bool. (* For bool_scope delimiter 'bool'. *) Require Import ssrmatching. Declare ML Module "ssreflect_plugin". -(******************************************************************************) -(* This file is the Gallina part of the ssreflect plugin implementation. *) -(* Files that use the ssreflect plugin should always Require ssreflect and *) -(* either Import ssreflect or Import ssreflect.SsrSyntax. *) -(* Part of the contents of this file is technical and will only interest *) -(* advanced developers; in addition the following are defined: *) -(* [the str of v by f] == the Canonical s : str such that f s = v. *) -(* [the str of v] == the Canonical s : str that coerces to v. *) -(* argumentType c == the T such that c : forall x : T, P x. *) -(* returnType c == the R such that c : T -> R. *) -(* {type of c for s} == P s where c : forall x : T, P x. *) -(* phantom T v == singleton type with inhabitant Phantom T v. *) -(* phant T == singleton type with inhabitant Phant v. *) -(* =^~ r == the converse of rewriting rule r (e.g., in a *) -(* rewrite multirule). *) -(* unkeyed t == t, but treated as an unkeyed matching pattern by *) -(* the ssreflect matching algorithm. *) -(* nosimpl t == t, but on the right-hand side of Definition C := *) -(* nosimpl disables expansion of C by /=. *) -(* locked t == t, but locked t is not convertible to t. *) -(* locked_with k t == t, but not convertible to t or locked_with k' t *) -(* unless k = k' (with k : unit). Coq type-checking *) -(* will be much more efficient if locked_with with a *) -(* bespoke k is used for sealed definitions. *) -(* unlockable v == interface for sealed constant definitions of v. *) -(* Unlockable def == the unlockable that registers def : C = v. *) -(* [unlockable of C] == a clone for C of the canonical unlockable for the *) -(* definition of C (e.g., if it uses locked_with). *) -(* [unlockable fun C] == [unlockable of C] with the expansion forced to be *) -(* an explicit lambda expression. *) -(* -> The usage pattern for ADT operations is: *) -(* Definition foo_def x1 .. xn := big_foo_expression. *) -(* Fact foo_key : unit. Proof. by []. Qed. *) -(* Definition foo := locked_with foo_key foo_def. *) -(* Canonical foo_unlockable := [unlockable fun foo]. *) -(* This minimizes the comparison overhead for foo, while still allowing *) -(* rewrite unlock to expose big_foo_expression. *) -(* More information about these definitions and their use can be found in the *) -(* ssreflect manual, and in specific comments below. *) -(******************************************************************************) + +(** + This file is the Gallina part of the ssreflect plugin implementation. + Files that use the ssreflect plugin should always Require ssreflect and + either Import ssreflect or Import ssreflect.SsrSyntax. + Part of the contents of this file is technical and will only interest + advanced developers; in addition the following are defined: + #[#the str of v by f#]# == the Canonical s : str such that f s = v. + #[#the str of v#]# == the Canonical s : str that coerces to v. + argumentType c == the T such that c : forall x : T, P x. + returnType c == the R such that c : T -> R. + {type of c for s} == P s where c : forall x : T, P x. + phantom T v == singleton type with inhabitant Phantom T v. + phant T == singleton type with inhabitant Phant v. + =^~ r == the converse of rewriting rule r (e.g., in a + rewrite multirule). + unkeyed t == t, but treated as an unkeyed matching pattern by + the ssreflect matching algorithm. + nosimpl t == t, but on the right-hand side of Definition C := + nosimpl disables expansion of C by /=. + locked t == t, but locked t is not convertible to t. + locked_with k t == t, but not convertible to t or locked_with k' t + unless k = k' (with k : unit). Coq type-checking + will be much more efficient if locked_with with a + bespoke k is used for sealed definitions. + unlockable v == interface for sealed constant definitions of v. + Unlockable def == the unlockable that registers def : C = v. + #[#unlockable of C#]# == a clone for C of the canonical unlockable for the + definition of C (e.g., if it uses locked_with). + #[#unlockable fun C#]# == #[#unlockable of C#]# with the expansion forced to be + an explicit lambda expression. + -> The usage pattern for ADT operations is: + Definition foo_def x1 .. xn := big_foo_expression. + Fact foo_key : unit. Proof. by #[# #]#. Qed. + Definition foo := locked_with foo_key foo_def. + Canonical foo_unlockable := #[#unlockable fun foo#]#. + This minimizes the comparison overhead for foo, while still allowing + rewrite unlock to expose big_foo_expression. + More information about these definitions and their use can be found in the + ssreflect manual, and in specific comments below. **) + Set Implicit Arguments. @@ -62,15 +65,16 @@ Unset Printing Implicit Defensive. Module SsrSyntax. -(* Declare Ssr keywords: 'is' 'of' '//' '/=' and '//='. We also declare the *) -(* parsing level 8, as a workaround for a notation grammar factoring problem. *) -(* Arguments of application-style notations (at level 10) should be declared *) -(* at level 8 rather than 9 or the camlp5 grammar will not factor properly. *) +(** + Declare Ssr keywords: 'is' 'of' '//' '/=' and '//='. We also declare the + parsing level 8, as a workaround for a notation grammar factoring problem. + Arguments of application-style notations (at level 10) should be declared + at level 8 rather than 9 or the camlp5 grammar will not factor properly. **) Reserved Notation "(* x 'is' y 'of' z 'isn't' // /= //= *)" (at level 8). Reserved Notation "(* 69 *)" (at level 69). -(* Non ambiguous keyword to check if the SsrSyntax module is imported *) +(** Non ambiguous keyword to check if the SsrSyntax module is imported **) Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). Reserved Notation "" (at level 200). @@ -81,10 +85,11 @@ End SsrSyntax. Export SsrMatchingSyntax. Export SsrSyntax. -(* Make the general "if" into a notation, so that we can override it below. *) -(* The notations are "only parsing" because the Coq decompiler will not *) -(* recognize the expansion of the boolean if; using the default printer *) -(* avoids a spurrious trailing %GEN_IF. *) +(** + Make the general "if" into a notation, so that we can override it below. + The notations are "only parsing" because the Coq decompiler will not + recognize the expansion of the boolean if; using the default printer + avoids a spurrious trailing %%GEN_IF. **) Delimit Scope general_if_scope with GEN_IF. @@ -101,7 +106,7 @@ Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := (at level 200, c, t, v1, v2 at level 200, x ident, only parsing) : general_if_scope. -(* Force boolean interpretation of simple if expressions. *) +(** Force boolean interpretation of simple if expressions. **) Delimit Scope boolean_if_scope with BOOL_IF. @@ -116,37 +121,40 @@ Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := Open Scope boolean_if_scope. -(* To allow a wider variety of notations without reserving a large number of *) -(* of identifiers, the ssreflect library systematically uses "forms" to *) -(* enclose complex mixfix syntax. A "form" is simply a mixfix expression *) -(* enclosed in square brackets and introduced by a keyword: *) -(* [keyword ... ] *) -(* Because the keyword follows a bracket it does not need to be reserved. *) -(* Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq *) -(* Lists library) should be loaded before ssreflect so that their notations *) -(* do not mask all ssreflect forms. *) +(** + To allow a wider variety of notations without reserving a large number of + of identifiers, the ssreflect library systematically uses "forms" to + enclose complex mixfix syntax. A "form" is simply a mixfix expression + enclosed in square brackets and introduced by a keyword: + #[#keyword ... #]# + Because the keyword follows a bracket it does not need to be reserved. + Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq + Lists library) should be loaded before ssreflect so that their notations + do not mask all ssreflect forms. **) Delimit Scope form_scope with FORM. Open Scope form_scope. -(* Allow overloading of the cast (x : T) syntax, put whitespace around the *) -(* ":" symbol to avoid lexical clashes (and for consistency with the parsing *) -(* precedence of the notation, which binds less tightly than application), *) -(* and put printing boxes that print the type of a long definition on a *) -(* separate line rather than force-fit it at the right margin. *) +(** + Allow overloading of the cast (x : T) syntax, put whitespace around the + ":" symbol to avoid lexical clashes (and for consistency with the parsing + precedence of the notation, which binds less tightly than application), + and put printing boxes that print the type of a long definition on a + separate line rather than force-fit it at the right margin. **) Notation "x : T" := (x : T) (at level 100, right associativity, format "'[hv' x '/ ' : T ']'") : core_scope. -(* Allow the casual use of notations like nat * nat for explicit Type *) -(* declarations. Note that (nat * nat : Type) is NOT equivalent to *) -(* (nat * nat)%type, whose inferred type is legacy type "Set". *) +(** + Allow the casual use of notations like nat * nat for explicit Type + declarations. Note that (nat * nat : Type) is NOT equivalent to + (nat * nat)%%type, whose inferred type is legacy type "Set". **) Notation "T : 'Type'" := (T%type : Type) (at level 100, only parsing) : core_scope. -(* Allow similarly Prop annotation for, e.g., rewrite multirules. *) +(** Allow similarly Prop annotation for, e.g., rewrite multirules. **) Notation "P : 'Prop'" := (P%type : Prop) (at level 100, only parsing) : core_scope. -(* Constants for abstract: and [: name ] intro pattern *) +(** Constants for abstract: and #[#: name #]# intro pattern **) Definition abstract_lock := unit. Definition abstract_key := tt. @@ -156,35 +164,36 @@ Definition abstract (statement : Type) (id : nat) (lock : abstract_lock) := Notation "" := (abstract _ n _). Notation "T (* n *)" := (abstract T n abstract_key). -(* Constants for tactic-views *) +(** Constants for tactic-views **) Inductive external_view : Type := tactic_view of Type. -(* Syntax for referring to canonical structures: *) -(* [the struct_type of proj_val by proj_fun] *) -(* This form denotes the Canonical instance s of the Structure type *) -(* struct_type whose proj_fun projection is proj_val, i.e., such that *) -(* proj_fun s = proj_val. *) -(* Typically proj_fun will be A record field accessors of struct_type, but *) -(* this need not be the case; it can be, for instance, a field of a record *) -(* type to which struct_type coerces; proj_val will likewise be coerced to *) -(* the return type of proj_fun. In all but the simplest cases, proj_fun *) -(* should be eta-expanded to allow for the insertion of implicit arguments. *) -(* In the common case where proj_fun itself is a coercion, the "by" part *) -(* can be omitted entirely; in this case it is inferred by casting s to the *) -(* inferred type of proj_val. Obviously the latter can be fixed by using an *) -(* explicit cast on proj_val, and it is highly recommended to do so when the *) -(* return type intended for proj_fun is "Type", as the type inferred for *) -(* proj_val may vary because of sort polymorphism (it could be Set or Prop). *) -(* Note when using the [the _ of _] form to generate a substructure from a *) -(* telescopes-style canonical hierarchy (implementing inheritance with *) -(* coercions), one should always project or coerce the value to the BASE *) -(* structure, because Coq will only find a Canonical derived structure for *) -(* the Canonical base structure -- not for a base structure that is specific *) -(* to proj_value. *) +(** + Syntax for referring to canonical structures: + #[#the struct_type of proj_val by proj_fun#]# + This form denotes the Canonical instance s of the Structure type + struct_type whose proj_fun projection is proj_val, i.e., such that + proj_fun s = proj_val. + Typically proj_fun will be A record field accessors of struct_type, but + this need not be the case; it can be, for instance, a field of a record + type to which struct_type coerces; proj_val will likewise be coerced to + the return type of proj_fun. In all but the simplest cases, proj_fun + should be eta-expanded to allow for the insertion of implicit arguments. + In the common case where proj_fun itself is a coercion, the "by" part + can be omitted entirely; in this case it is inferred by casting s to the + inferred type of proj_val. Obviously the latter can be fixed by using an + explicit cast on proj_val, and it is highly recommended to do so when the + return type intended for proj_fun is "Type", as the type inferred for + proj_val may vary because of sort polymorphism (it could be Set or Prop). + Note when using the #[#the _ of _ #]# form to generate a substructure from a + telescopes-style canonical hierarchy (implementing inheritance with + coercions), one should always project or coerce the value to the BASE + structure, because Coq will only find a Canonical derived structure for + the Canonical base structure -- not for a base structure that is specific + to proj_value. **) Module TheCanonical. -CoInductive put vT sT (v1 v2 : vT) (s : sT) := Put. +Variant put vT sT (v1 v2 : vT) (s : sT) := Put. Definition get vT sT v s (p : @put vT sT v v s) := let: Put _ _ _ := p in s. @@ -203,11 +212,12 @@ Notation "[ 'the' sT 'of' v 'by' f ]" := Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*)s s) _)) (at level 0, only parsing) : form_scope. -(* The following are "format only" versions of the above notations. Since Coq *) -(* doesn't provide this facility, we fake it by splitting the "the" keyword. *) -(* We need to do this to prevent the formatter from being be thrown off by *) -(* application collapsing, coercion insertion and beta reduction in the right *) -(* hand side of the notations above. *) +(** + The following are "format only" versions of the above notations. Since Coq + doesn't provide this facility, we fake it by splitting the "the" keyword. + We need to do this to prevent the formatter from being be thrown off by + application collapsing, coercion insertion and beta reduction in the right + hand side of the notations above. **) Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) (at level 0, format "[ 'th' 'e' sT 'of' v 'by' f ]") : form_scope. @@ -215,37 +225,39 @@ Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) Notation "[ 'th' 'e' sT 'of' v ]" := (@get _ sT v _ _) (at level 0, format "[ 'th' 'e' sT 'of' v ]") : form_scope. -(* We would like to recognize -Notation "[ 'th' 'e' sT 'of' v : 'Type' ]" := (@get Type sT v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v : 'Type' ]") : form_scope. -*) - -(* Helper notation for canonical structure inheritance support. *) -(* This is a workaround for the poor interaction between delta reduction and *) -(* canonical projections in Coq's unification algorithm, by which transparent *) -(* definitions hide canonical instances, i.e., in *) -(* Canonical a_type_struct := @Struct a_type ... *) -(* Definition my_type := a_type. *) -(* my_type doesn't effectively inherit the struct structure from a_type. Our *) -(* solution is to redeclare the instance as follows *) -(* Canonical my_type_struct := Eval hnf in [struct of my_type]. *) -(* The special notation [str of _] must be defined for each Strucure "str" *) -(* with constructor "Str", typically as follows *) -(* Definition clone_str s := *) -(* let: Str _ x y ... z := s return {type of Str for s} -> str in *) -(* fun k => k _ x y ... z. *) -(* Notation "[ 'str' 'of' T 'for' s ]" := (@clone_str s (@Str T)) *) -(* (at level 0, format "[ 'str' 'of' T 'for' s ]") : form_scope. *) -(* Notation "[ 'str' 'of' T ]" := (repack_str (fun x => @Str T x)) *) -(* (at level 0, format "[ 'str' 'of' T ]") : form_scope. *) -(* The notation for the match return predicate is defined below; the eta *) -(* expansion in the second form serves both to distinguish it from the first *) -(* and to avoid the delta reduction problem. *) -(* There are several variations on the notation and the definition of the *) -(* the "clone" function, for telescopes, mixin classes, and join (multiple *) -(* inheritance) classes. We describe a different idiom for clones in ssrfun; *) -(* it uses phantom types (see below) and static unification; see fintype and *) -(* ssralg for examples. *) +(** + We would like to recognize +Notation " #[# 'th' 'e' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) + (at level 0, format " #[# 'th' 'e' sT 'of' v : 'Type' #]#") : form_scope. + **) + +(** + Helper notation for canonical structure inheritance support. + This is a workaround for the poor interaction between delta reduction and + canonical projections in Coq's unification algorithm, by which transparent + definitions hide canonical instances, i.e., in + Canonical a_type_struct := @Struct a_type ... + Definition my_type := a_type. + my_type doesn't effectively inherit the struct structure from a_type. Our + solution is to redeclare the instance as follows + Canonical my_type_struct := Eval hnf in #[#struct of my_type#]#. + The special notation #[#str of _ #]# must be defined for each Strucure "str" + with constructor "Str", typically as follows + Definition clone_str s := + let: Str _ x y ... z := s return {type of Str for s} -> str in + fun k => k _ x y ... z. + Notation " #[# 'str' 'of' T 'for' s #]#" := (@clone_str s (@Str T)) + (at level 0, format " #[# 'str' 'of' T 'for' s #]#") : form_scope. + Notation " #[# 'str' 'of' T #]#" := (repack_str (fun x => @Str T x)) + (at level 0, format " #[# 'str' 'of' T #]#") : form_scope. + The notation for the match return predicate is defined below; the eta + expansion in the second form serves both to distinguish it from the first + and to avoid the delta reduction problem. + There are several variations on the notation and the definition of the + the "clone" function, for telescopes, mixin classes, and join (multiple + inheritance) classes. We describe a different idiom for clones in ssrfun; + it uses phantom types (see below) and static unification; see fintype and + ssralg for examples. **) Definition argumentType T P & forall x : T, P x := T. Definition dependentReturnType T P & forall x : T, P x := P. @@ -254,79 +266,82 @@ Definition returnType aT rT & aT -> rT := rT. Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) (at level 0, format "{ 'type' 'of' c 'for' s }") : type_scope. -(* A generic "phantom" type (actually, a unit type with a phantom parameter). *) -(* This type can be used for type definitions that require some Structure *) -(* on one of their parameters, to allow Coq to infer said structure so it *) -(* does not have to be supplied explicitly or via the "[the _ of _]" notation *) -(* (the latter interacts poorly with other Notation). *) -(* The definition of a (co)inductive type with a parameter p : p_type, that *) -(* needs to use the operations of a structure *) -(* Structure p_str : Type := p_Str {p_repr :> p_type; p_op : p_repr -> ...} *) -(* should be given as *) -(* Inductive indt_type (p : p_str) := Indt ... . *) -(* Definition indt_of (p : p_str) & phantom p_type p := indt_type p. *) -(* Notation "{ 'indt' p }" := (indt_of (Phantom p)). *) -(* Definition indt p x y ... z : {indt p} := @Indt p x y ... z. *) -(* Notation "[ 'indt' x y ... z ]" := (indt x y ... z). *) -(* That is, the concrete type and its constructor should be shadowed by *) -(* definitions that use a phantom argument to infer and display the true *) -(* value of p (in practice, the "indt" constructor often performs additional *) -(* functions, like "locking" the representation -- see below). *) -(* We also define a simpler version ("phant" / "Phant") of phantom for the *) -(* common case where p_type is Type. *) - -CoInductive phantom T (p : T) := Phantom. +(** + A generic "phantom" type (actually, a unit type with a phantom parameter). + This type can be used for type definitions that require some Structure + on one of their parameters, to allow Coq to infer said structure so it + does not have to be supplied explicitly or via the " #[#the _ of _ #]#" notation + (the latter interacts poorly with other Notation). + The definition of a (co)inductive type with a parameter p : p_type, that + needs to use the operations of a structure + Structure p_str : Type := p_Str {p_repr :> p_type; p_op : p_repr -> ...} + should be given as + Inductive indt_type (p : p_str) := Indt ... . + Definition indt_of (p : p_str) & phantom p_type p := indt_type p. + Notation "{ 'indt' p }" := (indt_of (Phantom p)). + Definition indt p x y ... z : {indt p} := @Indt p x y ... z. + Notation " #[# 'indt' x y ... z #]#" := (indt x y ... z). + That is, the concrete type and its constructor should be shadowed by + definitions that use a phantom argument to infer and display the true + value of p (in practice, the "indt" constructor often performs additional + functions, like "locking" the representation -- see below). + We also define a simpler version ("phant" / "Phant") of phantom for the + common case where p_type is Type. **) + +Variant phantom T (p : T) := Phantom. Arguments phantom : clear implicits. Arguments Phantom : clear implicits. -CoInductive phant (p : Type) := Phant. +Variant phant (p : Type) := Phant. -(* Internal tagging used by the implementation of the ssreflect elim. *) +(** Internal tagging used by the implementation of the ssreflect elim. **) Definition protect_term (A : Type) (x : A) : A := x. -(* The ssreflect idiom for a non-keyed pattern: *) -(* - unkeyed t wiil match any subterm that unifies with t, regardless of *) -(* whether it displays the same head symbol as t. *) -(* - unkeyed t a b will match any application of a term f unifying with t, *) -(* to two arguments unifying with with a and b, repectively, regardless of *) -(* apparent head symbols. *) -(* - unkeyed x where x is a variable will match any subterm with the same *) -(* type as x (when x would raise the 'indeterminate pattern' error). *) +(** + The ssreflect idiom for a non-keyed pattern: + - unkeyed t wiil match any subterm that unifies with t, regardless of + whether it displays the same head symbol as t. + - unkeyed t a b will match any application of a term f unifying with t, + to two arguments unifying with with a and b, repectively, regardless of + apparent head symbols. + - unkeyed x where x is a variable will match any subterm with the same + type as x (when x would raise the 'indeterminate pattern' error). **) Notation unkeyed x := (let flex := x in flex). -(* Ssreflect converse rewrite rule rule idiom. *) +(** Ssreflect converse rewrite rule rule idiom. **) Definition ssr_converse R (r : R) := (Logic.I, r). Notation "=^~ r" := (ssr_converse r) (at level 100) : form_scope. -(* Term tagging (user-level). *) -(* The ssreflect library uses four strengths of term tagging to restrict *) -(* convertibility during type checking: *) -(* nosimpl t simplifies to t EXCEPT in a definition; more precisely, given *) -(* Definition foo := nosimpl bar, foo (or foo t') will NOT be expanded by *) -(* the /= and //= switches unless it is in a forcing context (e.g., in *) -(* match foo t' with ... end, foo t' will be reduced if this allows the *) -(* match to be reduced). Note that nosimpl bar is simply notation for a *) -(* a term that beta-iota reduces to bar; hence rewrite /foo will replace *) -(* foo by bar, and rewrite -/foo will replace bar by foo. *) -(* CAVEAT: nosimpl should not be used inside a Section, because the end of *) -(* section "cooking" removes the iota redex. *) -(* locked t is provably equal to t, but is not convertible to t; 'locked' *) -(* provides support for selective rewriting, via the lock t : t = locked t *) -(* Lemma, and the ssreflect unlock tactic. *) -(* locked_with k t is equal but not convertible to t, much like locked t, *) -(* but supports explicit tagging with a value k : unit. This is used to *) -(* mitigate a flaw in the term comparison heuristic of the Coq kernel, *) -(* which treats all terms of the form locked t as equal and conpares their *) -(* arguments recursively, leading to an exponential blowup of comparison. *) -(* For this reason locked_with should be used rather than locked when *) -(* defining ADT operations. The unlock tactic does not support locked_with *) -(* but the unlock rewrite rule does, via the unlockable interface. *) -(* we also use Module Type ascription to create truly opaque constants, *) -(* because simple expansion of constants to reveal an unreducible term *) -(* doubles the time complexity of a negative comparison. Such opaque *) -(* constants can be expanded generically with the unlock rewrite rule. *) -(* See the definition of card and subset in fintype for examples of this. *) +(** + Term tagging (user-level). + The ssreflect library uses four strengths of term tagging to restrict + convertibility during type checking: + nosimpl t simplifies to t EXCEPT in a definition; more precisely, given + Definition foo := nosimpl bar, foo (or foo t') will NOT be expanded by + the /= and //= switches unless it is in a forcing context (e.g., in + match foo t' with ... end, foo t' will be reduced if this allows the + match to be reduced). Note that nosimpl bar is simply notation for a + a term that beta-iota reduces to bar; hence rewrite /foo will replace + foo by bar, and rewrite -/foo will replace bar by foo. + CAVEAT: nosimpl should not be used inside a Section, because the end of + section "cooking" removes the iota redex. + locked t is provably equal to t, but is not convertible to t; 'locked' + provides support for selective rewriting, via the lock t : t = locked t + Lemma, and the ssreflect unlock tactic. + locked_with k t is equal but not convertible to t, much like locked t, + but supports explicit tagging with a value k : unit. This is used to + mitigate a flaw in the term comparison heuristic of the Coq kernel, + which treats all terms of the form locked t as equal and conpares their + arguments recursively, leading to an exponential blowup of comparison. + For this reason locked_with should be used rather than locked when + defining ADT operations. The unlock tactic does not support locked_with + but the unlock rewrite rule does, via the unlockable interface. + we also use Module Type ascription to create truly opaque constants, + because simple expansion of constants to reveal an unreducible term + doubles the time complexity of a negative comparison. Such opaque + constants can be expanded generically with the unlock rewrite rule. + See the definition of card and subset in fintype for examples of this. **) Notation nosimpl t := (let: tt := tt in t). @@ -335,11 +350,11 @@ Definition locked A := let: tt := master_key in fun x : A => x. Lemma lock A x : x = locked x :> A. Proof. unlock; reflexivity. Qed. -(* Needed for locked predicates, in particular for eqType's. *) +(** Needed for locked predicates, in particular for eqType's. **) Lemma not_locked_false_eq_true : locked false <> true. Proof. unlock; discriminate. Qed. -(* The basic closing tactic "done". *) +(** The basic closing tactic "done". **) Ltac done := trivial; hnf; intros; solve [ do ![solve [trivial | apply: sym_equal; trivial] @@ -347,7 +362,7 @@ Ltac done := | case not_locked_false_eq_true; assumption | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. -(* Quicker done tactic not including split, syntax: /0/ *) +(** Quicker done tactic not including split, syntax: /0/ **) Ltac ssrdone0 := trivial; hnf; intros; solve [ do ![solve [trivial | apply: sym_equal; trivial] @@ -355,7 +370,7 @@ Ltac ssrdone0 := | case not_locked_false_eq_true; assumption | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. -(* To unlock opaque constants. *) +(** To unlock opaque constants. **) Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. @@ -365,25 +380,26 @@ Notation "[ 'unlockable' 'of' C ]" := (@Unlockable _ _ C (unlock _)) Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. -(* Generic keyed constant locking. *) +(** Generic keyed constant locking. **) -(* The argument order ensures that k is always compared before T. *) +(** The argument order ensures that k is always compared before T. **) Definition locked_with k := let: tt := k in fun T x => x : T. -(* This can be used as a cheap alternative to cloning the unlockable instance *) -(* below, but with caution as unkeyed matching can be expensive. *) +(** + This can be used as a cheap alternative to cloning the unlockable instance + below, but with caution as unkeyed matching can be expensive. **) Lemma locked_withE T k x : unkeyed (locked_with k x) = x :> T. Proof. by case: k. Qed. -(* Intensionaly, this instance will not apply to locked u. *) +(** Intensionaly, this instance will not apply to locked u. **) Canonical locked_with_unlockable T k x := @Unlockable T x (locked_with k x) (locked_withE k x). -(* More accurate variant of unlock, and safer alternative to locked_withE. *) +(** More accurate variant of unlock, and safer alternative to locked_withE. **) Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. Proof. exact: unlock. Qed. -(* The internal lemmas for the have tactics. *) +(** The internal lemmas for the have tactics. **) Definition ssr_have Plemma Pgoal (step : Plemma) rest : Pgoal := rest step. Arguments ssr_have Plemma [Pgoal]. @@ -398,7 +414,7 @@ Arguments ssr_suff Plemma [Pgoal]. Definition ssr_wlog := ssr_suff. Arguments ssr_wlog Plemma [Pgoal]. -(* Internal N-ary congruence lemmas for the congr tactic. *) +(** Internal N-ary congruence lemmas for the congr tactic. **) Fixpoint nary_congruence_statement (n : nat) : (forall B, (B -> B -> Prop) -> Prop) -> Prop := @@ -422,7 +438,7 @@ Lemma ssr_congr_arrow Plemma Pgoal : Plemma = Pgoal -> Plemma -> Pgoal. Proof. by move->. Qed. Arguments ssr_congr_arrow : clear implicits. -(* View lemmas that don't use reflection. *) +(** View lemmas that don't use reflection. **) Section ApplyIff. @@ -440,14 +456,15 @@ End ApplyIff. Hint View for move/ iffLRn|2 iffRLn|2 iffLR|2 iffRL|2. Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. -(* To focus non-ssreflect tactics on a subterm, eg vm_compute. *) -(* Usage: *) -(* elim/abstract_context: (pattern) => G defG. *) -(* vm_compute; rewrite {}defG {G}. *) -(* Note that vm_cast are not stored in the proof term *) -(* for reductions occuring in the context, hence *) -(* set here := pattern; vm_compute in (value of here) *) -(* blows up at Qed time. *) +(** + To focus non-ssreflect tactics on a subterm, eg vm_compute. + Usage: + elim/abstract_context: (pattern) => G defG. + vm_compute; rewrite {}defG {G}. + Note that vm_cast are not stored in the proof term + for reductions occuring in the context, hence + set here := pattern; vm_compute in (value of here) + blows up at Qed time. **) Lemma abstract_context T (P : T -> Type) x : (forall Q, Q = P -> Q x) -> P x. Proof. by move=> /(_ P); apply. Qed. diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 40af5187..602fcfca 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -14,9 +14,10 @@ open Util open Names open Printer open Term +open Constr open Termops open Globnames -open Misctypes +open Tactypes open Tacmach open Ssrmatching_plugin @@ -358,7 +359,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let ev = List.fold_left Evar.Set.union Evar.Set.empty patterns_ev in let ty_ev = Evar.Set.fold (fun i e -> let ex = i in - let i_ty = EConstr.of_constr (Evd.evar_concl (Evd.find (project gl) ex)) in + let i_ty = Evd.evar_concl (Evd.find (project gl) ex) in Evar.Set.union e (evars_of_term i_ty)) ev Evar.Set.empty in let inter = Evar.Set.inter ev ty_ev in @@ -420,7 +421,7 @@ let injectl2rtac sigma c = match EConstr.kind sigma c with let is_injection_case c gl = let gl, cty = pfe_type_of gl c in let (mind,_), _ = pf_reduce_to_quantified_ind gl cty in - eq_gr (IndRef mind) (Coqlib.build_coq_eq ()) + GlobRef.equal (IndRef mind) (Coqlib.build_coq_eq ()) let perform_injection c gl = let gl, cty = pfe_type_of gl c in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index c29203de..f23433f2 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -277,7 +277,7 @@ let unfoldintac occ rdx t (kt,_) gl = let foldtac occ rdx ft gl = let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let sigma, t = ft in - let t = EConstr.to_constr sigma t in + let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in let fold, conclude = match rdx with | Some (_, (In_T _ | In_X_In_T _)) | None -> let ise = Evd.create_evar_defs sigma in @@ -288,7 +288,10 @@ let foldtac occ rdx ft gl = (fun env c _ h -> try find_T env c h ~k:(fun env t _ _ -> t) with NoMatch ->c), (fun () -> try end_T () with NoMatch -> fake_pmatcher_end ()) | _ -> - (fun env c _ h -> try let sigma = unify_HO env sigma (EConstr.of_constr c) (EConstr.of_constr t) in EConstr.to_constr sigma (EConstr.of_constr t) + (fun env c _ h -> + try + let sigma = unify_HO env sigma (EConstr.of_constr c) (EConstr.of_constr t) in + EConstr.to_constr ~abort_on_undefined_evars:false sigma (EConstr.of_constr t) with _ -> errorstrm Pp.(str "fold pattern " ++ pr_constr_pat t ++ spc () ++ str "does not match redex " ++ pr_constr_pat c)), fake_pmatcher_end in @@ -360,7 +363,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let evs = Evar.Set.elements (Evarutil.undefined_evars_of_term sigma t) in let open_evs = List.filter (fun k -> Sorts.InProp <> Retyping.get_sort_family_of - env sigma (EConstr.of_constr (Evd.evar_concl (Evd.find sigma k)))) + env sigma (Evd.evar_concl (Evd.find sigma k))) evs in if open_evs <> [] then Some name else None) (List.combine (Array.to_list args) names) @@ -370,8 +373,8 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = ;; let is_construct_ref sigma c r = - EConstr.isConstruct sigma c && eq_gr (ConstructRef (fst(EConstr.destConstruct sigma c))) r -let is_ind_ref sigma c r = EConstr.isInd sigma c && eq_gr (IndRef (fst(EConstr.destInd sigma c))) r + EConstr.isConstruct sigma c && GlobRef.equal (ConstructRef (fst(EConstr.destConstruct sigma c))) r +let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (IndRef (fst(EConstr.destInd sigma c))) r let rwcltac cl rdx dir sr gl = let n, r_n,_, ucst = pf_abs_evars gl sr in @@ -415,8 +418,6 @@ let rwcltac cl rdx dir sr gl = then errorstrm Pp.(str "Rewriting impacts evars") else errorstrm Pp.(str "Dependent type error in rewrite of " ++ pr_constr_env (pf_env gl) (project gl) (Term.mkNamedLambda pattern_id (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl))) - | CErrors.UserError _ as e -> raise e - | e -> anomaly ("cvtac's exception: " ^ Printexc.to_string e); in tclTHEN cvtac' rwtac gl @@ -436,7 +437,7 @@ let lz_setoid_relation = | env', srel when env' == env -> srel | _ -> let srel = - try Some (Universes.constr_of_global @@ + try Some (UnivGen.constr_of_global @@ Coqlib.coq_reference "Class_setoid" sdir "RewriteRelation") with _ -> None in last_srel := (env, srel); srel @@ -479,11 +480,11 @@ let rwprocess_rule dir rule gl = | _ -> let ra = Array.append a [|r|] in function 1 -> let sigma, pi1 = Evd.fresh_global env sigma coq_prod.Coqlib.proj1 in - EConstr.mkApp (EConstr.of_constr pi1, ra), sigma + EConstr.mkApp (pi1, ra), sigma | _ -> let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in - EConstr.mkApp (EConstr.of_constr pi2, ra), sigma in - if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ())) then + EConstr.mkApp (pi2, ra), sigma in + if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_True ())) then let s, sigma = sr sigma 2 in loop (converse_dir d) sigma s a.(1) rs 0 else @@ -558,7 +559,7 @@ let rwrxtac occ rdx_pat dir rule gl = let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = let sigma, pat = let rw_progress rhs t evd = rw_progress rhs (EConstr.of_constr t) evd in - mk_tpattern env sigma0 (sigma,EConstr.to_constr sigma r) (rw_progress rhs) d (EConstr.to_constr sigma lhs) in + mk_tpattern env sigma0 (sigma, EConstr.to_constr ~abort_on_undefined_evars:false sigma r) (rw_progress rhs) d (EConstr.to_constr ~abort_on_undefined_evars:false sigma lhs) in sigma, pats @ [pat] in let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in @@ -568,7 +569,7 @@ let rwrxtac occ rdx_pat dir rule gl = let r = ref None in (fun env c _ h -> do_once r (fun () -> find_rule (EConstr.of_constr c), c); mkRel h), (fun concl -> closed0_check concl e gl; - let (d,(ev,ctx,c)) , x = assert_done r in (d,(ev,ctx, EConstr.to_constr ev c)) , x) in + let (d,(ev,ctx,c)) , x = assert_done r in (d,(ev,ctx, EConstr.to_constr ~abort_on_undefined_evars:false ev c)) , x) in let concl0 = EConstr.Unsafe.to_constr concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in let (d, r), rdx = conclude concl in @@ -590,7 +591,10 @@ let ssrinstancesofrule ist dir arg gl = let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = let sigma, pat = let rw_progress rhs t evd = rw_progress rhs (EConstr.of_constr t) evd in - mk_tpattern env sigma0 (sigma,EConstr.to_constr sigma r) (rw_progress rhs) d (EConstr.to_constr sigma lhs) in + mk_tpattern env sigma0 + (sigma,EConstr.to_constr ~abort_on_undefined_evars:false sigma r) + (rw_progress rhs) d + (EConstr.to_constr ~abort_on_undefined_evars:false sigma lhs) in sigma, pats @ [pat] in let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma0 None ~upats_origin rpats in diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index ac2c7824..4810c6e1 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -10,207 +10,210 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(** ## **) + Require Import ssreflect. -(******************************************************************************) -(* This file contains the basic definitions and notations for working with *) -(* functions. The definitions provide for: *) -(* *) -(* - Pair projections: *) -(* p.1 == first element of a pair *) -(* p.2 == second element of a pair *) -(* These notations also apply to p : P /\ Q, via an and >-> pair coercion. *) -(* *) -(* - Simplifying functions, beta-reduced by /= and simpl: *) -(* [fun : T => E] == constant function from type T that returns E *) -(* [fun x => E] == unary function *) -(* [fun x : T => E] == unary function with explicit domain type *) -(* [fun x y => E] == binary function *) -(* [fun x y : T => E] == binary function with common domain type *) -(* [fun (x : T) y => E] \ *) -(* [fun (x : xT) (y : yT) => E] | == binary function with (some) explicit, *) -(* [fun x (y : T) => E] / independent domain types for each argument *) -(* *) -(* - Partial functions using option type: *) -(* oapp f d ox == if ox is Some x returns f x, d otherwise *) -(* odflt d ox == if ox is Some x returns x, d otherwise *) -(* obind f ox == if ox is Some x returns f x, None otherwise *) -(* omap f ox == if ox is Some x returns Some (f x), None otherwise *) -(* *) -(* - Singleton types: *) -(* all_equal_to x0 == x0 is the only value in its type, so any such value *) -(* can be rewritten to x0. *) -(* *) -(* - A generic wrapper type: *) -(* wrapped T == the inductive type with values Wrap x for x : T. *) -(* unwrap w == the projection of w : wrapped T on T. *) -(* wrap x == the canonical injection of x : T into wrapped T; it is *) -(* equivalent to Wrap x, but is declared as a (default) *) -(* Canonical Structure, which lets the Coq HO unification *) -(* automatically expand x into unwrap (wrap x). The delta *) -(* reduction of wrap x to Wrap can be exploited to *) -(* introduce controlled nondeterminism in Canonical *) -(* Structure inference, as in the implementation of *) -(* the mxdirect predicate in matrix.v. *) -(* *) -(* - Sigma types: *) -(* tag w == the i of w : {i : I & T i}. *) -(* tagged w == the T i component of w : {i : I & T i}. *) -(* Tagged T x == the {i : I & T i} with component x : T i. *) -(* tag2 w == the i of w : {i : I & T i & U i}. *) -(* tagged2 w == the T i component of w : {i : I & T i & U i}. *) -(* tagged2' w == the U i component of w : {i : I & T i & U i}. *) -(* Tagged2 T U x y == the {i : I & T i} with components x : T i and y : U i. *) -(* sval u == the x of u : {x : T | P x}. *) -(* s2val u == the x of u : {x : T | P x & Q x}. *) -(* The properties of sval u, s2val u are given by lemmas svalP, s2valP, and *) -(* s2valP'. We provide coercions sigT2 >-> sigT and sig2 >-> sig >-> sigT. *) -(* A suite of lemmas (all_sig, ...) let us skolemize sig, sig2, sigT, sigT2 *) -(* and pair, e.g., *) -(* have /all_sig[f fP] (x : T): {y : U | P y} by ... *) -(* yields an f : T -> U such that fP : forall x, P (f x). *) -(* - Identity functions: *) -(* id == NOTATION for the explicit identity function fun x => x. *) -(* @id T == notation for the explicit identity at type T. *) -(* idfun == an expression with a head constant, convertible to id; *) -(* idfun x simplifies to x. *) -(* @idfun T == the expression above, specialized to type T. *) -(* phant_id x y == the function type phantom _ x -> phantom _ y. *) -(* *** In addition to their casual use in functional programming, identity *) -(* functions are often used to trigger static unification as part of the *) -(* construction of dependent Records and Structures. For example, if we need *) -(* a structure sT over a type T, we take as arguments T, sT, and a "dummy" *) -(* function T -> sort sT: *) -(* Definition foo T sT & T -> sort sT := ... *) -(* We can avoid specifying sT directly by calling foo (@id T), or specify *) -(* the call completely while still ensuring the consistency of T and sT, by *) -(* calling @foo T sT idfun. The phant_id type allows us to extend this trick *) -(* to non-Type canonical projections. It also allows us to sidestep *) -(* dependent type constraints when building explicit records, e.g., given *) -(* Record r := R {x; y : T(x)}. *) -(* if we need to build an r from a given y0 while inferring some x0, such *) -(* that y0 : T(x0), we pose *) -(* Definition mk_r .. y .. (x := ...) y' & phant_id y y' := R x y'. *) -(* Calling @mk_r .. y0 .. id will cause Coq to use y' := y0, while checking *) -(* the dependent type constraint y0 : T(x0). *) -(* *) -(* - Extensional equality for functions and relations (i.e. functions of two *) -(* arguments): *) -(* f1 =1 f2 == f1 x is equal to f2 x for all x. *) -(* f1 =1 f2 :> A == ... and f2 is explicitly typed. *) -(* f1 =2 f2 == f1 x y is equal to f2 x y for all x y. *) -(* f1 =2 f2 :> A == ... and f2 is explicitly typed. *) -(* *) -(* - Composition for total and partial functions: *) -(* f^~ y == function f with second argument specialised to y, *) -(* i.e., fun x => f x y *) -(* CAVEAT: conditional (non-maximal) implicit arguments *) -(* of f are NOT inserted in this context *) -(* @^~ x == application at x, i.e., fun f => f x *) -(* [eta f] == the explicit eta-expansion of f, i.e., fun x => f x *) -(* CAVEAT: conditional (non-maximal) implicit arguments *) -(* of f are NOT inserted in this context. *) -(* fun=> v := the constant function fun _ => v. *) -(* f1 \o f2 == composition of f1 and f2. *) -(* Note: (f1 \o f2) x simplifies to f1 (f2 x). *) -(* f1 \; f2 == categorical composition of f1 and f2. This expands to *) -(* to f2 \o f1 and (f1 \; f2) x simplifies to f2 (f1 x). *) -(* pcomp f1 f2 == composition of partial functions f1 and f2. *) -(* *) -(* *) -(* - Properties of functions: *) -(* injective f <-> f is injective. *) -(* cancel f g <-> g is a left inverse of f / f is a right inverse of g. *) -(* pcancel f g <-> g is a left inverse of f where g is partial. *) -(* ocancel f g <-> g is a left inverse of f where f is partial. *) -(* bijective f <-> f is bijective (has a left and right inverse). *) -(* involutive f <-> f is involutive. *) -(* *) -(* - Properties for operations. *) -(* left_id e op <-> e is a left identity for op (e op x = x). *) -(* right_id e op <-> e is a right identity for op (x op e = x). *) -(* left_inverse e inv op <-> inv is a left inverse for op wrt identity e, *) -(* i.e., (inv x) op x = e. *) -(* right_inverse e inv op <-> inv is a right inverse for op wrt identity e *) -(* i.e., x op (i x) = e. *) -(* self_inverse e op <-> each x is its own op-inverse (x op x = e). *) -(* idempotent op <-> op is idempotent for op (x op x = x). *) -(* associative op <-> op is associative, i.e., *) -(* x op (y op z) = (x op y) op z. *) -(* commutative op <-> op is commutative (x op y = y op x). *) -(* left_commutative op <-> op is left commutative, i.e., *) -(* x op (y op z) = y op (x op z). *) -(* right_commutative op <-> op is right commutative, i.e., *) -(* (x op y) op z = (x op z) op y. *) -(* left_zero z op <-> z is a left zero for op (z op x = z). *) -(* right_zero z op <-> z is a right zero for op (x op z = z). *) -(* left_distributive op1 op2 <-> op1 distributes over op2 to the left: *) -(* (x op2 y) op1 z = (x op1 z) op2 (y op1 z). *) -(* right_distributive op1 op2 <-> op distributes over add to the right: *) -(* x op1 (y op2 z) = (x op1 z) op2 (x op1 z). *) -(* interchange op1 op2 <-> op1 and op2 satisfy an interchange law: *) -(* (x op2 y) op1 (z op2 t) = (x op1 z) op2 (y op1 t). *) -(* Note that interchange op op is a commutativity property. *) -(* left_injective op <-> op is injective in its left argument: *) -(* x op y = z op y -> x = z. *) -(* right_injective op <-> op is injective in its right argument: *) -(* x op y = x op z -> y = z. *) -(* left_loop inv op <-> op, inv obey the inverse loop left axiom: *) -(* (inv x) op (x op y) = y for all x, y, i.e., *) -(* op (inv x) is always a left inverse of op x *) -(* rev_left_loop inv op <-> op, inv obey the inverse loop reverse left *) -(* axiom: x op ((inv x) op y) = y, for all x, y. *) -(* right_loop inv op <-> op, inv obey the inverse loop right axiom: *) -(* (x op y) op (inv y) = x for all x, y. *) -(* rev_right_loop inv op <-> op, inv obey the inverse loop reverse right *) -(* axiom: (x op y) op (inv y) = x for all x, y. *) -(* Note that familiar "cancellation" identities like x + y - y = x or *) -(* x - y + y = x are respectively instances of right_loop and rev_right_loop *) -(* The corresponding lemmas will use the K and NK/VK suffixes, respectively. *) -(* *) -(* - Morphisms for functions and relations: *) -(* {morph f : x / a >-> r} <-> f is a morphism with respect to functions *) -(* (fun x => a) and (fun x => r); if r == R[x], *) -(* this states that f a = R[f x] for all x. *) -(* {morph f : x / a} <-> f is a morphism with respect to the *) -(* function expression (fun x => a). This is *) -(* shorthand for {morph f : x / a >-> a}; note *) -(* that the two instances of a are often *) -(* interpreted at different types. *) -(* {morph f : x y / a >-> r} <-> f is a morphism with respect to functions *) -(* (fun x y => a) and (fun x y => r). *) -(* {morph f : x y / a} <-> f is a morphism with respect to the *) -(* function expression (fun x y => a). *) -(* {homo f : x / a >-> r} <-> f is a homomorphism with respect to the *) -(* predicates (fun x => a) and (fun x => r); *) -(* if r == R[x], this states that a -> R[f x] *) -(* for all x. *) -(* {homo f : x / a} <-> f is a homomorphism with respect to the *) -(* predicate expression (fun x => a). *) -(* {homo f : x y / a >-> r} <-> f is a homomorphism with respect to the *) -(* relations (fun x y => a) and (fun x y => r). *) -(* {homo f : x y / a} <-> f is a homomorphism with respect to the *) -(* relation expression (fun x y => a). *) -(* {mono f : x / a >-> r} <-> f is monotone with respect to projectors *) -(* (fun x => a) and (fun x => r); if r == R[x], *) -(* this states that R[f x] = a for all x. *) -(* {mono f : x / a} <-> f is monotone with respect to the projector *) -(* expression (fun x => a). *) -(* {mono f : x y / a >-> r} <-> f is monotone with respect to relators *) -(* (fun x y => a) and (fun x y => r). *) -(* {mono f : x y / a} <-> f is monotone with respect to the relator *) -(* expression (fun x y => a). *) -(* *) -(* The file also contains some basic lemmas for the above concepts. *) -(* Lemmas relative to cancellation laws use some abbreviated suffixes: *) -(* K - a cancellation rule like esymK : cancel (@esym T x y) (@esym T y x). *) -(* LR - a lemma moving an operation from the left hand side of a relation to *) -(* the right hand side, like canLR: cancel g f -> x = g y -> f x = y. *) -(* RL - a lemma moving an operation from the right to the left, e.g., canRL. *) -(* Beware that the LR and RL orientations refer to an "apply" (back chaining) *) -(* usage; when using the same lemmas with "have" or "move" (forward chaining) *) -(* the directions will be reversed!. *) -(******************************************************************************) + +(** + This file contains the basic definitions and notations for working with + functions. The definitions provide for: + + - Pair projections: + p.1 == first element of a pair + p.2 == second element of a pair + These notations also apply to p : P /\ Q, via an and >-> pair coercion. + + - Simplifying functions, beta-reduced by /= and simpl: + #[#fun : T => E#]# == constant function from type T that returns E + #[#fun x => E#]# == unary function + #[#fun x : T => E#]# == unary function with explicit domain type + #[#fun x y => E#]# == binary function + #[#fun x y : T => E#]# == binary function with common domain type + #[#fun (x : T) y => E#]# \ + #[#fun (x : xT) (y : yT) => E#]# | == binary function with (some) explicit, + #[#fun x (y : T) => E#]# / independent domain types for each argument + + - Partial functions using option type: + oapp f d ox == if ox is Some x returns f x, d otherwise + odflt d ox == if ox is Some x returns x, d otherwise + obind f ox == if ox is Some x returns f x, None otherwise + omap f ox == if ox is Some x returns Some (f x), None otherwise + + - Singleton types: + all_equal_to x0 == x0 is the only value in its type, so any such value + can be rewritten to x0. + + - A generic wrapper type: + wrapped T == the inductive type with values Wrap x for x : T. + unwrap w == the projection of w : wrapped T on T. + wrap x == the canonical injection of x : T into wrapped T; it is + equivalent to Wrap x, but is declared as a (default) + Canonical Structure, which lets the Coq HO unification + automatically expand x into unwrap (wrap x). The delta + reduction of wrap x to Wrap can be exploited to + introduce controlled nondeterminism in Canonical + Structure inference, as in the implementation of + the mxdirect predicate in matrix.v. + + - Sigma types: + tag w == the i of w : {i : I & T i}. + tagged w == the T i component of w : {i : I & T i}. + Tagged T x == the {i : I & T i} with component x : T i. + tag2 w == the i of w : {i : I & T i & U i}. + tagged2 w == the T i component of w : {i : I & T i & U i}. + tagged2' w == the U i component of w : {i : I & T i & U i}. + Tagged2 T U x y == the {i : I & T i} with components x : T i and y : U i. + sval u == the x of u : {x : T | P x}. + s2val u == the x of u : {x : T | P x & Q x}. + The properties of sval u, s2val u are given by lemmas svalP, s2valP, and + s2valP'. We provide coercions sigT2 >-> sigT and sig2 >-> sig >-> sigT. + A suite of lemmas (all_sig, ...) let us skolemize sig, sig2, sigT, sigT2 + and pair, e.g., + have /all_sig#[#f fP#]# (x : T): {y : U | P y} by ... + yields an f : T -> U such that fP : forall x, P (f x). + - Identity functions: + id == NOTATION for the explicit identity function fun x => x. + @id T == notation for the explicit identity at type T. + idfun == an expression with a head constant, convertible to id; + idfun x simplifies to x. + @idfun T == the expression above, specialized to type T. + phant_id x y == the function type phantom _ x -> phantom _ y. + *** In addition to their casual use in functional programming, identity + functions are often used to trigger static unification as part of the + construction of dependent Records and Structures. For example, if we need + a structure sT over a type T, we take as arguments T, sT, and a "dummy" + function T -> sort sT: + Definition foo T sT & T -> sort sT := ... + We can avoid specifying sT directly by calling foo (@id T), or specify + the call completely while still ensuring the consistency of T and sT, by + calling @foo T sT idfun. The phant_id type allows us to extend this trick + to non-Type canonical projections. It also allows us to sidestep + dependent type constraints when building explicit records, e.g., given + Record r := R {x; y : T(x)}. + if we need to build an r from a given y0 while inferring some x0, such + that y0 : T(x0), we pose + Definition mk_r .. y .. (x := ...) y' & phant_id y y' := R x y'. + Calling @mk_r .. y0 .. id will cause Coq to use y' := y0, while checking + the dependent type constraint y0 : T(x0). + + - Extensional equality for functions and relations (i.e. functions of two + arguments): + f1 =1 f2 == f1 x is equal to f2 x for all x. + f1 =1 f2 :> A == ... and f2 is explicitly typed. + f1 =2 f2 == f1 x y is equal to f2 x y for all x y. + f1 =2 f2 :> A == ... and f2 is explicitly typed. + + - Composition for total and partial functions: + f^~ y == function f with second argument specialised to y, + i.e., fun x => f x y + CAVEAT: conditional (non-maximal) implicit arguments + of f are NOT inserted in this context + @^~ x == application at x, i.e., fun f => f x + #[#eta f#]# == the explicit eta-expansion of f, i.e., fun x => f x + CAVEAT: conditional (non-maximal) implicit arguments + of f are NOT inserted in this context. + fun=> v := the constant function fun _ => v. + f1 \o f2 == composition of f1 and f2. + Note: (f1 \o f2) x simplifies to f1 (f2 x). + f1 \; f2 == categorical composition of f1 and f2. This expands to + to f2 \o f1 and (f1 \; f2) x simplifies to f2 (f1 x). + pcomp f1 f2 == composition of partial functions f1 and f2. + + + - Properties of functions: + injective f <-> f is injective. + cancel f g <-> g is a left inverse of f / f is a right inverse of g. + pcancel f g <-> g is a left inverse of f where g is partial. + ocancel f g <-> g is a left inverse of f where f is partial. + bijective f <-> f is bijective (has a left and right inverse). + involutive f <-> f is involutive. + + - Properties for operations. + left_id e op <-> e is a left identity for op (e op x = x). + right_id e op <-> e is a right identity for op (x op e = x). + left_inverse e inv op <-> inv is a left inverse for op wrt identity e, + i.e., (inv x) op x = e. + right_inverse e inv op <-> inv is a right inverse for op wrt identity e + i.e., x op (i x) = e. + self_inverse e op <-> each x is its own op-inverse (x op x = e). + idempotent op <-> op is idempotent for op (x op x = x). + associative op <-> op is associative, i.e., + x op (y op z) = (x op y) op z. + commutative op <-> op is commutative (x op y = y op x). + left_commutative op <-> op is left commutative, i.e., + x op (y op z) = y op (x op z). + right_commutative op <-> op is right commutative, i.e., + (x op y) op z = (x op z) op y. + left_zero z op <-> z is a left zero for op (z op x = z). + right_zero z op <-> z is a right zero for op (x op z = z). + left_distributive op1 op2 <-> op1 distributes over op2 to the left: + (x op2 y) op1 z = (x op1 z) op2 (y op1 z). + right_distributive op1 op2 <-> op distributes over add to the right: + x op1 (y op2 z) = (x op1 z) op2 (x op1 z). + interchange op1 op2 <-> op1 and op2 satisfy an interchange law: + (x op2 y) op1 (z op2 t) = (x op1 z) op2 (y op1 t). + Note that interchange op op is a commutativity property. + left_injective op <-> op is injective in its left argument: + x op y = z op y -> x = z. + right_injective op <-> op is injective in its right argument: + x op y = x op z -> y = z. + left_loop inv op <-> op, inv obey the inverse loop left axiom: + (inv x) op (x op y) = y for all x, y, i.e., + op (inv x) is always a left inverse of op x + rev_left_loop inv op <-> op, inv obey the inverse loop reverse left + axiom: x op ((inv x) op y) = y, for all x, y. + right_loop inv op <-> op, inv obey the inverse loop right axiom: + (x op y) op (inv y) = x for all x, y. + rev_right_loop inv op <-> op, inv obey the inverse loop reverse right + axiom: (x op y) op (inv y) = x for all x, y. + Note that familiar "cancellation" identities like x + y - y = x or + x - y + y = x are respectively instances of right_loop and rev_right_loop + The corresponding lemmas will use the K and NK/VK suffixes, respectively. + + - Morphisms for functions and relations: + {morph f : x / a >-> r} <-> f is a morphism with respect to functions + (fun x => a) and (fun x => r); if r == R#[#x#]#, + this states that f a = R#[#f x#]# for all x. + {morph f : x / a} <-> f is a morphism with respect to the + function expression (fun x => a). This is + shorthand for {morph f : x / a >-> a}; note + that the two instances of a are often + interpreted at different types. + {morph f : x y / a >-> r} <-> f is a morphism with respect to functions + (fun x y => a) and (fun x y => r). + {morph f : x y / a} <-> f is a morphism with respect to the + function expression (fun x y => a). + {homo f : x / a >-> r} <-> f is a homomorphism with respect to the + predicates (fun x => a) and (fun x => r); + if r == R#[#x#]#, this states that a -> R#[#f x#]# + for all x. + {homo f : x / a} <-> f is a homomorphism with respect to the + predicate expression (fun x => a). + {homo f : x y / a >-> r} <-> f is a homomorphism with respect to the + relations (fun x y => a) and (fun x y => r). + {homo f : x y / a} <-> f is a homomorphism with respect to the + relation expression (fun x y => a). + {mono f : x / a >-> r} <-> f is monotone with respect to projectors + (fun x => a) and (fun x => r); if r == R#[#x#]#, + this states that R#[#f x#]# = a for all x. + {mono f : x / a} <-> f is monotone with respect to the projector + expression (fun x => a). + {mono f : x y / a >-> r} <-> f is monotone with respect to relators + (fun x y => a) and (fun x y => r). + {mono f : x y / a} <-> f is monotone with respect to the relator + expression (fun x y => a). + + The file also contains some basic lemmas for the above concepts. + Lemmas relative to cancellation laws use some abbreviated suffixes: + K - a cancellation rule like esymK : cancel (@esym T x y) (@esym T y x). + LR - a lemma moving an operation from the left hand side of a relation to + the right hand side, like canLR: cancel g f -> x = g y -> f x = y. + RL - a lemma moving an operation from the right to the left, e.g., canRL. + Beware that the LR and RL orientations refer to an "apply" (back chaining) + usage; when using the same lemmas with "have" or "move" (forward chaining) + the directions will be reversed!. **) + Set Implicit Arguments. Unset Strict Implicit. @@ -219,7 +222,7 @@ Unset Printing Implicit Defensive. Delimit Scope fun_scope with FUN. Open Scope fun_scope. -(* Notations for argument transpose *) +(** Notations for argument transpose **) Notation "f ^~ y" := (fun x => f x y) (at level 10, y at level 8, no associativity, format "f ^~ y") : fun_scope. Notation "@^~ x" := (fun f => f x) @@ -228,7 +231,7 @@ Notation "@^~ x" := (fun f => f x) Delimit Scope pair_scope with PAIR. Open Scope pair_scope. -(* Notations for pair/conjunction projections *) +(** Notations for pair/conjunction projections **) Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1") : pair_scope. Notation "p .2" := (snd p) @@ -239,8 +242,9 @@ Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). Definition all_pair I T U (w : forall i : I, T i * U i) := (fun i => (w i).1, fun i => (w i).2). -(* Complements on the option type constructor, used below to *) -(* encode partial functions. *) +(** + Complements on the option type constructor, used below to + encode partial functions. **) Module Option. @@ -260,7 +264,7 @@ Notation obind := Option.bind. Notation omap := Option.map. Notation some := (@Some _) (only parsing). -(* Shorthand for some basic equality lemmas. *) +(** Shorthand for some basic equality lemmas. **) Notation erefl := refl_equal. Notation ecast i T e x := (let: erefl in _ = i := e return T in x). @@ -269,31 +273,32 @@ Definition nesym := sym_not_eq. Definition etrans := trans_eq. Definition congr1 := f_equal. Definition congr2 := f_equal2. -(* Force at least one implicit when used as a view. *) +(** Force at least one implicit when used as a view. **) Prenex Implicits esym nesym. -(* A predicate for singleton types. *) +(** A predicate for singleton types. **) Definition all_equal_to T (x0 : T) := forall x, unkeyed x = x0. Lemma unitE : all_equal_to tt. Proof. by case. Qed. -(* A generic wrapper type *) +(** A generic wrapper type **) Structure wrapped T := Wrap {unwrap : T}. Canonical wrap T x := @Wrap T x. Prenex Implicits unwrap wrap Wrap. -(* Syntax for defining auxiliary recursive function. *) -(* Usage: *) -(* Section FooDefinition. *) -(* Variables (g1 : T1) (g2 : T2). (globals) *) -(* Fixoint foo_auxiliary (a3 : T3) ... := *) -(* body, using [rec e3, ...] for recursive calls *) -(* where "[ 'rec' a3 , a4 , ... ]" := foo_auxiliary. *) -(* Definition foo x y .. := [rec e1, ...]. *) -(* + proofs about foo *) -(* End FooDefinition. *) +(** + Syntax for defining auxiliary recursive function. + Usage: + Section FooDefinition. + Variables (g1 : T1) (g2 : T2). (globals) + Fixoint foo_auxiliary (a3 : T3) ... := + body, using #[#rec e3, ... #]# for recursive calls + where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. + Definition foo x y .. := #[#rec e1, ... #]#. + + proofs about foo + End FooDefinition. **) Reserved Notation "[ 'rec' a0 ]" (at level 0, format "[ 'rec' a0 ]"). @@ -319,14 +324,15 @@ Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]" (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"). -(* Definitions and notation for explicit functions with simplification, *) -(* i.e., which simpl and /= beta expand (this is complementary to nosimpl). *) +(** + Definitions and notation for explicit functions with simplification, + i.e., which simpl and /= beta expand (this is complementary to nosimpl). **) Section SimplFun. Variables aT rT : Type. -CoInductive simpl_fun := SimplFun of aT -> rT. +Variant simpl_fun := SimplFun of aT -> rT. Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. @@ -362,11 +368,12 @@ Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" := (fun x : xT => [fun y : yT => E]) (at level 0, x ident, y ident, only parsing) : fun_scope. -(* For delta functions in eqtype.v. *) +(** For delta functions in eqtype.v. **) Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. -(* Extensional equality, for unary and binary functions, including syntactic *) -(* sugar. *) +(** + Extensional equality, for unary and binary functions, including syntactic + sugar. **) Section ExtensionalEquality. @@ -439,7 +446,7 @@ Notation "@ 'idfun' T " := (@id_head T explicit_id_key) Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. -(* Strong sigma types. *) +(** Strong sigma types. **) Section Tag. @@ -473,9 +480,9 @@ Lemma all_tag2 I T U V : {f : forall i, T i & forall i, U i (f i) & forall i, V i (f i)}. Proof. by case/all_tag=> f /all_pair[]; exists f. Qed. -(* Refinement types. *) +(** Refinement types. **) -(* Prenex Implicits and renaming. *) +(** Prenex Implicits and renaming. **) Notation sval := (@proj1_sig _ _). Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'"). @@ -514,16 +521,16 @@ Section Morphism. Variables (aT rT sT : Type) (f : aT -> rT). -(* Morphism property for unary and binary functions *) +(** Morphism property for unary and binary functions **) Definition morphism_1 aF rF := forall x, f (aF x) = rF (f x). Definition morphism_2 aOp rOp := forall x y, f (aOp x y) = rOp (f x) (f y). -(* Homomorphism property for unary and binary relations *) +(** Homomorphism property for unary and binary relations **) Definition homomorphism_1 (aP rP : _ -> Prop) := forall x, aP x -> rP (f x). Definition homomorphism_2 (aR rR : _ -> _ -> Prop) := forall x y, aR x y -> rR (f x) (f y). -(* Stability property for unary and binary relations *) +(** Stability property for unary and binary relations **) Definition monomorphism_1 (aP rP : _ -> sT) := forall x, rP (f x) = aP x. Definition monomorphism_2 (aR rR : _ -> _ -> sT) := forall x y, rR (f x) (f y) = aR x y. @@ -600,16 +607,18 @@ Notation "{ 'mono' f : x y /~ a }" := (at level 0, f at level 99, x ident, y ident, format "{ 'mono' f : x y /~ a }") : type_scope. -(* In an intuitionistic setting, we have two degrees of injectivity. The *) -(* weaker one gives only simplification, and the strong one provides a left *) -(* inverse (we show in `fintype' that they coincide for finite types). *) -(* We also define an intermediate version where the left inverse is only a *) -(* partial function. *) +(** + In an intuitionistic setting, we have two degrees of injectivity. The + weaker one gives only simplification, and the strong one provides a left + inverse (we show in `fintype' that they coincide for finite types). + We also define an intermediate version where the left inverse is only a + partial function. **) Section Injections. -(* rT must come first so we can use @ to mitigate the Coq 1st order *) -(* unification bug (e..g., Coq can't infer rT from a "cancel" lemma). *) +(** + rT must come first so we can use @ to mitigate the Coq 1st order + unification bug (e..g., Coq can't infer rT from a "cancel" lemma). **) Variables (rT aT : Type) (f : aT -> rT). Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. @@ -639,10 +648,10 @@ End Injections. Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed. -(* Force implicits to use as a view. *) +(** Force implicits to use as a view. **) Prenex Implicits Some_inj. -(* cancellation lemmas for dependent type casts. *) +(** cancellation lemmas for dependent type casts. **) Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). Proof. by case: y /. Qed. @@ -684,7 +693,7 @@ Section Bijections. Variables (A B : Type) (f : B -> A). -CoInductive bijective : Prop := Bijective g of cancel f g & cancel g f. +Variant bijective : Prop := Bijective g of cancel f g & cancel g f. Hypothesis bijf : bijective. diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index a5765feb..e367cd32 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -68,25 +68,18 @@ open Ssripats let ssrhaveNOtcresolution = Summary.ref ~name:"SSR:havenotcresolution" false -let inHaveTCResolution = Libobject.declare_object { - (Libobject.default_object "SSRHAVETCRESOLUTION") with - Libobject.cache_function = (fun (_,v) -> ssrhaveNOtcresolution := v); - Libobject.load_function = (fun _ (_,v) -> ssrhaveNOtcresolution := v); - Libobject.classify_function = (fun v -> Libobject.Keep v); -} let _ = Goptions.declare_bool_option { Goptions.optname = "have type classes"; Goptions.optkey = ["SsrHave";"NoTCResolution"]; Goptions.optread = (fun _ -> !ssrhaveNOtcresolution); Goptions.optdepr = false; - Goptions.optwrite = (fun b -> - Lib.add_anonymous_leaf (inHaveTCResolution b)) } + Goptions.optwrite = (fun b -> ssrhaveNOtcresolution := b); + } open Constrexpr open Glob_term -open Misctypes let combineCG t1 t2 f g = match t1, t2 with | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) @@ -184,9 +177,7 @@ let havetac ist let gs = List.map (fun (_,a) -> Ssripats.Internal.pf_find_abstract_proof false gl (EConstr.Unsafe.to_constr a.(1))) skols_args in - let tacopen_skols gl = - let stuff, g = Refiner.unpackage gl in - Refiner.repackage stuff (gs @ [g]) in + let tacopen_skols gl = re_sig (gs @ [gl.Evd.it]) gl.Evd.sigma in let gl, ty = pf_e_type_of gl t in gl, ty, Proofview.V82.of_tactic (Tactics.apply t), id, Tacticals.tclTHEN (Tacticals.tclTHEN itac_c simpltac) diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 35036b6c..37dd00a7 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -12,6 +12,7 @@ open Ssrmatching_plugin open Util open Names +open Constr open Proofview open Proofview.Notations @@ -90,11 +91,11 @@ open State (** Warning: unlike [nb_deps_assums], it does not perform reduction *) let rec nb_assums cur env sigma t = match EConstr.kind sigma t with - | Term.Prod(name,ty,body) -> + | Prod(name,ty,body) -> nb_assums (cur+1) env sigma body - | Term.LetIn(name,ty,t1,t2) -> + | LetIn(name,ty,t1,t2) -> nb_assums (cur+1) env sigma t2 - | Term.Cast(t,_,_) -> + | Cast(t,_,_) -> nb_assums cur env sigma t | _ -> cur let nb_assums = nb_assums 0 @@ -118,13 +119,10 @@ let intro_end = Ssrcommon.tcl0G (isCLR_CONSUME) (** [=> _] *****************************************************************) -let intro_clear ids future_ipats = +let intro_clear ids = Goal.enter begin fun gl -> let _, clear_ids, ren = List.fold_left (fun (used_ids, clear_ids, ren) id -> - if not(Ssrcommon.is_name_in_ipats id future_ipats) then begin - used_ids, id :: clear_ids, ren - end else let new_id = Ssrcommon.mk_anon_id (Id.to_string id) used_ids in (new_id :: used_ids, new_id :: clear_ids, (id, new_id) :: ren)) (Tacmach.New.pf_ids_of_hyps gl, [], []) ids @@ -212,22 +210,25 @@ let tclLOG p t = tclUNIT () end -let rec ipat_tac1 future_ipats ipat : unit tactic = +let rec ipat_tac1 ipat : unit tactic = match ipat with - | IPatView l -> - Ssrview.tclIPAT_VIEWS ~views:l - ~conclusion:(fun ~to_clear:clr -> intro_clear clr future_ipats) - | IPatDispatch ipatss -> - tclEXTEND (List.map (ipat_tac future_ipats) ipatss) (tclUNIT ()) [] + | IPatView (clear_if_id,l) -> + Ssrview.tclIPAT_VIEWS ~views:l ~clear_if_id + ~conclusion:(fun ~to_clear:clr -> intro_clear clr) + + | IPatDispatch(true,[[]]) -> + tclUNIT () + | IPatDispatch(_,ipatss) -> + tclDISPATCH (List.map ipat_tac ipatss) | IPatId id -> Ssrcommon.tclINTRO_ID id | IPatCase ipatss -> - tclIORPAT (Ssrcommon.tclWITHTOP tac_case) future_ipats ipatss + tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss | IPatInj ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) - future_ipats ipatss + ipatss | IPatAnon Drop -> intro_drop | IPatAnon One -> Ssrcommon.tclINTRO_ANON @@ -238,7 +239,7 @@ let rec ipat_tac1 future_ipats ipat : unit tactic = | IPatClear ids -> tacCHECK_HYPS_EXIST ids <*> - intro_clear (List.map Ssrcommon.hyp_id ids) future_ipats + intro_clear (List.map Ssrcommon.hyp_id ids) | IPatSimpl (Simpl n) -> V82.tactic ~nf_evars:false (Ssrequality.simpltac (Simpl n)) @@ -255,17 +256,17 @@ let rec ipat_tac1 future_ipats ipat : unit tactic = | IPatTac t -> t -and ipat_tac future_ipats pl : unit tactic = +and ipat_tac pl : unit tactic = match pl with | [] -> tclUNIT () | pat :: pl -> - Ssrcommon.tcl0G (tclLOG pat (ipat_tac1 (pl @ future_ipats))) <*> + Ssrcommon.tcl0G (tclLOG pat ipat_tac1) <*> isTICK pat <*> - ipat_tac future_ipats pl + ipat_tac pl -and tclIORPAT tac future_ipats = function +and tclIORPAT tac = function | [[]] -> tac - | p -> Tacticals.New.tclTHENS tac (List.map (ipat_tac future_ipats) p) + | p -> Tacticals.New.tclTHENS tac (List.map ipat_tac p) let split_at_first_case ipats = let rec loop acc = function @@ -276,17 +277,32 @@ let split_at_first_case ipats = loop [] ipats let ssr_exception is_on = function - | Some (IPatCase l) when is_on -> Some (IPatDispatch l) + | Some (IPatCase l) when is_on -> Some (IPatDispatch(true, l)) | x -> x let option_to_list = function None -> [] | Some x -> [x] +(* Simple pass doing {x}/v -> /v{x} *) +let elaborate_ipats l = + let rec elab = function + | [] -> [] + | (IPatClear _ as p1) :: (IPatView _ as p2) :: rest -> p2 :: p1 :: elab rest + | IPatDispatch(s,p) :: rest -> IPatDispatch (s,List.map elab p) :: elab rest + | IPatCase p :: rest -> IPatCase (List.map elab p) :: elab rest + | IPatInj p :: rest -> IPatInj (List.map elab p) :: elab rest + | (IPatTac _ | IPatId _ | IPatSimpl _ | IPatClear _ | + IPatAnon _ | IPatView _ | IPatNoop | IPatRewrite _ | + IPatAbstractVars _) as x :: rest -> x :: elab rest + in + elab l + let main ?eqtac ~first_case_is_dispatch ipats = + let ipats = elaborate_ipats ipats in let ip_before, case, ip_after = split_at_first_case ipats in let case = ssr_exception first_case_is_dispatch case in let case = option_to_list case in let eqtac = option_to_list (Option.map (fun x -> IPatTac x) eqtac) in - Ssrcommon.tcl0G (ipat_tac [] (ip_before @ case @ eqtac @ ip_after) <*> intro_end) + Ssrcommon.tcl0G (ipat_tac (ip_before @ case @ eqtac @ ip_after) <*> intro_end) end (* }}} *) @@ -366,8 +382,9 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = let ctx, last = EConstr.decompose_prod_assum sigma concl in let args = match EConstr.kind_of_type sigma last with | Term.AtomicType (hd, args) -> - assert(Ssrcommon.is_protect hd env sigma); - args + if Ssrcommon.is_protect hd env sigma then args + else Ssrcommon.errorstrm + (Pp.str "Too many names in intro pattern") | _ -> assert false in let case = args.(Array.length args-1) in if not(EConstr.Vars.closed0 sigma case) @@ -419,7 +436,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin Goal.enter_one begin fun g -> let pat = Ssrmatching.interp_cpattern sigma0 t None in let cl0, env, sigma, hyps = Goal.(concl g, env g, sigma g, hyps g) in - let cl = EConstr.to_constr sigma cl0 in + let cl = EConstr.to_constr ~abort_on_undefined_evars:false sigma cl0 in let (c, ucst), cl = try Ssrmatching.fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 with Ssrmatching.NoMatch -> Ssrmatching.redex_of_pattern env pat, cl in @@ -556,7 +573,7 @@ let rec eqmoveipats eqpat = function let ssrsmovetac = Goal.enter begin fun g -> let sigma, concl = Goal.(sigma g, concl g) in match EConstr.kind sigma concl with - | Term.Prod _ | Term.LetIn _ -> tclUNIT () + | Prod _ | LetIn _ -> tclUNIT () | _ -> Tactics.hnf_in_concl end @@ -575,7 +592,7 @@ let ssrmovetac = function (tacVIEW_THEN_GRAB view ~conclusion) <*> tclIPAT (IPatClear clr :: ipats) | _::_ as view, (_, ({ gens = []; clr }, ipats)) -> - tclIPAT (IPatView view :: IPatClear clr :: ipats) + tclIPAT (IPatView (false,view) :: IPatClear clr :: ipats) | _, (Some pat, (dgens, ipats)) -> let dgentac = with_dgens dgens eqmovetac in dgentac <*> tclIPAT (eqmoveipats pat ipats) @@ -594,8 +611,8 @@ let rec is_Evar_or_CastedMeta sigma x = let occur_existential_or_casted_meta sigma c = let rec occrec c = match EConstr.kind sigma c with - | Term.Evar _ -> raise Not_found - | Term.Cast (m,_,_) when EConstr.isMeta sigma m -> raise Not_found + | Evar _ -> raise Not_found + | Cast (m,_,_) when EConstr.isMeta sigma m -> raise Not_found | _ -> EConstr.iter sigma occrec c in try occrec c; false @@ -624,8 +641,8 @@ let tacFIND_ABSTRACT_PROOF check_lock abstract_n = Goal.enter_one ~__LOC__ begin fun g -> let sigma, env = Goal.(sigma g, env g) in let l = Evd.fold_undefined (fun e ei l -> - match EConstr.kind sigma (EConstr.of_constr ei.Evd.evar_concl) with - | Term.App(hd, [|ty; n; lock|]) + match EConstr.kind sigma ei.Evd.evar_concl with + | App(hd, [|ty; n; lock|]) when (not check_lock || (occur_existential_or_casted_meta sigma ty && is_Evar_or_CastedMeta sigma lock)) && @@ -654,8 +671,8 @@ let ssrabstract dgens = let sigma, env, concl = Goal.(sigma g, env g, concl g) in let t = args_id.(0) in match EConstr.kind sigma t with - | (Term.Evar _ | Term.Meta _) -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id - | Term.Cast(m,_,_) + | (Evar _ | Meta _) -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id + | Cast(m,_,_) when EConstr.isEvar sigma m || EConstr.isMeta sigma m -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id | _ -> diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 5f396744..eb69dca9 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -10,6 +10,7 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +let _vmcast = Constr.VMcast open Names open Pp open Pcoq @@ -17,18 +18,19 @@ open Ltac_plugin open Genarg open Stdarg open Tacarg -open Term open Libnames open Tactics open Tacmach open Util +open Locus open Tacexpr open Tacinterp open Pltac open Extraargs open Ppconstr -open Misctypes +open Namegen +open Tactypes open Decl_kinds open Constrexpr open Constrexpr_ops @@ -64,7 +66,7 @@ DECLARE PLUGIN "ssreflect_plugin" * we thus save the lexer to restore it at the end of the file *) let frozen_lexer = CLexer.get_keyword_state () ;; -let tacltop = (5,Notation_term.E) +let tacltop = (5,Notation_gram.E) let pr_ssrtacarg _ _ prt = prt tacltop ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg @@ -301,24 +303,24 @@ END let pr_index = function - | Misctypes.ArgVar {CAst.v=id} -> pr_id id - | Misctypes.ArgArg n when n > 0 -> int n + | ArgVar {CAst.v=id} -> pr_id id + | ArgArg n when n > 0 -> int n | _ -> mt () let pr_ssrindex _ _ _ = pr_index -let noindex = Misctypes.ArgArg 0 +let noindex = ArgArg 0 let check_index ?loc i = if i > 0 then i else CErrors.user_err ?loc (str"Index not positive") let mk_index ?loc = function - | Misctypes.ArgArg i -> Misctypes.ArgArg (check_index ?loc i) + | ArgArg i -> ArgArg (check_index ?loc i) | iv -> iv let interp_index ist gl idx = Tacmach.project gl, match idx with - | Misctypes.ArgArg _ -> idx - | Misctypes.ArgVar id -> + | ArgArg _ -> idx + | ArgVar id -> let i = try let v = Id.Map.find id.CAst.v ist.Tacinterp.lfun in @@ -336,7 +338,7 @@ let interp_index ist gl idx = | None -> raise Not_found end end with _ -> CErrors.user_err ?loc:id.CAst.loc (str"Index not a number") in - Misctypes.ArgArg (check_index ?loc:id.CAst.loc i) + ArgArg (check_index ?loc:id.CAst.loc i) open Pltac @@ -410,8 +412,8 @@ let pr_docc = function let pr_ssrdocc _ _ _ = pr_docc ARGUMENT EXTEND ssrdocc TYPED AS ssrclear option * ssrocc PRINTED BY pr_ssrdocc -| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ mkclr clr ] | [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] END (* Old kinds of terms *) @@ -543,7 +545,7 @@ END let remove_loc x = x.CAst.v -let ipat_of_intro_pattern p = Misctypes.( +let ipat_of_intro_pattern p = Tactypes.( let rec ipat_of_intro_pattern = function | IntroNaming (IntroIdentifier id) -> IPatId id | IntroAction IntroWildcard -> IPatAnon Drop @@ -574,9 +576,9 @@ let rec map_ipat map_id map_ssrhyp map_ast_closure_term = function | IPatAbstractVars l -> IPatAbstractVars (List.map map_id l) | IPatClear clr -> IPatClear (List.map map_ssrhyp clr) | IPatCase iorpat -> IPatCase (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) - | IPatDispatch iorpat -> IPatDispatch (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) + | IPatDispatch (s,iorpat) -> IPatDispatch (s,List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) | IPatInj iorpat -> IPatInj (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) - | IPatView v -> IPatView (List.map map_ast_closure_term v) + | IPatView (clr,v) -> IPatView (clr,List.map map_ast_closure_term v) | IPatTac _ -> assert false (*internal usage only *) let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat @@ -595,16 +597,15 @@ let intern_ipats ist = List.map (intern_ipat ist) let interp_intro_pattern = interp_wit wit_intro_pattern -let interp_introid ist gl id = Misctypes.( +let interp_introid ist gl id = try IntroNaming (IntroIdentifier (hyp_id (snd (interp_hyp ist gl (SsrHyp (Loc.tag id)))))) with _ -> (snd (interp_intro_pattern ist gl (CAst.make @@ IntroNaming (IntroIdentifier id)))).CAst.v -) let get_intro_id = function | IntroNaming (IntroIdentifier id) -> id | _ -> assert false -let rec add_intro_pattern_hyps ipat hyps = Misctypes.( +let rec add_intro_pattern_hyps ipat hyps = let {CAst.loc=loc;v=ipat} = ipat in match ipat with | IntroNaming (IntroIdentifier id) -> @@ -623,7 +624,6 @@ let rec add_intro_pattern_hyps ipat hyps = Misctypes.( | IntroForthcoming _ -> (* As in ipat_of_intro_pattern, was unable to determine which kind of ipat interp_introid could return [HH] *) assert false -) (* We interp the ipat using the standard ltac machinery for ids, since * we have no clue what a name could be bound to (maybe another ipat) *) @@ -641,12 +641,12 @@ let interp_ipat ist gl = check_hyps_uniq [] clr'; IPatClear clr' | IPatCase(iorpat) -> IPatCase(List.map (List.map interp) iorpat) - | IPatDispatch(iorpat) -> - IPatDispatch(List.map (List.map interp) iorpat) + | IPatDispatch(s,iorpat) -> + IPatDispatch(s,List.map (List.map interp) iorpat) | IPatInj iorpat -> IPatInj (List.map (List.map interp) iorpat) | IPatAbstractVars l -> IPatAbstractVars (List.map get_intro_id (List.map (interp_introid ist gl) l)) - | IPatView l -> IPatView (List.map (fun x -> snd(interp_ast_closure_term ist + | IPatView (clr,l) -> IPatView (clr,List.map (fun x -> snd(interp_ast_closure_term ist gl x)) l) | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x | IPatTac _ -> assert false (*internal usage only *) @@ -683,11 +683,17 @@ ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats (* TODO | [ "+" ] -> [ [IPatAnon Temporary] ] *) | [ ssrsimpl_ne(sim) ] -> [ [IPatSimpl sim] ] | [ ssrdocc(occ) "->" ] -> [ match occ with + | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") | None, occ -> [IPatRewrite (occ, L2R)] | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, L2R)]] | [ ssrdocc(occ) "<-" ] -> [ match occ with + | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") | None, occ -> [IPatRewrite (occ, R2L)] | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, R2L)]] + | [ ssrdocc(occ) ssrfwdview(v) ] -> [ match occ with + | Some [], _ -> [IPatView (true,v)] + | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl;IPatView (false,v)] + | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") ] | [ ssrdocc(occ) ] -> [ match occ with | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl] | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here")] @@ -705,7 +711,7 @@ ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats | [ "-/" integer(n) "/=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (n,~-1))] ] | [ "-/" integer(n) "/" integer (m) "=" ] -> [ [IPatNoop;IPatSimpl(SimplCut(n,m))] ] - | [ ssrfwdview(v) ] -> [ [IPatView v] ] + | [ ssrfwdview(v) ] -> [ [IPatView (false,v)] ] | [ "[" ":" ident_list(idl) "]" ] -> [ [IPatAbstractVars idl] ] | [ "[:" ident_list(idl) "]" ] -> [ [IPatAbstractVars idl] ] END @@ -956,6 +962,7 @@ END (* the default simpl and unfold tactics would erase blindly. *) open Ssrmatching_plugin.Ssrmatching +open Ssrmatching_plugin.G_ssrmatching let pr_wgen = function | (clr, Some((id,k),None)) -> spc() ++ pr_clear mt clr ++ str k ++ pr_hoi id @@ -1064,7 +1071,7 @@ let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with | BFdef :: h, { v = CLetIn({CAst.v=x}, v, oty, c) } -> let bs, c' = format_constr_expr h c in Bdef (x, oty, v) :: bs, c' - | [BFcast], { v = CCast (c, CastConv t) } -> + | [BFcast], { v = CCast (c, Glob_term.CastConv t) } -> [Bcast t], c | BFrec (has_str, has_cast) :: h, { v = CFix ( _, [_, (Some locn, CStructRec), bl, t, c]) } -> @@ -1093,7 +1100,7 @@ let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt let mkFwdVal fk c = ((fk, []), c) let mkssrFwdVal fk c = ((fk, []), (c,None)) -let dC t = CastConv t +let dC t = Glob_term.CastConv t let same_ist { interp_env = x } { interp_env = y } = match x,y with @@ -1154,7 +1161,8 @@ ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar END let bvar_lname = let open CAst in function - | { v = CRef ({loc;v=Ident id}, _) } -> CAst.make ?loc @@ Name id + | { v = CRef (qid, _) } when qualid_is_ident qid -> + CAst.make ?loc:qid.CAst.loc @@ Name (qualid_basename qid) | { loc = loc } -> CAst.make ?loc Anonymous let pr_ssrbinder prc _ _ (_, c) = prc c @@ -1210,8 +1218,8 @@ let push_binders c2 bs = | [] -> c | _ -> anomaly "binder not a lambda nor a let in" in match c2 with - | { loc; v = CCast (ct, CastConv cty) } -> - CAst.make ?loc @@ (CCast (loop false ct bs, CastConv (loop true cty bs))) + | { loc; v = CCast (ct, Glob_term.CastConv cty) } -> + CAst.make ?loc @@ (CCast (loop false ct bs, Glob_term.CastConv (loop true cty bs))) | ct -> loop false ct bs let rec fix_binders = let open CAst in function @@ -1246,7 +1254,8 @@ END let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd let bvar_locid = function - | { CAst.v = CRef ({CAst.loc=loc;v=Ident id}, _) } -> CAst.make ?loc id + | { CAst.v = CRef (qid, _) } when qualid_is_ident qid -> + CAst.make ?loc:qid.CAst.loc (qualid_basename qid) | _ -> CErrors.user_err (Pp.str "Missing identifier after \"(co)fix\"") @@ -1399,7 +1408,7 @@ let check_seqtacarg dir arg = match snd arg, dir with CErrors.user_err ?loc (str "expected \"first\"") | _, _ -> arg -let ssrorelse = Gram.entry_create "ssrorelse" +let ssrorelse = Entry.create "ssrorelse" GEXTEND Gram GLOBAL: ssrorelse ssrseqarg; ssrseqidx: [ @@ -1676,7 +1685,10 @@ let pr_gen (docc, dt) = pr_docc docc ++ pr_cpattern dt let pr_ssrgen _ _ _ = pr_gen ARGUMENT EXTEND ssrgen TYPED AS ssrdocc * cpattern PRINTED BY pr_ssrgen -| [ ssrdocc(docc) cpattern(dt) ] -> [ docc, dt ] +| [ ssrdocc(docc) cpattern(dt) ] -> [ + match docc with + | Some [], _ -> CErrors.user_err ~loc (str"Clear flag {} not allowed here") + | _ -> docc, dt ] | [ cpattern(dt) ] -> [ nodocc, dt ] END @@ -1938,7 +1950,7 @@ END let vmexacttac pf = Goal.nf_enter begin fun gl -> - exact_no_check (EConstr.mkCast (pf, VMcast, Tacmach.New.pf_concl gl)) + exact_no_check (EConstr.mkCast (pf, _vmcast, Tacmach.New.pf_concl gl)) end TACTIC EXTEND ssrexact diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index 2ac7c7e2..862a9376 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -12,13 +12,13 @@ open Ltac_plugin -val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry +val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Entry.t val wit_ssrtacarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtacarg : 'a -> 'b -> (Notation_term.tolerability -> 'c) -> 'c +val pr_ssrtacarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c) -> 'c -val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry +val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Entry.t val wit_ssrtclarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtclarg : 'a -> 'b -> (Notation_term.tolerability -> 'c -> 'd) -> 'c -> 'd +val pr_ssrtclarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c -> 'd) -> 'c -> 'd val add_genarg : string -> ('a -> Pp.t) -> 'a Genarg.uniform_genarg_type diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 11369228..824666ba 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -101,13 +101,14 @@ let rec pr_ipat p = | IPatSimpl sim -> pr_simpl sim | IPatClear clr -> pr_clear mt clr | IPatCase iorpat -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") - | IPatDispatch iorpat -> hov 1 (str "/[" ++ pr_iorpat iorpat ++ str "]") + | IPatDispatch(_,iorpat) -> hov 1 (str "/[" ++ pr_iorpat iorpat ++ str "]") | IPatInj iorpat -> hov 1 (str "[=" ++ pr_iorpat iorpat ++ str "]") | IPatRewrite (occ, dir) -> pr_occ occ ++ pr_dir dir | IPatAnon All -> str "*" | IPatAnon Drop -> str "_" | IPatAnon One -> str "?" - | IPatView v -> pr_view2 v + | IPatView (false,v) -> pr_view2 v + | IPatView (true,v) -> str"{}" ++ pr_view2 v | IPatNoop -> str "-" | IPatAbstractVars l -> str "[:" ++ pr_list spc Id.print l ++ str "]" | IPatTac _ -> str "" diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 9cc4f5ce..83581f34 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -11,9 +11,9 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) open Names +open Constr open Termops open Tacmach -open Misctypes open Locusops open Ssrast @@ -24,7 +24,7 @@ module NamedDecl = Context.Named.Declaration (** Tacticals (+, -, *, done, by, do, =>, first, and last). *) -let get_index = function ArgArg i -> i | _ -> +let get_index = function Locus.ArgArg i -> i | _ -> anomaly "Uninterpreted index" (* Toplevel constr must be globalized twice ! *) @@ -32,9 +32,8 @@ let get_index = function ArgArg i -> i | _ -> let tclPERM perm tac gls = let subgls = tac gls in - let sigma, subgll = Refiner.unpackage subgls in - let subgll' = perm subgll in - Refiner.repackage sigma subgll' + let subgll' = perm subgls.Evd.it in + re_sig subgll' subgls.Evd.sigma let rot_hyps dir i hyps = let n = List.length hyps in @@ -104,10 +103,10 @@ let endclausestac id_map clseq gl_id cl0 gl = | ids, dc' -> forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in let rec unmark c = match EConstr.kind (project gl) c with - | Term.Var id when hidden_clseq clseq && id = gl_id -> cl0 - | Term.Prod (Name id, t, c') when List.mem_assoc id id_map -> + | Var id when hidden_clseq clseq && id = gl_id -> cl0 + | Prod (Name id, t, c') when List.mem_assoc id id_map -> EConstr.mkProd (Name (orig_id id), unmark t, unmark c') - | Term.LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> + | LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> EConstr.mkLetIn (Name (orig_id id), unmark v, unmark t, unmark c') | _ -> EConstr.map (project gl) unmark c in let utac hyp = diff --git a/plugins/ssr/ssrtacticals.mli b/plugins/ssr/ssrtacticals.mli index a5636ad0..684e0023 100644 --- a/plugins/ssr/ssrtacticals.mli +++ b/plugins/ssr/ssrtacticals.mli @@ -17,7 +17,7 @@ val tclSEQAT : Tacinterp.interp_sign -> Tacinterp.Value.t -> Ssrast.ssrdir -> - int Misctypes.or_var * + int Locus.or_var * (('a * Tacinterp.Value.t option list) * Tacinterp.Value.t option) -> Tacmach.tactic @@ -37,7 +37,7 @@ val hinttac : val ssrdotac : Tacinterp.interp_sign -> - ((int Misctypes.or_var * Ssrast.ssrmmod) * + ((int Locus.or_var * Ssrast.ssrmmod) * (bool * Tacinterp.Value.t option list)) * ((Ssrast.ssrhyps * ((Ssrast.ssrhyp_or_id * string) * diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 05dbf0a8..989a6c5b 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -19,17 +19,14 @@ open Constrexpr_ops open Pcoq open Pcoq.Prim open Pcoq.Constr -open Pcoq.Vernac_ +open Pvernac.Vernac_ open Ltac_plugin open Notation_ops open Notation_term open Glob_term -open Globnames open Stdarg open Genarg -open Misctypes open Decl_kinds -open Libnames open Pp open Ppconstr open Printer @@ -144,21 +141,21 @@ END let declare_one_prenex_implicit locality f = let fref = try Smartlocate.global_with_alias f - with _ -> errorstrm (pr_reference f ++ str " is not declared") in + with _ -> errorstrm (pr_qualid f ++ str " is not declared") in let rec loop = function | a :: args' when Impargs.is_status_implicit a -> (ExplByName (Impargs.name_of_implicit a), (true, true, true)) :: loop args' | args' when List.exists Impargs.is_status_implicit args' -> - errorstrm (str "Expected prenex implicits for " ++ pr_reference f) + errorstrm (str "Expected prenex implicits for " ++ pr_qualid f) | _ -> [] in let impls = match Impargs.implicits_of_global fref with | [cond,impls] -> impls - | [] -> errorstrm (str "Expected some implicits for " ++ pr_reference f) + | [] -> errorstrm (str "Expected some implicits for " ++ pr_qualid f) | _ -> errorstrm (str "Multiple implicits not supported") in match loop impls with | [] -> - errorstrm (str "Expected some implicits for " ++ pr_reference f) + errorstrm (str "Expected some implicits for " ++ pr_qualid f) | impls -> Impargs.declare_manual_implicits locality fref ~enriching:false [impls] @@ -220,8 +217,8 @@ let interp_search_notation ?loc tag okey = (Bytes.set s' i' '_'; loop (j + 1) (i' + 2)) else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in loop 0 1 in - let trim_ntn (pntn, m) = Bytes.sub_string pntn 1 (max 0 m) in - let pr_ntn ntn = str "(" ++ str ntn ++ str ")" in + let trim_ntn (pntn, m) = (InConstrEntrySomeLevel,Bytes.sub_string pntn 1 (max 0 m)) in + let pr_ntn ntn = str "(" ++ Notation.pr_notation ntn ++ str ")" in let pr_and_list pr = function | [x] -> pr x | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x @@ -296,7 +293,7 @@ let interp_search_notation ?loc tag okey = let scs' = List.remove (=) sc !scs in let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in Feedback.msg_warning (hov 4 w) - else if String.string_contains ~where:ntn ~what:" .. " then + else if String.string_contains ~where:(snd ntn) ~what:" .. " then err (pr_ntn ntn ++ str " is an n-ary notation"); let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in let rec sub () = function @@ -361,13 +358,12 @@ let coerce_search_pattern_to_sort hpat = true, cp with _ -> false, [] in let coerce hp coe_index = - let coe = Classops.get_coercion_value coe_index in + let coe_ref = coe_index.Classops.coe_value in try - let coe_ref = global_of_constr coe in let n_imps = Option.get (Classops.hide_coercion coe_ref) in mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] - with _ -> - errorstrm (str "need explicit coercion " ++ pr_constr_env env sigma coe ++ spc () + with Not_found | Option.IsNone -> + errorstrm (str "need explicit coercion " ++ pr_global coe_ref ++ spc () ++ str "to interpret head search pattern as type") in filter_head, List.fold_left coerce hpat' coe_path @@ -377,7 +373,10 @@ let interp_head_pat hpat = | Cast (c', _, _) -> loop c' | Prod (_, _, c') -> loop c' | LetIn (_, _, _, c') -> loop c' - | _ -> Constr_matching.is_matching (Global.env()) Evd.empty p (EConstr.of_constr c) in + | _ -> + let env = Global.env () in + let sigma = Evd.from_env env in + Constr_matching.is_matching env sigma p (EConstr.of_constr c) in filter_head, loop let all_true _ = true @@ -413,7 +412,7 @@ let interp_search_arg arg = (* Module path postfilter *) -let pr_modloc (b, m) = if b then str "-" ++ pr_reference m else pr_reference m +let pr_modloc (b, m) = if b then str "-" ++ pr_qualid m else pr_qualid m let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc @@ -431,10 +430,9 @@ GEXTEND Gram END let interp_modloc mr = - let interp_mod (_, mr) = - let {CAst.loc=loc; v=qid} = qualid_of_reference mr in + let interp_mod (_, qid) = try Nametab.full_name_module qid with Not_found -> - CErrors.user_err ?loc (str "No Module " ++ pr_qualid qid) in + CErrors.user_err ?loc:qid.CAst.loc (str "No Module " ++ pr_qualid qid) in let mr_out, mr_in = List.partition fst mr in let interp_bmod b = function | [] -> fun _ _ _ -> true diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index aa614fbc..3f974ea0 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -67,9 +67,9 @@ end module State : sig (* View storage API *) - val vsINIT : EConstr.t -> unit tactic - val vsPUSH : (EConstr.t -> EConstr.t tactic) -> unit tactic - val vsCONSUME : (Id.t option -> EConstr.t -> unit tactic) -> unit tactic + val vsINIT : EConstr.t * Id.t list -> unit tactic + val vsPUSH : (EConstr.t -> (EConstr.t * Id.t list) tactic) -> unit tactic + val vsCONSUME : (name:Id.t option -> EConstr.t -> to_clear:Id.t list -> unit tactic) -> unit tactic val vsASSERT_EMPTY : unit tactic end = struct (* {{{ *) @@ -78,6 +78,7 @@ type vstate = { subject_name : Id.t option; (* top *) (* None if views are being applied to a term *) view : EConstr.t; (* v2 (v1 top) *) + to_clear : Id.t list; } include Ssrcommon.MakeState(struct @@ -85,13 +86,14 @@ include Ssrcommon.MakeState(struct let init = None end) -let vsINIT view = tclSET (Some { subject_name = None; view }) +let vsINIT (view, to_clear) = + tclSET (Some { subject_name = None; view; to_clear }) let vsPUSH k = tacUPDATE (fun s -> match s with - | Some { subject_name; view } -> - k view >>= fun view -> - tclUNIT (Some { subject_name; view }) + | Some { subject_name; view; to_clear } -> + k view >>= fun (view, clr) -> + tclUNIT (Some { subject_name; view; to_clear = to_clear @ clr }) | None -> Goal.enter_one ~__LOC__ begin fun gl -> let concl = Goal.concl gl in @@ -102,15 +104,15 @@ let vsPUSH k = | _ -> mk_anon_id "view_subject" (Tacmach.New.pf_ids_of_hyps gl) in let view = EConstr.mkVar id in Ssrcommon.tclINTRO_ID id <*> - k view >>= fun view -> - tclUNIT (Some { subject_name = Some id; view }) + k view >>= fun (view, to_clear) -> + tclUNIT (Some { subject_name = Some id; view; to_clear }) end) let vsCONSUME k = tclGET (fun s -> match s with - | Some { subject_name; view } -> + | Some { subject_name; view; to_clear } -> tclSET None <*> - k subject_name view + k ~name:subject_name view ~to_clear | None -> anomaly "vsCONSUME: empty storage") let vsASSERT_EMPTY = @@ -157,7 +159,7 @@ let tclINJ_CONSTR_IST ist p = let mkGHole = DAst.make - (Glob_term.GHole(Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)) + (Glob_term.GHole(Evar_kinds.InternalHole, Namegen.IntroAnonymous, None)) let rec mkGHoles n = if n > 0 then mkGHole :: mkGHoles (n - 1) else [] let mkGApp f args = if args = [] then f @@ -187,6 +189,16 @@ end * modular, see the 2 functions below that would need to "uncommit" *) let tclKeepOpenConstr (_env, sigma, t) = Unsafe.tclEVARS sigma <*> tclUNIT t +let tclADD_CLEAR_IF_ID (env, ist, t) x = + Ssrprinters.ppdebug (lazy + Pp.(str"tclADD_CLEAR_IF_ID: " ++ Printer.pr_econstr_env env ist t)); + let hd, _ = EConstr.decompose_app ist t in + match EConstr.kind ist hd with + | Constr.Var id when Ssrcommon.not_section_id id -> tclUNIT (x, [id]) + | _ -> tclUNIT (x,[]) + +let tclPAIR p x = tclUNIT (x, p) + (* The ssr heuristic : *) (* Estimate a bound on the number of arguments of a raw constr. *) (* This is not perfect, because the unifier may fail to *) @@ -203,14 +215,15 @@ let guess_max_implicits ist glob = (fun _ -> tclUNIT 5) let pad_to_inductive ist glob = Goal.enter_one ~__LOC__ begin fun goal -> - interp_glob ist glob >>= fun (env, sigma, term) -> + interp_glob ist glob >>= fun (env, sigma, term as ot) -> let term_ty = Retyping.get_type_of env sigma term in let ctx, i = Reductionops.splay_prod env sigma term_ty in let rel_ctx = List.map (fun (a,b) -> Context.Rel.Declaration.LocalAssum(a,b)) ctx in - if Ssrcommon.isAppInd (EConstr.push_rel_context rel_ctx env) sigma i - then tclUNIT (mkGApp glob (mkGHoles (List.length ctx))) - else Tacticals.New.tclZEROMSG Pp.(str"not an inductive") + if not (Ssrcommon.isAppInd (EConstr.push_rel_context rel_ctx env) sigma i) + then Tacticals.New.tclZEROMSG Pp.(str"not an inductive") + else tclUNIT (mkGApp glob (mkGHoles (List.length ctx))) + >>= tclADD_CLEAR_IF_ID ot end (* There are two ways of "applying" a view to term: *) @@ -221,7 +234,7 @@ end (* They require guessing the view hints and the number of *) (* implicits, respectively, which we do by brute force. *) (* Builds v p *) -let interp_view ist v p = +let interp_view ~clear_if_id ist v p = let is_specialize hd = match DAst.get hd with Glob_term.GHole _ -> true | _ -> false in (* We cast the pile of views p into a term p_id *) @@ -230,42 +243,48 @@ let interp_view ist v p = match DAst.get v with | Glob_term.GApp (hd, rargs) when is_specialize hd -> Ssrprinters.ppdebug (lazy Pp.(str "specialize")); - interp_glob ist (mkGApp p_id rargs) >>= tclKeepOpenConstr + interp_glob ist (mkGApp p_id rargs) + >>= tclKeepOpenConstr >>= tclPAIR [] | _ -> Ssrprinters.ppdebug (lazy Pp.(str "view")); (* We find out how to build (v p) eventually using an adaptor *) let adaptors = AdaptorDb.(get Forward) in Proofview.tclORELSE - (pad_to_inductive ist v >>= fun vpad -> + (pad_to_inductive ist v >>= fun (vpad,clr) -> Ssrcommon.tclFIRSTa (List.map - (fun a -> interp_glob ist (mkGApp a [vpad; p_id])) adaptors)) + (fun a -> interp_glob ist (mkGApp a [vpad; p_id])) adaptors) + >>= tclPAIR clr) (fun _ -> guess_max_implicits ist v >>= fun n -> Ssrcommon.tclFIRSTi (fun n -> - interp_glob ist (mkGApp v (mkGHoles n @ [p_id]))) n) - >>= tclKeepOpenConstr + interp_glob ist (mkGApp v (mkGHoles n @ [p_id]))) n + >>= fun x -> tclADD_CLEAR_IF_ID x x) + >>= fun (ot,clr) -> + if clear_if_id + then tclKeepOpenConstr ot >>= tclPAIR clr + else tclKeepOpenConstr ot >>= tclPAIR [] (* we store in the state (v top), then (v1 (v2 top))... *) -let pile_up_view (ist, v) = +let pile_up_view ~clear_if_id (ist, v) = let ist = Ssrcommon.option_assert_get ist (Pp.str"not a term") in - State.vsPUSH (fun p -> interp_view ist v p) + State.vsPUSH (fun p -> interp_view ~clear_if_id ist v p) let finalize_view s0 ?(simple_types=true) p = Goal.enter_one ~__LOC__ begin fun g -> let env = Goal.env g in let sigma = Goal.sigma g in - let evars_of_p = Evd.evars_of_term (EConstr.to_constr sigma p) in + let evars_of_p = Evd.evars_of_term (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in let filter x _ = Evar.Set.mem x evars_of_p in let sigma = Typeclasses.resolve_typeclasses ~fail:false ~filter env sigma in let p = Reductionops.nf_evar sigma p in let get_body = function Evd.Evar_defined x -> x | _ -> assert false in let evars_of_econstr sigma t = - Evd.evars_of_term (EConstr.to_constr sigma (EConstr.of_constr t)) in + Evarutil.undefined_evars_of_term sigma (EConstr.of_constr t) in let rigid_of s = List.fold_left (fun l k -> if Evd.is_defined sigma k then let bo = get_body Evd.(evar_body (find sigma k)) in - k :: l @ Evar.Set.elements (evars_of_econstr sigma bo) + k :: l @ Evar.Set.elements (evars_of_econstr sigma (EConstr.Unsafe.to_constr bo)) else l ) [] s in let und0 = (* Unassigned evars in the initial goal *) @@ -292,7 +311,7 @@ let pose_proof subject_name p = <*> Tactics.New.reduce_after_refine -let rec apply_all_views ending vs s0 = +let rec apply_all_views ~clear_if_id ending vs s0 = match vs with | [] -> ending s0 | v :: vs -> @@ -301,31 +320,35 @@ let rec apply_all_views ending vs s0 = | `Tac tac -> Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); ending s0 <*> Tacinterp.eval_tactic tac <*> - Ssrcommon.tacSIGMA >>= apply_all_views ending vs + Ssrcommon.tacSIGMA >>= apply_all_views ~clear_if_id ending vs | `Term v -> Ssrprinters.ppdebug (lazy Pp.(str"..a term")); - pile_up_view v <*> apply_all_views ending vs s0 + pile_up_view ~clear_if_id v <*> + apply_all_views ~clear_if_id ending vs s0 (* Entry points *********************************************************) -let tclIPAT_VIEWS ~views:vs ~conclusion:tac = +let tclIPAT_VIEWS ~views:vs ?(clear_if_id=false) ~conclusion:tac = let end_view_application s0 = - State.vsCONSUME (fun name t -> - finalize_view s0 t >>= pose_proof name <*> - tac ~to_clear:(Option.cata (fun x -> [x]) [] name)) in + State.vsCONSUME (fun ~name t ~to_clear -> + let to_clear = Option.cata (fun x -> [x]) [] name @ to_clear in + finalize_view s0 t >>= pose_proof name <*> tac ~to_clear) in tclINDEPENDENT begin State.vsASSERT_EMPTY <*> - Ssrcommon.tacSIGMA >>= apply_all_views end_view_application vs <*> + Ssrcommon.tacSIGMA >>= + apply_all_views ~clear_if_id end_view_application vs <*> State.vsASSERT_EMPTY end let tclWITH_FWD_VIEWS ~simple_types ~subject ~views:vs ~conclusion:tac = let ending_tac s0 = - State.vsCONSUME (fun _ t -> finalize_view s0 ~simple_types t >>= tac) in + State.vsCONSUME (fun ~name:_ t ~to_clear:_ -> + finalize_view s0 ~simple_types t >>= tac) in tclINDEPENDENT begin State.vsASSERT_EMPTY <*> - State.vsINIT subject <*> - Ssrcommon.tacSIGMA >>= apply_all_views ending_tac vs <*> + State.vsINIT (subject,[]) <*> + Ssrcommon.tacSIGMA >>= + apply_all_views ~clear_if_id:false ending_tac vs <*> State.vsASSERT_EMPTY end diff --git a/plugins/ssr/ssrview.mli b/plugins/ssr/ssrview.mli index be51fe7f..b128a95d 100644 --- a/plugins/ssr/ssrview.mli +++ b/plugins/ssr/ssrview.mli @@ -20,9 +20,11 @@ module AdaptorDb : sig end -(* Apply views to the top of the stack (intro pattern) *) +(* Apply views to the top of the stack (intro pattern). If clear_if_id is + * true (default false) then views that happen to be a variable are considered + * as to be cleared (see the to_clear argument to the continuation) *) val tclIPAT_VIEWS : - views:ast_closure_term list -> + views:ast_closure_term list -> ?clear_if_id:bool -> conclusion:(to_clear:Names.Id.t list -> unit Proofview.tactic) -> unit Proofview.tactic diff --git a/plugins/ssrmatching/g_ssrmatching.ml4 b/plugins/ssrmatching/g_ssrmatching.ml4 new file mode 100644 index 00000000..746c368a --- /dev/null +++ b/plugins/ssrmatching/g_ssrmatching.ml4 @@ -0,0 +1,101 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* [ mk_rpattern (T (mk_lterm c None)) ] + | [ "in" lconstr(c) ] -> [ mk_rpattern (In_T (mk_lterm c None)) ] + | [ lconstr(x) "in" lconstr(c) ] -> + [ mk_rpattern (X_In_T (mk_lterm x None, mk_lterm c None)) ] + | [ "in" lconstr(x) "in" lconstr(c) ] -> + [ mk_rpattern (In_X_In_T (mk_lterm x None, mk_lterm c None)) ] + | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> + [ mk_rpattern (E_In_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None)) ] + | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> + [ mk_rpattern (E_As_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None)) ] +END + +let pr_ssrterm _ _ _ = pr_ssrterm + +ARGUMENT EXTEND cpattern + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm + RAW_PRINTED BY pr_ssrterm + GLOB_PRINTED BY pr_ssrterm +| [ "Qed" constr(c) ] -> [ mk_lterm c None ] +END + +let input_ssrtermkind strm = match Util.stream_nth 0 strm with + | Tok.KEYWORD "(" -> '(' + | Tok.KEYWORD "@" -> '@' + | _ -> ' ' +let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +GEXTEND Gram + GLOBAL: cpattern; + cpattern: [[ k = ssrtermkind; c = constr -> + let pattern = mk_term k c None in + if loc_of_cpattern pattern <> Some !@loc && k = '(' + then mk_term 'x' c None + else pattern ]]; +END + +ARGUMENT EXTEND lcpattern + TYPED AS cpattern + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm + RAW_PRINTED BY pr_ssrterm + GLOB_PRINTED BY pr_ssrterm +| [ "Qed" lconstr(c) ] -> [ mk_lterm c None ] +END + +GEXTEND Gram + GLOBAL: lcpattern; + lcpattern: [[ k = ssrtermkind; c = lconstr -> + let pattern = mk_term k c None in + if loc_of_cpattern pattern <> Some !@loc && k = '(' + then mk_term 'x' c None + else pattern ]]; +END + +ARGUMENT EXTEND ssrpatternarg TYPED AS rpattern PRINTED BY pr_rpattern +| [ rpattern(pat) ] -> [ pat ] +END + +TACTIC EXTEND ssrinstoftpat +| [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof arg) ] +END + +(* We wipe out all the keywords generated by the grammar rules we defined. *) +(* 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.set_keyword_state frozen_lexer ;; diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml new file mode 100644 index 00000000..4a63dd47 --- /dev/null +++ b/plugins/ssrmatching/ssrmatching.ml @@ -0,0 +1,1428 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* ()) +let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) +let _ = + try ignore(Sys.getenv "SSRMATCHINGDEBUG"); pp_ref := ssr_pp + with Not_found -> () +let debug b = + if b then pp_ref := ssr_pp else pp_ref := fun _ -> () +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssrmatching debugging"; + Goptions.optkey = ["Debug";"SsrMatching"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !pp_ref == ssr_pp); + Goptions.optwrite = debug } +let pp s = !pp_ref s + +(** Utils *)(* {{{ *****************************************************************) +let env_size env = List.length (Environ.named_context env) +let safeDestApp c = + match kind c with App (f, a) -> f, a | _ -> c, [| |] +(* Toplevel constr must be globalized twice ! *) +let glob_constr ist genv sigma t = match t, ist with + | (_, Some ce), Some ist -> + let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in + let ltacvars = { Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in + Constrintern.intern_gen WithoutTypeConstraint ~ltacvars:ltacvars genv sigma ce + | (rc, None), _ -> rc + | (_, Some _), None -> CErrors.anomaly Pp.(str"glob_constr: term with no ist") + +(* Term printing utilities functions for deciding bracketing. *) +let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") +(* String lexing utilities *) +let skip_wschars s = + let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let guard_term ch1 s i = match s.[i] with + | '(' -> false + | '{' | '/' | '=' -> true + | _ -> ch1 = '(' +(* The call 'guard s i' should return true if the contents of s *) +(* starting at i need bracketing to avoid ambiguities. *) +let pr_guarded guard prc c = + let s = Pp.string_of_ppcmds (prc c) ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c +(* More sensible names for constr printers *) +let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let prl_constr_expr = pr_lconstr_expr +let pr_constr_expr = pr_constr_expr +let prl_glob_constr_and_expr = function + | _, Some c -> prl_constr_expr c + | c, None -> prl_glob_constr c +let pr_glob_constr_and_expr = function + | _, Some c -> pr_constr_expr c + | c, None -> pr_glob_constr c +let pr_term (k, c, _) = pr_guarded (guard_term k) pr_glob_constr_and_expr c +let prl_term (k, c, _) = pr_guarded (guard_term k) prl_glob_constr_and_expr c + +(** Adding a new uninterpreted generic argument type *) +let add_genarg tag pr = + let wit = Genarg.make0 tag in + let tag = Geninterp.Val.create tag in + let glob ist x = (ist, x) in + let subst _ x = x in + let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in + let gen_pr _ _ _ = pr in + let () = Genintern.register_intern0 wit glob in + let () = Genintern.register_subst0 wit subst in + let () = Geninterp.register_interp0 wit interp in + let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in + Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; + wit + +(** Constructors for cast type *) +let dC t = CastConv t +(** Constructors for constr_expr *) +let isCVar = function { CAst.v = CRef (qid,_) } -> qualid_is_ident qid | _ -> false +let destCVar = function + | { CAst.v = CRef (qid,_) } when qualid_is_ident qid -> + qualid_basename qid + | _ -> + CErrors.anomaly (str"not a CRef.") +let isGLambda c = match DAst.get c with GLambda (Name _, _, _, _) -> true | _ -> false +let destGLambda c = match DAst.get c with GLambda (Name id, _, _, c) -> (id, c) + | _ -> CErrors.anomaly (str "not a GLambda") +let isGHole c = match DAst.get c with GHole _ -> true | _ -> false +let mkCHole ~loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) +let mkCLambda ?loc name ty t = CAst.make ?loc @@ + CLambdaN ([CLocalAssum([CAst.make ?loc name], Default Explicit, ty)], t) +let mkCLetIn ?loc name bo t = CAst.make ?loc @@ + CLetIn ((CAst.make ?loc name), bo, None, t) +let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, dC ty) +(** Constructors for rawconstr *) +let mkRHole = DAst.make @@ GHole (InternalHole, IntroAnonymous, None) +let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) +let mkRCast rc rt = DAst.make @@ GCast (rc, dC rt) +let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) + +(* ssrterm conbinators *) +let combineCG t1 t2 f g = + let mk_ist i1 i2 = match i1, i2 with + | None, Some i -> Some i + | Some i, None -> Some i + | None, None -> None + | Some i, Some j when i == j -> Some i + | _ -> CErrors.anomaly (Pp.str "combineCG: different ist") in + match t1, t2 with + | (x, (t1, None), i1), (_, (t2, None), i2) -> + x, (g t1 t2, None), mk_ist i1 i2 + | (x, (_, Some t1), i1), (_, (_, Some t2), i2) -> + x, (mkRHole, Some (f t1 t2)), mk_ist i1 i2 + | _, (_, (_, None), _) -> CErrors.anomaly (str"have: mixed C-G constr.") + | _ -> CErrors.anomaly (str"have: mixed G-C constr.") +let loc_ofCG = function + | (_, (s, None), _) -> Glob_ops.loc_of_glob_constr s + | (_, (_, Some s), _) -> Constrexpr_ops.constr_loc s + +let mk_term k c ist = k, (mkRHole, Some c), ist +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 *)(* {{{ *************************************************************) +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } +let profile_now = ref false +let something_profiled = ref false +let profilers = ref [] +let add_profiler f = profilers := f :: !profilers;; +let profile b = + profile_now := b; + if b then List.iter (fun f -> f.reset ()) !profilers; + if not b then List.iter (fun f -> f.print ()) !profilers +;; +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssrmatching profiling"; + Goptions.optkey = ["SsrMatchingProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = profile } +let () = + let prof_total = + let init = ref 0.0 in { + profile = (fun f x -> assert false); + reset = (fun () -> init := Unix.gettimeofday ()); + print = (fun () -> if !something_profiled then + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in + let prof_legenda = { + profile = (fun f x -> assert false); + reset = (fun () -> ()); + print = (fun () -> if !something_profiled then begin + prerr_endline + (Printf.sprintf "!! %39s ---------- --------- --------- ---------" + (String.make 39 '-')); + prerr_endline + (Printf.sprintf "!! %-39s %10s %9s %9s %9s" + "function" "#calls" "total" "max" "average") end) } in + add_profiler prof_legenda; + add_profiler prof_total +;; + +let mk_profiler s = + let total, calls, max = ref 0.0, ref 0, ref 0.0 in + let reset () = total := 0.0; calls := 0; max := 0.0 in + let profile f x = + if not !profile_now then f x else + let before = Unix.gettimeofday () in + try + incr calls; + let res = f x in + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + res + with exc -> + let after = Unix.gettimeofday () in + let delta = after -. before in + total := !total +. delta; + if delta > !max then max := delta; + raise exc in + let print () = + if !calls <> 0 then begin + something_profiled := true; + prerr_endline + (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" + s !calls !total !max (!total /. (float_of_int !calls))) end in + let prof = { profile = profile; reset = reset; print = print } in + add_profiler prof; + prof +;; +(* }}} *) + +exception NoProgress + +(** Unification procedures. *) + +(* To enforce the rigidity of the rooted match we always split *) +(* top applications, so the unification procedures operate on *) +(* arrays of patterns and terms. *) +(* We perform three kinds of unification: *) +(* EQ: exact conversion check *) +(* FO: first-order unification of evars, without conversion *) +(* HO: higher-order unification with conversion *) +(* The subterm unification strategy is to find the first FO *) +(* match, if possible, and the first HO match otherwise, then *) +(* compute all the occurrences that are EQ matches for the *) +(* relevant subterm. *) +(* Additional twists: *) +(* - If FO/HO fails then we attempt to fill evars using *) +(* typeclasses before raising an outright error. We also *) +(* fill typeclasses even after a successful match, since *) +(* beta-reduction and canonical instances may leave *) +(* undefined evars. *) +(* - We do postchecks to rule out matches that are not *) +(* closed or that assign to a global evar; these can be *) +(* disabled for rewrite or dependent family matches. *) +(* - We do a full FO scan before turning to HO, as the FO *) +(* comparison can be much faster than the HO one. *) + +let unif_EQ env sigma p c = + let evars = existential_opt_value0 sigma, Evd.universes sigma in + try let _ = Reduction.conv env p ~evars c in true with _ -> false + +let unif_EQ_args env sigma pa a = + let n = Array.length pa in + let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in + loop 0 + +let prof_unif_eq_args = mk_profiler "unif_EQ_args";; +let unif_EQ_args env sigma pa a = + prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a +;; + +let unif_HO env ise p c = + try Evarconv.the_conv_x env p c ise + with Evarconv.UnableToUnify(ise, err) -> + raise Pretype_errors.(PretypeError(env,ise,CannotUnify(p,c,Some err))) + +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 (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 *) +(* alas things are not so simple: w_unify does partial type-checking, *) +(* which breaks down when the no-delta flag is on (as the Coq type system *) +(* requires full convertibility. The workaround here is to convert all *) +(* evars into metas, since 8.2 does not TC metas. This means some lossage *) +(* for HO evars, though hopefully Miller patterns can pick up some of *) +(* those cases, and HO matching will mop up the rest. *) +let flags_FO env = + let oracle = Environ.oracle env in + let ts = Conv_oracle.get_transp_state oracle in + let flags = + { (Unification.default_no_delta_unify_flags ts).Unification.core_unify_flags + with + Unification.modulo_conv_on_closed_terms = None; + Unification.modulo_eta = true; + Unification.modulo_betaiota = true; + Unification.modulo_delta_types = ts } + in + { Unification.core_unify_flags = flags; + Unification.merge_unify_flags = flags; + Unification.subterm_unify_flags = flags; + Unification.allow_K_in_toplevel_higher_order_unification = false; + Unification.resolve_evars = + (Unification.default_no_delta_unify_flags ts).Unification.resolve_evars + } +let unif_FO env ise p c = + Unification.w_unify env ise Reduction.CONV ~flags:(flags_FO env) + (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 c' with + | Evar ex -> + begin try nf (existential_value0 s ex) with _ -> + let k, a = ex in let a' = Array.map nf a in + if not (Evd.mem !s' k) then + s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); + mkEvar (k, a') + end + | _ -> map nf c' in + let copy_def k evi () = + if evar_body evi != Evd.Evar_empty then () else + match Evd.evar_body (Evd.find s k) with + | Evar_defined c' -> + let c' = EConstr.of_constr (nf (EConstr.Unsafe.to_constr c')) in + s' := Evd.define k c' !s' + | _ -> () in + let c' = nf c in let _ = Evd.fold copy_def sigma0 () in + !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 + let s, uc, t = nf_open_term sigma0 ise pt in + let ise1 = create_evar_defs s in + let ise1 = Evd.set_universe_context ise1 uc in + let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in + if not (ok ise) then raise NoProgress else + if ise2 == ise1 then (s, uc, t) + else + let s, uc', t = nf_open_term sigma0 ise2 t in + s, UState.union uc uc', t + +let unify_HO env sigma0 t1 t2 = + let sigma = unif_HO env sigma0 t1 t2 in + let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in + Evd.set_universe_context sigma uc + +let pf_unify_HO gl t1 t2 = + let env, sigma0, si = pf_env gl, project gl, sig_it gl in + let sigma = unify_HO env sigma0 t1 t2 in + re_sig si sigma + +(* This is what the definition of iter_constr should be... *) +let iter_constr_LR f c = match kind c with + | Evar (k, a) -> Array.iter f a + | Cast (cc, _, t) -> f cc; f t + | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b + | LetIn (_, v, t, b) -> f v; f t; f b + | App (cf, a) -> f cf; Array.iter f a + | Case (_, p, v, b) -> f v; f p; Array.iter f b + | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> + for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done + | Proj(_,a) -> f a + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () + +(* The comparison used to determine which subterms matches is KEYED *) +(* CONVERSION. This looks for convertible terms that either have the same *) +(* same head constant as pat if pat is an application (after beta-iota), *) +(* or start with the same constr constructor (esp. for LetIn); this is *) +(* disregarded if the head term is let x := ... in x, and casts are always *) +(* ignored and removed). *) +(* Record projections get special treatment: in addition to the projection *) +(* constant itself, ssreflect also recognizes head constants of canonical *) +(* projections. *) + +exception NoMatch +type ssrdir = L2R | R2L +let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS" +let inv_dir = function L2R -> R2L | R2L -> L2R + + +type pattern_class = + | KpatFixed + | KpatConst + | KpatEvar of Evar.t + | KpatLet + | KpatLam + | KpatRigid + | KpatFlex + | KpatProj of Constant.t + +type tpattern = { + up_k : pattern_class; + up_FO : constr; + up_f : constr; + 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; (* progress test for rewrite *) + } + +let all_ok _ _ = true + +let proj_nparams c = + try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0 + +let isRigid c = match kind c with + | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true + | _ -> false + +let hole_var = mkVar (Id.of_string "_") +let pr_constr_pat c0 = + let rec wipe_evar c = + if isEvar c then hole_var else map wipe_evar c in + let sigma, env = Pfedit.get_current_context () in + pr_constr_env env sigma (wipe_evar c0) + +(* Turn (new) evars into metas *) +let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = + let ise = ref ise0 in + let sigma = ref ise0 in + let nenv = env_size env + if hack then 1 else 0 in + let rec put c = match kind c with + | Evar (k, a as ex) -> + begin try put (existential_value0 !sigma ex) + with NotInstantiatedEvar -> + if Evd.mem sigma0 k then map put c else + let evi = Evd.find !sigma k in + let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in + let abs_dc (d, c) = function + | Context.Named.Declaration.LocalDef (x, b, t) -> + d, mkNamedLetIn x (put b) (put t) c + | Context.Named.Declaration.LocalAssum (x, t) -> + mkVar x :: d, mkNamedProd x (put t) c in + let a, t = + Context.Named.fold_inside abs_dc + ~init:([], (put @@ EConstr.Unsafe.to_constr evi.evar_concl)) + (EConstr.Unsafe.to_named_context dc) in + let m = Evarutil.new_meta () in + ise := meta_declare m (EConstr.of_constr t) !ise; + sigma := Evd.define k (EConstr.of_constr (applistc (mkMeta m) a)) !sigma; + put (existential_value0 !sigma ex) + end + | _ -> map put c in + let c1 = put c0 in !ise, c1 + +(* Compile a match pattern from a term; t is the term to fill. *) +(* 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 (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 f with + | Const (p,_) -> + let np = proj_nparams p in + if np = 0 || np > List.length a then KpatConst, f, a else + let a1, a2 = List.chop np a in KpatProj p, (applistc f a1), a2 + | Proj (p,arg) -> KpatProj (Projection.constant p), f, a + | Var _ | Ind _ | Construct _ -> KpatFixed, f, a + | Evar (k, _) -> + if Evd.mem sigma0 k then KpatEvar k, f, a else + if a <> [] then KpatFlex, f, a else + (match p_origin with None -> CErrors.user_err Pp.(str "indeterminate pattern") + | Some (dir, rule) -> + errorstrm (str "indeterminate " ++ pr_dir_side dir + ++ str " in " ++ pr_constr_pat rule)) + | LetIn (_, v, _, b) -> + if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a + | Lambda _ -> KpatLam, f, a + | _ -> KpatRigid, f, a in + let aa = Array.of_list a in + let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in + ise', + { up_k = k; up_FO = p'; up_f = f; + up_a = aa; up_ok = ok; up_dir = dir; up_t = t} + +(* Specialize a pattern after a successful match: assign a precise head *) +(* kind and arity for Proj and Flex patterns. *) +let ungen_upat lhs (sigma, uc, t) u = + let f, a = safeDestApp lhs in + let k = match kind f with + | Var _ | Ind _ | Construct _ -> KpatFixed + | Const _ -> KpatConst + | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k + | LetIn _ -> KpatLet + | Lambda _ -> KpatLam + | _ -> KpatRigid in + sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t} + +let nb_cs_proj_args pc f u = + let na k = + List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in + let nargs_of_proj t = match kind t with + | App(_,args) -> Array.length args + | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be + the number of arguments including the projected *) + | _ -> assert false in + try match kind f with + | Prod _ -> na Prod_cs + | Sort s -> na (Sort_cs (Sorts.family s)) + | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f + | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f + | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) + | _ -> -1 + with Not_found -> -1 + +let isEvar_k k f = + match kind f with Evar (k', _) -> k = k' | _ -> false + +let nb_args c = + match kind c with App (_, a) -> Array.length a | _ -> 0 + +let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i +let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a) + +let splay_app ise = + let rec loop c a = match kind c with + | App (f, a') -> loop f (Array.append a' a) + | Cast (c', _, _) -> loop c' a + | Evar ex -> + (try loop (existential_value0 ise ex) a with _ -> c, a) + | _ -> c, a in + fun c -> match kind c with + | App (f, a) -> loop f a + | Cast _ | Evar _ -> loop c [| |] + | _ -> c, [| |] + +let filter_upat i0 f n u fpats = + let na = Array.length u.up_a in + if n < na then fpats else + let np = match u.up_k with + | KpatConst when eq_constr_nounivs u.up_f f -> na + | KpatFixed when eq_constr_nounivs u.up_f f -> na + | KpatEvar k when isEvar_k k f -> na + | KpatLet when isLetIn f -> na + | KpatLam when isLambda f -> na + | KpatRigid when isRigid f -> na + | KpatFlex -> na + | KpatProj pc -> + let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np + | _ -> -1 in + if np < na then fpats else + let () = if !i0 < np then i0 := n in (u, np) :: fpats + +let eq_prim_proj c t = match kind t with + | Proj(p,_) -> Constant.equal (Projection.constant p) c + | _ -> false + +let filter_upat_FO i0 f n u fpats = + let np = nb_args u.up_FO in + if n < np then fpats else + let ok = match u.up_k with + | KpatConst -> eq_constr_nounivs u.up_f f + | KpatFixed -> eq_constr_nounivs u.up_f f + | KpatEvar k -> isEvar_k k f + | KpatLet -> isLetIn f + | KpatLam -> isLambda f + | KpatRigid -> isRigid f + | KpatProj pc -> equal f (mkConst pc) || eq_prim_proj pc f + | KpatFlex -> i0 := n; true in + if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats + +exception FoundUnif of (evar_map * UState.t * tpattern) +(* Note: we don't update env as we descend into the term, as the primitive *) +(* unification procedure always rejects subterms with bound variables. *) + +let dont_impact_evars_in cl = + let evs_in_cl = Evd.evars_of_term cl in + fun sigma -> Evar.Set.for_all (fun k -> + try let _ = Evd.find_undefined sigma k in true + with Not_found -> false) evs_in_cl + +(* We are forced to duplicate code between the FO/HO matching because we *) +(* have to work around several kludges in unify.ml: *) +(* - w_unify drops into second-order unification when the pattern is an *) +(* application whose head is a meta. *) +(* - w_unify tries to unify types without subsumption when the pattern *) +(* head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type). *) +(* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) +(* match a head let rigidly. *) +let match_upats_FO upats env sigma0 ise orig_c = + let dont_impact_evars = dont_impact_evars_in orig_c in + let rec loop c = + let f, a = splay_app ise c in let i0 = ref (-1) in + let fpats = + List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in + while !i0 >= 0 do + let i = !i0 in i0 := -1; + let c' = mkSubApp f i a in + let one_match (u, np) = + let skip = + if i <= np then i < np else + if u.up_k == KpatFlex then begin i0 := i - 1; false end else + begin if !i0 < np then i0 := np; true end in + if skip || not (closed0 c') then () else try + let _ = match u.up_k with + | KpatFlex -> + let kludge v = mkLambda (Anonymous, mkProp, v) in + unif_FO env ise (kludge u.up_FO) (kludge c') + | KpatLet -> + let kludge vla = + let vl, a = safeDestApp vla in + let x, v, t, b = destLetIn vl in + mkApp (mkLambda (x, t, b), Array.cons v a) in + unif_FO env ise (kludge u.up_FO) (kludge 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 (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' (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.") + | e when CErrors.noncritical e -> () in + List.iter one_match fpats + done; + iter_constr_LR loop f; Array.iter loop a in + try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO.") + +let prof_FO = mk_profiler "match_upats_FO";; +let match_upats_FO upats env sigma0 ise c = + prof_FO.profile (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 it_did_match = ref false in + let failed_because_of_TC = ref false in + let rec aux upats env sigma0 ise c = + let f, a = splay_app ise c in let i0 = ref (-1) in + let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in + while !i0 >= 0 do + let i = !i0 in i0 := -1; + let one_match (u, np) = + let skip = + if i <= np then i < np else + if u.up_k == KpatFlex then begin i0 := i - 1; false end else + begin if !i0 < np then i0 := np; true end in + if skip then () else try + let ise' = match u.up_k with + | KpatFixed | KpatConst -> ise + | KpatEvar _ -> + let _, pka = destEvar u.up_f and _, ka = destEvar f in + unif_HO_args env ise pka 0 ka + | KpatLet -> + let x, v, t, b = destLetIn f in + let _, pv, _, pb = destLetIn u.up_f 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' (EConstr.of_constr pb) (EConstr.of_constr b) + | KpatFlex | KpatProj _ -> + 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'' (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 + | Pretype_errors.PretypeError + (_,_,Pretype_errors.UnsatisfiableConstraints _) -> + failed_because_of_TC:=true + | e when CErrors.noncritical e -> () in + List.iter one_match fpats + done; + iter_constr_LR (aux upats env sigma0 ise) f; + Array.iter (aux upats env sigma0 ise) a + in + aux upats env sigma0 ise c; + if !it_did_match then raise NoProgress; + !failed_because_of_TC + +let prof_HO = mk_profiler "match_upats_HO";; +let match_upats_HO ~on_instance upats env sigma0 ise c = + prof_HO.profile (match_upats_HO ~on_instance upats env sigma0) ise c +;; + + +let fixed_upat evd = function +| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false +| {up_t = t} -> not (occur_existential evd (EConstr.of_constr t)) (** FIXME *) + +let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) + +let assert_done r = + match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called.") + +let assert_done_multires r = + match !r with + | None -> CErrors.anomaly (str"do_once never called.") + | Some (n, xs) -> + r := Some (n+1,xs); + try List.nth xs n with Failure _ -> raise NoMatch + +type subst = Environ.env -> constr -> constr -> int -> constr +type find_P = + Environ.env -> constr -> int -> + k:subst -> + constr +type conclude = unit -> + constr * ssrdir * (Evd.evar_map * UState.t * constr) + +(* upats_origin makes a better error message only *) +let mk_tpattern_matcher ?(all_instances=false) + ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats) += + let nocc = ref 0 and skip_occ = ref false in + let use_occ, occ_list = match occ with + | Some (true, ol) -> ol = [], ol + | Some (false, ol) -> ol <> [], ol + | None -> false, [] in + let max_occ = List.fold_right max occ_list 0 in + let subst_occ = + let occ_set = Array.make max_occ (not use_occ) in + let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in + let _ = if max_occ = 0 then skip_occ := use_occ in + fun () -> incr nocc; + if !nocc = max_occ then skip_occ := use_occ; + if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in + let upat_that_matched = ref None in + let match_EQ env sigma u = + match u.up_k with + | KpatLet -> + let x, pv, t, pb = destLetIn u.up_f in + let env' = + Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env in + let match_let f = match kind f with + | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b + | _ -> false in match_let + | KpatFixed -> eq_constr_nounivs u.up_f + | KpatConst -> eq_constr_nounivs u.up_f + | KpatLam -> fun c -> + (match kind c with + | Lambda _ -> unif_EQ env sigma u.up_f c + | _ -> false) + | _ -> unif_EQ env sigma u.up_f in +let p2t p = mkApp(p.up_f,p.up_a) in +let source () = match upats_origin, upats with + | None, [p] -> + (if fixed_upat ise p then str"term " else str"partial term ") ++ + pr_constr_pat (p2t p) ++ spc() + | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ + pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl() + | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ + pr_constr_pat rule ++ spc() + | _, [] | None, _::_::_ -> + CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in +let on_instance, instances = + let instances = ref [] in + (fun x -> + if all_instances then instances := !instances @ [x] + else raise (FoundUnif x)), + (fun () -> !instances) in +let rec uniquize = function + | [] -> [] + | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs -> + 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 = nf_evar sigma1 t1 in + let f1 = nf_evar sigma1 f1 in + let a1 = Array.map (nf_evar sigma1) a1 in + not (equal t t1 && + equal f f1 && CArray.for_all2 equal a a1) in + x :: uniquize (List.filter neq xs) in + +((fun env c h ~k -> + do_once upat_that_matched (fun () -> + let failed_because_of_TC = ref false in + try + if not all_instances then match_upats_FO upats env sigma0 ise c; + failed_because_of_TC:=match_upats_HO ~on_instance upats env sigma0 ise c; + raise NoMatch + with FoundUnif sigma_u -> 0,[sigma_u] + | (NoMatch|NoProgress) when all_instances && instances () <> [] -> + 0, uniquize (instances ()) + | NoMatch when (not raise_NoMatch) -> + if !failed_because_of_TC then + errorstrm (source ()++strbrk"matches but type classes inference fails") + else + errorstrm (source () ++ str "does not match any subterm of the goal") + | NoProgress when (not raise_NoMatch) -> + let dir = match upats_origin with Some (d,_) -> d | _ -> + CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in + errorstrm (str"all matches of "++source()++ + str"are equal to the " ++ pr_dir_side (inv_dir dir)) + | NoProgress -> raise NoMatch); + let sigma, _, ({up_f = pf; up_a = pa} as u) = + if all_instances then assert_done_multires upat_that_matched + else List.hd (snd(assert_done upat_that_matched)) in +(* pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); *) + if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else + let match_EQ = match_EQ env sigma u in + let pn = Array.length pa in + let rec subst_loop (env,h as acc) c' = + if !skip_occ then c' else + let f, a = splay_app sigma c' in + if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then + let a1, a2 = Array.chop (Array.length pa) a in + let fa1 = mkApp (f, a1) in + let f' = if subst_occ () then k env u.up_t fa1 h else fa1 in + mkApp (f', Array.map_left (subst_loop acc) a2) + else + (* TASSI: clear letin values to avoid unfolding *) + let inc_h rd (env,h') = + let ctx_item = + match rd with + | Context.Rel.Declaration.LocalAssum _ as x -> x + | Context.Rel.Declaration.LocalDef (x,_,y) -> + Context.Rel.Declaration.LocalAssum(x,y) 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 () -> + let sigma, uc, ({up_f = pf; up_a = pa} as u) = + match !upat_that_matched with + | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch + | None -> CErrors.anomaly (str"companion function never called.") in + let p' = mkApp (pf, pa) in + if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) + else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ + str(String.plural !nocc " occurrence") ++ match upats_origin with + | None -> str" of" ++ spc() ++ pr_constr_pat p' + | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ + ws 4 ++ pr_constr_pat p' ++ fnl () ++ + str"of " ++ pr_constr_pat rule)) : conclude) + +type ('ident, 'term) ssrpattern = + | T of 'term + | In_T of 'term + | X_In_T of 'ident * 'term + | In_X_In_T of 'ident * 'term + | E_In_X_In_T of 'term * 'ident * 'term + | E_As_X_In_T of 'term * 'ident * 'term + +let pr_pattern = function + | T t -> prl_term t + | In_T t -> str "in " ++ prl_term t + | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t + | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t + | E_In_X_In_T (e,x,t) -> + prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t + | E_As_X_In_T (e,x,t) -> + prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t + +let pr_pattern_w_ids = function + | T t -> prl_term t + | In_T t -> str "in " ++ prl_term t + | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t + | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t + | E_In_X_In_T (e,x,t) -> + prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t + | E_As_X_In_T (e,x,t) -> + prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t + +let pr_pattern_aux pr_constr = function + | T t -> pr_constr t + | In_T t -> str "in " ++ pr_constr t + | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t + | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t + | E_In_X_In_T (e,x,t) -> + pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t + | 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 (EConstr.Unsafe.to_constr (pi3 (nf_open_term sigma sigma (EConstr.of_constr t))))) p +let pr_cpattern = pr_term + +let wit_rpatternty = add_genarg "rpatternty" pr_pattern + +let glob_ssrterm gs = function + | k, (_, Some c), None -> + let x = Tacintern.intern_constr gs c in + k, (fst x, Some c), None + | ct -> ct + +(* This piece of code asserts the following notations are reserved *) +(* Reserved Notation "( a 'in' b )" (at level 0). *) +(* Reserved Notation "( a 'as' b )" (at level 0). *) +(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *) +(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) +let glob_cpattern gs p = + pp(lazy(str"globbing pattern: " ++ pr_term p)); + let glob x = pi2 (glob_ssrterm gs (mk_lterm x None)) in + let encode k s l = + let name = Name (Id.of_string ("_ssrpat_" ^ s)) in + k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None), None in + let bind_in t1 t2 = + let mkCHole = mkCHole ~loc:None in let n = Name (destCVar t1) in + fst (glob (mkCCast mkCHole (mkCLambda n mkCHole t2))) in + let check_var t2 = if not (isCVar t2) then + loc_error (constr_loc t2) "Only identifiers are allowed here" in + match p with + | _, (_, None), _ as x -> x + | k, (v, Some t), _ as orig -> + if k = 'x' then glob_ssrterm gs ('(', (v, Some t), None) else + match t.CAst.v with + | CNotation((InConstrEntrySomeLevel,"( _ in _ )"), ([t1; t2], [], [], [])) -> + (try match glob t1, glob t2 with + | (r1, None), (r2, None) -> encode k "In" [r1;r2] + | (r1, Some _), (r2, Some _) when isCVar t1 -> + encode k "In" [r1; r2; bind_in t1 t2] + | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] + | _ -> CErrors.anomaly (str"where are we?.") + with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) + | CNotation((InConstrEntrySomeLevel,"( _ in _ in _ )"), ([t1; t2; t3], [], [], [])) -> + check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] + | CNotation((InConstrEntrySomeLevel,"( _ as _ )"), ([t1; t2], [], [], [])) -> + encode k "As" [fst (glob t1); fst (glob t2)] + | CNotation((InConstrEntrySomeLevel,"( _ as _ in _ )"), ([t1; t2; t3], [], [], [])) -> + check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] + | _ -> glob_ssrterm gs orig +;; + +let glob_rpattern s p = + match p with + | T t -> T (glob_cpattern s t) + | In_T t -> In_T (glob_ssrterm s t) + | X_In_T(x,t) -> X_In_T (x,glob_ssrterm s t) + | In_X_In_T(x,t) -> In_X_In_T (x,glob_ssrterm s t) + | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) + | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) + +let subst_ssrterm s (k, c, ist) = + k, Tacsubst.subst_glob_constr_and_expr s c, ist + +let subst_rpattern s = function + | T t -> T (subst_ssrterm s t) + | In_T t -> In_T (subst_ssrterm s t) + | X_In_T(x,t) -> X_In_T (x,subst_ssrterm s t) + | In_X_In_T(x,t) -> In_X_In_T (x,subst_ssrterm s t) + | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) + | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) + +let interp_ssrterm ist (k,t,_) = k, t, Some ist + +let interp_rpattern s = function + | T t -> T (interp_ssrterm s t) + | In_T t -> In_T (interp_ssrterm s t) + | X_In_T(x,t) -> X_In_T (interp_ssrterm s x,interp_ssrterm s t) + | In_X_In_T(x,t) -> In_X_In_T (interp_ssrterm s x,interp_ssrterm s t) + | E_In_X_In_T(e,x,t) -> + E_In_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) + | E_As_X_In_T(e,x,t) -> + E_As_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) + +let interp_rpattern0 ist gl t = Tacmach.project gl, interp_rpattern ist t + +type cpattern = char * glob_constr_and_expr * Geninterp.interp_sign option +let tag_of_cpattern = pi1 +let loc_of_cpattern = loc_ofCG +let cpattern_of_term (c, t) ist = c, t, Some ist +type occ = (bool * int list) option + +type rpattern = (cpattern, cpattern) ssrpattern + +type pattern = Evd.evar_map * (constr, constr) ssrpattern + +let id_of_cpattern (_, (c1, c2), _) = + let open CAst in + match DAst.get c1, c2 with + | _, Some { v = CRef (qid, _) } when qualid_is_ident qid -> + Some (qualid_basename qid) + | _, Some { v = CAppExpl ((_, qid, _), []) } when qualid_is_ident qid -> + Some (qualid_basename qid) + | GRef (VarRef x, _), None -> Some x + | _ -> None +let id_of_Cterm t = match id_of_cpattern t with + | Some x -> x + | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" + +let of_ftactic ftac gl = + let r = ref None in + let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in + let tac = Proofview.V82.of_tactic tac in + let { sigma = sigma } = tac gl in + let ans = match !r with + | None -> assert false (** If the tactic failed we should not reach this point *) + | Some ans -> ans + in + (sigma, ans) + +let interp_wit wit ist gl x = + let globarg = in_gen (glbwit wit) x in + let arg = interp_genarg ist globarg in + let (sigma, arg) = of_ftactic arg gl in + sigma, Value.cast (topwit wit) arg +let interp_open_constr ist gl gc = + interp_wit wit_open_constr ist gl gc +let pf_intern_term gl (_, c, ist) = glob_constr ist (pf_env gl) (project gl) c + +let interp_ssrterm ist gl t = Tacmach.project gl, interp_ssrterm ist t + +let interp_term gl = function + | (_, c, Some ist) -> + on_snd EConstr.Unsafe.to_constr (interp_open_constr ist gl c) + | _ -> errorstrm (str"interpreting a term with no ist") + +let thin id sigma goal = + let ids = Id.Set.singleton id in + let env = Goal.V82.env sigma goal in + let cl = Goal.V82.concl sigma goal in + let sigma = Evd.clear_metas sigma in + let ans = + try Some (Evarutil.clear_hyps_in_evi env sigma (Environ.named_context_val env) cl ids) + with Evarutil.ClearDependencyError _ -> None + in + match ans with + | None -> sigma + | Some (sigma, hyps, concl) -> + 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 + sigma + +(* +let pr_ist { lfun= lfun } = + prlist_with_sep spc + (fun (id, Geninterp.Val.Dyn(ty,_)) -> + pr_id id ++ str":" ++ Geninterp.Val.pr ty) (Id.Map.bindings lfun) +*) + +let interp_pattern ?wit_ssrpatternarg gl red redty = + pp(lazy(str"interpreting: " ++ pr_pattern red)); + let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in + let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in + let eAsXInT e x t = E_As_X_In_T(e,x,t) in + let mkG ?(k=' ') x ist = k,(x,None), ist in + let ist_of (_,_,ist) = ist in + let decode (_,_,ist as t) ?reccall f g = + try match DAst.get (pf_intern_term gl t) with + | GCast(t,CastConv c) when isGHole t && isGLambda c-> + let (x, c) = destGLambda c in + f x (' ',(c,None),ist) + | GVar id + when Option.has_some ist && let ist = Option.get ist in + Id.Map.mem id ist.lfun && + not(Option.is_empty reccall) && + not(Option.is_empty wit_ssrpatternarg) -> + let v = Id.Map.find id (Option.get ist).lfun in + Option.get reccall + (Value.cast (topwit (Option.get wit_ssrpatternarg)) v) + | it -> g t with e when CErrors.noncritical e -> g t in + let decodeG ist t f g = decode (mkG t ist) f g in + let bad_enc id _ = CErrors.anomaly (str"bad encoding for pattern "++str id++str".") in + let cleanup_XinE h x rp sigma = + let h_k = match kind h with Evar (k,_) -> k | _ -> assert false in + let to_clean, update = (* handle rename if x is already used *) + let ctx = pf_hyps gl in + let len = Context.Named.length ctx in + let name = ref None in + try ignore(Context.Named.lookup x ctx); (name, fun k -> + if !name = None then + let nctx = Evd.evar_context (Evd.find sigma k) in + let nlen = Context.Named.length nctx in + if nlen > len then begin + name := Some (Context.Named.Declaration.get_id (List.nth nctx (nlen - len - 1))) + end) + with Not_found -> ref (Some x), fun _ -> () in + let sigma0 = project gl in + let new_evars = + let rec aux acc t = match kind t with + | Evar (k,_) -> + if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else + (update k; k::acc) + | _ -> CoqConstr.fold aux acc t 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 *) + if Option.is_empty !to_clean then sigma else + let name = Option.get !to_clean in + pp(lazy(pr_id name)); + thin name sigma e) + sigma new_evars in + sigma in + let red = let rec decode_red = function + | T(k,(t,None),ist) -> + begin match DAst.get t with + | GCast (c,CastConv t) + when isGHole c && + let (id, t) = destGLambda t in + let id = Id.to_string id in let len = String.length id in + (len > 8 && String.sub id 0 8 = "_ssrpat_") -> + let (id, t) = destGLambda t in + let id = Id.to_string id in let len = String.length id in + (match String.sub id 8 (len - 8), DAst.get t with + | "In", GApp( _, [t]) -> decodeG ist t xInT (fun x -> T x) + | "In", GApp( _, [e; t]) -> decodeG ist t (eInXInT (mkG e ist)) (bad_enc id) + | "In", GApp( _, [e; t; e_in_t]) -> + decodeG ist t (eInXInT (mkG e ist)) + (fun _ -> decodeG ist e_in_t xInT (fun _ -> assert false)) + | "As", GApp(_, [e; t]) -> decodeG ist t (eAsXInT (mkG e ist)) (bad_enc id) + | _ -> bad_enc id ()) + | _ -> + decode ~reccall:decode_red (mkG ~k t ist) xInT (fun x -> T x) + end + | T t -> decode ~reccall:decode_red t xInT (fun x -> T x) + | In_T t -> decode t inXInT inT + | X_In_T (e,t) -> decode t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x) + | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t + | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp + | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in + decode_red red in + pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red)); + let red = + match redty with + | None -> red + | Some (ty, ist) -> let ty = ' ', ty, Some ist in + match red with + | T t -> T (combineCG t ty (mkCCast ?loc:(loc_ofCG t)) mkRCast) + | X_In_T (x,t) -> + let gty = pf_intern_term gl ty in + E_As_X_In_T (mkG (mkRCast mkRHole gty) (ist_of ty), x, t) + | E_In_X_In_T (e,x,t) -> + let ty = mkG (pf_intern_term gl ty) (ist_of ty) in + E_In_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) + | E_As_X_In_T (e,x,t) -> + let ty = mkG (pf_intern_term gl ty) (ist_of ty) in + E_As_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) + | red -> red in + pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); + let mkXLetIn ?loc x (a,(g,c),ist) = match c with + | Some b -> a,(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)), ist + | None -> a,(DAst.make ?loc @@ GLetIn (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None), ist in + match red with + | T t -> let sigma, t = interp_term gl t in sigma, T t + | In_T t -> let sigma, t = interp_term gl t in sigma, In_T t + | X_In_T (x, rp) | In_X_In_T (x, rp) -> + let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in + let rp = mkXLetIn (Name x) rp in + let sigma, rp = interp_term gl rp in + let _, h, _, rp = destLetIn rp in + let sigma = cleanup_XinE h x rp sigma 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 = + match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in + let rp = mkXLetIn (Name x) rp in + let sigma, rp = interp_term gl rp in + let _, h, _, rp = destLetIn rp in + let sigma = cleanup_XinE h x rp sigma in + let rp = subst1 h (nf_evar sigma rp) in + let sigma, e = interp_term (re_sig (sig_it gl) sigma) e in + sigma, mk e h rp +;; +let interp_cpattern gl red redty = interp_pattern gl (T red) redty;; +let interp_rpattern ~wit_ssrpatternarg gl red = interp_pattern ~wit_ssrpatternarg gl red None;; + +let id_of_pattern = function + | _, T t -> (match kind t with Var id -> Some id | _ -> None) + | _ -> None + +(* The full occurrence set *) +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 = 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 -> EConstr.Unsafe.to_constr c + | _ -> errorstrm (str "Matching the pattern " ++ pr_constr_env env0 sigma0 p ++ + str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ + str "Does the variable bound by the \"in\" construct occur "++ + str "in the pattern?") in + let sigma = + Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in + sigma, e_body in + let ex_value hole = + match kind hole with Evar (e,_) -> e | _ -> assert false in + let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok = + let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in + sigma, [pat] in + match pattern with + | None -> do_subst env0 concl0 concl0 1, UState.empty + | Some (sigma, (T rp | In_T rp)) -> + let rp = fs sigma rp in + let ise = create_evar_defs sigma in + let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in + let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in + let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in + let concl = find_T env0 concl0 1 ~k:do_subst in + let _, _, (_, us, _) = end_T () in + concl, us + | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) -> + let p = fs sigma p in + let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in + let ex = ex_value hole in + let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in + let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in + (* we start from sigma, so hole is considered a rigid head *) + 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 ~k:(fun env c _ h -> + 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 + ~k:(fun env _ -> do_subst env e_body))) in + let _ = end_X () in let _, _, (_, us, _) = end_T () in + concl, us + | Some (sigma, E_In_X_In_T (e, hole, p)) -> + let p, e = fs sigma p, fs sigma e in + let ex = ex_value hole in + let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in + let find_T, end_T = 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 noindex holep in + 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 ~k:(fun env c _ h -> + 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 ~k:(fun env c _ h -> + find_E env e_body h ~k:do_subst))) in + let _,_,(_,us,_) = end_E () in + let _ = end_X () in let _ = end_T () in + concl, us + | Some (sigma, E_As_X_In_T (e, hole, p)) -> + 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 (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 ~k:(fun env c _ h -> + 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 ~k:(fun env c _ h -> + 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 _,_,(_,us,_) = end_TE () in + concl, us +;; + +let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = + let e = match p with + | In_T _ | In_X_In_T _ -> CErrors.anomaly (str"pattern without redex.") + | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in + let sigma = + if not resolve_typeclasses then sigma + else Typeclasses.resolve_typeclasses ~fail:false env sigma in + 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 = + if occ = Some(true,[]) then false, Some(false,[1]) else true, occ in + let find_R, conclude = + let r = ref None in + (fun env c _ h' -> + do_once r (fun () -> c); + if do_make_rel then mkRel (h'+h-1) else c), + (fun _ -> if !r = None then fst(redex_of_pattern env pat) + else assert_done r) in + let cl, us = + eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in + let e = conclude cl in + (e, us), cl +;; + +(* clenup interface for external use *) +let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = + mk_tpattern ?p_origin env sigma0 sigma_t f dir c +;; + +let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = + fst (eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst) +;; + +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,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 ~k:(fun _ _ _ -> mkRel) in + let rdx, _, (sigma, uc, p) = end_U () in + 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 + let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in + if sigma' != sigma0 then CErrors.user_err Pp.(str "matching impacts evars") + else cl, (Evd.merge_universe_context sigma' uc, t') + with NoMatch -> try + let sigma', uc, t' = + unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in + if sigma' != sigma0 then raise NoMatch + else cl, (Evd.merge_universe_context sigma' uc, t') + with _ -> + 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 = + let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in + let cl,(_,t) = fill_occ_term env concl occ sigma0 t in + cl, t + +let cpattern_of_id id = + ' ', (DAst.make @@ GRef (VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty }) + +let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with + | _, Some { CAst.v = CHole _ } | GHole _, None -> true + | _ -> false + +(* "ssrpattern" *) + +let pr_rpattern = pr_pattern + +let pf_merge_uc uc gl = + re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) + +let pf_unsafe_merge_uc uc gl = + re_sig (sig_it gl) (Evd.set_universe_context (project gl) uc) + +(** All the pattern types reuse the same dynamic toplevel tag *) +let wit_ssrpatternarg = wit_rpatternty + +let interp_rpattern = interp_rpattern ~wit_ssrpatternarg + +let ssrpatterntac _ist arg gl = + let pat = interp_rpattern 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 (pf_env gl) 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 = EConstr.mkLetIn (Name (Id.of_string "selected"), t, tty, concl_x) in + Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl + +(* Register "ssrpattern" tactic *) +let () = + let mltac _ ist = + let arg = + let v = Id.Map.find (Names.Id.of_string "pattern") ist.lfun in + Value.cast (topwit wit_ssrpatternarg) v in + Proofview.V82.tactic (ssrpatterntac ist arg) in + let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in + let () = Tacenv.register_ml_tactic name [|mltac|] in + let tac = + TacFun ([Name (Id.of_string "pattern")], + TacML (Loc.tag ({ mltac_name = name; mltac_index = 0 }, []))) in + let obj () = + Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in + Mltop.declare_cache_obj obj "ssrmatching_plugin" + +let ssrinstancesof arg gl = + let ok rhs lhs ise = true in +(* not (equal 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 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 + let find, conclude = + mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true + sigma None (etpat,[tpat]) in + let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) p ++ spc() + ++ str "matches:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) c)); c in + ppnl (str"BEGIN INSTANCES"); + try + while true do + ignore(find env concl 1 ~k:print) + done; raise NoMatch + with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl + +module Internal = +struct + let wit_rpatternty = wit_rpatternty + let glob_rpattern = glob_rpattern + let subst_rpattern = subst_rpattern + let interp_rpattern = interp_rpattern0 + let pr_rpattern = pr_rpattern + let mk_rpattern x = x + let mk_lterm = mk_lterm + let mk_term = mk_term + let glob_cpattern = glob_cpattern + let subst_ssrterm = subst_ssrterm + let interp_ssrterm = interp_ssrterm + let pr_ssrterm = pr_term +end + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 deleted file mode 100644 index 307bc21a..00000000 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ /dev/null @@ -1,1484 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* ()) -let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) -let _ = - try ignore(Sys.getenv "SSRMATCHINGDEBUG"); pp_ref := ssr_pp - with Not_found -> () -let debug b = - if b then pp_ref := ssr_pp else pp_ref := fun _ -> () -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssrmatching debugging"; - Goptions.optkey = ["Debug";"SsrMatching"]; - Goptions.optdepr = false; - Goptions.optread = (fun _ -> !pp_ref == ssr_pp); - Goptions.optwrite = debug } -let pp s = !pp_ref s - -(** Utils *)(* {{{ *****************************************************************) -let env_size env = List.length (Environ.named_context env) -let safeDestApp c = - match kind c with App (f, a) -> f, a | _ -> c, [| |] -(* Toplevel constr must be globalized twice ! *) -let glob_constr ist genv sigma t = match t, ist with - | (_, Some ce), Some ist -> - let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in - let ltacvars = { Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in - Constrintern.intern_gen WithoutTypeConstraint ~ltacvars:ltacvars genv sigma ce - | (rc, None), _ -> rc - | (_, Some _), None -> CErrors.anomaly Pp.(str"glob_constr: term with no ist") - -(* Term printing utilities functions for deciding bracketing. *) -let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")") -(* String lexing utilities *) -let skip_wschars s = - let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop -(* We also guard characters that might interfere with the ssreflect *) -(* tactic syntax. *) -let guard_term ch1 s i = match s.[i] with - | '(' -> false - | '{' | '/' | '=' -> true - | _ -> ch1 = '(' -(* The call 'guard s i' should return true if the contents of s *) -(* starting at i need bracketing to avoid ambiguities. *) -let pr_guarded guard prc c = - let s = Pp.string_of_ppcmds (prc c) ^ "$" in - if guard s (skip_wschars s 0) then pr_paren prc c else prc c -(* More sensible names for constr printers *) -let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c -let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c -let prl_constr_expr = pr_lconstr_expr -let pr_constr_expr = pr_constr_expr -let prl_glob_constr_and_expr = function - | _, Some c -> prl_constr_expr c - | c, None -> prl_glob_constr c -let pr_glob_constr_and_expr = function - | _, Some c -> pr_constr_expr c - | c, None -> pr_glob_constr c -let pr_term (k, c, _) = pr_guarded (guard_term k) pr_glob_constr_and_expr c -let prl_term (k, c, _) = pr_guarded (guard_term k) prl_glob_constr_and_expr c - -(** Adding a new uninterpreted generic argument type *) -let add_genarg tag pr = - let wit = Genarg.make0 tag in - let tag = Geninterp.Val.create tag in - let glob ist x = (ist, x) in - let subst _ x = x in - let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in - let gen_pr _ _ _ = pr in - let () = Genintern.register_intern0 wit glob in - let () = Genintern.register_subst0 wit subst in - let () = Geninterp.register_interp0 wit interp in - let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in - Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr; - wit - -(** Constructors for cast type *) -let dC t = CastConv t -(** Constructors for constr_expr *) -let isCVar = function { CAst.v = CRef ({CAst.v=Ident _},_) } -> true | _ -> false -let destCVar = function { CAst.v = CRef ({CAst.v=Ident id},_) } -> id | _ -> - CErrors.anomaly (str"not a CRef.") -let isGLambda c = match DAst.get c with GLambda (Name _, _, _, _) -> true | _ -> false -let destGLambda c = match DAst.get c with GLambda (Name id, _, _, c) -> (id, c) - | _ -> CErrors.anomaly (str "not a GLambda") -let isGHole c = match DAst.get c with GHole _ -> true | _ -> false -let mkCHole ~loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) -let mkCLambda ?loc name ty t = CAst.make ?loc @@ - CLambdaN ([CLocalAssum([CAst.make ?loc name], Default Explicit, ty)], t) -let mkCLetIn ?loc name bo t = CAst.make ?loc @@ - CLetIn ((CAst.make ?loc name), bo, None, t) -let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, dC ty) -(** Constructors for rawconstr *) -let mkRHole = DAst.make @@ GHole (InternalHole, IntroAnonymous, None) -let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) -let mkRCast rc rt = DAst.make @@ GCast (rc, dC rt) -let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) - -(* ssrterm conbinators *) -let combineCG t1 t2 f g = - let mk_ist i1 i2 = match i1, i2 with - | None, Some i -> Some i - | Some i, None -> Some i - | None, None -> None - | Some i, Some j when i == j -> Some i - | _ -> CErrors.anomaly (Pp.str "combineCG: different ist") in - match t1, t2 with - | (x, (t1, None), i1), (_, (t2, None), i2) -> - x, (g t1 t2, None), mk_ist i1 i2 - | (x, (_, Some t1), i1), (_, (_, Some t2), i2) -> - x, (mkRHole, Some (f t1 t2)), mk_ist i1 i2 - | _, (_, (_, None), _) -> CErrors.anomaly (str"have: mixed C-G constr.") - | _ -> CErrors.anomaly (str"have: mixed G-C constr.") -let loc_ofCG = function - | (_, (s, None), _) -> Glob_ops.loc_of_glob_constr s - | (_, (_, Some s), _) -> Constrexpr_ops.constr_loc s - -let mk_term k c ist = k, (mkRHole, Some c), ist -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 *)(* {{{ *************************************************************) -type profiler = { - profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; - reset : unit -> unit; - print : unit -> unit } -let profile_now = ref false -let something_profiled = ref false -let profilers = ref [] -let add_profiler f = profilers := f :: !profilers;; -let profile b = - profile_now := b; - if b then List.iter (fun f -> f.reset ()) !profilers; - if not b then List.iter (fun f -> f.print ()) !profilers -;; -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssrmatching profiling"; - Goptions.optkey = ["SsrMatchingProfiling"]; - Goptions.optread = (fun _ -> !profile_now); - Goptions.optdepr = false; - Goptions.optwrite = profile } -let () = - let prof_total = - let init = ref 0.0 in { - profile = (fun f x -> assert false); - reset = (fun () -> init := Unix.gettimeofday ()); - print = (fun () -> if !something_profiled then - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in - let prof_legenda = { - profile = (fun f x -> assert false); - reset = (fun () -> ()); - print = (fun () -> if !something_profiled then begin - prerr_endline - (Printf.sprintf "!! %39s ---------- --------- --------- ---------" - (String.make 39 '-')); - prerr_endline - (Printf.sprintf "!! %-39s %10s %9s %9s %9s" - "function" "#calls" "total" "max" "average") end) } in - add_profiler prof_legenda; - add_profiler prof_total -;; - -let mk_profiler s = - let total, calls, max = ref 0.0, ref 0, ref 0.0 in - let reset () = total := 0.0; calls := 0; max := 0.0 in - let profile f x = - if not !profile_now then f x else - let before = Unix.gettimeofday () in - try - incr calls; - let res = f x in - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - res - with exc -> - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - raise exc in - let print () = - if !calls <> 0 then begin - something_profiled := true; - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - s !calls !total !max (!total /. (float_of_int !calls))) end in - let prof = { profile = profile; reset = reset; print = print } in - add_profiler prof; - prof -;; -(* }}} *) - -exception NoProgress - -(** Unification procedures. *) - -(* To enforce the rigidity of the rooted match we always split *) -(* top applications, so the unification procedures operate on *) -(* arrays of patterns and terms. *) -(* We perform three kinds of unification: *) -(* EQ: exact conversion check *) -(* FO: first-order unification of evars, without conversion *) -(* HO: higher-order unification with conversion *) -(* The subterm unification strategy is to find the first FO *) -(* match, if possible, and the first HO match otherwise, then *) -(* compute all the occurrences that are EQ matches for the *) -(* relevant subterm. *) -(* Additional twists: *) -(* - If FO/HO fails then we attempt to fill evars using *) -(* typeclasses before raising an outright error. We also *) -(* fill typeclasses even after a successful match, since *) -(* beta-reduction and canonical instances may leave *) -(* undefined evars. *) -(* - We do postchecks to rule out matches that are not *) -(* closed or that assign to a global evar; these can be *) -(* disabled for rewrite or dependent family matches. *) -(* - We do a full FO scan before turning to HO, as the FO *) -(* comparison can be much faster than the HO one. *) - -let unif_EQ env sigma p c = - let evars = existential_opt_value sigma, Evd.universes sigma in - try let _ = Reduction.conv env p ~evars c in true with _ -> false - -let unif_EQ_args env sigma pa a = - let n = Array.length pa in - let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in - loop 0 - -let prof_unif_eq_args = mk_profiler "unif_EQ_args";; -let unif_EQ_args env sigma pa a = - prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a -;; - -let unif_HO env ise p c = - try Evarconv.the_conv_x env p c ise - with Evarconv.UnableToUnify(ise, err) -> - raise Pretype_errors.(PretypeError(env,ise,CannotUnify(p,c,Some err))) - -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 (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 *) -(* alas things are not so simple: w_unify does partial type-checking, *) -(* which breaks down when the no-delta flag is on (as the Coq type system *) -(* requires full convertibility. The workaround here is to convert all *) -(* evars into metas, since 8.2 does not TC metas. This means some lossage *) -(* for HO evars, though hopefully Miller patterns can pick up some of *) -(* those cases, and HO matching will mop up the rest. *) -let flags_FO = - let flags = - { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags - with - Unification.modulo_conv_on_closed_terms = None; - Unification.modulo_eta = true; - Unification.modulo_betaiota = true; - Unification.modulo_delta_types = full_transparent_state} - in - { Unification.core_unify_flags = flags; - Unification.merge_unify_flags = flags; - Unification.subterm_unify_flags = flags; - Unification.allow_K_in_toplevel_higher_order_unification = false; - Unification.resolve_evars = - (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 (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 c' with - | Evar ex -> - begin try nf (existential_value s ex) with _ -> - let k, a = ex in let a' = Array.map nf a in - if not (Evd.mem !s' k) then - s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); - mkEvar (k, a') - end - | _ -> map nf c' in - let copy_def k evi () = - if evar_body evi != Evd.Evar_empty then () else - match Evd.evar_body (Evd.find s k) with - | 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, EConstr.of_constr c' - -let unif_end env sigma0 ise0 pt ok = - let ise = Evarconv.solve_unif_constraints_with_heuristics env ise0 in - let s, uc, t = nf_open_term sigma0 ise pt in - let ise1 = create_evar_defs s in - let ise1 = Evd.set_universe_context ise1 uc in - let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in - if not (ok ise) then raise NoProgress else - if ise2 == ise1 then (s, uc, t) - else - let s, uc', t = nf_open_term sigma0 ise2 t in - s, UState.union uc uc', t - -let unify_HO env sigma0 t1 t2 = - let sigma = unif_HO env sigma0 t1 t2 in - let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in - Evd.set_universe_context sigma uc - -let pf_unify_HO gl t1 t2 = - let env, sigma0, si = pf_env gl, project gl, sig_it gl in - let sigma = unify_HO env sigma0 t1 t2 in - re_sig si sigma - -(* This is what the definition of iter_constr should be... *) -let iter_constr_LR f c = match kind c with - | Evar (k, a) -> Array.iter f a - | Cast (cc, _, t) -> f cc; f t - | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b - | LetIn (_, v, t, b) -> f v; f t; f b - | App (cf, a) -> f cf; Array.iter f a - | Case (_, p, v, b) -> f v; f p; Array.iter f b - | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> - for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done - | Proj(_,a) -> f a - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () - -(* The comparison used to determine which subterms matches is KEYED *) -(* CONVERSION. This looks for convertible terms that either have the same *) -(* same head constant as pat if pat is an application (after beta-iota), *) -(* or start with the same constr constructor (esp. for LetIn); this is *) -(* disregarded if the head term is let x := ... in x, and casts are always *) -(* ignored and removed). *) -(* Record projections get special treatment: in addition to the projection *) -(* constant itself, ssreflect also recognizes head constants of canonical *) -(* projections. *) - -exception NoMatch -type ssrdir = L2R | R2L -let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS" -let inv_dir = function L2R -> R2L | R2L -> L2R - - -type pattern_class = - | KpatFixed - | KpatConst - | KpatEvar of Evar.t - | KpatLet - | KpatLam - | KpatRigid - | KpatFlex - | KpatProj of Constant.t - -type tpattern = { - up_k : pattern_class; - up_FO : constr; - up_f : constr; - 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; (* progress test for rewrite *) - } - -let all_ok _ _ = true - -let proj_nparams c = - try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0 - -let isRigid c = match kind c with - | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true - | _ -> false - -let hole_var = mkVar (Id.of_string "_") -let pr_constr_pat c0 = - let rec wipe_evar c = - if isEvar c then hole_var else map wipe_evar c in - let sigma, env = Pfedit.get_current_context () in - pr_constr_env env sigma (wipe_evar c0) - -(* Turn (new) evars into metas *) -let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = - let ise = ref ise0 in - let sigma = ref ise0 in - let nenv = env_size env + if hack then 1 else 0 in - let rec put c = match kind c with - | Evar (k, a as ex) -> - begin try put (existential_value !sigma ex) - with NotInstantiatedEvar -> - if Evd.mem sigma0 k then map put c else - let evi = Evd.find !sigma k in - let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in - let abs_dc (d, c) = function - | Context.Named.Declaration.LocalDef (x, b, t) -> - d, mkNamedLetIn x (put b) (put t) c - | Context.Named.Declaration.LocalAssum (x, t) -> - mkVar x :: d, mkNamedProd x (put t) c in - let a, t = - Context.Named.fold_inside abs_dc ~init:([], (put evi.evar_concl)) dc in - let m = Evarutil.new_meta () in - ise := meta_declare m t !ise; - sigma := Evd.define k (applistc (mkMeta m) a) !sigma; - put (existential_value !sigma ex) - end - | _ -> map put c in - let c1 = put c0 in !ise, c1 - -(* Compile a match pattern from a term; t is the term to fill. *) -(* 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 (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 f with - | Const (p,_) -> - let np = proj_nparams p in - if np = 0 || np > List.length a then KpatConst, f, a else - let a1, a2 = List.chop np a in KpatProj p, (applistc f a1), a2 - | Proj (p,arg) -> KpatProj (Projection.constant p), f, a - | Var _ | Ind _ | Construct _ -> KpatFixed, f, a - | Evar (k, _) -> - if Evd.mem sigma0 k then KpatEvar k, f, a else - if a <> [] then KpatFlex, f, a else - (match p_origin with None -> CErrors.user_err Pp.(str "indeterminate pattern") - | Some (dir, rule) -> - errorstrm (str "indeterminate " ++ pr_dir_side dir - ++ str " in " ++ pr_constr_pat rule)) - | LetIn (_, v, _, b) -> - if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a - | Lambda _ -> KpatLam, f, a - | _ -> KpatRigid, f, a in - let aa = Array.of_list a in - let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in - ise', - { up_k = k; up_FO = p'; up_f = f; - up_a = aa; up_ok = ok; up_dir = dir; up_t = t} - -(* Specialize a pattern after a successful match: assign a precise head *) -(* kind and arity for Proj and Flex patterns. *) -let ungen_upat lhs (sigma, uc, t) u = - let f, a = safeDestApp lhs in - let k = match kind f with - | Var _ | Ind _ | Construct _ -> KpatFixed - | Const _ -> KpatConst - | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k - | LetIn _ -> KpatLet - | Lambda _ -> KpatLam - | _ -> KpatRigid in - sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t} - -let nb_cs_proj_args pc f u = - let na k = - List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in - let nargs_of_proj t = match kind t with - | App(_,args) -> Array.length args - | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be - the number of arguments including the projected *) - | _ -> assert false in - try match kind f with - | Prod _ -> na Prod_cs - | Sort s -> na (Sort_cs (Sorts.family s)) - | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f - | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f - | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) - | _ -> -1 - with Not_found -> -1 - -let isEvar_k k f = - match kind f with Evar (k', _) -> k = k' | _ -> false - -let nb_args c = - match kind c with App (_, a) -> Array.length a | _ -> 0 - -let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i -let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a) - -let splay_app ise = - let rec loop c a = match kind c with - | App (f, a') -> loop f (Array.append a' a) - | Cast (c', _, _) -> loop c' a - | Evar ex -> - (try loop (existential_value ise ex) a with _ -> c, a) - | _ -> c, a in - fun c -> match kind c with - | App (f, a) -> loop f a - | Cast _ | Evar _ -> loop c [| |] - | _ -> c, [| |] - -let filter_upat i0 f n u fpats = - let na = Array.length u.up_a in - if n < na then fpats else - let np = match u.up_k with - | KpatConst when eq_constr_nounivs u.up_f f -> na - | KpatFixed when eq_constr_nounivs u.up_f f -> na - | KpatEvar k when isEvar_k k f -> na - | KpatLet when isLetIn f -> na - | KpatLam when isLambda f -> na - | KpatRigid when isRigid f -> na - | KpatFlex -> na - | KpatProj pc -> - let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np - | _ -> -1 in - if np < na then fpats else - let () = if !i0 < np then i0 := n in (u, np) :: fpats - -let eq_prim_proj c t = match kind t with - | Proj(p,_) -> Constant.equal (Projection.constant p) c - | _ -> false - -let filter_upat_FO i0 f n u fpats = - let np = nb_args u.up_FO in - if n < np then fpats else - let ok = match u.up_k with - | KpatConst -> eq_constr_nounivs u.up_f f - | KpatFixed -> eq_constr_nounivs u.up_f f - | KpatEvar k -> isEvar_k k f - | KpatLet -> isLetIn f - | KpatLam -> isLambda f - | KpatRigid -> isRigid f - | KpatProj pc -> equal f (mkConst pc) || eq_prim_proj pc f - | KpatFlex -> i0 := n; true in - if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats - -exception FoundUnif of (evar_map * UState.t * tpattern) -(* Note: we don't update env as we descend into the term, as the primitive *) -(* unification procedure always rejects subterms with bound variables. *) - -let dont_impact_evars_in cl = - let evs_in_cl = Evd.evars_of_term cl in - fun sigma -> Evar.Set.for_all (fun k -> - try let _ = Evd.find_undefined sigma k in true - with Not_found -> false) evs_in_cl - -(* We are forced to duplicate code between the FO/HO matching because we *) -(* have to work around several kludges in unify.ml: *) -(* - w_unify drops into second-order unification when the pattern is an *) -(* application whose head is a meta. *) -(* - w_unify tries to unify types without subsumption when the pattern *) -(* head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type). *) -(* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) -(* match a head let rigidly. *) -let match_upats_FO upats env sigma0 ise orig_c = - let dont_impact_evars = dont_impact_evars_in orig_c in - let rec loop c = - let f, a = splay_app ise c in let i0 = ref (-1) in - let fpats = - List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in - while !i0 >= 0 do - let i = !i0 in i0 := -1; - let c' = mkSubApp f i a in - let one_match (u, np) = - let skip = - if i <= np then i < np else - if u.up_k == KpatFlex then begin i0 := i - 1; false end else - begin if !i0 < np then i0 := np; true end in - if skip || not (closed0 c') then () else try - let _ = match u.up_k with - | KpatFlex -> - let kludge v = mkLambda (Anonymous, mkProp, v) in - unif_FO env ise (kludge u.up_FO) (kludge c') - | KpatLet -> - let kludge vla = - let vl, a = safeDestApp vla in - let x, v, t, b = destLetIn vl in - mkApp (mkLambda (x, t, b), Array.cons v a) in - unif_FO env ise (kludge u.up_FO) (kludge 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 (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' (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.") - | e when CErrors.noncritical e -> () in - List.iter one_match fpats - done; - iter_constr_LR loop f; Array.iter loop a in - try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO.") - -let prof_FO = mk_profiler "match_upats_FO";; -let match_upats_FO upats env sigma0 ise c = - prof_FO.profile (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 it_did_match = ref false in - let failed_because_of_TC = ref false in - let rec aux upats env sigma0 ise c = - let f, a = splay_app ise c in let i0 = ref (-1) in - let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in - while !i0 >= 0 do - let i = !i0 in i0 := -1; - let one_match (u, np) = - let skip = - if i <= np then i < np else - if u.up_k == KpatFlex then begin i0 := i - 1; false end else - begin if !i0 < np then i0 := np; true end in - if skip then () else try - let ise' = match u.up_k with - | KpatFixed | KpatConst -> ise - | KpatEvar _ -> - let _, pka = destEvar u.up_f and _, ka = destEvar f in - unif_HO_args env ise pka 0 ka - | KpatLet -> - let x, v, t, b = destLetIn f in - let _, pv, _, pb = destLetIn u.up_f 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' (EConstr.of_constr pb) (EConstr.of_constr b) - | KpatFlex | KpatProj _ -> - 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'' (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 - | Pretype_errors.PretypeError - (_,_,Pretype_errors.UnsatisfiableConstraints _) -> - failed_because_of_TC:=true - | e when CErrors.noncritical e -> () in - List.iter one_match fpats - done; - iter_constr_LR (aux upats env sigma0 ise) f; - Array.iter (aux upats env sigma0 ise) a - in - aux upats env sigma0 ise c; - if !it_did_match then raise NoProgress; - !failed_because_of_TC - -let prof_HO = mk_profiler "match_upats_HO";; -let match_upats_HO ~on_instance upats env sigma0 ise c = - prof_HO.profile (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 Evd.empty (EConstr.of_constr t)) (** FIXME *) - -let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) - -let assert_done r = - match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called.") - -let assert_done_multires r = - match !r with - | None -> CErrors.anomaly (str"do_once never called.") - | Some (n, xs) -> - r := Some (n+1,xs); - try List.nth xs n with Failure _ -> raise NoMatch - -type subst = Environ.env -> constr -> constr -> int -> constr -type find_P = - Environ.env -> constr -> int -> - k:subst -> - constr -type conclude = unit -> - constr * ssrdir * (Evd.evar_map * UState.t * constr) - -(* upats_origin makes a better error message only *) -let mk_tpattern_matcher ?(all_instances=false) - ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats) -= - let nocc = ref 0 and skip_occ = ref false in - let use_occ, occ_list = match occ with - | Some (true, ol) -> ol = [], ol - | Some (false, ol) -> ol <> [], ol - | None -> false, [] in - let max_occ = List.fold_right max occ_list 0 in - let subst_occ = - let occ_set = Array.make max_occ (not use_occ) in - let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in - let _ = if max_occ = 0 then skip_occ := use_occ in - fun () -> incr nocc; - if !nocc = max_occ then skip_occ := use_occ; - if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in - let upat_that_matched = ref None in - let match_EQ env sigma u = - match u.up_k with - | KpatLet -> - let x, pv, t, pb = destLetIn u.up_f in - let env' = - Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env in - let match_let f = match kind f with - | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b - | _ -> false in match_let - | KpatFixed -> eq_constr_nounivs u.up_f - | KpatConst -> eq_constr_nounivs u.up_f - | KpatLam -> fun c -> - (match kind c with - | Lambda _ -> unif_EQ env sigma u.up_f c - | _ -> false) - | _ -> unif_EQ env sigma u.up_f in -let p2t p = mkApp(p.up_f,p.up_a) in -let source () = match upats_origin, upats with - | None, [p] -> - (if fixed_upat p then str"term " else str"partial term ") ++ - pr_constr_pat (p2t p) ++ spc() - | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl() - | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat rule ++ spc() - | _, [] | None, _::_::_ -> - CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in -let on_instance, instances = - let instances = ref [] in - (fun x -> - if all_instances then instances := !instances @ [x] - else raise (FoundUnif x)), - (fun () -> !instances) in -let rec uniquize = function - | [] -> [] - | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs -> - 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 = nf_evar sigma1 t1 in - let f1 = nf_evar sigma1 f1 in - let a1 = Array.map (nf_evar sigma1) a1 in - not (equal t t1 && - equal f f1 && CArray.for_all2 equal a a1) in - x :: uniquize (List.filter neq xs) in - -((fun env c h ~k -> - do_once upat_that_matched (fun () -> - let failed_because_of_TC = ref false in - try - if not all_instances then match_upats_FO upats env sigma0 ise c; - failed_because_of_TC:=match_upats_HO ~on_instance upats env sigma0 ise c; - raise NoMatch - with FoundUnif sigma_u -> 0,[sigma_u] - | (NoMatch|NoProgress) when all_instances && instances () <> [] -> - 0, uniquize (instances ()) - | NoMatch when (not raise_NoMatch) -> - if !failed_because_of_TC then - errorstrm (source ()++strbrk"matches but type classes inference fails") - else - errorstrm (source () ++ str "does not match any subterm of the goal") - | NoProgress when (not raise_NoMatch) -> - let dir = match upats_origin with Some (d,_) -> d | _ -> - CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in - errorstrm (str"all matches of "++source()++ - str"are equal to the " ++ pr_dir_side (inv_dir dir)) - | NoProgress -> raise NoMatch); - let sigma, _, ({up_f = pf; up_a = pa} as u) = - if all_instances then assert_done_multires upat_that_matched - else List.hd (snd(assert_done upat_that_matched)) in -(* pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); *) - if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else - let match_EQ = match_EQ env sigma u in - let pn = Array.length pa in - let rec subst_loop (env,h as acc) c' = - if !skip_occ then c' else - let f, a = splay_app sigma c' in - if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then - let a1, a2 = Array.chop (Array.length pa) a in - let fa1 = mkApp (f, a1) in - let f' = if subst_occ () then k env u.up_t fa1 h else fa1 in - mkApp (f', Array.map_left (subst_loop acc) a2) - else - (* TASSI: clear letin values to avoid unfolding *) - let inc_h rd (env,h') = - let ctx_item = - match rd with - | Context.Rel.Declaration.LocalAssum _ as x -> x - | Context.Rel.Declaration.LocalDef (x,_,y) -> - Context.Rel.Declaration.LocalAssum(x,y) 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 () -> - let sigma, uc, ({up_f = pf; up_a = pa} as u) = - match !upat_that_matched with - | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch - | None -> CErrors.anomaly (str"companion function never called.") in - let p' = mkApp (pf, pa) in - if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) - else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ - str(String.plural !nocc " occurence") ++ match upats_origin with - | None -> str" of" ++ spc() ++ pr_constr_pat p' - | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ - ws 4 ++ pr_constr_pat p' ++ fnl () ++ - str"of " ++ pr_constr_pat rule)) : conclude) - -type ('ident, 'term) ssrpattern = - | T of 'term - | In_T of 'term - | X_In_T of 'ident * 'term - | In_X_In_T of 'ident * 'term - | E_In_X_In_T of 'term * 'ident * 'term - | E_As_X_In_T of 'term * 'ident * 'term - -let pr_pattern = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t - | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t - | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t - -let pr_pattern_w_ids = function - | T t -> prl_term t - | In_T t -> str "in " ++ prl_term t - | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t - | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t - | E_In_X_In_T (e,x,t) -> - prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t - | E_As_X_In_T (e,x,t) -> - prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t - -let pr_pattern_aux pr_constr = function - | T t -> pr_constr t - | In_T t -> str "in " ++ pr_constr t - | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t - | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t - | E_In_X_In_T (e,x,t) -> - pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t - | 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 (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 - -let wit_rpatternty = add_genarg "rpatternty" pr_pattern - -let glob_ssrterm gs = function - | k, (_, Some c), None -> - let x = Tacintern.intern_constr gs c in - k, (fst x, Some c), None - | ct -> ct - -(* This piece of code asserts the following notations are reserved *) -(* Reserved Notation "( a 'in' b )" (at level 0). *) -(* Reserved Notation "( a 'as' b )" (at level 0). *) -(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *) -(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) -let glob_cpattern gs p = - pp(lazy(str"globbing pattern: " ++ pr_term p)); - let glob x = pi2 (glob_ssrterm gs (mk_lterm x None)) in - let encode k s l = - let name = Name (Id.of_string ("_ssrpat_" ^ s)) in - k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None), None in - let bind_in t1 t2 = - let mkCHole = mkCHole ~loc:None in let n = Name (destCVar t1) in - fst (glob (mkCCast mkCHole (mkCLambda n mkCHole t2))) in - let check_var t2 = if not (isCVar t2) then - loc_error (constr_loc t2) "Only identifiers are allowed here" in - match p with - | _, (_, None), _ as x -> x - | k, (v, Some t), _ as orig -> - if k = 'x' then glob_ssrterm gs ('(', (v, Some t), None) else - match t.CAst.v with - | CNotation("( _ in _ )", ([t1; t2], [], [], [])) -> - (try match glob t1, glob t2 with - | (r1, None), (r2, None) -> encode k "In" [r1;r2] - | (r1, Some _), (r2, Some _) when isCVar t1 -> - encode k "In" [r1; r2; bind_in t1 t2] - | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] - | _ -> CErrors.anomaly (str"where are we?.") - with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) - | CNotation("( _ in _ in _ )", ([t1; t2; t3], [], [], [])) -> - check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] - | CNotation("( _ as _ )", ([t1; t2], [], [], [])) -> - encode k "As" [fst (glob t1); fst (glob t2)] - | CNotation("( _ as _ in _ )", ([t1; t2; t3], [], [], [])) -> - check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] - | _ -> glob_ssrterm gs orig -;; - -let glob_rpattern s p = - match p with - | T t -> T (glob_cpattern s t) - | In_T t -> In_T (glob_ssrterm s t) - | X_In_T(x,t) -> X_In_T (x,glob_ssrterm s t) - | In_X_In_T(x,t) -> In_X_In_T (x,glob_ssrterm s t) - | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) - | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t) - -let subst_ssrterm s (k, c, ist) = - k, Tacsubst.subst_glob_constr_and_expr s c, ist - -let subst_rpattern s = function - | T t -> T (subst_ssrterm s t) - | In_T t -> In_T (subst_ssrterm s t) - | X_In_T(x,t) -> X_In_T (x,subst_ssrterm s t) - | In_X_In_T(x,t) -> In_X_In_T (x,subst_ssrterm s t) - | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) - | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t) - -let interp_ssrterm ist (k,t,_) = k, t, Some ist - -let interp_rpattern s = function - | T t -> T (interp_ssrterm s t) - | In_T t -> In_T (interp_ssrterm s t) - | X_In_T(x,t) -> X_In_T (interp_ssrterm s x,interp_ssrterm s t) - | In_X_In_T(x,t) -> In_X_In_T (interp_ssrterm s x,interp_ssrterm s t) - | E_In_X_In_T(e,x,t) -> - E_In_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) - | E_As_X_In_T(e,x,t) -> - E_As_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) - -let interp_rpattern ist gl t = Tacmach.project gl, interp_rpattern ist t - -ARGUMENT EXTEND rpattern - TYPED AS rpatternty - PRINTED BY pr_rpattern - INTERPRETED BY interp_rpattern - GLOBALIZED BY glob_rpattern - SUBSTITUTED BY subst_rpattern - | [ lconstr(c) ] -> [ T (mk_lterm c None) ] - | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c None) ] - | [ lconstr(x) "in" lconstr(c) ] -> - [ X_In_T (mk_lterm x None, mk_lterm c None) ] - | [ "in" lconstr(x) "in" lconstr(c) ] -> - [ In_X_In_T (mk_lterm x None, mk_lterm c None) ] - | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> - [ E_In_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None) ] - | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> - [ E_As_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None) ] -END - - - -type cpattern = char * glob_constr_and_expr * Geninterp.interp_sign option -let tag_of_cpattern = pi1 -let loc_of_cpattern = loc_ofCG -let cpattern_of_term (c, t) ist = c, t, Some ist -type occ = (bool * int list) option - -type rpattern = (cpattern, cpattern) ssrpattern - -type pattern = Evd.evar_map * (constr, constr) ssrpattern - -let id_of_cpattern (_, (c1, c2), _) = - let open CAst in - match DAst.get c1, c2 with - | _, Some { v = CRef ({CAst.v=Ident x}, _) } -> Some x - | _, Some { v = CAppExpl ((_, {CAst.v=Ident x}, _), []) } -> Some x - | GRef (VarRef x, _), None -> Some x - | _ -> None -let id_of_Cterm t = match id_of_cpattern t with - | Some x -> x - | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" - -let of_ftactic ftac gl = - let r = ref None in - let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in - let tac = Proofview.V82.of_tactic tac in - let { sigma = sigma } = tac gl in - let ans = match !r with - | None -> assert false (** If the tactic failed we should not reach this point *) - | Some ans -> ans - in - (sigma, ans) - -let interp_wit wit ist gl x = - let globarg = in_gen (glbwit wit) x in - let arg = interp_genarg ist globarg in - let (sigma, arg) = of_ftactic arg gl in - sigma, Value.cast (topwit wit) arg -let interp_open_constr ist gl gc = - interp_wit wit_open_constr ist gl gc -let pf_intern_term gl (_, c, ist) = glob_constr ist (pf_env gl) (project gl) c -let pr_ssrterm _ _ _ = pr_term -let input_ssrtermkind strm = match stream_nth 0 strm with - | Tok.KEYWORD "(" -> '(' - | Tok.KEYWORD "@" -> '@' - | _ -> ' ' -let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind - -let interp_ssrterm ist gl t = Tacmach.project gl, interp_ssrterm ist t - -ARGUMENT EXTEND cpattern - PRINTED BY pr_ssrterm - INTERPRETED BY interp_ssrterm - GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm - RAW_PRINTED BY pr_ssrterm - GLOB_PRINTED BY pr_ssrterm -| [ "Qed" constr(c) ] -> [ mk_lterm c None ] -END - -GEXTEND Gram - GLOBAL: cpattern; - cpattern: [[ k = ssrtermkind; c = constr -> - let pattern = mk_term k c None in - if loc_ofCG pattern <> Some !@loc && k = '(' - then mk_term 'x' c None - else pattern ]]; -END - -ARGUMENT EXTEND lcpattern - TYPED AS cpattern - PRINTED BY pr_ssrterm - INTERPRETED BY interp_ssrterm - GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm - RAW_PRINTED BY pr_ssrterm - GLOB_PRINTED BY pr_ssrterm -| [ "Qed" lconstr(c) ] -> [ mk_lterm c None ] -END - -GEXTEND Gram - GLOBAL: lcpattern; - lcpattern: [[ k = ssrtermkind; c = lconstr -> - let pattern = mk_term k c None in - if loc_ofCG pattern <> Some !@loc && k = '(' - then mk_term 'x' c None - else pattern ]]; -END - -let interp_term gl = function - | (_, c, Some ist) -> - on_snd EConstr.Unsafe.to_constr (interp_open_constr ist gl c) - | _ -> errorstrm (str"interpreting a term with no ist") - -let thin id sigma goal = - let ids = Id.Set.singleton id in - let env = Goal.V82.env sigma goal in - let cl = Goal.V82.concl sigma goal in - let evdref = ref (Evd.clear_metas sigma) in - let ans = - try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids) - with Evarutil.ClearDependencyError _ -> None - in - match ans with - | None -> sigma - | Some (hyps, concl) -> - 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 - sigma - -(* -let pr_ist { lfun= lfun } = - prlist_with_sep spc - (fun (id, Geninterp.Val.Dyn(ty,_)) -> - pr_id id ++ str":" ++ Geninterp.Val.pr ty) (Id.Map.bindings lfun) -*) - -let interp_pattern ?wit_ssrpatternarg gl red redty = - pp(lazy(str"interpreting: " ++ pr_pattern red)); - let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in - let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in - let eAsXInT e x t = E_As_X_In_T(e,x,t) in - let mkG ?(k=' ') x ist = k,(x,None), ist in - let ist_of (_,_,ist) = ist in - let decode (_,_,ist as t) ?reccall f g = - try match DAst.get (pf_intern_term gl t) with - | GCast(t,CastConv c) when isGHole t && isGLambda c-> - let (x, c) = destGLambda c in - f x (' ',(c,None),ist) - | GVar id - when Option.has_some ist && let ist = Option.get ist in - Id.Map.mem id ist.lfun && - not(Option.is_empty reccall) && - not(Option.is_empty wit_ssrpatternarg) -> - let v = Id.Map.find id (Option.get ist).lfun in - Option.get reccall - (Value.cast (topwit (Option.get wit_ssrpatternarg)) v) - | it -> g t with e when CErrors.noncritical e -> g t in - let decodeG ist t f g = decode (mkG t ist) f g in - let bad_enc id _ = CErrors.anomaly (str"bad encoding for pattern "++str id++str".") in - let cleanup_XinE h x rp sigma = - let h_k = match kind h with Evar (k,_) -> k | _ -> assert false in - let to_clean, update = (* handle rename if x is already used *) - let ctx = pf_hyps gl in - let len = Context.Named.length ctx in - let name = ref None in - try ignore(Context.Named.lookup x ctx); (name, fun k -> - if !name = None then - let nctx = Evd.evar_context (Evd.find sigma k) in - let nlen = Context.Named.length nctx in - if nlen > len then begin - name := Some (Context.Named.Declaration.get_id (List.nth nctx (nlen - len - 1))) - end) - with Not_found -> ref (Some x), fun _ -> () in - let sigma0 = project gl in - let new_evars = - let rec aux acc t = match kind t with - | Evar (k,_) -> - if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else - (update k; k::acc) - | _ -> CoqConstr.fold aux acc t 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 *) - if Option.is_empty !to_clean then sigma else - let name = Option.get !to_clean in - pp(lazy(pr_id name)); - thin name sigma e) - sigma new_evars in - sigma in - let red = let rec decode_red = function - | T(k,(t,None),ist) -> - begin match DAst.get t with - | GCast (c,CastConv t) - when isGHole c && - let (id, t) = destGLambda t in - let id = Id.to_string id in let len = String.length id in - (len > 8 && String.sub id 0 8 = "_ssrpat_") -> - let (id, t) = destGLambda t in - let id = Id.to_string id in let len = String.length id in - (match String.sub id 8 (len - 8), DAst.get t with - | "In", GApp( _, [t]) -> decodeG ist t xInT (fun x -> T x) - | "In", GApp( _, [e; t]) -> decodeG ist t (eInXInT (mkG e ist)) (bad_enc id) - | "In", GApp( _, [e; t; e_in_t]) -> - decodeG ist t (eInXInT (mkG e ist)) - (fun _ -> decodeG ist e_in_t xInT (fun _ -> assert false)) - | "As", GApp(_, [e; t]) -> decodeG ist t (eAsXInT (mkG e ist)) (bad_enc id) - | _ -> bad_enc id ()) - | _ -> - decode ~reccall:decode_red (mkG ~k t ist) xInT (fun x -> T x) - end - | T t -> decode ~reccall:decode_red t xInT (fun x -> T x) - | In_T t -> decode t inXInT inT - | X_In_T (e,t) -> decode t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x) - | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t - | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp - | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in - decode_red red in - pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red)); - let red = - match redty with - | None -> red - | Some (ty, ist) -> let ty = ' ', ty, Some ist in - match red with - | T t -> T (combineCG t ty (mkCCast ?loc:(loc_ofCG t)) mkRCast) - | X_In_T (x,t) -> - let gty = pf_intern_term gl ty in - E_As_X_In_T (mkG (mkRCast mkRHole gty) (ist_of ty), x, t) - | E_In_X_In_T (e,x,t) -> - let ty = mkG (pf_intern_term gl ty) (ist_of ty) in - E_In_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) - | E_As_X_In_T (e,x,t) -> - let ty = mkG (pf_intern_term gl ty) (ist_of ty) in - E_As_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) - | red -> red in - pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); - let mkXLetIn ?loc x (a,(g,c),ist) = match c with - | Some b -> a,(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)), ist - | None -> a,(DAst.make ?loc @@ GLetIn (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None), ist in - match red with - | T t -> let sigma, t = interp_term gl t in sigma, T t - | In_T t -> let sigma, t = interp_term gl t in sigma, In_T t - | X_In_T (x, rp) | In_X_In_T (x, rp) -> - let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in - let rp = mkXLetIn (Name x) rp in - let sigma, rp = interp_term gl rp in - let _, h, _, rp = destLetIn rp in - let sigma = cleanup_XinE h x rp sigma 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 = - match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in - let rp = mkXLetIn (Name x) rp in - let sigma, rp = interp_term gl rp in - let _, h, _, rp = destLetIn rp in - let sigma = cleanup_XinE h x rp sigma in - let rp = subst1 h (nf_evar sigma rp) in - let sigma, e = interp_term (re_sig (sig_it gl) sigma) e in - sigma, mk e h rp -;; -let interp_cpattern gl red redty = interp_pattern gl (T red) redty;; -let interp_rpattern ~wit_ssrpatternarg gl red = interp_pattern ~wit_ssrpatternarg gl red None;; - -let id_of_pattern = function - | _, T t -> (match kind t with Var id -> Some id | _ -> None) - | _ -> None - -(* The full occurrence set *) -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 = 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 - | _ -> errorstrm (str "Matching the pattern " ++ pr_constr_env env0 sigma0 p ++ - str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ - str "Does the variable bound by the \"in\" construct occur "++ - str "in the pattern?") in - let sigma = - Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in - sigma, e_body in - let ex_value hole = - match kind hole with Evar (e,_) -> e | _ -> assert false in - let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok = - let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in - sigma, [pat] in - match pattern with - | None -> do_subst env0 concl0 concl0 1, UState.empty - | Some (sigma, (T rp | In_T rp)) -> - let rp = fs sigma rp in - let ise = create_evar_defs sigma in - let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in - let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in - let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in - let concl = find_T env0 concl0 1 ~k:do_subst in - let _, _, (_, us, _) = end_T () in - concl, us - | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) -> - let p = fs sigma p in - let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in - let ex = ex_value hole in - let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in - let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in - (* we start from sigma, so hole is considered a rigid head *) - 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 ~k:(fun env c _ h -> - 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 - ~k:(fun env _ -> do_subst env e_body))) in - let _ = end_X () in let _, _, (_, us, _) = end_T () in - concl, us - | Some (sigma, E_In_X_In_T (e, hole, p)) -> - let p, e = fs sigma p, fs sigma e in - let ex = ex_value hole in - let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in - let find_T, end_T = 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 noindex holep in - 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 ~k:(fun env c _ h -> - 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 ~k:(fun env c _ h -> - find_E env e_body h ~k:do_subst))) in - let _,_,(_,us,_) = end_E () in - let _ = end_X () in let _ = end_T () in - concl, us - | Some (sigma, E_As_X_In_T (e, hole, p)) -> - 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 (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 ~k:(fun env c _ h -> - 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 ~k:(fun env c _ h -> - 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 _,_,(_,us,_) = end_TE () in - concl, us -;; - -let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = - let e = match p with - | In_T _ | In_X_In_T _ -> CErrors.anomaly (str"pattern without redex.") - | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in - let sigma = - if not resolve_typeclasses then sigma - else Typeclasses.resolve_typeclasses ~fail:false env sigma in - 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 = - if occ = Some(true,[]) then false, Some(false,[1]) else true, occ in - let find_R, conclude = - let r = ref None in - (fun env c _ h' -> - do_once r (fun () -> c); - if do_make_rel then mkRel (h'+h-1) else c), - (fun _ -> if !r = None then fst(redex_of_pattern env pat) - else assert_done r) in - let cl, us = - eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in - let e = conclude cl in - (e, us), cl -;; - -(* clenup interface for external use *) -let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = - mk_tpattern ?p_origin env sigma0 sigma_t f dir c -;; - -let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = - fst (eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst) -;; - -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,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 ~k:(fun _ _ _ -> mkRel) in - let rdx, _, (sigma, uc, p) = end_U () in - 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 - let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in - if sigma' != sigma0 then CErrors.user_err Pp.(str "matching impacts evars") - else cl, (Evd.merge_universe_context sigma' uc, t') - with NoMatch -> try - let sigma', uc, t' = - unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in - if sigma' != sigma0 then raise NoMatch - else cl, (Evd.merge_universe_context sigma' uc, t') - with _ -> - 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 = - let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in - let cl,(_,t) = fill_occ_term env concl occ sigma0 t in - cl, t - -let cpattern_of_id id = - ' ', (DAst.make @@ GRef (VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty }) - -let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with - | _, Some { CAst.v = CHole _ } | GHole _, None -> true - | _ -> false - -(* "ssrpattern" *) - -ARGUMENT EXTEND ssrpatternarg TYPED AS rpattern PRINTED BY pr_rpattern -| [ rpattern(pat) ] -> [ pat ] -END - -let pr_rpattern = pr_pattern - -let pf_merge_uc uc gl = - re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) - -let pf_unsafe_merge_uc uc gl = - re_sig (sig_it gl) (Evd.set_universe_context (project gl) uc) - -let interp_rpattern = interp_rpattern ~wit_ssrpatternarg - -let ssrpatterntac _ist arg gl = - let pat = interp_rpattern 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 = EConstr.mkLetIn (Name (Id.of_string "selected"), t, tty, concl_x) in - Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl - -(* Register "ssrpattern" tactic *) -let () = - let mltac _ ist = - let arg = - let v = Id.Map.find (Names.Id.of_string "pattern") ist.lfun in - Value.cast (topwit wit_ssrpatternarg) v in - Proofview.V82.tactic (ssrpatterntac ist arg) in - let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in - let () = Tacenv.register_ml_tactic name [|mltac|] in - let tac = - TacFun ([Name (Id.of_string "pattern")], - TacML (Loc.tag ({ mltac_name = name; mltac_index = 0 }, []))) in - let obj () = - Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in - Mltop.declare_cache_obj obj "ssrmatching_plugin" - -let ssrinstancesof arg gl = - let ok rhs lhs ise = true in -(* not (equal 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 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 - let find, conclude = - mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true - sigma None (etpat,[tpat]) in - let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) p ++ spc() - ++ str "matches:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) c)); c in - ppnl (str"BEGIN INSTANCES"); - try - while true do - ignore(find env concl 1 ~k:print) - done; raise NoMatch - with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl - -TACTIC EXTEND ssrinstoftpat -| [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof arg) ] -END - -(* We wipe out all the keywords generated by the grammar rules we defined. *) -(* 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.set_keyword_state frozen_lexer ;; - -(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli new file mode 100644 index 00000000..9c79879d --- /dev/null +++ b/plugins/ssrmatching/ssrmatching.mli @@ -0,0 +1,258 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* Pp.t + +(** The type of rewrite patterns, the patterns of the [rewrite] tactic. + These patterns also include patterns that identify all the subterms + of a context (i.e. "in" prefix) *) +type rpattern +val pr_rpattern : rpattern -> Pp.t + +(** Pattern interpretation and matching *) + +exception NoMatch +exception NoProgress + +(** AST for [rpattern] (and consequently [cpattern]) *) +type ('ident, 'term) ssrpattern = + | T of 'term + | In_T of 'term + | X_In_T of 'ident * 'term + | In_X_In_T of 'ident * 'term + | E_In_X_In_T of 'term * 'ident * 'term + | E_As_X_In_T of 'term * 'ident * 'term + +type pattern = evar_map * (constr, constr) ssrpattern +val pp_pattern : pattern -> Pp.t + +(** Extracts the redex and applies to it the substitution part of the pattern. + @raise Anomaly if called on [In_T] or [In_X_In_T] *) +val redex_of_pattern : + ?resolve_typeclasses:bool -> env -> pattern -> + constr Evd.in_evar_universe_context + +(** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat] + in the current [Ltac] interpretation signature [ise] and tactic input [gl]*) +val interp_rpattern : + goal sigma -> + rpattern -> + pattern + +(** [interp_cpattern ise gl cpat ty] "internalizes" and "interprets" [cpat] + in the current [Ltac] interpretation signature [ise] and tactic input [gl]. + [ty] is an optional type for the redex of [cpat] *) +val interp_cpattern : + goal sigma -> + cpattern -> (glob_constr_and_expr * Geninterp.interp_sign) option -> + pattern + +(** The set of occurrences to be matched. The boolean is set to true + * to signal the complement of this set (i.e. \{-1 3\}) *) +type occ = (bool * int list) option + +(** [subst e p t i]. [i] is the number of binders + traversed so far, [p] the term from the pattern, [t] the matched one *) +type subst = env -> constr -> constr -> int -> constr + +(** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every + [occ] occurrence of [pat]. The [int] argument is the number of + binders traversed. If [pat] is [None] then then subst is called on [t]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. + @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) + @return [t] where all [occ] occurrences of [pat] have been mapped using + [subst] *) +val eval_pattern : + ?raise_NoMatch:bool -> + env -> evar_map -> constr -> + pattern option -> occ -> subst -> + constr + +(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of + [eval_pattern]. + It replaces all [occ] occurrences of [pat] in [t] with Rel [h]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. + @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) + @return the instance of the redex of [pat] that was matched and [t] + transformed as described above. *) +val fill_occ_pattern : + ?raise_NoMatch:bool -> + env -> evar_map -> constr -> + pattern -> occ -> int -> + constr Evd.in_evar_universe_context * constr + +(** *************************** Low level APIs ****************************** *) + +(* The primitive matching facility. It matches of a term with holes, like + the T pattern above, and calls a continuation on its occurrences. *) + +type ssrdir = L2R | R2L +val pr_dir_side : ssrdir -> Pp.t + +(** a pattern for a term with wildcards *) +type tpattern + +(** [mk_tpattern env sigma0 sigma_p ok p_origin dir t] compiles a term [t] + living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern]. + The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok] + callback is used to filter occurrences. + @return the compiled [tpattern] and its [evar_map] + @raise UserEerror is the pattern is a wildcard *) +val mk_tpattern : + ?p_origin:ssrdir * constr -> + env -> evar_map -> + evar_map * constr -> + (constr -> evar_map -> bool) -> + ssrdir -> constr -> + evar_map * tpattern + +(** [findP env t i k] is a stateful function that finds the next occurrence + of a tpattern and calls the callback [k] to map the subterm matched. + The [int] argument passed to [k] is the number of binders traversed so far + plus the initial value [i]. + @return [t] where the subterms identified by the selected occurrences of + the patter have been mapped using [k] + @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is + [true] and if the pattern did not match + @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is + [false] and if the pattern did not match *) +type find_P = + env -> constr -> int -> k:subst -> constr + +(** [conclude ()] asserts that all mentioned ocurrences have been visited. + @return the instance of the pattern, the evarmap after the pattern + instantiation, the proof term and the ssrdit stored in the tpattern + @raise UserEerror if too many occurrences were specified *) +type conclude = + unit -> constr * ssrdir * (evar_map * UState.t * constr) + +(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair + a function [find_P] and [conclude] with the behaviour explained above. + The flag [b] (default [false]) changes the error reporting behaviour + of [find_P] if none of the [tpattern] matches. The argument [o] can + be passed to tune the [UserError] eventually raised (useful if the + pattern is coming from the LHS/RHS of an equation) *) +val mk_tpattern_matcher : + ?all_instances:bool -> + ?raise_NoMatch:bool -> + ?upats_origin:ssrdir * constr -> + evar_map -> occ -> evar_map * tpattern list -> + find_P * conclude + +(** Example of [mk_tpattern_matcher] to implement + [rewrite \{occ\}\[in t\]rules]. + It first matches "in t" (called [pat]), then in all matched subterms + it matches the LHS of the rules using [find_R]. + [concl0] is the initial goal, [concl] will be the goal where some terms + are replaced by a De Bruijn index. The [rw_progress] extra check + selects only occurrences that are not rewritten to themselves (e.g. + an occurrence "x + x" rewritten with the commutativity law of addition + is skipped) {[ + let find_R, conclude = match pat with + | Some (_, In_T _) -> + let aux (sigma, pats) (d, r, lhs, rhs) = + let sigma, pat = + mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in + sigma, pats @ [pat] in + let rpats = List.fold_left aux (r_sigma, []) rules in + let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in + find_R ~k:(fun _ _ h -> mkRel h), + fun cl -> let rdx, d, r = end_R () in (d,r),rdx + | _ -> ... in + let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in + let (d, r), rdx = conclude concl in ]} *) + +(* 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 * 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 -> Geninterp.interp_sign -> cpattern + +(** Helpers to make stateful closures. Example: a [find_P] function may be + called many times, but the pattern instantiation phase is performed only the + first time. The corresponding [conclude] has to return the instantiated + pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern + has no instance, [conclude] considers it an anomaly if the pattern did + not match *) + +(** [do_once r f] calls [f] and updates the ref only once *) +val do_once : 'a option ref -> (unit -> 'a) -> unit +(** [assert_done r] return the content of r. @raise Anomaly is r is [None] *) +val assert_done : 'a option ref -> 'a + +(** Very low level APIs. + these are calls to evarconv's [the_conv_x] followed by + [solve_unif_constraints_with_heuristics] and [resolve_typeclasses]. + In case of failure they raise [NoMatch] *) + +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 *) +val tag_of_cpattern : cpattern -> char +val loc_of_cpattern : cpattern -> Loc.t option +val id_of_pattern : pattern -> Names.Id.t option +val is_wildcard : cpattern -> bool +val cpattern_of_id : Names.Id.t -> cpattern +val pr_constr_pat : constr -> Pp.t +val pf_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma +val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma + +(* One can also "Set SsrMatchingDebug" from a .v *) +val debug : bool -> unit + +(* One should delimit a snippet with "Set SsrMatchingProfiling" and + * "Unset SsrMatchingProfiling" to get timings *) +val profile : bool -> unit + +val ssrinstancesof : cpattern -> Tacmach.tactic + +(** Functions used for grammar extensions. Do not use. *) + +module Internal : +sig + val wit_rpatternty : (rpattern, rpattern, rpattern) Genarg.genarg_type + val glob_rpattern : Genintern.glob_sign -> rpattern -> rpattern + val subst_rpattern : Mod_subst.substitution -> rpattern -> rpattern + val interp_rpattern : Geninterp.interp_sign -> Proof_type.goal Evd.sigma -> rpattern -> Evd.evar_map * rpattern + val pr_rpattern : rpattern -> Pp.t + val mk_rpattern : (cpattern, cpattern) ssrpattern -> rpattern + val mk_lterm : Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern + val mk_term : char -> Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern + + val glob_cpattern : Genintern.glob_sign -> cpattern -> cpattern + val subst_ssrterm : Mod_subst.substitution -> cpattern -> cpattern + val interp_ssrterm : Geninterp.interp_sign -> Proof_type.goal Evd.sigma -> cpattern -> Evd.evar_map * cpattern + val pr_ssrterm : cpattern -> Pp.t +end + +(* eof *) diff --git a/plugins/ssrmatching/ssrmatching.v b/plugins/ssrmatching/ssrmatching.v new file mode 100644 index 00000000..fee09cc9 --- /dev/null +++ b/plugins/ssrmatching/ssrmatching.v @@ -0,0 +1,36 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* t) : ssrpatternscope. +Delimit Scope ssrpatternscope with pattern. + +(* Some shortcuts for recurrent "X in t" parts. *) +Notation RHS := (X in _ = X)%pattern. +Notation LHS := (X in X = _)%pattern. + +End SsrMatchingSyntax. + +Export SsrMatchingSyntax. + +Tactic Notation "ssrpattern" ssrpatternarg(p) := ssrpattern p . diff --git a/plugins/ssrmatching/ssrmatching_plugin.mlpack b/plugins/ssrmatching/ssrmatching_plugin.mlpack index 5fb1f156..02c75f14 100644 --- a/plugins/ssrmatching/ssrmatching_plugin.mlpack +++ b/plugins/ssrmatching/ssrmatching_plugin.mlpack @@ -1 +1,2 @@ Ssrmatching +G_ssrmatching diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index acb297dd..53153198 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -28,7 +28,7 @@ let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let ascii_module = ["Coq";"Strings";"Ascii"] @@ -83,8 +83,18 @@ let make_ascii_string n = let uninterp_ascii_string (AnyGlobConstr r) = Option.map make_ascii_string (uninterp_ascii r) +open Notation + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + let _ = - Notation.declare_string_interpreter "char_scope" - (ascii_path,ascii_module) - interp_ascii_string - ([DAst.make @@ GRef (static_glob_Ascii,None)], uninterp_ascii_string, true) + let sc = "char_scope" in + register_string_interpretation sc (interp_ascii_string,uninterp_ascii_string); + at_declare_ml_module enable_prim_token_interpretation + { pt_local = false; + pt_scope = sc; + pt_interp_info = Uid sc; + pt_required = (ascii_path,ascii_module); + pt_refs = [static_glob_Ascii]; + pt_in_match = true } diff --git a/plugins/syntax/g_numeral.ml4 b/plugins/syntax/g_numeral.ml4 new file mode 100644 index 00000000..55f61a58 --- /dev/null +++ b/plugins/syntax/g_numeral.ml4 @@ -0,0 +1,38 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* mt () + | Warning n -> str "(warning after " ++ str n ++ str ")" + | Abstract n -> str "(abstract after " ++ str n ++ str ")" + +ARGUMENT EXTEND numnotoption + PRINTED BY pr_numnot_option +| [ ] -> [ Nop ] +| [ "(" "warning" "after" bigint(waft) ")" ] -> [ Warning waft ] +| [ "(" "abstract" "after" bigint(n) ")" ] -> [ Abstract n ] +END + +VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF + | [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + ident(sc) numnotoption(o) ] -> + [ vernac_numeral_notation (Locality.make_module_locality atts.locality) ty f g (Id.to_string sc) o ] +END diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml index 5529ea70..e34a401c 100644 --- a/plugins/syntax/int31_syntax.ml +++ b/plugins/syntax/int31_syntax.ml @@ -26,7 +26,7 @@ let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let make_mind mp id = Names.MutInd.make2 mp (Label.make id) @@ -96,10 +96,19 @@ let uninterp_int31 (AnyGlobConstr i) = with Non_closed -> None +open Notation + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + (* Actually declares the interpreter for int31 *) -let _ = Notation.declare_numeral_interpreter int31_scope - (int31_path, int31_module) - interp_int31 - ([DAst.make (GRef (int31_construct, None))], - uninterp_int31, - true) + +let _ = + register_bignumeral_interpretation int31_scope (interp_int31,uninterp_int31); + at_declare_ml_module enable_prim_token_interpretation + { pt_local = false; + pt_scope = int31_scope; + pt_interp_info = Uid int31_scope; + pt_required = (int31_path,int31_module); + pt_refs = [int31_construct]; + pt_in_match = true } diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml deleted file mode 100644 index ad8b54d4..00000000 --- a/plugins/syntax/nat_syntax.ml +++ /dev/null @@ -1,84 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* > *) - -let threshold = of_int 5000 - -let warn_large_nat = - CWarnings.create ~name:"large-nat" ~category:"numbers" - (fun () -> strbrk "Stack overflow or segmentation fault happens when " ++ - strbrk "working with large numbers in nat (observed threshold " ++ - strbrk "may vary from 5000 to 70000 depending on your system " ++ - strbrk "limits and on the command executed).") - -let nat_of_int ?loc n = - if is_pos_or_zero n then begin - if less_than threshold n then warn_large_nat (); - let ref_O = DAst.make ?loc @@ GRef (glob_O, None) in - let ref_S = DAst.make ?loc @@ GRef (glob_S, None) in - let rec mk_nat acc n = - if n <> zero then - mk_nat (DAst.make ?loc @@ GApp (ref_S, [acc])) (sub_1 n) - else - acc - in - mk_nat ref_O n - end - else - user_err ?loc ~hdr:"nat_of_int" - (str "Cannot interpret a negative number as a number of type nat") - -(************************************************************************) -(* Printing via scopes *) - -exception Non_closed_number - -let rec int_of_nat x = DAst.with_val (function - | GApp (r, [a]) -> - begin match DAst.get r with - | GRef (s,_) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) - | _ -> raise Non_closed_number - end - | GRef (z,_) when Globnames.eq_gr z glob_O -> zero - | _ -> raise Non_closed_number - ) x - -let uninterp_nat (AnyGlobConstr p) = - try - Some (int_of_nat p) - with - Non_closed_number -> None - -(************************************************************************) -(* Declare the primitive parsers and printers *) - -let _ = - Notation.declare_numeral_interpreter "nat_scope" - (nat_path,datatypes_module_name) - nat_of_int - ([DAst.make @@ GRef (glob_S,None); DAst.make @@ GRef (glob_O,None)], uninterp_nat, true) diff --git a/plugins/syntax/nat_syntax_plugin.mlpack b/plugins/syntax/nat_syntax_plugin.mlpack deleted file mode 100644 index 39bdd62f..00000000 --- a/plugins/syntax/nat_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -Nat_syntax diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml new file mode 100644 index 00000000..10a0af0b --- /dev/null +++ b/plugins/syntax/numeral.ml @@ -0,0 +1,142 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* + strbrk "The 'abstract after' directive has no effect when " ++ + strbrk "the parsing function (" ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ + strbrk "option type.") + +let get_constructors ind = + let mib,oib = Global.lookup_inductive ind in + let mc = oib.Declarations.mind_consnames in + Array.to_list + (Array.mapi (fun j c -> ConstructRef (ind, j + 1)) mc) + +let q_z = qualid_of_string "Coq.Numbers.BinNums.Z" +let q_positive = qualid_of_string "Coq.Numbers.BinNums.positive" +let q_int = qualid_of_string "Coq.Init.Decimal.int" +let q_uint = qualid_of_string "Coq.Init.Decimal.uint" +let q_option = qualid_of_string "Coq.Init.Datatypes.option" + +let unsafe_locate_ind q = + match Nametab.locate q with + | IndRef i -> i + | _ -> raise Not_found + +let locate_ind q = + try unsafe_locate_ind q + with Not_found -> Nametab.error_global_not_found q + +let locate_z () = + try + Some { z_ty = unsafe_locate_ind q_z; + pos_ty = unsafe_locate_ind q_positive } + with Not_found -> None + +let locate_int () = + { uint = locate_ind q_uint; + int = locate_ind q_int } + +let has_type f ty = + let (sigma, env) = Pfedit.get_current_context () in + let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in + try let _ = Constrintern.interp_constr env sigma c in true + with Pretype_errors.PretypeError _ -> false + +let type_error_to f ty loadZ = + CErrors.user_err + (pr_qualid f ++ str " should go from Decimal.int to " ++ + pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ + fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z could be used" ++ + (if loadZ then str " (require BinNums first)." else str ".")) + +let type_error_of g ty loadZ = + CErrors.user_err + (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ + str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ + str "Instead of Decimal.int, the types Decimal.uint or Z could be used" ++ + (if loadZ then str " (require BinNums first)." else str ".")) + +let vernac_numeral_notation local ty f g scope opts = + let int_ty = locate_int () in + let z_pos_ty = locate_z () in + let tyc = Smartlocate.global_inductive_with_alias ty in + let to_ty = Smartlocate.global_with_alias f in + let of_ty = Smartlocate.global_with_alias g in + let cty = mkRefC ty in + let app x y = mkAppC (x,[y]) in + let cref q = mkRefC q in + let arrow x y = + mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, x, y) + in + let cZ = cref q_z in + let cint = cref q_int in + let cuint = cref q_uint in + let coption = cref q_option in + let opt r = app coption r in + let constructors = get_constructors tyc in + (* Check the type of f *) + let to_kind = + if has_type f (arrow cint cty) then Int int_ty, Direct + else if has_type f (arrow cint (opt cty)) then Int int_ty, Option + else if has_type f (arrow cuint cty) then UInt int_ty.uint, Direct + else if has_type f (arrow cuint (opt cty)) then UInt int_ty.uint, Option + else + match z_pos_ty with + | Some z_pos_ty -> + if has_type f (arrow cZ cty) then Z z_pos_ty, Direct + else if has_type f (arrow cZ (opt cty)) then Z z_pos_ty, Option + else type_error_to f ty false + | None -> type_error_to f ty true + in + (* Check the type of g *) + let of_kind = + if has_type g (arrow cty cint) then Int int_ty, Direct + else if has_type g (arrow cty (opt cint)) then Int int_ty, Option + else if has_type g (arrow cty cuint) then UInt int_ty.uint, Direct + else if has_type g (arrow cty (opt cuint)) then UInt int_ty.uint, Option + else + match z_pos_ty with + | Some z_pos_ty -> + if has_type g (arrow cty cZ) then Z z_pos_ty, Direct + else if has_type g (arrow cty (opt cZ)) then Z z_pos_ty, Option + else type_error_of g ty false + | None -> type_error_of g ty true + in + let o = { to_kind; to_ty; of_kind; of_ty; + num_ty = ty; + warning = opts } + in + (match opts, to_kind with + | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty + | _ -> ()); + let i = + { pt_local = local; + pt_scope = scope; + pt_interp_info = NumeralNotation o; + pt_required = Nametab.path_of_global (IndRef tyc),[]; + pt_refs = constructors; + pt_in_match = true } + in + enable_prim_token_interpretation i diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli new file mode 100644 index 00000000..f96b8321 --- /dev/null +++ b/plugins/syntax/numeral.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* qualid -> qualid -> qualid -> Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/numeral_notation_plugin.mlpack b/plugins/syntax/numeral_notation_plugin.mlpack new file mode 100644 index 00000000..f4d9cae3 --- /dev/null +++ b/plugins/syntax/numeral_notation_plugin.mlpack @@ -0,0 +1,2 @@ +Numeral +G_numeral diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 372e8ff3..49497aef 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -30,7 +30,7 @@ let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let positive_path = make_path binnums "positive" @@ -66,7 +66,7 @@ let pos_of_bignat ?loc x = let rec bignat_of_pos c = match DAst.get c with | GApp (r, [a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) | GApp (r, [a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one + | GRef (a, _) when GlobRef.equal a glob_xH -> Bigint.one | _ -> raise Non_closed_number (**********************************************************************) @@ -98,7 +98,7 @@ let z_of_int ?loc n = let bigint_of_z c = match DAst.get c with | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a | GApp (r,[a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | GRef (a, _) when GlobRef.equal a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number (**********************************************************************) @@ -131,9 +131,19 @@ let uninterp_r (AnyGlobConstr p) = with Non_closed_number -> None -let _ = Notation.declare_numeral_interpreter "R_scope" - (r_path,["Coq";"Reals";"Rdefinitions"]) - r_of_int - ([DAst.make @@ GRef (glob_IZR, None)], - uninterp_r, - false) +open Notation + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + +let r_scope = "R_scope" + +let _ = + register_bignumeral_interpretation r_scope (r_of_int,uninterp_r); + at_declare_ml_module enable_prim_token_interpretation + { pt_local = false; + pt_scope = r_scope; + pt_interp_info = Uid r_scope; + pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); + pt_refs = [glob_IZR]; + pt_in_match = false } diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 2421cc12..7478c1e9 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open Globnames open Ascii_syntax_plugin.Ascii_syntax open Glob_term @@ -34,7 +35,7 @@ let glob_String = lazy (make_reference "String") let glob_EmptyString = lazy (make_reference "EmptyString") let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false open Lazy @@ -55,7 +56,7 @@ let uninterp_string (AnyGlobConstr r) = (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | GRef (z,_) when eq_gr z (force glob_EmptyString) -> + | GRef (z,_) when GlobRef.equal z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string @@ -63,10 +64,18 @@ let uninterp_string (AnyGlobConstr r) = with Non_closed_string -> None +open Notation + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + let _ = - Notation.declare_string_interpreter "string_scope" - (string_path,["Coq";"Strings";"String"]) - interp_string - ([DAst.make @@ GRef (static_glob_String,None); - DAst.make @@ GRef (static_glob_EmptyString,None)], - uninterp_string, true) + let sc = "string_scope" in + register_string_interpretation sc (interp_string,uninterp_string); + at_declare_ml_module enable_prim_token_interpretation + { pt_local = false; + pt_scope = sc; + pt_interp_info = Uid sc; + pt_required = (string_path,["Coq";"Strings";"String"]); + pt_refs = [static_glob_String; static_glob_EmptyString]; + pt_in_match = true } diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml deleted file mode 100644 index d5300e47..00000000 --- a/plugins/syntax/z_syntax.ml +++ /dev/null @@ -1,202 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* DAst.make ?loc @@ GApp (ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> DAst.make ?loc @@ GApp (ref_xI,[pos_of q]) - | (q,true) -> ref_xH - in - pos_of x - -let error_non_positive ?loc = - user_err ?loc ~hdr:"interp_positive" - (str "Only strictly positive numbers in type \"positive\".") - -let interp_positive ?loc n = - if is_strictly_pos n then pos_of_bignat ?loc n - else error_non_positive ?loc - -(**********************************************************************) -(* Printing positive via scopes *) -(**********************************************************************) - -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr -| _ -> false - -let rec bignat_of_pos x = DAst.with_val (function - | GApp (r ,[a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) - | GApp (r ,[a]) when is_gr r 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 - ) x - -let uninterp_positive (AnyGlobConstr p) = - try - Some (bignat_of_pos p) - with Non_closed_number -> - None - -(************************************************************************) -(* Declaring interpreters and uninterpreters for positive *) -(************************************************************************) - -let _ = Notation.declare_numeral_interpreter "positive_scope" - (positive_path,binnums) - interp_positive - ([DAst.make @@ GRef (glob_xI, None); - DAst.make @@ GRef (glob_xO, None); - DAst.make @@ GRef (glob_xH, None)], - uninterp_positive, - true) - -(**********************************************************************) -(* Parsing N via scopes *) -(**********************************************************************) - -let n_kn = make_kn (make_dir binnums) (Id.of_string "N") -let glob_n = IndRef (n_kn,0) -let path_of_N0 = ((n_kn,0),1) -let path_of_Npos = ((n_kn,0),2) -let glob_N0 = ConstructRef path_of_N0 -let glob_Npos = ConstructRef path_of_Npos - -let n_path = make_path binnums "N" - -let n_of_binnat ?loc pos_or_neg n = DAst.make ?loc @@ - if not (Bigint.equal n zero) then - GApp(DAst.make @@ GRef (glob_Npos,None), [pos_of_bignat ?loc n]) - else - GRef(glob_N0, None) - -let error_negative ?loc = - user_err ?loc ~hdr:"interp_N" (str "No negative numbers in type \"N\".") - -let n_of_int ?loc n = - if is_pos_or_zero n then n_of_binnat ?loc true n - else error_negative ?loc - -(**********************************************************************) -(* Printing N via scopes *) -(**********************************************************************) - -let bignat_of_n n = DAst.with_val (function - | GApp (r, [a]) when is_gr r glob_Npos -> bignat_of_pos a - | GRef (a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero - | _ -> raise Non_closed_number - ) n - -let uninterp_n (AnyGlobConstr p) = - try Some (bignat_of_n p) - with Non_closed_number -> None - -(************************************************************************) -(* Declaring interpreters and uninterpreters for N *) - -let _ = Notation.declare_numeral_interpreter "N_scope" - (n_path,binnums) - n_of_int - ([DAst.make @@ GRef (glob_N0, None); - DAst.make @@ GRef (glob_Npos, None)], - uninterp_n, - true) - -(**********************************************************************) -(* 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 ?loc 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 - DAst.make ?loc @@ GApp(DAst.make ?loc @@ GRef(sgn,None), [pos_of_bignat ?loc n]) - else - DAst.make ?loc @@ GRef(glob_ZERO, None) - -(**********************************************************************) -(* Printing Z via scopes *) -(**********************************************************************) - -let bigint_of_z z = DAst.with_val (function - | GApp (r, [a]) when is_gr r glob_POS -> bignat_of_pos a - | GApp (r, [a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero - | _ -> raise Non_closed_number - ) z - -let uninterp_z (AnyGlobConstr p) = - try - Some (bigint_of_z p) - with Non_closed_number -> None - -(************************************************************************) -(* Declaring interpreters and uninterpreters for Z *) - -let _ = Notation.declare_numeral_interpreter "Z_scope" - (z_path,binnums) - z_of_int - ([DAst.make @@ GRef (glob_ZERO, None); - DAst.make @@ GRef (glob_POS, None); - DAst.make @@ GRef (glob_NEG, None)], - uninterp_z, - true) diff --git a/plugins/syntax/z_syntax_plugin.mlpack b/plugins/syntax/z_syntax_plugin.mlpack deleted file mode 100644 index 411260c0..00000000 --- a/plugins/syntax/z_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -Z_syntax -- cgit v1.2.3