diff options
| author |  Benjamin Barenblat <bbaren@debian.org> | 2018-12-29 14:31:27 -0500 |
|---|---|---|
| committer | Benjamin Barenblat <bbaren@debian.org> | 2018-12-29 14:31:27 -0500 |
| commit | 9043add656177eeac1491a73d2f3ab92bec0013c (patch) | |
| tree | 2b0092c84bfbf718eca10c81f60b2640dc8cab05 /plugins/ssr | |
| parent | a4c7f8bd98be2a200489325ff7c5061cf80ab4f3 (diff) | |
Imported Upstream version 8.8.2upstream/8.8.2
Diffstat (limited to 'plugins/ssr')
27 files changed, 11682 insertions, 0 deletions
diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli new file mode 100644 index 00000000..7f5f2f63 --- /dev/null +++ b/plugins/ssr/ssrast.mli @@ -0,0 +1,175 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Ltac_plugin + +(* Names of variables to be cleared (automatic check: not a section var) *) +type ssrhyp = SsrHyp of Id.t Loc.located +(* Variant of the above *) +type ssrhyp_or_id = Hyp of ssrhyp | Id of ssrhyp + +(* Variant of the above *) +type ssrhyps = ssrhyp list + +(* Direction to be used for rewriting as in -> or rewrite flag *) +type ssrdir = Ssrmatching_plugin.Ssrmatching.ssrdir = L2R | R2L + +(* simpl: "/=", cut: "//", simplcut: "//=" nop: commodity placeholder *) +type ssrsimpl = Simpl of int | Cut of int | SimplCut of int * int | Nop + +(* modality for rewrite and do: ! ? *) +type ssrmmod = May | Must | Once + +(* modality with a bound for rewrite and do: !n ?n *) +type ssrmult = int * ssrmmod + +(** Occurrence switch {1 2}, all is Some(false,[]) *) +type ssrocc = (bool * int list) option + +(* index MAYBE REMOVE ONLY INTERNAL stuff between {} *) +type ssrindex = int Misctypes.or_var + +(* clear switch {H G} *) +type ssrclear = ssrhyps + +(* Discharge occ switch (combined occurrence / clear switch) *) +type ssrdocc = ssrclear option * ssrocc + +(* OLD ssr terms *) +type ssrtermkind = char (* FIXME, make algebraic *) +type ssrterm = ssrtermkind * Tacexpr.glob_constr_and_expr + +(* NEW ssr term *) + +(* These terms are raw but closed with the intenalization/interpretation + * context. It is up to the tactic receiving it to decide if such contexts + * are useful or not, and eventually manipulate the term before turning it + * into a constr *) +type ast_closure_term = { + body : Constrexpr.constr_expr; + glob_env : Genintern.glob_sign option; (* for Tacintern.intern_constr *) + interp_env : Geninterp.interp_sign option; (* for Tacinterp.interp_open_constr_with_bindings *) + annotation : [ `None | `Parens | `DoubleParens | `At ]; +} + +type ssrview = ast_closure_term list + +(* TODO +type id_mod = Hat | HatTilde | Sharp + *) + +(* Only [One] forces an introduction, possibly reducing the goal. *) +type anon_iter = + | One + | Drop + | All +(* TODO + | Dependent (* fast mode *) + | UntilMark + | Temporary (* "+" *) + *) + +type ssripat = + | IPatNoop + | IPatId of (*TODO id_mod option * *) Id.t + | IPatAnon of anon_iter (* inaccessible name *) +(* TODO | IPatClearMark *) + | IPatDispatch of 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 *) + | IPatClear of ssrclear (* {H1 H2} *) + | IPatSimpl of ssrsimpl + | IPatAbstractVars of Id.t list + | IPatTac of unit Proofview.tactic + +and ssripats = ssripat list +and ssripatss = ssripats list +type ssrhpats = ((ssrclear * ssripats) * ssripats) * ssripats +type ssrhpats_wtransp = bool * ssrhpats + +(* tac => inpats *) +type ssrintrosarg = Tacexpr.raw_tactic_expr * ssripats + + +type ssrfwdid = Id.t +(** Binders (for fwd tactics) *) +type 'term ssrbind = + | Bvar of Name.t + | Bdecl of Name.t list * 'term + | Bdef of Name.t * 'term option * 'term + | Bstruct of Name.t + | Bcast of 'term +(* We use an intermediate structure to correctly render the binder list *) +(* abbreviations. We use a list of hints to extract the binders and *) +(* base term from a term, for the two first levels of representation of *) +(* of constr terms. *) +type ssrbindfmt = + | BFvar + | BFdecl of int (* #xs *) + | BFcast (* final cast *) + | BFdef (* has cast? *) + | BFrec of bool * bool (* has struct? * has cast? *) +type 'term ssrbindval = 'term ssrbind list * 'term + +(** Forward chaining argument *) +(* There are three kinds of forward definitions: *) +(* - Hint: type only, cast to Type, may have proof hint. *) +(* - Have: type option + value, no space before type *) +(* - Pose: binders + value, space before binders. *) +type ssrfwdkind = FwdHint of string * bool | FwdHave | FwdPose +type ssrfwdfmt = ssrfwdkind * ssrbindfmt list + +(* in *) +type ssrclseq = InGoal | InHyps + | InHypsGoal | InHypsSeqGoal | InSeqGoal | InHypsSeq | InAll | InAllHyps + +type 'tac ssrhint = bool * 'tac option list + +type 'tac fwdbinders = + bool * (ssrhpats * ((ssrfwdfmt * ast_closure_term) * 'tac ssrhint)) + +type clause = + (ssrclear * ((ssrhyp_or_id * string) * + Ssrmatching_plugin.Ssrmatching.cpattern option) option) +type clauses = clause list * ssrclseq + +type wgen = + (ssrclear * + ((ssrhyp_or_id * string) * + Ssrmatching_plugin.Ssrmatching.cpattern option) + option) + +type 'a ssrdoarg = ((ssrindex * ssrmmod) * 'a ssrhint) * clauses +type 'a ssrseqarg = ssrindex * ('a ssrhint * 'a option) + + +open Ssrmatching_plugin +open Ssrmatching + +type 'a ssrcasearg = ssripat option * ('a * ssripats) +type 'a ssrmovearg = ssrview * 'a ssrcasearg + +type ssrdgens = { dgens : (ssrdocc * cpattern) list; + gens : (ssrdocc * cpattern) list; + clr : ssrclear } +type 'a ssragens = (ssrdocc * 'a) list list * ssrclear +type ssrapplyarg = ssrterm list * (ssrterm ssragens * ssripats) + +(* OOP : these are general shortcuts *) +type gist = Tacintern.glob_sign +type ist = Tacinterp.interp_sign +type goal = Goal.goal +type 'a sigma = 'a Evd.sigma +type v82tac = Tacmach.tactic diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v new file mode 100644 index 00000000..7d05b643 --- /dev/null +++ b/plugins/ssr/ssrbool.v @@ -0,0 +1,1873 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* 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. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. +Set Warnings "-projection-no-head-constant". + +Notation reflect := Bool.reflect. +Notation ReflectT := Bool.ReflectT. +Notation ReflectF := Bool.ReflectF. + +Reserved Notation "~~ b" (at level 35, right associativity). +Reserved Notation "b ==> c" (at level 55, right associativity). +Reserved Notation "b1 (+) b2" (at level 50, left associativity). +Reserved Notation "x \in A" + (at level 70, format "'[hv' x '/ ' \in A ']'", no associativity). +Reserved Notation "x \notin A" + (at level 70, format "'[hv' x '/ ' \notin A ']'", no associativity). +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. *) + +Reserved Notation "[ /\ P1 & P2 ]" (at level 0, only parsing). +Reserved Notation "[ /\ P1 , P2 & P3 ]" (at level 0, format + "'[hv' [ /\ '[' P1 , '/' P2 ']' '/ ' & P3 ] ']'"). +Reserved Notation "[ /\ P1 , P2 , P3 & P4 ]" (at level 0, format + "'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 ']' '/ ' & P4 ] ']'"). +Reserved Notation "[ /\ P1 , P2 , P3 , P4 & P5 ]" (at level 0, format + "'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 , '/' P4 ']' '/ ' & P5 ] ']'"). + +Reserved Notation "[ \/ P1 | P2 ]" (at level 0, only parsing). +Reserved Notation "[ \/ P1 , P2 | P3 ]" (at level 0, format + "'[hv' [ \/ '[' P1 , '/' P2 ']' '/ ' | P3 ] ']'"). +Reserved Notation "[ \/ P1 , P2 , P3 | P4 ]" (at level 0, format + "'[hv' [ \/ '[' P1 , '/' P2 , '/' P3 ']' '/ ' | P4 ] ']'"). + +Reserved Notation "[ && b1 & c ]" (at level 0, only parsing). +Reserved Notation "[ && b1 , b2 , .. , bn & c ]" (at level 0, format + "'[hv' [ && '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' & c ] ']'"). + +Reserved Notation "[ || b1 | c ]" (at level 0, only parsing). +Reserved Notation "[ || b1 , b2 , .. , bn | c ]" (at level 0, format + "'[hv' [ || '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/ ' | c ] ']'"). + +Reserved Notation "[ ==> b1 => c ]" (at level 0, only parsing). +Reserved Notation "[ ==> b1 , b2 , .. , bn => c ]" (at level 0, format + "'[hv' [ ==> '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/' => c ] ']'"). + +Reserved Notation "[ 'pred' : T => E ]" (at level 0, format + "'[hv' [ 'pred' : T => '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x => E ]" (at level 0, x at level 8, format + "'[hv' [ 'pred' x => '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x : T => E ]" (at level 0, x at level 8, format + "'[hv' [ 'pred' x : T => '/ ' E ] ']'"). + +Reserved Notation "[ 'rel' x y => E ]" (at level 0, x, y at level 8, format + "'[hv' [ 'rel' x y => '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y : T => E ]" (at level 0, x, y at level 8, format + "'[hv' [ 'rel' x y : T => '/ ' E ] ']'"). + +(* Shorter delimiter *) +Delimit Scope bool_scope with B. +Open Scope bool_scope. + +(* 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 "~~ 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. *) +Coercion is_true : bool >-> Sortclass. (* Prop *) + +Lemma prop_congr : forall b b' : bool, b = b' -> b = b' :> Prop. +Proof. by move=> b b' ->. Qed. + +Ltac prop_congr := apply: prop_congr. + +(* 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. *) +Definition isT := is_true_true. +Definition notF := not_false_is_true. + +(* 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. *) + +Lemma negbT b : b = false -> ~~ b. Proof. by case: b. Qed. +Lemma negbTE b : ~~ b -> b = false. Proof. by case: b. Qed. +Lemma negbF b : (b : bool) -> ~~ b = false. Proof. by case: b. Qed. +Lemma negbFE b : ~~ b = false -> b. Proof. by case: b. Qed. +Lemma negbK : involutive negb. Proof. by case. Qed. +Lemma negbNE b : ~~ ~~ b -> b. Proof. by case: b. Qed. + +Lemma negb_inj : injective negb. Proof. exact: can_inj negbK. Qed. +Lemma negbLR b c : b = ~~ c -> ~~ b = c. Proof. exact: canLR negbK. Qed. +Lemma negbRL b c : ~~ b = c -> b = ~~ c. Proof. exact: canRL negbK. Qed. + +Lemma contra (c b : bool) : (c -> b) -> ~~ b -> ~~ c. +Proof. by case: b => //; case: c. Qed. +Definition contraNN := contra. + +Lemma contraL (c b : bool) : (c -> ~~ b) -> b -> ~~ c. +Proof. by case: b => //; case: c. Qed. +Definition contraTN := contraL. + +Lemma contraR (c b : bool) : (~~ c -> b) -> ~~ b -> c. +Proof. by case: b => //; case: c. Qed. +Definition contraNT := contraR. + +Lemma contraLR (c b : bool) : (~~ c -> ~~ b) -> b -> c. +Proof. by case: b => //; case: c. Qed. +Definition contraTT := contraLR. + +Lemma contraT b : (~~ b -> false) -> b. Proof. by case: b => // ->. Qed. + +Lemma wlog_neg b : (~~ b -> b) -> b. Proof. by case: b => // ->. Qed. + +Lemma contraFT (c b : bool) : (~~ c -> b) -> b = false -> c. +Proof. by move/contraR=> notb_c /negbT. Qed. + +Lemma contraFN (c b : bool) : (c -> b) -> b = false -> ~~ c. +Proof. by move/contra=> notb_notc /negbT. Qed. + +Lemma contraTF (c b : bool) : (c -> ~~ b) -> b -> c = false. +Proof. by move/contraL=> b_notc /b_notc/negbTE. Qed. + +Lemma contraNF (c b : bool) : (c -> b) -> ~~ b -> c = false. +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 isSome T (u : option T) := if u is Some _ then true else false. + +Coercion is_inl A B (u : A + B) := if u is inl _ then true else false. + +Coercion is_left A B (u : {A} + {B}) := if u is left _ then true else false. + +Coercion is_inleft A B (u : A + {B}) := if u is inleft _ then true else false. + +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 *) + +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 := + | IfSpecTrue of b : if_spec not_b true vT + | IfSpecFalse of not_b : if_spec not_b false vF. + +Lemma ifP : if_spec (b = false) b (if b then vT else vF). +Proof. by case def_b: b; constructor. Qed. + +Lemma ifPn : if_spec (~~ b) b (if b then vT else vF). +Proof. by case def_b: b; constructor; rewrite ?def_b. Qed. + +Lemma ifT : b -> (if b then vT else vF) = vT. Proof. by move->. Qed. +Lemma ifF : b = false -> (if b then vT else vF) = vF. Proof. by move->. Qed. +Lemma ifN : ~~ b -> (if b then vT else vF) = vF. Proof. by move/negbTE->. Qed. + +Lemma if_same : (if b then vT else vT) = vT. +Proof. by case b. Qed. + +Lemma if_neg : (if ~~ b then vT else vF) = if b then vF else vT. +Proof. by case b. Qed. + +Lemma fun_if : f (if b then vT else vF) = if b then f vT else f vF. +Proof. by case b. Qed. + +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. *) +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. *) + +Section ReflectCore. + +Variables (P Q : Prop) (b c : bool). + +Hypothesis Hb : reflect P b. + +Lemma introNTF : (if c then ~ P else P) -> ~~ b = c. +Proof. by case c; case Hb. Qed. + +Lemma introTF : (if c then P else ~ P) -> b = c. +Proof. by case c; case Hb. Qed. + +Lemma elimNTF : ~~ b = c -> if c then ~ P else P. +Proof. by move <-; case Hb. Qed. + +Lemma elimTF : b = c -> if c then P else ~ P. +Proof. by move <-; case Hb. Qed. + +Lemma equivPif : (Q -> P) -> (P -> Q) -> if b then Q else ~ Q. +Proof. by case Hb; auto. Qed. + +Lemma xorPif : Q \/ P -> ~ (Q /\ P) -> if b then ~ Q else Q. +Proof. by case Hb => [? _ H ? | ? H _]; case: H. Qed. + +End ReflectCore. + +(* Internal negated reflection lemmas *) +Section ReflectNegCore. + +Variables (P Q : Prop) (b c : bool). +Hypothesis Hb : reflect P (~~ b). + +Lemma introTFn : (if c then ~ P else P) -> b = c. +Proof. by move/(introNTF Hb) <-; case b. Qed. + +Lemma elimTFn : b = c -> if c then ~ P else P. +Proof. by move <-; apply: (elimNTF Hb); case b. Qed. + +Lemma equivPifn : (Q -> P) -> (P -> Q) -> if b then ~ Q else Q. +Proof. by rewrite -if_neg; apply: equivPif. Qed. + +Lemma xorPifn : Q \/ P -> ~ (Q /\ P) -> if b then Q else ~ Q. +Proof. by rewrite -if_neg; apply: xorPif. Qed. + +End ReflectNegCore. + +(* User-oriented reflection lemmas *) +Section Reflect. + +Variables (P Q : Prop) (b b' c : bool). +Hypotheses (Pb : reflect P b) (Pb' : reflect P (~~ b')). + +Lemma introT : P -> b. Proof. exact: introTF true _. Qed. +Lemma introF : ~ P -> b = false. Proof. exact: introTF false _. Qed. +Lemma introN : ~ P -> ~~ b. Proof. exact: introNTF true _. Qed. +Lemma introNf : P -> ~~ b = false. Proof. exact: introNTF false _. Qed. +Lemma introTn : ~ P -> b'. Proof. exact: introTFn true _. Qed. +Lemma introFn : P -> b' = false. Proof. exact: introTFn false _. Qed. + +Lemma elimT : b -> P. Proof. exact: elimTF true _. Qed. +Lemma elimF : b = false -> ~ P. Proof. exact: elimTF false _. Qed. +Lemma elimN : ~~ b -> ~P. Proof. exact: elimNTF true _. Qed. +Lemma elimNf : ~~ b = false -> P. Proof. exact: elimNTF false _. Qed. +Lemma elimTn : b' -> ~ P. Proof. exact: elimTFn true _. Qed. +Lemma elimFn : b' = false -> P. Proof. exact: elimTFn false _. Qed. + +Lemma introP : (b -> Q) -> (~~ b -> ~ Q) -> reflect Q b. +Proof. by case b; constructor; auto. Qed. + +Lemma iffP : (P -> Q) -> (Q -> P) -> reflect Q b. +Proof. by case: Pb; constructor; auto. Qed. + +Lemma equivP : (P <-> Q) -> reflect Q b. +Proof. by case; apply: iffP. Qed. + +Lemma sumboolP (decQ : decidable Q) : reflect Q decQ. +Proof. by case: decQ; constructor. Qed. + +Lemma appP : reflect Q b -> P -> Q. +Proof. by move=> Qb; move/introT; case: Qb. Qed. + +Lemma sameP : reflect P c -> b = c. +Proof. by case; [apply: introT | apply: introF]. Qed. + +Lemma decPcases : if b then P else ~ P. Proof. by case Pb. Qed. + +Definition decP : decidable P. by case: b decPcases; [left | right]. Defined. + +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 := + | AltTrue of P : alt_spec true + | AltFalse of ~~ b : alt_spec false. + +Lemma altP : alt_spec b. +Proof. by case def_b: b / Pb; constructor; rewrite ?def_b. Qed. + +End Reflect. + +Hint View for move/ elimTF|3 elimNTF|3 elimTFn|3 introT|2 introTn|2 introN|2. + +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. *) +Coercion elimT : reflect >-> Funclass. + +CoInductive 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. +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. *) +Definition unless condition property : Prop := + forall goal : Prop, (condition -> goal) -> (property -> goal) -> goal. + +Notation "\unless C , P" := (unless C P) + (at level 200, C at level 100, + format "'[' \unless C , '/ ' P ']'") : type_scope. + +Lemma unlessL C P : implies C (\unless C, P). +Proof. by split=> hC G /(_ hC). Qed. + +Lemma unlessR C P : implies P (\unless C, P). +Proof. by split=> hP G _ /(_ hP). Qed. + +Lemma unless_sym C P : implies (\unless C, P) (\unless P, C). +Proof. by split; apply; [apply/unlessR | apply/unlessL]. Qed. + +Lemma unlessP (C P : Prop) : (\unless C, P) <-> C \/ P. +Proof. by split=> [|[/unlessL | /unlessR]]; apply; [left | right]. Qed. + +Lemma bind_unless C P {Q} : implies (\unless C, P) (\unless (\unless C, Q), P). +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. *) +Definition classically P : Prop := forall b : bool, (P -> b) -> b. + +Lemma classicP (P : Prop) : classically P <-> ~ ~ P. +Proof. +split=> [cP nP | nnP [] // nP]; last by case nnP; move/nP. +by have: P -> false; [move/nP | move/cP]. +Qed. + +Lemma classicW P : P -> classically P. Proof. by move=> hP _ ->. Qed. + +Lemma classic_bind P Q : (P -> classically Q) -> classically P -> classically Q. +Proof. by move=> iPQ cP b /iPQ-/cP. Qed. + +Lemma classic_EM P : classically (decidable P). +Proof. +by case=> // undecP; apply/undecP; right=> notP; apply/notF/undecP; left. +Qed. + +Lemma classic_pick T P : classically ({x : T | P x} + (forall x, ~ P x)). +Proof. +case=> // undecP; apply/undecP; right=> x Px. +by apply/notF/undecP; left; exists x. +Qed. + +Lemma classic_imply P Q : (P -> classically Q) -> classically (P -> Q). +Proof. +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. *) + +Inductive and3 (P1 P2 P3 : Prop) : Prop := And3 of P1 & P2 & P3. + +Inductive and4 (P1 P2 P3 P4 : Prop) : Prop := And4 of P1 & P2 & P3 & P4. + +Inductive and5 (P1 P2 P3 P4 P5 : Prop) : Prop := + And5 of P1 & P2 & P3 & P4 & P5. + +Inductive or3 (P1 P2 P3 : Prop) : Prop := Or31 of P1 | Or32 of P2 | Or33 of P3. + +Inductive or4 (P1 P2 P3 P4 : Prop) : Prop := + Or41 of P1 | Or42 of P2 | Or43 of P3 | Or44 of P4. + +Notation "[ /\ P1 & P2 ]" := (and P1 P2) (only parsing) : type_scope. +Notation "[ /\ P1 , P2 & P3 ]" := (and3 P1 P2 P3) : type_scope. +Notation "[ /\ P1 , P2 , P3 & P4 ]" := (and4 P1 P2 P3 P4) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 & P5 ]" := (and5 P1 P2 P3 P4 P5) : type_scope. + +Notation "[ \/ P1 | P2 ]" := (or P1 P2) (only parsing) : type_scope. +Notation "[ \/ P1 , P2 | P3 ]" := (or3 P1 P2 P3) : type_scope. +Notation "[ \/ P1 , P2 , P3 | P4 ]" := (or4 P1 P2 P3 P4) : type_scope. + +Notation "[ && b1 & c ]" := (b1 && c) (only parsing) : bool_scope. +Notation "[ && b1 , b2 , .. , bn & c ]" := (b1 && (b2 && .. (bn && c) .. )) + : bool_scope. + +Notation "[ || b1 | c ]" := (b1 || c) (only parsing) : bool_scope. +Notation "[ || b1 , b2 , .. , bn | c ]" := (b1 || (b2 || .. (bn || c) .. )) + : bool_scope. + +Notation "[ ==> b1 , b2 , .. , bn => c ]" := + (b1 ==> (b2 ==> .. (bn ==> c) .. )) : bool_scope. +Notation "[ ==> b1 => c ]" := (b1 ==> c) (only parsing) : bool_scope. + +Section AllAnd. + +Variables (T : Type) (P1 P2 P3 P4 P5 : T -> Prop). +Local Notation a P := (forall x, P x). + +Lemma all_and2 : implies (forall x, [/\ P1 x & P2 x]) [/\ a P1 & a P2]. +Proof. by split=> haveP; split=> x; case: (haveP x). Qed. + +Lemma all_and3 : implies (forall x, [/\ P1 x, P2 x & P3 x]) + [/\ a P1, a P2 & a P3]. +Proof. by split=> haveP; split=> x; case: (haveP x). Qed. + +Lemma all_and4 : implies (forall x, [/\ P1 x, P2 x, P3 x & P4 x]) + [/\ a P1, a P2, a P3 & a P4]. +Proof. by split=> haveP; split=> x; case: (haveP x). Qed. + +Lemma all_and5 : implies (forall x, [/\ P1 x, P2 x, P3 x, P4 x & P5 x]) + [/\ a P1, a P2, a P3, a P4 & a P5]. +Proof. by split=> haveP; split=> x; case: (haveP x). Qed. + +End AllAnd. + +Arguments all_and2 {T P1 P2}. +Arguments all_and3 {T P1 P2 P3}. +Arguments all_and4 {T P1 P2 P3 P4}. +Arguments all_and5 {T P1 P2 P3 P4 P5}. + +Lemma pair_andP P Q : P /\ Q <-> P * Q. Proof. by split; case. Qed. + +Section ReflectConnectives. + +Variable b1 b2 b3 b4 b5 : bool. + +Lemma idP : reflect b1 b1. +Proof. by case b1; constructor. Qed. + +Lemma boolP : alt_spec b1 b1 b1. +Proof. exact: (altP idP). Qed. + +Lemma idPn : reflect (~~ b1) (~~ b1). +Proof. by case b1; constructor. Qed. + +Lemma negP : reflect (~ b1) (~~ b1). +Proof. by case b1; constructor; auto. Qed. + +Lemma negPn : reflect b1 (~~ ~~ b1). +Proof. by case b1; constructor. Qed. + +Lemma negPf : reflect (b1 = false) (~~ b1). +Proof. by case b1; constructor. Qed. + +Lemma andP : reflect (b1 /\ b2) (b1 && b2). +Proof. by case b1; case b2; constructor=> //; case. Qed. + +Lemma and3P : reflect [/\ b1, b2 & b3] [&& b1, b2 & b3]. +Proof. by case b1; case b2; case b3; constructor; try by case. Qed. + +Lemma and4P : reflect [/\ b1, b2, b3 & b4] [&& b1, b2, b3 & b4]. +Proof. by case b1; case b2; case b3; case b4; constructor; try by case. Qed. + +Lemma and5P : reflect [/\ b1, b2, b3, b4 & b5] [&& b1, b2, b3, b4 & b5]. +Proof. +by case b1; case b2; case b3; case b4; case b5; constructor; try by case. +Qed. + +Lemma orP : reflect (b1 \/ b2) (b1 || b2). +Proof. by case b1; case b2; constructor; auto; case. Qed. + +Lemma or3P : reflect [\/ b1, b2 | b3] [|| b1, b2 | b3]. +Proof. +case b1; first by constructor; constructor 1. +case b2; first by constructor; constructor 2. +case b3; first by constructor; constructor 3. +by constructor; case. +Qed. + +Lemma or4P : reflect [\/ b1, b2, b3 | b4] [|| b1, b2, b3 | b4]. +Proof. +case b1; first by constructor; constructor 1. +case b2; first by constructor; constructor 2. +case b3; first by constructor; constructor 3. +case b4; first by constructor; constructor 4. +by constructor; case. +Qed. + +Lemma nandP : reflect (~~ b1 \/ ~~ b2) (~~ (b1 && b2)). +Proof. by case b1; case b2; constructor; auto; case; auto. Qed. + +Lemma norP : reflect (~~ b1 /\ ~~ b2) (~~ (b1 || b2)). +Proof. by case b1; case b2; constructor; auto; case; auto. Qed. + +Lemma implyP : reflect (b1 -> b2) (b1 ==> b2). +Proof. by case b1; case b2; constructor; auto. Qed. + +End ReflectConnectives. + +Arguments idP [b1]. +Arguments idPn [b1]. +Arguments negP [b1]. +Arguments negPn [b1]. +Arguments negPf [b1]. +Arguments andP [b1 b2]. +Arguments and3P [b1 b2 b3]. +Arguments and4P [b1 b2 b3 b4]. +Arguments and5P [b1 b2 b3 b4 b5]. +Arguments orP [b1 b2]. +Arguments or3P [b1 b2 b3]. +Arguments or4P [b1 b2 b3 b4]. +Arguments nandP [b1 b2]. +Arguments norP [b1 b2]. +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. *) + +Lemma andTb : left_id true andb. Proof. by []. Qed. +Lemma andFb : left_zero false andb. Proof. by []. Qed. +Lemma andbT : right_id true andb. Proof. by case. Qed. +Lemma andbF : right_zero false andb. Proof. by case. Qed. +Lemma andbb : idempotent andb. Proof. by case. Qed. +Lemma andbC : commutative andb. Proof. by do 2!case. Qed. +Lemma andbA : associative andb. Proof. by do 3!case. Qed. +Lemma andbCA : left_commutative andb. Proof. by do 3!case. Qed. +Lemma andbAC : right_commutative andb. Proof. by do 3!case. Qed. +Lemma andbACA : interchange andb andb. Proof. by do 4!case. Qed. + +Lemma orTb : forall b, true || b. Proof. by []. Qed. +Lemma orFb : left_id false orb. Proof. by []. Qed. +Lemma orbT : forall b, b || true. Proof. by case. Qed. +Lemma orbF : right_id false orb. Proof. by case. Qed. +Lemma orbb : idempotent orb. Proof. by case. Qed. +Lemma orbC : commutative orb. Proof. by do 2!case. Qed. +Lemma orbA : associative orb. Proof. by do 3!case. Qed. +Lemma orbCA : left_commutative orb. Proof. by do 3!case. Qed. +Lemma orbAC : right_commutative orb. Proof. by do 3!case. Qed. +Lemma orbACA : interchange orb orb. Proof. by do 4!case. Qed. + +Lemma andbN b : b && ~~ b = false. Proof. by case: b. Qed. +Lemma andNb b : ~~ b && b = false. Proof. by case: b. Qed. +Lemma orbN b : b || ~~ b = true. Proof. by case: b. Qed. +Lemma orNb b : ~~ b || b = true. Proof. by case: b. Qed. + +Lemma andb_orl : left_distributive andb orb. Proof. by do 3!case. Qed. +Lemma andb_orr : right_distributive andb orb. Proof. by do 3!case. Qed. +Lemma orb_andl : left_distributive orb andb. Proof. by do 3!case. Qed. +Lemma orb_andr : right_distributive orb andb. Proof. by do 3!case. Qed. + +Lemma andb_idl (a b : bool) : (b -> a) -> a && b = b. +Proof. by case: a; case: b => // ->. Qed. +Lemma andb_idr (a b : bool) : (a -> b) -> a && b = a. +Proof. by case: a; case: b => // ->. Qed. +Lemma andb_id2l (a b c : bool) : (a -> b = c) -> a && b = a && c. +Proof. by case: a; case: b; case: c => // ->. Qed. +Lemma andb_id2r (a b c : bool) : (b -> a = c) -> a && b = c && b. +Proof. by case: a; case: b; case: c => // ->. Qed. + +Lemma orb_idl (a b : bool) : (a -> b) -> a || b = b. +Proof. by case: a; case: b => // ->. Qed. +Lemma orb_idr (a b : bool) : (b -> a) -> a || b = a. +Proof. by case: a; case: b => // ->. Qed. +Lemma orb_id2l (a b c : bool) : (~~ a -> b = c) -> a || b = a || c. +Proof. by case: a; case: b; case: c => // ->. Qed. +Lemma orb_id2r (a b c : bool) : (~~ b -> a = c) -> a || b = c || b. +Proof. by case: a; case: b; case: c => // ->. Qed. + +Lemma negb_and (a b : bool) : ~~ (a && b) = ~~ a || ~~ b. +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 *) + +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 *) + +Lemma implybT b : b ==> true. Proof. by case: b. Qed. +Lemma implybF b : (b ==> false) = ~~ b. Proof. by case: b. Qed. +Lemma implyFb b : false ==> b. Proof. by []. Qed. +Lemma implyTb b : (true ==> b) = b. Proof. by []. Qed. +Lemma implybb b : b ==> b. Proof. by case: b. Qed. + +Lemma negb_imply a b : ~~ (a ==> b) = a && ~~ b. +Proof. by case: a; case: b. Qed. + +Lemma implybE a b : (a ==> b) = ~~ a || b. +Proof. by case: a; case: b. Qed. + +Lemma implyNb a b : (~~ a ==> b) = a || b. +Proof. by case: a; case: b. Qed. + +Lemma implybN a b : (a ==> ~~ b) = (b ==> ~~ a). +Proof. by case: a; case: b. Qed. + +Lemma implybNN a b : (~~ a ==> ~~ b) = b ==> a. +Proof. by case: a; case: b. Qed. + +Lemma implyb_idl (a b : bool) : (~~ a -> b) -> (a ==> b) = b. +Proof. by case: a; case: b => // ->. Qed. +Lemma implyb_idr (a b : bool) : (b -> ~~ a) -> (a ==> b) = ~~ a. +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) *) + +Lemma addFb : left_id false addb. Proof. by []. Qed. +Lemma addbF : right_id false addb. Proof. by case. Qed. +Lemma addbb : self_inverse false addb. Proof. by case. Qed. +Lemma addbC : commutative addb. Proof. by do 2!case. Qed. +Lemma addbA : associative addb. Proof. by do 3!case. Qed. +Lemma addbCA : left_commutative addb. Proof. by do 3!case. Qed. +Lemma addbAC : right_commutative addb. Proof. by do 3!case. Qed. +Lemma addbACA : interchange addb addb. Proof. by do 4!case. Qed. +Lemma andb_addl : left_distributive andb addb. Proof. by do 3!case. Qed. +Lemma andb_addr : right_distributive andb addb. Proof. by do 3!case. Qed. +Lemma addKb : left_loop id addb. Proof. by do 2!case. Qed. +Lemma addbK : right_loop id addb. Proof. by do 2!case. Qed. +Lemma addIb : left_injective addb. Proof. by do 3!case. Qed. +Lemma addbI : right_injective addb. Proof. by do 3!case. Qed. + +Lemma addTb b : true (+) b = ~~ b. Proof. by []. Qed. +Lemma addbT b : b (+) true = ~~ b. Proof. by case: b. Qed. + +Lemma addbN a b : a (+) ~~ b = ~~ (a (+) b). +Proof. by case: a; case: b. Qed. +Lemma addNb a b : ~~ a (+) b = ~~ (a (+) b). +Proof. by case: a; case: b. Qed. + +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! *) + +Ltac bool_congr := + match goal with + | |- (?X1 && ?X2 = ?X3) => first + [ symmetry; rewrite -1?(andbC X1) -?(andbCA X1); congr 1 (andb X1); symmetry + | case: (X1); [ rewrite ?andTb ?andbT // | by rewrite ?andbF /= ] ] + | |- (?X1 || ?X2 = ?X3) => first + [ symmetry; rewrite -1?(orbC X1) -?(orbCA X1); congr 1 (orb X1); symmetry + | case: (X1); [ by rewrite ?orbT //= | rewrite ?orFb ?orbF ] ] + | |- (?X1 (+) ?X2 = ?X3) => + symmetry; rewrite -1?(addbC X1) -?(addbCA X1); congr 1 (addb X1); symmetry + | |- (~~ ?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. *) +(******************************************************************************) + +Definition pred T := T -> bool. + +Identity Coercion fun_of_pred : pred >-> Funclass. + +Definition rel T := T -> pred T. + +Identity Coercion fun_of_rel : rel >-> Funclass. + +Notation xpred0 := (fun _ => false). +Notation xpredT := (fun _ => true). +Notation xpredI := (fun (p1 p2 : pred _) x => p1 x && p2 x). +Notation xpredU := (fun (p1 p2 : pred _) x => p1 x || p2 x). +Notation xpredC := (fun (p : pred _) x => ~~ p x). +Notation xpredD := (fun (p1 p2 : pred _) x => ~~ p2 x && p1 x). +Notation xpreim := (fun f (p : pred _) x => p (f x)). +Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). + +Section Predicates. + +Variables T : Type. + +Definition subpred (p1 p2 : pred T) := forall x, p1 x -> p2 x. + +Definition subrel (r1 r2 : rel T) := forall x y, r1 x y -> r2 x y. + +Definition simpl_pred := simpl_fun T bool. +Definition applicative_pred := pred T. +Definition collective_pred := pred T. + +Definition SimplPred (p : pred T) : simpl_pred := SimplFun p. + +Coercion pred_of_simpl (p : simpl_pred) : pred T := fun_of_simpl p. +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. *) + +Definition pred0 := SimplPred xpred0. +Definition predT := SimplPred xpredT. +Definition predI p1 p2 := SimplPred (xpredI p1 p2). +Definition predU p1 p2 := SimplPred (xpredU p1 p2). +Definition predC p := SimplPred (xpredC p). +Definition predD p1 p2 := SimplPred (xpredD p1 p2). +Definition preim rT f (d : pred rT) := SimplPred (xpreim f d). + +Definition simpl_rel := simpl_fun T (pred T). + +Definition SimplRel (r : rel T) : simpl_rel := [fun x => r x]. + +Coercion rel_of_simpl_rel (r : simpl_rel) : rel T := fun x y => r x y. + +Definition relU r1 r2 := SimplRel (xrelU r1 r2). + +Lemma subrelUl r1 r2 : subrel r1 (relU r1 r2). +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. + +Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). + +Structure predType := PredType { + pred_sort :> Type; + topred : pred_sort -> pred T; + _ : {mem | isMem topred mem} +}. + +Definition mkPredType pT toP := PredType (exist (@isMem pT toP) _ (erefl _)). + +Canonical predPredType := Eval hnf in @mkPredType (pred T) id. +Canonical simplPredType := Eval hnf in mkPredType pred_of_simpl. +Canonical boolfunPredType := Eval hnf in @mkPredType (T -> bool) id. + +Coercion pred_of_mem mp : pred_sort predPredType := let: Mem p := mp in [eta p]. +Canonical memPredType := Eval hnf in mkPredType pred_of_mem. + +Definition clone_pred U := + fun pT & pred_sort pT -> U => + fun a mP (pT' := @PredType U a mP) & phant_id pT' pT => pT'. + +End Predicates. + +Arguments pred0 [T]. +Arguments predT [T]. +Prenex Implicits pred0 predT predI predU predC predD preim relU. + +Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) + (at level 0, format "[ 'pred' : T | E ]") : fun_scope. +Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) + (at level 0, x ident, format "[ 'pred' x | E ]") : fun_scope. +Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] + (at level 0, x ident, format "[ 'pred' x | E1 & E2 ]") : fun_scope. +Notation "[ 'pred' x : T | E ]" := (SimplPred (fun x : T => E%B)) + (at level 0, x ident, only parsing) : fun_scope. +Notation "[ 'pred' x : T | E1 & E2 ]" := [pred x : T | E1 && E2 ] + (at level 0, x ident, only parsing) : fun_scope. +Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) + (at level 0, x ident, y ident, format "[ 'rel' x y | E ]") : fun_scope. +Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +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. *) + +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. *) +Definition predArgType := Type. +Bind Scope type_scope with predArgType. +Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. +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. *) + +Definition mem T (pT : predType T) : pT -> mem_pred T := + nosimpl (let: @PredType _ _ _ (exist _ mem _) := pT return pT -> _ in mem). +Definition in_mem T x mp := nosimpl pred_of_mem T mp x. + +Prenex Implicits mem. + +Coercion pred_of_mem_pred T mp := [pred x : T | in_mem x mp]. + +Definition eq_mem T p1 p2 := forall x : T, in_mem x p1 = in_mem x p2. +Definition sub_mem T p1 p2 := forall x : T, in_mem x p1 -> in_mem x p2. + +Typeclasses Opaque eq_mem. + +Lemma sub_refl T (p : mem_pred T) : sub_mem p p. Proof. by []. Qed. +Arguments sub_refl {T p}. + +Notation "x \in A" := (in_mem x (mem A)) : bool_scope. +Notation "x \in A" := (in_mem x (mem A)) : bool_scope. +Notation "x \notin A" := (~~ (x \in A)) : bool_scope. +Notation "A =i B" := (eq_mem (mem A) (mem B)) : type_scope. +Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) + (at level 0, A, B at level 69, + format "{ '[hv' 'subset' A '/ ' <= B ']' }") : type_scope. +Notation "[ 'mem' A ]" := (pred_of_simpl (pred_of_mem_pred (mem A))) + (at level 0, only parsing) : fun_scope. +Notation "[ 'rel' 'of' fA ]" := (fun x => [mem (fA x)]) + (at level 0, format "[ 'rel' 'of' fA ]") : fun_scope. +Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) + (at level 0, format "[ 'predI' A & B ]") : fun_scope. +Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) + (at level 0, format "[ 'predU' A & B ]") : fun_scope. +Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) + (at level 0, format "[ 'predD' A & B ]") : fun_scope. +Notation "[ 'predC' A ]" := (predC [mem A]) + (at level 0, format "[ 'predC' A ]") : fun_scope. +Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) + (at level 0, format "[ 'preim' f 'of' A ]") : fun_scope. + +Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] + (at level 0, x ident, format "[ 'pred' x 'in' A ]") : fun_scope. +Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] + (at level 0, x ident, format "[ 'pred' x 'in' A | E ]") : fun_scope. +Notation "[ 'pred' x 'in' A | E1 & E2 ]" := [pred x | x \in A & E1 && E2 ] + (at level 0, x ident, + format "[ 'pred' x 'in' A | E1 & E2 ]") : fun_scope. +Notation "[ 'rel' x y 'in' A & B | E ]" := + [rel x y | (x \in A) && (y \in B) && E] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A & B | E ]") : fun_scope. +Notation "[ 'rel' x y 'in' A & B ]" := [rel x y | (x \in A) && (y \in B)] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A & B ]") : fun_scope. +Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A | E ]") : fun_scope. +Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] + (at level 0, x ident, y ident, + format "[ 'rel' x y 'in' A ]") : fun_scope. + +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). *) +Structure manifest_applicative_pred p := ManifestApplicativePred { + manifest_applicative_pred_value :> pred T; + _ : manifest_applicative_pred_value = p +}. +Definition ApplicativePred p := ManifestApplicativePred (erefl p). +Canonical applicative_pred_applicative sp := + ApplicativePred (applicative_pred_of_simpl sp). + +Structure manifest_simpl_pred p := ManifestSimplPred { + manifest_simpl_pred_value :> simpl_pred T; + _ : manifest_simpl_pred_value = SimplPred p +}. +Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). + +Structure manifest_mem_pred p := ManifestMemPred { + manifest_mem_pred_value :> mem_pred T; + _ : manifest_mem_pred_value= Mem [eta p] +}. +Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). + +Structure applicative_mem_pred p := + ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. +Canonical check_applicative_mem_pred p (ap : manifest_applicative_pred p) mp := + @ApplicativeMemPred ap mp. + +Lemma mem_topred (pp : pT) : mem (topred pp) = mem pp. +Proof. by rewrite /mem; case: pT pp => T1 app1 [mem1 /= ->]. Qed. + +Lemma topredE x (pp : pT) : topred pp x = (x \in pp). +Proof. by rewrite -mem_topred. Qed. + +Lemma app_predE x p (ap : manifest_applicative_pred p) : ap x = (x \in p). +Proof. by case: ap => _ /= ->. Qed. + +Lemma in_applicative x p (amp : applicative_mem_pred p) : in_mem x amp = p x. +Proof. by case: amp => [[_ /= ->]]. Qed. + +Lemma in_collective x p (msp : manifest_simpl_pred p) : + (x \in collective_pred_of_simpl msp) = p x. +Proof. by case: msp => _ /= ->. Qed. + +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. *) +Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. +Proof. by []. Qed. + +Lemma simpl_predE p : SimplPred p =1 p. +Proof. by []. Qed. + +Definition inE := (in_applicative, in_simpl, simpl_predE). (* to be extended *) + +Lemma mem_simpl sp : mem sp = sp :> pred T. +Proof. by []. Qed. + +Definition memE := mem_simpl. (* could be extended *) + +Lemma mem_mem (pp : pT) : (mem (mem pp) = mem pp) * (mem [mem pp] = mem pp). +Proof. by rewrite -mem_topred. Qed. + +End simpl_mem. + +(* Qualifiers and keyed predicates. *) + +CoInductive 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. +Arguments has_quality n [T]. + +Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. + +Notation "x \is A" := (x \in has_quality 0 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \is A ']'") : bool_scope. +Notation "x \is 'a' A" := (x \in has_quality 1 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \is 'a' A ']'") : bool_scope. +Notation "x \is 'an' A" := (x \in has_quality 2 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \is 'an' A ']'") : bool_scope. +Notation "x \isn't A" := (x \notin has_quality 0 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \isn't A ']'") : bool_scope. +Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'a' A ']'") : bool_scope. +Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) + (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'an' A ']'") : bool_scope. +Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) + (at level 0, x at level 99, + format "'[hv' [ 'qualify' x | '/ ' P ] ']'") : form_scope. +Notation "[ 'qualify' x : T | P ]" := (Qualifier 0 (fun x : T => P%B)) + (at level 0, x at level 99, only parsing) : form_scope. +Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) + (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'") : form_scope. +Notation "[ 'qualify' 'a' x : T | P ]" := (Qualifier 1 (fun x : T => P%B)) + (at level 0, x at level 99, only parsing) : form_scope. +Notation "[ 'qualify' 'an' x | P ]" := (Qualifier 2 (fun x => P%B)) + (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'") : form_scope. +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. *) + +Section KeyPred. + +Variable T : Type. +CoInductive pred_key (p : predPredType T) := DefaultPredKey. + +Variable p : predPredType T. +Structure keyed_pred (k : pred_key p) := + PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. + +Variable k : pred_key p. +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 !! *) +Canonical keyed_mem := + @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. +Canonical keyed_mem_simpl := + @PackKeyedPred k (pred_of_simpl (mem k_p)) keyed_predE. + +End KeyPred. + +Notation "x \i 'n' S" := (x \in @unkey_pred _ S _ _) + (at level 70, format "'[hv' x '/ ' \i 'n' S ']'") : bool_scope. + +Section KeyedQualifier. + +Variables (T : Type) (n : nat) (q : qualifier n T). + +Structure keyed_qualifier (k : pred_key q) := + PackKeyedQualifier {unkey_qualifier; _ : unkey_qualifier = q}. +Definition KeyedQualifier k := PackKeyedQualifier k (erefl q). +Variables (k : pred_key q) (k_q : keyed_qualifier k). +Fact keyed_qualifier_suproof : unkey_qualifier k_q =i q. +Proof. by case: k_q => /= _ ->. Qed. +Canonical keyed_qualifier_keyed := PackKeyedPred k keyed_qualifier_suproof. + +End KeyedQualifier. + +Notation "x \i 's' A" := (x \i n has_quality 0 A) + (at level 70, format "'[hv' x '/ ' \i 's' A ']'") : bool_scope. +Notation "x \i 's' 'a' A" := (x \i n has_quality 1 A) + (at level 70, format "'[hv' x '/ ' \i 's' 'a' A ']'") : bool_scope. +Notation "x \i 's' 'an' A" := (x \i n has_quality 2 A) + (at level 70, format "'[hv' x '/ ' \i 's' 'an' A ']'") : bool_scope. + +Module DefaultKeying. + +Canonical default_keyed_pred T p := KeyedPred (@DefaultPredKey T p). +Canonical default_keyed_qualifier T n (q : qualifier n T) := + KeyedQualifier (DefaultPredKey q). + +End DefaultKeying. + +(* 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}) -> + {f : forall x, T x & forall x, C x -> U x (f x)}. +Proof. +move=> f0 fP; apply: all_tag (fun x y => C x -> U x y) _ => x. +by case Cx: (C x); [case/fP: Cx => y; exists y | exists (f0 x)]. +Qed. + +Lemma all_tag_cond I T (C : pred I) U : + T -> (forall x, C x -> {y : T & U x y}) -> + {f : I -> T & forall x, C x -> U x (f x)}. +Proof. by move=> y0; apply: all_tag_cond_dep. Qed. + +Lemma all_sig_cond_dep I T (C : pred I) P : + (forall x, T x) -> (forall x, C x -> {y : T x | P x y}) -> + {f : forall x, T x | forall x, C x -> P x (f x)}. +Proof. by move=> f0 /(all_tag_cond_dep f0)[f]; exists f. Qed. + +Lemma all_sig_cond I T (C : pred I) P : + T -> (forall x, C x -> {y : T | P x y}) -> + {f : I -> T | forall x, C x -> P x (f x)}. +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. *) + +Variable T : Type. + +Variable R : rel T. + +Definition total := forall x y, R x y || R y x. +Definition transitive := forall y x z, R x y -> R y z -> R x z. + +Definition symmetric := forall x y, R x y = R y x. +Definition antisymmetric := forall x y, R x y && R y x -> x = y. +Definition pre_symmetric := forall x y, R x y -> R y x. + +Lemma symmetric_from_pre : pre_symmetric -> symmetric. +Proof. by move=> symR x y; apply/idP/idP; apply: symR. Qed. + +Definition reflexive := forall x, R x x. +Definition irreflexive := forall x, R x x = false. + +Definition left_transitive := forall x y, R x y -> R x =1 R y. +Definition right_transitive := forall x y, R x y -> R^~ x =1 R^~ y. + +Section PER. + +Hypotheses (symR : symmetric) (trR : transitive). + +Lemma sym_left_transitive : left_transitive. +Proof. by move=> x y Rxy z; apply/idP/idP; apply: trR; rewrite // symR. Qed. + +Lemma sym_right_transitive : right_transitive. +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. *) + +Definition equivalence_rel := forall x y z, R z z * (R x y -> R x z = R y z). + +Lemma equivalence_relP : equivalence_rel <-> reflexive /\ left_transitive. +Proof. +split=> [eqiR | [Rxx trR] x y z]; last by split=> [|/trR->]. +by split=> [x | x y Rxy z]; [rewrite (eqiR x x x) | rewrite (eqiR x y z)]. +Qed. + +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 *) + +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). +Local Notation "{ 'all3' P }" := (forall x y z, P x y z: Prop) (at level 0). +Local Notation ph := (phantom _). + +Section LocalProperties. + +Variables T1 T2 T3 : Type. + +Variables (d1 : mem_pred T1) (d2 : mem_pred T2) (d3 : mem_pred T3). +Local Notation ph := (phantom Prop). + +Definition prop_for (x : T1) P & ph {all1 P} := P x. + +Lemma forE x P phP : @prop_for x P phP = P x. Proof. by []. Qed. + +Definition prop_in1 P & ph {all1 P} := + forall x, in_mem x d1 -> P x. + +Definition prop_in11 P & ph {all2 P} := + forall x y, in_mem x d1 -> in_mem y d2 -> P x y. + +Definition prop_in2 P & ph {all2 P} := + forall x y, in_mem x d1 -> in_mem y d1 -> P x y. + +Definition prop_in111 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d2 -> in_mem z d3 -> P x y z. + +Definition prop_in12 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d2 -> in_mem z d2 -> P x y z. + +Definition prop_in21 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d1 -> in_mem z d2 -> P x y z. + +Definition prop_in3 P & ph {all3 P} := + forall x y z, in_mem x d1 -> in_mem y d1 -> in_mem z d1 -> P x y z. + +Variable f : T1 -> T2. + +Definition prop_on1 Pf P & phantom T3 (Pf f) & ph {all1 P} := + forall x, in_mem (f x) d2 -> P x. + +Definition prop_on2 Pf P & phantom T3 (Pf f) & ph {all2 P} := + forall x y, in_mem (f x) d2 -> in_mem (f y) d2 -> P x y. + +End LocalProperties. + +Definition inPhantom := Phantom Prop. +Definition onPhantom T P (x : T) := Phantom Prop (P x). + +Definition bijective_in aT rT (d : mem_pred aT) (f : aT -> rT) := + exists2 g, prop_in1 d (inPhantom (cancel f g)) + & prop_on1 d (Phantom _ (cancel g)) (onPhantom (cancel g) f). + +Definition bijective_on aT rT (cd : mem_pred rT) (f : aT -> rT) := + exists2 g, prop_on1 cd (Phantom _ (cancel f)) (onPhantom (cancel f) g) + & prop_in1 cd (inPhantom (cancel g f)). + +Notation "{ 'for' x , P }" := + (prop_for x (inPhantom P)) + (at level 0, format "{ 'for' x , P }") : type_scope. + +Notation "{ 'in' d , P }" := + (prop_in1 (mem d) (inPhantom P)) + (at level 0, format "{ 'in' d , P }") : type_scope. + +Notation "{ 'in' d1 & d2 , P }" := + (prop_in11 (mem d1) (mem d2) (inPhantom P)) + (at level 0, format "{ 'in' d1 & d2 , P }") : type_scope. + +Notation "{ 'in' d & , P }" := + (prop_in2 (mem d) (inPhantom P)) + (at level 0, format "{ 'in' d & , P }") : type_scope. + +Notation "{ 'in' d1 & d2 & d3 , P }" := + (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) + (at level 0, format "{ 'in' d1 & d2 & d3 , P }") : type_scope. + +Notation "{ 'in' d1 & & d3 , P }" := + (prop_in21 (mem d1) (mem d3) (inPhantom P)) + (at level 0, format "{ 'in' d1 & & d3 , P }") : type_scope. + +Notation "{ 'in' d1 & d2 & , P }" := + (prop_in12 (mem d1) (mem d2) (inPhantom P)) + (at level 0, format "{ 'in' d1 & d2 & , P }") : type_scope. + +Notation "{ 'in' d & & , P }" := + (prop_in3 (mem d) (inPhantom P)) + (at level 0, format "{ 'in' d & & , P }") : type_scope. + +Notation "{ 'on' cd , P }" := + (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) + (at level 0, format "{ 'on' cd , P }") : type_scope. + +Notation "{ 'on' cd & , P }" := + (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) + (at level 0, format "{ 'on' cd & , P }") : type_scope. + +Local Arguments onPhantom {_%type_scope} _ _. + +Notation "{ 'on' cd , P & g }" := + (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) + (at level 0, format "{ 'on' cd , P & g }") : type_scope. + +Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) + (at level 0, f at level 8, + format "{ 'in' d , 'bijective' f }") : type_scope. + +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. *) + +Section LocalGlobal. + +Variables T1 T2 T3 : predArgType. +Variables (D1 : pred T1) (D2 : pred T2) (D3 : pred T3). +Variables (d1 d1' : mem_pred T1) (d2 d2' : mem_pred T2) (d3 d3' : mem_pred T3). +Variables (f f' : T1 -> T2) (g : T2 -> T1) (h : T3). +Variables (P1 : T1 -> Prop) (P2 : T1 -> T2 -> Prop). +Variable P3 : T1 -> T2 -> T3 -> Prop. +Variable Q1 : (T1 -> T2) -> T1 -> Prop. +Variable Q1l : (T1 -> T2) -> T3 -> T1 -> Prop. +Variable Q2 : (T1 -> T2) -> T1 -> T1 -> Prop. + +Hypothesis sub1 : sub_mem d1 d1'. +Hypothesis sub2 : sub_mem d2 d2'. +Hypothesis sub3 : sub_mem d3 d3'. + +Lemma in1W : {all1 P1} -> {in D1, {all1 P1}}. +Proof. by move=> ? ?. Qed. +Lemma in2W : {all2 P2} -> {in D1 & D2, {all2 P2}}. +Proof. by move=> ? ?. Qed. +Lemma in3W : {all3 P3} -> {in D1 & D2 & D3, {all3 P3}}. +Proof. by move=> ? ?. Qed. + +Lemma in1T : {in T1, {all1 P1}} -> {all1 P1}. +Proof. by move=> ? ?; auto. Qed. +Lemma in2T : {in T1 & T2, {all2 P2}} -> {all2 P2}. +Proof. by move=> ? ?; auto. Qed. +Lemma in3T : {in T1 & T2 & T3, {all3 P3}} -> {all3 P3}. +Proof. by move=> ? ?; auto. Qed. + +Lemma sub_in1 (Ph : ph {all1 P1}) : prop_in1 d1' Ph -> prop_in1 d1 Ph. +Proof. by move=> allP x /sub1; apply: allP. Qed. + +Lemma sub_in11 (Ph : ph {all2 P2}) : prop_in11 d1' d2' Ph -> prop_in11 d1 d2 Ph. +Proof. by move=> allP x1 x2 /sub1 d1x1 /sub2; apply: allP. Qed. + +Lemma sub_in111 (Ph : ph {all3 P3}) : + prop_in111 d1' d2' d3' Ph -> prop_in111 d1 d2 d3 Ph. +Proof. by move=> allP x1 x2 x3 /sub1 d1x1 /sub2 d2x2 /sub3; apply: allP. Qed. + +Let allQ1 f'' := {all1 Q1 f''}. +Let allQ1l f'' h' := {all1 Q1l f'' h'}. +Let allQ2 f'' := {all2 Q2 f''}. + +Lemma on1W : allQ1 f -> {on D2, allQ1 f}. Proof. by move=> ? ?. Qed. + +Lemma on1lW : allQ1l f h -> {on D2, allQ1l f & h}. Proof. by move=> ? ?. Qed. + +Lemma on2W : allQ2 f -> {on D2 &, allQ2 f}. Proof. by move=> ? ?. Qed. + +Lemma on1T : {on T2, allQ1 f} -> allQ1 f. Proof. by move=> ? ?; auto. Qed. + +Lemma on1lT : {on T2, allQ1l f & h} -> allQ1l f h. +Proof. by move=> ? ?; auto. Qed. + +Lemma on2T : {on T2 &, allQ2 f} -> allQ2 f. +Proof. by move=> ? ?; auto. Qed. + +Lemma subon1 (Phf : ph (allQ1 f)) (Ph : ph (allQ1 f)) : + prop_on1 d2' Phf Ph -> prop_on1 d2 Phf Ph. +Proof. by move=> allQ x /sub2; apply: allQ. Qed. + +Lemma subon1l (Phf : ph (allQ1l f)) (Ph : ph (allQ1l f h)) : + prop_on1 d2' Phf Ph -> prop_on1 d2 Phf Ph. +Proof. by move=> allQ x /sub2; apply: allQ. Qed. + +Lemma subon2 (Phf : ph (allQ2 f)) (Ph : ph (allQ2 f)) : + prop_on2 d2' Phf Ph -> prop_on2 d2 Phf Ph. +Proof. by move=> allQ x y /sub2=> d2fx /sub2; apply: allQ. Qed. + +Lemma can_in_inj : {in D1, cancel f g} -> {in D1 &, injective f}. +Proof. by move=> fK x y /fK{2}<- /fK{2}<- ->. Qed. + +Lemma canLR_in x y : {in D1, cancel f g} -> y \in D1 -> x = f y -> g x = y. +Proof. by move=> fK D1y ->; rewrite fK. Qed. + +Lemma canRL_in x y : {in D1, cancel f g} -> x \in D1 -> f x = y -> x = g y. +Proof. by move=> fK D1x <-; rewrite fK. Qed. + +Lemma on_can_inj : {on D2, cancel f & g} -> {on D2 &, injective f}. +Proof. by move=> fK x y /fK{2}<- /fK{2}<- ->. Qed. + +Lemma canLR_on x y : {on D2, cancel f & g} -> f y \in D2 -> x = f y -> g x = y. +Proof. by move=> fK D2fy ->; rewrite fK. Qed. + +Lemma canRL_on x y : {on D2, cancel f & g} -> f x \in D2 -> f x = y -> x = g y. +Proof. by move=> fK D2fx <-; rewrite fK. Qed. + +Lemma inW_bij : bijective f -> {in D1, bijective f}. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma onW_bij : bijective f -> {on D2, bijective f}. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma inT_bij : {in T1, bijective f} -> bijective f. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma onT_bij : {on T2, bijective f} -> bijective f. +Proof. by case=> g' fK g'K; exists g' => * ? *; auto. Qed. + +Lemma sub_in_bij (D1' : pred T1) : + {subset D1 <= D1'} -> {in D1', bijective f} -> {in D1, bijective f}. +Proof. +by move=> subD [g' fK g'K]; exists g' => x; move/subD; [apply: fK | apply: g'K]. +Qed. + +Lemma subon_bij (D2' : pred T2) : + {subset D2 <= D2'} -> {on D2', bijective f} -> {on D2, bijective f}. +Proof. +by move=> subD [g' fK g'K]; exists g' => x; move/subD; [apply: fK | apply: g'K]. +Qed. + +End LocalGlobal. + +Lemma sub_in2 T d d' (P : T -> T -> Prop) : + sub_mem d d' -> forall Ph : ph {all2 P}, prop_in2 d' Ph -> prop_in2 d Ph. +Proof. by move=> /= sub_dd'; apply: sub_in11. Qed. + +Lemma sub_in3 T d d' (P : T -> T -> T -> Prop) : + sub_mem d d' -> forall Ph : ph {all3 P}, prop_in3 d' Ph -> prop_in3 d Ph. +Proof. by move=> /= sub_dd'; apply: sub_in111. Qed. + +Lemma sub_in12 T1 T d1 d1' d d' (P : T1 -> T -> T -> Prop) : + sub_mem d1 d1' -> sub_mem d d' -> + forall Ph : ph {all3 P}, prop_in12 d1' d' Ph -> prop_in12 d1 d Ph. +Proof. by move=> /= sub1 sub; apply: sub_in111. Qed. + +Lemma sub_in21 T T3 d d' d3 d3' (P : T -> T -> T3 -> Prop) : + sub_mem d d' -> sub_mem d3 d3' -> + forall Ph : ph {all3 P}, prop_in21 d' d3' Ph -> prop_in21 d d3 Ph. +Proof. by move=> /= sub sub3; apply: sub_in111. Qed. + +Lemma equivalence_relP_in T (R : rel T) (A : pred T) : + {in A & &, equivalence_rel R} + <-> {in A, reflexive R} /\ {in A &, forall x y, R x y -> {in A, R x =1 R y}}. +Proof. +split=> [eqiR | [Rxx trR] x y z *]; last by split=> [|/trR-> //]; apply: Rxx. +by split=> [x Ax|x y Ax Ay Rxy z Az]; [rewrite (eqiR x x) | rewrite (eqiR x y)]. +Qed. + +Section MonoHomoMorphismTheory. + +Variables (aT rT sT : Type) (f : aT -> rT) (g : rT -> aT). +Variables (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). + +Lemma monoW : {mono f : x / aP x >-> rP x} -> {homo f : x / aP x >-> rP x}. +Proof. by move=> hf x ax; rewrite hf. Qed. + +Lemma mono2W : + {mono f : x y / aR x y >-> rR x y} -> {homo f : x y / aR x y >-> rR x y}. +Proof. by move=> hf x y axy; rewrite hf. Qed. + +Hypothesis fgK : cancel g f. + +Lemma homoRL : + {homo f : x y / aR x y >-> rR x y} -> forall x y, aR (g x) y -> rR x (f y). +Proof. by move=> Hf x y /Hf; rewrite fgK. Qed. + +Lemma homoLR : + {homo f : x y / aR x y >-> rR x y} -> forall x y, aR x (g y) -> rR (f x) y. +Proof. by move=> Hf x y /Hf; rewrite fgK. Qed. + +Lemma homo_mono : + {homo f : x y / aR x y >-> rR x y} -> {homo g : x y / rR x y >-> aR x y} -> + {mono g : x y / rR x y >-> aR x y}. +Proof. +move=> mf mg x y; case: (boolP (rR _ _))=> [/mg //|]. +by apply: contraNF=> /mf; rewrite !fgK. +Qed. + +Lemma monoLR : + {mono f : x y / aR x y >-> rR x y} -> forall x y, rR (f x) y = aR x (g y). +Proof. by move=> mf x y; rewrite -{1}[y]fgK mf. Qed. + +Lemma monoRL : + {mono f : x y / aR x y >-> rR x y} -> forall x y, rR x (f y) = aR (g x) y. +Proof. by move=> mf x y; rewrite -{1}[x]fgK mf. Qed. + +Lemma can_mono : + {mono f : x y / aR x y >-> rR x y} -> {mono g : x y / rR x y >-> aR x y}. +Proof. by move=> mf x y /=; rewrite -mf !fgK. Qed. + +End MonoHomoMorphismTheory. + +Section MonoHomoMorphismTheory_in. + +Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). +Variable (aD : pred aT). +Variable (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). + +Notation rD := [pred x | g x \in aD]. + +Lemma monoW_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in aD &, {homo f : x y / aR x y >-> rR x y}}. +Proof. by move=> hf x y hx hy axy; rewrite hf. Qed. + +Lemma mono2W_in : + {in aD, {mono f : x / aP x >-> rP x}} -> + {in aD, {homo f : x / aP x >-> rP x}}. +Proof. by move=> hf x hx ax; rewrite hf. Qed. + +Hypothesis fgK_on : {on aD, cancel g & f}. + +Lemma homoRL_in : + {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in rD & aD, forall x y, aR (g x) y -> rR x (f y)}. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. + +Lemma homoLR_in : + {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in aD & rD, forall x y, aR x (g y) -> rR (f x) y}. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. + +Lemma homo_mono_in : + {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in rD &, {homo g : x y / rR x y >-> aR x y}} -> + {in rD &, {mono g : x y / rR x y >-> aR x y}}. +Proof. +move=> mf mg x y hx hy; case: (boolP (rR _ _))=> [/mg //|]; first exact. +by apply: contraNF=> /mf; rewrite !fgK_on //; apply. +Qed. + +Lemma monoLR_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in aD & rD, forall x y, rR (f x) y = aR x (g y)}. +Proof. by move=> mf x y hx hy; rewrite -{1}[y]fgK_on // mf. Qed. + +Lemma monoRL_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in rD & aD, forall x y, rR x (f y) = aR (g x) y}. +Proof. by move=> mf x y hx hy; rewrite -{1}[x]fgK_on // mf. Qed. + +Lemma can_mono_in : + {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in rD &, {mono g : x y / rR x y >-> aR x y}}. +Proof. by move=> mf x y hx hy /=; rewrite -mf // !fgK_on. Qed. + +End MonoHomoMorphismTheory_in. diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml new file mode 100644 index 00000000..1c4508ab --- /dev/null +++ b/plugins/ssr/ssrbwd.ml @@ -0,0 +1,160 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Printer +open Pretyping +open Globnames +open Glob_term +open Tacmach + +open Ssrmatching_plugin +open Ssrmatching + +open Ssrast +open Ssrprinters +open Ssrcommon + +let char_to_kind = function + | '(' -> xInParens + | '@' -> xWithAt + | ' ' -> xNoFlag + | 'x' -> xCpattern + | _ -> assert false + +(** Backward chaining tactics: apply, exact, congr. *) + +(** The "apply" tactic *) + +let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = +(* ppdebug(lazy(str"sigma@interp_agen=" ++ pr_evar_map None (project gl))); *) + let k = char_to_kind k in + let rc = pf_intern_term ist gl c in + let rcs' = rc :: rcs in + match goclr with + | None -> clr, rcs' + | Some ghyps -> + let clr' = snd (interp_hyps ist gl ghyps) @ clr in + if k <> xNoFlag then clr', rcs' else + let loc = rc.CAst.loc in + match DAst.get rc with + | GVar id when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' + | GRef (VarRef id, _) when not_section_id id -> + SsrHyp (Loc.tag ?loc id) :: clr', rcs' + | _ -> clr', rcs' + +let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) + +let interp_nbargs ist gl rc = + try + let rc6 = mkRApp rc (mkRHoles 6) in + let sigma, t = interp_open_constr ist gl (rc6, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + 6 + Ssrcommon.nbargs_open_constr gl t + with _ -> 5 + +let interp_view_nbimps ist gl rc = + try + let sigma, t = interp_open_constr ist gl (rc, None) in + let si = sig_it gl in + let gl = re_sig si sigma in + let pl, c = splay_open_constr gl t in + if Ssrcommon.isAppInd (pf_env gl) (project gl) c then List.length pl else (-(List.length pl)) + with _ -> 0 + +let interp_agens ist gl gagens = + match List.fold_right (interp_agen ist gl) gagens ([], []) with + | clr, rlemma :: args -> + let n = interp_nbargs ist gl rlemma - List.length args in + let rec loop i = + if i > n then + errorstrm Pp.(str "Cannot apply lemma " ++ pf_pr_glob_constr gl rlemma) + else + try interp_refine ist gl (mkRApp rlemma (mkRHoles i @ args)) + with _ -> loop (i + 1) in + clr, loop 0 + | _ -> assert false + +let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) + +let apply_rconstr ?ist t gl = +(* ppdebug(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) + let n = match ist, DAst.get t with + | None, (GVar id | GRef (VarRef id,_)) -> pf_nbargs gl (EConstr.mkVar id) + | Some ist, _ -> interp_nbargs ist gl t + | _ -> anomaly "apply_rconstr without ist and not RVar" in + let mkRlemma i = mkRApp t (mkRHoles i) in + let cl = pf_concl gl in + let rec loop i = + if i > n then + errorstrm Pp.(str"Cannot apply lemma "++pf_pr_glob_constr gl t) + else try pf_match gl (mkRlemma i) (OfType cl) with _ -> loop (i + 1) in + refine_with (loop 0) gl + +let mkRAppView ist gl rv gv = + let nb_view_imps = interp_view_nbimps ist gl rv in + mkRApp rv (mkRHoles (abs nb_view_imps)) + +let prof_apply_interp_with = mk_profiler "ssrapplytac.interp_with";; + +let refine_interp_apply_view dbl ist gl gv = + let pair i = List.map (fun x -> i, x) in + let rv = pf_intern_term ist gl gv in + let v = mkRAppView ist gl rv gv in + let interp_with (dbl, hint) = + let i = if dbl = Ssrview.AdaptorDb.Equivalence then 2 else 1 in + interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in + let interp_with x = prof_apply_interp_with.profile interp_with x in + let rec loop = function + | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) + | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in + loop (pair dbl (Ssrview.AdaptorDb.get dbl) @ + if dbl = Ssrview.AdaptorDb.Equivalence + then pair Ssrview.AdaptorDb.Backward (Ssrview.AdaptorDb.(get Backward)) + else []) + +let apply_top_tac = + Tacticals.tclTHENLIST [ + introid top_id; + apply_rconstr (mkRVar top_id); + old_cleartac [SsrHyp(None,top_id)] + ] + +let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars:false (fun gl -> + let _, clr = interp_hyps ist gl gclr in + let vtac gv i gl' = refine_interp_apply_view i ist gl' gv in + let ggenl, tclGENTAC = + if gviews <> [] && ggenl <> [] then + let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g ist) (List.hd ggenl) in + [], Tacticals.tclTHEN (genstac (ggenl,[])) + else ggenl, Tacticals.tclTHEN Tacticals.tclIDTAC in + tclGENTAC (fun gl -> + match gviews, ggenl with + | v :: tl, [] -> + let dbl = + if List.length tl = 1 + then Ssrview.AdaptorDb.Equivalence + else Ssrview.AdaptorDb.Backward in + Tacticals.tclTHEN + (List.fold_left (fun acc v -> + Tacticals.tclTHENLAST acc (vtac v dbl)) + (vtac v Ssrview.AdaptorDb.Backward) tl) + (old_cleartac clr) gl + | [], [agens] -> + let clr', (sigma, lemma) = interp_agens ist gl agens in + let gl = pf_merge_uc_of sigma gl in + Tacticals.tclTHENLIST [old_cleartac clr; refine_with ~beta:true lemma; old_cleartac clr'] gl + | _, _ -> + Tacticals.tclTHENLIST [apply_top_tac; old_cleartac clr] gl) gl +) + +let apply_top_tac = Proofview.V82.tactic ~nf_evars:false apply_top_tac diff --git a/plugins/ssr/ssrbwd.mli b/plugins/ssr/ssrbwd.mli new file mode 100644 index 00000000..694ecfa3 --- /dev/null +++ b/plugins/ssr/ssrbwd.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Ssrast +open Proofview + +val apply_top_tac : unit tactic + +val inner_ssrapplytac : ssrterm list -> ssrterm ssragens -> ist -> unit tactic diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml new file mode 100644 index 00000000..82cae439 --- /dev/null +++ b/plugins/ssr/ssrcommon.ml @@ -0,0 +1,1572 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Util +open Names +open Evd +open Term +open Constr +open Termops +open Printer +open Locusops + +open Ltac_plugin +open Tacmach +open Refiner +open Libnames +open Ssrmatching_plugin +open Ssrmatching +open Ssrast +open Ssrprinters + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = CLexer.get_keyword_state () ;; + +let errorstrm x = CErrors.user_err ~hdr:"ssreflect" x + +let allocc = Some(false,[]) + +(** Bound assumption argument *) + +(* The Ltac API does have a type for assumptions but it is level-dependent *) +(* and therefore impractical to use for complex arguments, so we substitute *) +(* our own to have a uniform representation. Also, we refuse to intern *) +(* idents that match global/section constants, since this would lead to *) +(* fragile Ltac scripts. *) + +let hyp_id (SsrHyp (_, id)) = id + +let hyp_err ?loc msg id = + CErrors.user_err ?loc ~hdr:"ssrhyp" Pp.(str msg ++ Id.print id) + +let not_section_id id = not (Termops.is_section_variable id) + +let hyps_ids = List.map hyp_id + +let rec check_hyps_uniq ids = function + | SsrHyp (loc, id) :: _ when List.mem id ids -> + hyp_err ?loc "Duplicate assumption " id + | SsrHyp (_, id) :: hyps -> check_hyps_uniq (id :: ids) hyps + | [] -> () + +let check_hyp_exists hyps (SsrHyp(_, id)) = + try ignore(Context.Named.lookup id hyps) + with Not_found -> errorstrm Pp.(str"No assumption is named " ++ Id.print id) + +let test_hypname_exists hyps id = + try ignore(Context.Named.lookup id hyps); true + with Not_found -> false + +let hoik f = function Hyp x -> f x | Id x -> f x +let hoi_id = hoik hyp_id + +let mk_hint tac = false, [Some tac] +let mk_orhint tacs = true, tacs +let nullhint = true, [] +let nohint = false, [] + +type 'a tac_a = (goal * 'a) sigma -> (goal * 'a) list sigma + +let push_ctx a gl = re_sig (sig_it gl, a) (project gl) +let push_ctxs a gl = + re_sig (List.map (fun x -> x,a) (sig_it gl)) (project gl) +let pull_ctx gl = let g, a = sig_it gl in re_sig g (project gl), a +let pull_ctxs gl = let g, a = List.split (sig_it gl) in re_sig g (project gl), a + +let with_ctx f gl = + let gl, ctx = pull_ctx gl in + let rc, ctx = f ctx in + rc, push_ctx ctx gl +let without_ctx f gl = + let gl, _ctx = pull_ctx gl in + f gl +let tac_ctx t gl = + let gl, a = pull_ctx gl in + let gl = t gl in + push_ctxs a gl + +let tclTHEN_ia t1 t2 gl = + let gal = t1 gl in + let goals, sigma = sig_it gal, project gal in + let _, opened, sigma = + List.fold_left (fun (i,opened,sigma) g -> + let gl = t2 i (re_sig g sigma) in + i+1, sig_it gl :: opened, project gl) + (1,[],sigma) goals in + re_sig (List.flatten (List.rev opened)) sigma + +let tclTHEN_a t1 t2 gl = tclTHEN_ia t1 (fun _ -> t2) gl + +let tclTHENS_a t1 tl gl = tclTHEN_ia t1 + (fun i -> List.nth tl (i-1)) gl + +let rec tclTHENLIST_a = function + | [] -> tac_ctx tclIDTAC + | t1::tacl -> tclTHEN_a t1 (tclTHENLIST_a tacl) + +(* like tclTHEN_i but passes to the tac "i of n" and not just i *) +let tclTHEN_i_max tac taci gl = + let maxi = ref 0 in + tclTHEN_ia (tclTHEN_ia tac (fun i -> maxi := max i !maxi; tac_ctx tclIDTAC)) + (fun i gl -> taci i !maxi gl) gl + +let tac_on_all gl tac = + let goals = sig_it gl in + let opened, sigma = + List.fold_left (fun (opened,sigma) g -> + let gl = tac (re_sig g sigma) in + sig_it gl :: opened, project gl) + ([],project gl) goals in + re_sig (List.flatten (List.rev opened)) sigma + +(* Used to thread data between intro patterns at run time *) +type tac_ctx = { + tmp_ids : (Id.t * Name.t ref) list; + wild_ids : Id.t list; + delayed_clears : Id.t list; +} + +let new_ctx () = + { tmp_ids = []; wild_ids = []; delayed_clears = [] } + +let with_fresh_ctx t gl = + let gl = push_ctx (new_ctx()) gl in + let gl = t gl in + fst (pull_ctxs gl) + +open Genarg +open Stdarg +open Pp + +let errorstrm x = CErrors.user_err ~hdr:"ssreflect" x +let anomaly s = CErrors.anomaly (str s) + +(* Tentative patch from util.ml *) + +let array_fold_right_from n f v a = + let rec fold n = + if n >= Array.length v then a else f v.(n) (fold (succ n)) + in + fold n + +let array_app_tl v l = + if Array.length v = 0 then invalid_arg "array_app_tl"; + array_fold_right_from 1 (fun e l -> e::l) v l + +let array_list_of_tl v = + if Array.length v = 0 then invalid_arg "array_list_of_tl"; + array_fold_right_from 1 (fun e l -> e::l) v [] + +(* end patch *) + +let option_assert_get o msg = + match o with + | None -> CErrors.anomaly msg + | Some x -> x + + +(** Constructors for rawconstr *) +open Glob_term +open Globnames +open Misctypes +open Decl_kinds + +let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None) + +let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] +let rec isRHoles cl = match cl with +| [] -> true +| c :: l -> match DAst.get c with GHole _ -> isRHoles l | _ -> false +let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) +let mkRVar id = DAst.make @@ GRef (VarRef id,None) +let mkRltacVar id = DAst.make @@ GVar (id) +let mkRCast rc rt = DAst.make @@ GCast (rc, CastConv rt) +let mkRType = DAst.make @@ GSort (GType []) +let mkRProp = DAst.make @@ GSort (GProp) +let mkRArrow rt1 rt2 = DAst.make @@ GProd (Anonymous, Explicit, rt1, rt2) +let mkRConstruct c = DAst.make @@ GRef (ConstructRef c,None) +let mkRInd mind = DAst.make @@ GRef (IndRef mind,None) +let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) + +let rec mkRnat n = + if n <= 0 then DAst.make @@ GRef (Coqlib.glob_O, None) else + mkRApp (DAst.make @@ GRef (Coqlib.glob_S, None)) [mkRnat (n - 1)] + +let glob_constr ist genv = function + | _, Some ce -> + let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.Tacinterp.lfun Id.Set.empty in + let ltacvars = { + Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in + Constrintern.intern_gen Pretyping.WithoutTypeConstraint ~ltacvars genv Evd.(from_env genv) ce + | rc, None -> rc + +let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c +let intern_term ist env (_, c) = glob_constr ist env c + +(* Estimate a bound on the number of arguments of a raw constr. *) +(* This is not perfect, because the unifier may fail to *) +(* typecheck the partial application, so we use a minimum of 5. *) +(* Also, we don't handle delayed or iterated coercions to *) +(* FUNCLASS, which is probably just as well since these can *) +(* lead to infinite arities. *) + +let splay_open_constr gl (sigma, c) = + let env = pf_env gl in let t = Retyping.get_type_of env sigma c in + Reductionops.splay_prod env sigma t + +let isAppInd env sigma c = + let c = Reductionops.clos_whd_flags CClosure.all env sigma c in + let c, _ = decompose_app_vect sigma c in + EConstr.isInd sigma c + +(** Generic argument-based globbing/typing utilities *) + +let interp_refine ist gl rc = + let constrvars = Tacinterp.extract_ltac_constr_values ist (pf_env gl) in + let vars = { Glob_ops.empty_lvar with + Ltac_pretype.ltac_constrs = constrvars; ltac_genargs = ist.Tacinterp.lfun + } in + let kind = Pretyping.OfType (pf_concl gl) in + let flags = { + Pretyping.use_typeclasses = true; + solve_unification_constraints = true; + use_hook = None; + fail_evar = false; + expand_evars = true } + in + let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in +(* ppdebug(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) + ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c)); + (sigma, (sigma, c)) + + +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 + (project gl, (sigma, c)) + +let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) + +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 = Tacinterp.interp_genarg ist globarg in + let (sigma, arg) = of_ftactic arg gl in + sigma, Tacinterp.Value.cast (topwit wit) arg + +let interp_hyp ist gl (SsrHyp (loc, id)) = + let s, id' = interp_wit wit_var ist gl CAst.(make ?loc id) in + if not_section_id id' then s, SsrHyp (loc, id') else + hyp_err ?loc "Can't clear section hypothesis " id' + +let interp_hyps ist gl ghyps = + let hyps = List.map snd (List.map (interp_hyp ist gl) ghyps) in + check_hyps_uniq [] hyps; Tacmach.project gl, hyps + +(* Old terms *) +let mk_term k c = k, (mkRHole, Some c) +let mk_lterm c = mk_term xNoFlag c + +(* New terms *) + +let mk_ast_closure_term a t = { + annotation = a; + body = t; + interp_env = None; + glob_env = None; +} + +let glob_ast_closure_term (ist : Genintern.glob_sign) t = + { t with glob_env = Some ist } +let subst_ast_closure_term (_s : Mod_subst.substitution) t = + (* _s makes sense only for glob constr *) + t +let interp_ast_closure_term (ist : Geninterp.interp_sign) (gl : 'goal Evd.sigma) t = + (* gl is only useful if we want to interp *now*, later we have + * a potentially different gl.sigma *) + Tacmach.project gl, { t with interp_env = Some ist } + +let ssrterm_of_ast_closure_term { body; annotation } = + let c = match annotation with + | `Parens -> xInParens + | `At -> xWithAt + | _ -> xNoFlag in + mk_term c body + +let ssrdgens_of_parsed_dgens = function + | [], clr -> { dgens = []; gens = []; clr } + | [gens], clr -> { dgens = []; gens; clr } + | [dgens;gens], clr -> { dgens; gens; clr } + | _ -> assert false + + +let nbargs_open_constr gl oc = + let pl, _ = splay_open_constr gl oc in List.length pl + +let pf_nbargs gl c = nbargs_open_constr gl (project gl, c) + +let internal_names = ref [] +let add_internal_name pt = internal_names := pt :: !internal_names +let is_internal_name s = List.exists (fun p -> p s) !internal_names + +let tmp_tag = "_the_" +let tmp_post = "_tmp_" +let mk_tmp_id i = + Id.of_string (Printf.sprintf "%s%s%s" tmp_tag (CString.ordinal i) tmp_post) +let new_tmp_id ctx = + let id = mk_tmp_id (1 + List.length ctx.tmp_ids) in + let orig = ref Anonymous in + (id, orig), { ctx with tmp_ids = (id, orig) :: ctx.tmp_ids } +;; + +let mk_internal_id s = + let s' = Printf.sprintf "_%s_" s in + let s' = String.map (fun c -> if c = ' ' then '_' else c) s' in + add_internal_name ((=) s'); Id.of_string s' + +let same_prefix s t n = + let rec loop i = i = n || s.[i] = t.[i] && loop (i + 1) in loop 0 + +let skip_digits s = + let n = String.length s in + let rec loop i = if i < n && is_digit s.[i] then loop (i + 1) else i in loop + +let mk_tagged_id t i = Id.of_string (Printf.sprintf "%s%d_" t i) +let is_tagged t s = + let n = String.length s - 1 and m = String.length t in + m < n && s.[n] = '_' && same_prefix s t m && skip_digits s m = n + +let evar_tag = "_evar_" +let _ = add_internal_name (is_tagged evar_tag) +let mk_evar_name n = Name (mk_tagged_id evar_tag n) + +let ssr_anon_hyp = "Hyp" + +let wildcard_tag = "_the_" +let wildcard_post = "_wildcard_" +let mk_wildcard_id i = + Id.of_string (Printf.sprintf "%s%s%s" wildcard_tag (CString.ordinal i) wildcard_post) +let has_wildcard_tag s = + let n = String.length s in let m = String.length wildcard_tag in + let m' = String.length wildcard_post in + n < m + m' + 2 && same_prefix s wildcard_tag m && + String.sub s (n - m') m' = wildcard_post && + skip_digits s m = n - m' - 2 +let _ = add_internal_name has_wildcard_tag + +let new_wild_id ctx = + let i = 1 + List.length ctx.wild_ids in + let id = mk_wildcard_id i in + id, { ctx with wild_ids = id :: ctx.wild_ids } + +let discharged_tag = "_discharged_" +let mk_discharged_id id = + Id.of_string (Printf.sprintf "%s%s_" discharged_tag (Id.to_string id)) +let has_discharged_tag s = + let m = String.length discharged_tag and n = String.length s - 1 in + m < n && s.[n] = '_' && same_prefix s discharged_tag m +let _ = add_internal_name has_discharged_tag +let is_discharged_id id = has_discharged_tag (Id.to_string id) + +let max_suffix m (t, j0 as tj0) id = + let s = Id.to_string id in let n = String.length s - 1 in + let dn = String.length t - 1 - n in let i0 = j0 - dn in + if not (i0 >= m && s.[n] = '_' && same_prefix s t m) then tj0 else + let rec loop i = + if i < i0 && s.[i] = '0' then loop (i + 1) else + if (if i < i0 then skip_digits s i = n else le_s_t i) then s, i else tj0 + and le_s_t i = + let ds = s.[i] and dt = t.[i + dn] in + if ds = dt then i = n || le_s_t (i + 1) else + dt < ds && skip_digits s i = n in + loop m + +let mk_anon_id t gl_ids = + let m, si0, id0 = + let s = ref (Printf.sprintf "_%s_" t) in + if is_internal_name !s then s := "_" ^ !s; + let n = String.length !s - 1 in + let rec loop i j = + let d = !s.[i] in if not (is_digit d) then i + 1, j else + loop (i - 1) (if d = '0' then j else i) in + let m, j = loop (n - 1) n in m, (!s, j), Id.of_string !s in + if not (List.mem id0 gl_ids) then id0 else + let s, i = List.fold_left (max_suffix m) si0 gl_ids in + let open Bytes in + let s = of_string s in + let n = length s - 1 in + let rec loop i = + if get s i = '9' then (set s i '0'; loop (i - 1)) else + if i < m then (set s n '0'; set s m '1'; cat s (of_string "_")) else + (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 rename_hd_prod orig_name_ref gl = + match EConstr.kind (project gl) (pf_concl gl) with + | Term.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") + +(* Reduction that preserves the Prod/Let spine of the "in" tactical. *) + +let inc_safe n = if n = 0 then n else n + 1 +let rec safe_depth s c = match EConstr.kind s c with +| LetIn (Name x, _, _, c') when is_discharged_id x -> safe_depth s c' + 1 +| LetIn (_, _, _, c') | Prod (_, _, c') -> inc_safe (safe_depth s c') +| _ -> 0 + +let red_safe (r : Reductionops.reduction_function) e s c0 = + let rec red_to e c n = match EConstr.kind s c with + | Prod (x, t, c') when n > 0 -> + let t' = r e s t in let e' = EConstr.push_rel (RelDecl.LocalAssum (x, t')) e in + EConstr.mkProd (x, t', red_to e' c' (n - 1)) + | LetIn (x, b, t, c') when n > 0 -> + let t' = r e s t in let e' = EConstr.push_rel (RelDecl.LocalAssum (x, t')) e in + EConstr.mkLetIn (x, r e s b, t', red_to e' c' (n - 1)) + | _ -> r e s c in + red_to e c0 (safe_depth s c0) + +let is_id_constr sigma c = match EConstr.kind sigma c with + | Lambda(_,_,c) when EConstr.isRel sigma c -> 1 = EConstr.destRel sigma c + | _ -> false + +let red_product_skip_id env sigma c = match EConstr.kind sigma c with + | App(hd,args) when Array.length args = 1 && is_id_constr sigma hd -> args.(0) + | _ -> try Tacred.red_product env sigma c with _ -> c + +let ssrevaltac ist gtac = Tacinterp.tactic_of_value ist gtac + +(** Open term to lambda-term coercion *)(* {{{ ************************************) + +(* This operation takes a goal gl and an open term (sigma, t), and *) +(* returns a term t' where all the new evars in sigma are abstracted *) +(* with the mkAbs argument, i.e., for mkAbs = mkLambda then there is *) +(* some duplicate-free array args of evars of sigma such that the *) +(* term mkApp (t', args) is convertible to t. *) +(* This makes a useful shorthand for local definitions in proofs, *) +(* i.e., pose succ := _ + 1 means pose succ := fun n : nat => n + 1, *) +(* and, in context of the 4CT library, pose mid := maps id means *) +(* pose mid := fun d : detaSet => @maps d d (@id (datum d)) *) +(* Note that this facility does not extend to set, which tries *) +(* instead to fill holes by matching a goal subterm. *) +(* The argument to "have" et al. uses product abstraction, e.g. *) +(* have Hmid: forall s, (maps id s) = s. *) +(* stands for *) +(* have Hmid: forall (d : dataSet) (s : seq d), (maps id s) = s. *) +(* We also use this feature for rewrite rules, so that, e.g., *) +(* rewrite: (plus_assoc _ 3). *) +(* will execute as *) +(* rewrite (fun n => plus_assoc n 3) *) +(* i.e., it will rewrite some subterm .. + (3 + ..) to .. + 3 + ... *) +(* The convention is also used for the argument of the congr tactic, *) +(* e.g., congr (x + _ * 1). *) + +(* Replace new evars with lambda variables, retaining local dependencies *) +(* but stripping global ones. We use the variable names to encode the *) +(* the number of dependencies, so that the transformation is reversible. *) + +let env_size env = List.length (Environ.named_context env) + +let pf_concl gl = EConstr.Unsafe.to_constr (pf_concl gl) +let pf_get_hyp gl x = EConstr.Unsafe.to_named_decl (pf_get_hyp gl x) + +let pf_e_type_of gl t = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma, ty = Typing.type_of env sigma t in + re_sig it sigma, ty + +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 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 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 + nf_evar sigma t in + let rec put evlist c = match Constr.kind c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k || List.mem k rigid then evlist else + let n = max 0 (Array.length a - nenv) in + let t = abs_evar n k in (k, (n, t)) :: put evlist t + | _ -> Constr.fold put evlist c in + let evlist = put [] c0 in + if evlist = [] then 0, EConstr.of_constr c0,[], ucst else + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n, _)) :: evl -> if k = k' then i, n else lookup k (i + 1) evl in + let rec get i c = match Constr.kind c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then Constr.map (get i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) + | _ -> Constr.map_with_binders ((+) 1) get i c in + let rec loop c i = function + | (_, (n, t)) :: evl -> + loop (mkLambda (mk_evar_name n, get (i - 1) t, c)) (i - 1) evl + | [] -> c in + List.length evlist, EConstr.of_constr (loop (get 1 c0) 1 evlist), List.map fst evlist, ucst + +let pf_abs_evars gl t = pf_abs_evars2 gl [] t + + +(* As before but if (?i : T(?j)) and (?j : P : Prop), then the lambda for i + * looks like (fun evar_i : (forall pi : P. T(pi))) thanks to "loopP" and all + * occurrences of evar_i are replaced by (evar_i evar_j) thanks to "app". + * + * If P can be solved by ssrautoprop (that defaults to trivial), then + * the corresponding lambda looks like (fun evar_i : T(c)) where c is + * the solution found by ssrautoprop. + *) +let ssrautoprop_tac = ref (fun gl -> assert false) + +(* Thanks to Arnaud Spiwack for this snippet *) +let call_on_evar tac e s = + let { it = gs ; sigma = s } = + tac { it = e ; sigma = s; } in + gs, s + +open Pp +let pp _ = () (* FIXME *) +module Intset = Evar.Set + +let pf_abs_evars_pirrel gl (sigma, c0) = + pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); + pp(lazy(str"c0= " ++ Printer.pr_constr_env (pf_env gl) sigma c0)); + let sigma0 = project gl in + let c0 = nf_evar sigma0 (nf_evar sigma c0) 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 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 + nf_evar sigma0 (nf_evar sigma t) in + let rec put evlist c = match Constr.kind c with + | Evar (k, a) -> + if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else + 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 + 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 + let evlist = put [] c0 in + if evlist = [] then 0, c0 else + let pr_constr t = Printer.pr_econstr_env (pf_env gl) sigma (Reductionops.nf_beta (pf_env gl) (project gl) (EConstr.of_constr t)) in + pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") + (fun (k,_) -> Evar.print k) evlist)); + let evplist = + let depev = List.fold_left (fun evs (_,(_,t,_)) -> + let t = EConstr.of_constr t in + Intset.union evs (Evarutil.undefined_evars_of_term sigma t)) Intset.empty evlist in + List.filter (fun (i,(_,_,b)) -> b && Intset.mem i depev) evlist in + let evlist, evplist, sigma = + if evplist = [] then evlist, [], sigma else + List.fold_left (fun (ev, evp, sigma) (i, (_,t,_) as p) -> + try + let ng, sigma = call_on_evar !ssrautoprop_tac i sigma in + if (ng <> []) then errorstrm (str "Should we tell the user?"); + List.filter (fun (j,_) -> j <> i) ev, evp, sigma + with _ -> ev, p::evp, sigma) (evlist, [], sigma) (List.rev evplist) in + let c0 = nf_evar sigma c0 in + let evlist = + List.map (fun (x,(y,t,z)) -> x,(y,nf_evar sigma t,z)) evlist in + let evplist = + List.map (fun (x,(y,t,z)) -> x,(y,nf_evar sigma t,z)) evplist in + pp(lazy(str"c0= " ++ pr_constr c0)); + let rec lookup k i = function + | [] -> 0, 0 + | (k', (n,_,_)) :: evl -> if k = k' then i,n else lookup k (i + 1) evl in + let rec get evlist i c = match Constr.kind c with + | Evar (ev, a) -> + let j, n = lookup ev i evlist in + if j = 0 then Constr.map (get evlist i) c else if n = 0 then mkRel j else + mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) + | _ -> Constr.map_with_binders ((+) 1) (get evlist) i c in + let rec app extra_args i c = match decompose_app c with + | hd, args when isRel hd && destRel hd = i -> + let j = destRel hd in + mkApp (mkRel j, Array.of_list (List.map (Vars.lift (i-1)) extra_args @ args)) + | _ -> Constr.map_with_binders ((+) 1) (app extra_args) i c in + let rec loopP evlist c i = function + | (_, (n, t, _)) :: evl -> + let t = get evlist (i - 1) t in + let n = Name (Id.of_string (ssr_anon_hyp ^ string_of_int n)) in + loopP evlist (mkProd (n, t, c)) (i - 1) evl + | [] -> c in + let rec loop c i = function + | (_, (n, t, _)) :: evl -> + let evs = Evarutil.undefined_evars_of_term sigma (EConstr.of_constr t) in + let t_evplist = List.filter (fun (k,_) -> Intset.mem k evs) evplist in + let t = loopP t_evplist (get t_evplist 1 t) 1 t_evplist in + let t = get evlist (i - 1) t in + let extra_args = + List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) + (List.rev t_evplist) in + let c = if extra_args = [] then c else app extra_args 1 c in + loop (mkLambda (mk_evar_name n, t, c)) (i - 1) evl + | [] -> c in + let res = loop (get evlist 1 c0) 1 evlist in + pp(lazy(str"res= " ++ pr_constr res)); + List.length evlist, res + +(* Strip all non-essential dependencies from an abstracted term, generating *) +(* standard names for the abstracted holes. *) + +let nb_evar_deps = function + | Name id -> + let s = Id.to_string id in + if not (is_tagged evar_tag s) then 0 else + let m = String.length evar_tag in + (try int_of_string (String.sub s m (String.length s - 1 - m)) with _ -> 0) + | _ -> 0 + +let pf_type_id gl t = Id.of_string (Namegen.hdchar (pf_env gl) (project gl) t) +let pfe_type_of gl t = + let sigma, ty = pf_type_of gl t in + re_sig (sig_it gl) sigma, ty +let pf_type_of gl t = + let sigma, ty = pf_type_of gl (EConstr.of_constr t) in + re_sig (sig_it gl) sigma, EConstr.Unsafe.to_constr ty + +let pf_abs_cterm gl n c0 = + if n <= 0 then c0 else + let c0 = EConstr.Unsafe.to_constr c0 in + let noargs = [|0|] in + let eva = Array.make n noargs in + let rec strip i c = match Constr.kind c with + | App (f, a) when isRel f -> + let j = i - destRel f in + if j >= n || eva.(j) = noargs then mkApp (f, Array.map (strip i) a) else + let dp = eva.(j) in + let nd = Array.length dp - 1 in + let mkarg k = strip i a.(if k < nd then dp.(k + 1) - j else k + dp.(0)) in + mkApp (f, Array.init (Array.length a - dp.(0)) mkarg) + | _ -> Constr.map_with_binders ((+) 1) strip i c in + let rec strip_ndeps j i c = match Constr.kind c with + | Prod (x, t, c1) when i < j -> + let dl, c2 = strip_ndeps j (i + 1) c1 in + if Vars.noccurn 1 c2 then dl, Vars.lift (-1) c2 else + i :: dl, mkProd (x, strip i t, c2) + | LetIn (x, b, t, c1) when i < j -> + let _, _, c1' = destProd c1 in + let dl, c2 = strip_ndeps j (i + 1) c1' in + if Vars.noccurn 1 c2 then dl, Vars.lift (-1) c2 else + i :: dl, mkLetIn (x, strip i b, strip i t, c2) + | _ -> [], strip i c in + let rec strip_evars i c = match Constr.kind c with + | Lambda (x, t1, c1) when i < n -> + let na = nb_evar_deps x in + let dl, t2 = strip_ndeps (i + na) i t1 in + let na' = List.length dl in + eva.(i) <- Array.of_list (na - na' :: dl); + let x' = + if na' = 0 then Name (pf_type_id gl (EConstr.of_constr t2)) else mk_evar_name na' in + mkLambda (x', t2, strip_evars (i + 1) c1) +(* if noccurn 1 c2 then lift (-1) c2 else + mkLambda (Name (pf_type_id gl t2), t2, c2) *) + | _ -> strip i c in + EConstr.of_constr (strip_evars 0 c0) + +(* }}} *) + +let pf_merge_uc uc gl = + re_sig (sig_it gl) (Evd.merge_universe_context (Refiner.project gl) uc) +let pf_merge_uc_of sigma gl = + let ucst = Evd.evar_universe_context sigma in + pf_merge_uc ucst gl + + +let rec constr_name sigma c = match EConstr.kind sigma c with + | Var id -> Name id + | Cast (c', _, _) -> constr_name sigma c' + | Const (cn,_) -> Name (Label.to_id (Constant.label cn)) + | App (c', _) -> constr_name sigma c' + | _ -> Anonymous + +let pf_mkprod gl c ?(name=constr_name (project gl) c) cl = + let gl, t = pfe_type_of gl c in + if name <> Anonymous || EConstr.Vars.noccurn (project gl) 1 cl then gl, EConstr.mkProd (name, t, cl) else + gl, EConstr.mkProd (Name (pf_type_id gl t), t, cl) + +let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (Termops.subst_term (project gl) c cl) + +(** look up a name in the ssreflect internals module *) +let ssrdirpath = DirPath.make [Id.of_string "ssreflect"] +let ssrqid name = Libnames.make_qualid ssrdirpath (Id.of_string name) +let ssrtopqid name = Libnames.qualid_of_ident (Id.of_string name) +let locate_reference qid = + Smartlocate.global_of_extended_global (Nametab.locate_extended qid) +let mkSsrRef name = + try locate_reference (ssrqid name) with Not_found -> + try locate_reference (ssrtopqid name) with Not_found -> + CErrors.user_err (Pp.str "Small scale reflection library not loaded") +let mkSsrRRef name = (DAst.make @@ GRef (mkSsrRef name,None)), None +let mkSsrConst name env sigma = + EConstr.fresh_global env sigma (mkSsrRef name) +let pf_mkSsrConst name gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let (sigma, t) = mkSsrConst name env sigma in + t, re_sig it sigma +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 + +let mkProt t c gl = + let prot, gl = pf_mkSsrConst "protect_term" gl in + EConstr.mkApp (prot, [|t; c|]), gl + +let mkEtaApp c n imin = + let open EConstr in + if n = 0 then c else + let nargs, mkarg = + if n < 0 then -n, (fun i -> mkRel (imin + i)) else + let imax = imin + n - 1 in n, (fun i -> mkRel (imax - i)) in + mkApp (c, Array.init nargs mkarg) + +let mkRefl t c gl = + let sigma = project gl in + let (sigma, refl) = EConstr.fresh_global (pf_env gl) sigma Coqlib.((build_coq_eq_data()).refl) in + EConstr.mkApp (refl, [|t; c|]), { gl with sigma } + +let discharge_hyp (id', (id, mode)) gl = + let cl' = Vars.subst_var id (pf_concl gl) in + match pf_get_hyp gl id, mode with + | NamedDecl.LocalAssum (_, t), _ | NamedDecl.LocalDef (_, _, t), "(" -> + Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true (EConstr.of_constr (mkProd (Name id', t, cl'))) + [EConstr.of_constr (mkVar id)]) gl + | NamedDecl.LocalDef (_, v, t), _ -> + Proofview.V82.of_tactic + (convert_concl (EConstr.of_constr (mkLetIn (Name id', v, t, cl')))) gl + +(* wildcard names *) +let clear_wilds wilds gl = + Proofview.V82.of_tactic (Tactics.clear (List.filter (fun id -> List.mem id wilds) (pf_ids_of_hyps gl))) gl + +let clear_with_wilds wilds clr0 gl = + let extend_clr clr nd = + let id = NamedDecl.get_id nd in + if List.mem id clr || not (List.mem id wilds) then clr else + let vars = Termops.global_vars_set_of_decl (pf_env gl) (project gl) nd in + let occurs id' = Id.Set.mem id' vars in + if List.exists occurs clr then id :: clr else clr in + Proofview.V82.of_tactic (Tactics.clear (Context.Named.fold_inside extend_clr ~init:clr0 (Tacmach.pf_hyps gl))) gl + +let clear_wilds_and_tmp_and_delayed_ids gl = + let _, ctx = pull_ctx gl in + tac_ctx + (tclTHEN + (clear_with_wilds ctx.wild_ids ctx.delayed_clears) + (clear_wilds (List.map fst ctx.tmp_ids @ ctx.wild_ids))) gl + +let rec is_name_in_ipats name = function + | IPatClear clr :: tl -> + List.exists (function SsrHyp(_,id) -> id = name) clr + || is_name_in_ipats name tl + | 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 -> + 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 + +let view_error s gv = + errorstrm (str ("Cannot " ^ s ^ " view ") ++ pr_term gv) + + +open Locus +(****************************** tactics ***********************************) + +let rewritetac dir c = + (* Due to the new optional arg ?tac, application shouldn't be too partial *) + Proofview.V82.of_tactic begin + Equality.general_rewrite (dir = L2R) AllOccurrences true false c + end + +(**********************`:********* hooks ************************************) + +type name_hint = (int * EConstr.types array) option ref + +let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = + let sigma, ct as t = interp_term ist gl t in + let sigma, _ as t = + let env = pf_env gl in + if not resolve_typeclasses then t + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma ct in + let n, c, abstracted_away, ucst = pf_abs_evars gl t in + List.fold_left Evd.remove sigma abstracted_away, pf_abs_cterm gl n c, ucst, n + +let top_id = mk_internal_id "top assumption" + +let ssr_n_tac seed n gl = + let name = if n = -1 then seed else ("ssr" ^ seed ^ string_of_int n) in + let fail msg = CErrors.user_err (Pp.str msg) in + let tacname = + try Tacenv.locate_tactic (Libnames.qualid_of_ident (Id.of_string name)) + with Not_found -> try Tacenv.locate_tactic (ssrqid name) + with Not_found -> + if n = -1 then fail "The ssreflect library was not loaded" + else fail ("The tactic "^name^" was not found") in + let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + Proofview.V82.of_tactic (Tacinterp.eval_tactic (Tacexpr.TacArg tacexpr)) gl + +let donetac n gl = ssr_n_tac "done" n gl + +open Constrexpr +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 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) +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 @@ + CProdN ([CLocalAssum([CAst.make Anonymous], Default Explicit, ty)], t) +let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, CastConv ty) + +let rec isCHoles = function { CAst.v = CHole _ } :: cl -> isCHoles cl | cl -> cl = [] +let rec isCxHoles = function ({ CAst.v = CHole _ }, None) :: ch -> isCxHoles ch | _ -> false + +let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = + let n_binders = ref 0 in + let ty = match ty with + | a, (t, None) -> + let rec force_type ty = DAst.(map (function + | GProd (x, k, s, t) -> incr n_binders; GProd (x, k, s, force_type t) + | GLetIn (x, v, oty, t) -> incr n_binders; GLetIn (x, v, oty, force_type t) + | _ -> DAst.get (mkRCast ty mkRType))) ty in + a, (force_type t, None) + | _, (_, Some ty) -> + let rec force_type ty = CAst.(map (function + | CProdN (abs, t) -> + n_binders := !n_binders + List.length (List.flatten (List.map (function CLocalAssum (nal,_,_) -> nal | CLocalDef (na,_,_) -> [na] | CLocalPattern _ -> (* We count a 'pat for 1; TO BE CHECKED *) [CAst.make Name.Anonymous]) abs)); + CProdN (abs, force_type t) + | CLetIn (n, v, oty, t) -> incr n_binders; CLetIn (n, v, oty, force_type t) + | _ -> (mkCCast ty (mkCType None)).v)) ty in + mk_term ' ' (force_type ty) in + let strip_cast (sigma, t) = + let rec aux t = match EConstr.kind_of_type sigma t with + | CastType (t, ty) when !n_binders = 0 && EConstr.isSort sigma ty -> t + | ProdType(n,s,t) -> decr n_binders; EConstr.mkProd (n, s, aux t) + | LetInType(n,v,ty,t) -> decr n_binders; EConstr.mkLetIn (n, v, ty, aux t) + | _ -> anomaly "pf_interp_ty: ssr Type cast deleted by typecheck" in + sigma, aux t in + let sigma, cty as ty = strip_cast (interp_term ist gl ty) in + let ty = + let env = pf_env gl in + if not resolve_typeclasses then ty + else + let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in + sigma, Evarutil.nf_evar sigma cty in + let n, c, _, ucst = pf_abs_evars gl ty in + let lam_c = pf_abs_cterm gl n c in + let ctx, c = EConstr.decompose_lam_n_assum sigma n lam_c in + n, EConstr.it_mkProd_or_LetIn c ctx, lam_c, ucst +;; + +(* TASSI: given (c : ty), generates (c ??? : ty[???/...]) with m evars *) +exception NotEnoughProducts +let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_of env sigma c) m += + let rec loop ty args sigma n = + if n = 0 then + let args = List.rev args in + (if beta then Reductionops.whd_beta sigma else fun x -> x) + (EConstr.mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma + else match EConstr.kind_of_type sigma ty with + | ProdType (_, src, tgt) -> + let sigma = create_evar_defs sigma in + let (sigma, x) = + Evarutil.new_evar env sigma + (if bi_types then Reductionops.nf_betaiota env sigma src else src) in + loop (EConstr.Vars.subst1 x tgt) ((m - n,x) :: args) sigma (n-1) + | CastType (t, _) -> loop t args sigma n + | LetInType (_, v, _, t) -> loop (EConstr.Vars.subst1 v t) args sigma n + | SortType _ -> assert false + | AtomicType _ -> + let ty = (* FIXME *) + (Reductionops.whd_all env sigma) ty in + match EConstr.kind_of_type sigma ty with + | ProdType _ -> loop ty args sigma n + | _ -> raise NotEnoughProducts + in + loop ty [] sigma m + +let pf_saturate ?beta ?bi_types gl c ?ty m = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let t, ty, args, sigma = saturate ?beta ?bi_types env sigma c ?ty m in + t, ty, args, re_sig si sigma + +let pf_partial_solution gl t evl = + let sigma, g = project gl, sig_it gl in + let sigma = Goal.V82.partial_solution sigma g t in + re_sig (List.map (fun x -> (fst (EConstr.destEvar sigma x))) evl) sigma + +let dependent_apply_error = + try CErrors.user_err (Pp.str "Could not fill dependent hole in \"apply\"") + with err -> err + +(* TASSI: Sometimes Coq's apply fails. According to my experience it may be + * related to goals that are products and with beta redexes. In that case it + * guesses the wrong number of implicit arguments for your lemma. What follows + * is just like apply, but with a user-provided number n of implicits. + * + * Refine.refine function that handles type classes and evars but fails to + * handle "dependently typed higher order evars". + * + * Refiner.refiner that does not handle metas with a non ground type but works + * with dependently typed higher order metas. *) +let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = + if with_evars then + let refine gl = + let t, ty, args, gl = pf_saturate ?beta ~bi_types:true gl t n in +(* pp(lazy(str"sigma@saturate=" ++ pr_evar_map None (project gl))); *) + let gl = pf_unify_HO gl ty (Tacmach.pf_concl gl) in + let gs = CList.map_filter (fun (_, e) -> + if EConstr.isEvar (project gl) e then Some e else None) + args in + pf_partial_solution gl t gs + in + Proofview.(V82.of_tactic + (tclTHEN (V82.tactic refine) + (if with_shelve then shelve_unifiable else tclUNIT ()))) gl + else + let t, gl = if n = 0 then t, gl else + let sigma, si = project gl, sig_it gl in + let rec loop sigma bo args = function (* saturate with metas *) + | 0 -> EConstr.mkApp (t, Array.of_list (List.rev args)), re_sig si sigma + | n -> match EConstr.kind sigma bo with + | Lambda (_, ty, bo) -> + 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) + | _ -> assert false + in loop sigma t [] n in + pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); + Tacmach.refine_no_check t gl + +let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = + let rec mkRels = function 1 -> [] | n -> mkRel n :: mkRels (n-1) in + let uct = Evd.evar_universe_context (fst oc) in + let n, oc = pf_abs_evars_pirrel gl (fst oc, EConstr.Unsafe.to_constr (snd oc)) in + let gl = pf_unsafe_merge_uc uct gl in + let oc = if not first_goes_last || n <= 1 then oc else + let l, c = decompose_lam oc in + if not (List.for_all_i (fun i (_,t) -> Vars.closedn ~-i t) (1-n) l) then oc else + compose_lam (let xs,y = List.chop (n-1) l in y @ xs) + (mkApp (compose_lam l c, Array.of_list (mkRel 1 :: mkRels n))) + in + pp(lazy(str"after: " ++ Printer.pr_constr_env (pf_env gl) (project gl) oc)); + try applyn ~with_evars ~with_shelve:true ?beta n (EConstr.of_constr oc) gl + with e when CErrors.noncritical e -> raise dependent_apply_error + +(** 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 _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect profiling"; + Goptions.optkey = ["SsrProfiling"]; + Goptions.optread = (fun _ -> !profile_now); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> + Ssrmatching.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 () = + 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 +;; +(* }}} *) + +(* 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 ;; + +(** Basic tactics *) + +let rec fst_prod red tac = Proofview.Goal.nf_enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + match EConstr.kind (Proofview.Goal.sigma gl) concl with + | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id + | _ -> if red then Tacticals.New.tclZEROMSG (str"No product even after head-reduction.") + else Tacticals.New.tclTHEN Tactics.hnf_in_concl (fst_prod true tac) +end + +let introid ?(orig=ref Anonymous) name = tclTHEN (fun gl -> + let g, env = Tacmach.pf_concl gl, pf_env gl in + let sigma = project gl in + match EConstr.kind sigma g with + | App (hd, _) when EConstr.isLambda sigma hd -> + Proofview.V82.of_tactic (convert_concl_no_check (Reductionops.whd_beta sigma g)) gl + | _ -> tclIDTAC gl) + (Proofview.V82.of_tactic + (fst_prod false (fun id -> orig := id; Tactics.intro_mustbe_force name))) +;; + +let anontac decl gl = + let id = match RelDecl.get_name decl with + | Name id -> + if is_discharged_id id then id else mk_anon_id (Id.to_string id) (Tacmach.pf_ids_of_hyps gl) + | _ -> mk_anon_id ssr_anon_hyp (Tacmach.pf_ids_of_hyps gl) in + introid id gl + +let rec intro_anon gl = + try anontac (List.hd (fst (EConstr.decompose_prod_n_assum (project gl) 1 (Tacmach.pf_concl gl)))) gl + with err0 -> try tclTHEN (Proofview.V82.of_tactic Tactics.red_in_concl) intro_anon gl with e when CErrors.noncritical e -> raise err0 + (* with _ -> CErrors.error "No product even after reduction" *) + +let is_pf_var sigma c = + EConstr.isVar sigma c && not_section_id (EConstr.destVar sigma c) + +let hyp_of_var sigma v = SsrHyp (Loc.tag @@ EConstr.destVar sigma v) + +let interp_clr sigma = function +| Some clr, (k, c) + when (k = xNoFlag || k = xWithAt) && is_pf_var sigma c -> + hyp_of_var sigma c :: clr +| Some clr, _ -> clr +| None, _ -> [] + +(** Basic tacticals *) + +(** Multipliers *)(* {{{ ***********************************************************) + +(* tactical *) + +let tclID tac = tac + +let tclDOTRY n tac = + if n <= 0 then tclIDTAC else + let rec loop i gl = + if i = n then tclTRY tac gl else + tclTRY (tclTHEN tac (loop (i + 1))) gl in + loop 1 + +let tclDO n tac = + let prefix i = str"At iteration " ++ int i ++ str": " in + let tac_err_at i gl = + try tac gl + with + | CErrors.UserError (l, s) as e -> + let _, info = CErrors.push e in + let e' = CErrors.UserError (l, prefix i ++ s) in + Util.iraise (e', info) + | Ploc.Exc(loc, CErrors.UserError (l, s)) -> + raise (Ploc.Exc(loc, CErrors.UserError (l, prefix i ++ s))) in + let rec loop i gl = + if i = n then tac_err_at i gl else + (tclTHEN (tac_err_at i) (loop (i + 1))) gl in + loop 1 + +let tclMULT = function + | 0, May -> tclREPEAT + | 1, May -> tclTRY + | n, May -> tclDOTRY n + | 0, Must -> tclAT_LEAST_ONCE + | n, Must when n > 1 -> tclDO n + | _ -> tclID + +let old_cleartac clr = check_hyps_uniq [] clr; Proofview.V82.of_tactic (Tactics.clear (hyps_ids clr)) +let cleartac clr = check_hyps_uniq [] clr; Tactics.clear (hyps_ids clr) + +(* }}} *) + +(** Generalize tactic *) + +(* XXX the k of the redex should percolate out *) +let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = + let pat = interp_cpattern gl t None in (* UGLY API *) + let cl, env, sigma = Tacmach.pf_concl gl, pf_env gl, project gl in + let (c, ucst), cl = + try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr cl) pat occ 1 + with NoMatch -> redex_of_pattern env pat, (EConstr.Unsafe.to_constr cl) in + let gl = pf_merge_uc ucst gl in + let c = EConstr.of_constr c in + let cl = EConstr.of_constr cl in + let clr = interp_clr sigma (oclr, (tag_of_cpattern t, c)) in + if not(occur_existential sigma c) then + if tag_of_cpattern t = xWithAt then + if not (EConstr.isVar sigma c) then + errorstrm (str "@ can be used with variables only") + else match Tacmach.pf_get_hyp gl (EConstr.destVar sigma c) with + | NamedDecl.LocalAssum _ -> errorstrm (str "@ can be used with let-ins only") + | NamedDecl.LocalDef (name, b, ty) -> true, pat, EConstr.mkLetIn (Name name,b,ty,cl),c,clr,ucst,gl + else let gl, ccl = pf_mkprod gl c cl in false, pat, ccl, c, clr,ucst,gl + else if to_ind && occ = None then + let nv, p, _, ucst' = pf_abs_evars gl (fst pat, c) in + let ucst = UState.union ucst ucst' in + if nv = 0 then anomaly "occur_existential but no evars" else + let gl, pty = pfe_type_of gl p in + false, pat, EConstr.mkProd (constr_name (project gl) c, pty, Tacmach.pf_concl gl), p, clr,ucst,gl + else CErrors.user_err ?loc:(loc_of_cpattern t) (str "generalized term didn't match") + +let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true x xs) + +let genclrtac cl cs clr = + let tclmyORELSE tac1 tac2 gl = + try tac1 gl + with e when CErrors.noncritical e -> tac2 e gl in + (* apply_type may give a type error, but the useful message is + * the one of clear. You type "move: x" and you get + * "x is used in hyp H" instead of + * "The term H has type T x but is expected to have type T x0". *) + tclTHEN + (tclmyORELSE + (apply_type cl cs) + (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)) + (fun gl -> raise type_err) + gl)) + (old_cleartac clr) + +let gentac gen gl = +(* ppdebug(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) + let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux gl false gen in + ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); + let gl = pf_merge_uc ucst gl in + if conv + then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (old_cleartac clr) gl + else genclrtac cl [c] clr gl + +let genstac (gens, clr) = + tclTHENLIST (old_cleartac clr :: List.rev_map gentac gens) + +let gen_tmp_ids + ?(ist=Geninterp.({ lfun = Id.Map.empty; extra = Tacinterp.TacStore.empty })) gl += + let gl, ctx = pull_ctx gl in + push_ctxs ctx + (tclTHENLIST + (List.map (fun (id,orig_ref) -> + tclTHEN + (gentac ((None,Some(false,[])),cpattern_of_id id)) + (rename_hd_prod orig_ref)) + ctx.tmp_ids) gl) +;; + +let pf_interp_gen gl to_ind gen = + let _, _, a, b, c, ucst,gl = pf_interp_gen_aux gl to_ind gen in + a, b ,c, pf_merge_uc ucst gl + +(* TASSI: This version of unprotects inlines the unfold tactic definition, + * since we don't want to wipe out let-ins, and it seems there is no flag + * to change that behaviour in the standard unfold code *) +let unprotecttac gl = + let c, gl = pf_mkSsrConst "protect_term" gl in + let prot, _ = EConstr.destConst (project gl) c in + Tacticals.onClause (fun idopt -> + let hyploc = Option.map (fun id -> id, InHyp) idopt in + Proofview.V82.of_tactic (Tactics.reduct_option + (Reductionops.clos_norm_flags + (CClosure.RedFlags.mkflags + [CClosure.RedFlags.fBETA; + CClosure.RedFlags.fCONST prot; + CClosure.RedFlags.fMATCH; + CClosure.RedFlags.fFIX; + CClosure.RedFlags.fCOFIX]), DEFAULTcast) hyploc)) + allHypsAndConcl gl + +let is_protect hd env sigma = + let _, protectC = mkSsrConst "protect_term" env sigma in + EConstr.eq_constr_nounivs sigma hd protectC + +let abs_wgen keep_let f gen (gl,args,c) = + let sigma, env = project gl, pf_env gl in + let evar_closed t p = + if occur_existential sigma t then + CErrors.user_err ?loc:(loc_of_cpattern p) ~hdr:"ssreflect" + (pr_constr_pat (EConstr.Unsafe.to_constr t) ++ + str" contains holes and matches no subterm of the goal") in + match gen with + | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> + let x = hoi_id x in + let decl = Tacmach.pf_get_hyp gl x in + gl, + (if NamedDecl.is_local_def decl then args else EConstr.mkVar x :: args), + EConstr.mkProd_or_LetIn (decl |> NamedDecl.to_rel_decl |> RelDecl.set_name (Name (f x))) + (EConstr.Vars.subst_var x c) + | _, Some ((x, _), None) -> + let x = hoi_id x in + gl, EConstr.mkVar x :: args, EConstr.mkProd (Name (f x),Tacmach.pf_get_hyp_typ gl x, EConstr.Vars.subst_var x c) + | _, Some ((x, "@"), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 + with NoMatch -> redex_of_pattern env cp, (EConstr.Unsafe.to_constr c) in + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in + evar_closed t p; + let ut = red_product_skip_id env sigma t in + let gl, ty = pfe_type_of gl t in + pf_merge_uc ucst gl, args, EConstr.mkLetIn(Name (f x), ut, ty, c) + | _, Some ((x, _), Some p) -> + let x = hoi_id x in + let cp = interp_cpattern gl p None in + let (t, ucst), c = + try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 + with NoMatch -> redex_of_pattern env cp, (EConstr.Unsafe.to_constr c) in + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in + evar_closed t p; + let gl, ty = pfe_type_of gl t in + pf_merge_uc ucst gl, t :: args, EConstr.mkProd(Name (f x), ty, c) + | _ -> gl, args, c + +let clr_of_wgen gen clrs = match gen with + | clr, Some ((x, _), None) -> + let x = hoi_id x in + old_cleartac clr :: old_cleartac [SsrHyp(Loc.tag x)] :: clrs + | clr, _ -> old_cleartac clr :: clrs + + +let reduct_in_concl t = Tactics.reduct_in_concl (t, DEFAULTcast) +let unfold cl = + let module R = Reductionops in let module F = CClosure.RedFlags in + reduct_in_concl (R.clos_norm_flags (F.mkflags + (List.map (fun c -> F.fCONST (fst (destConst (EConstr.Unsafe.to_constr c)))) cl @ + [F.fBETA; F.fMATCH; F.fFIX; F.fCOFIX]))) + +open Proofview +open Notations + +let tacSIGMA = Goal.enter_one begin fun g -> + let k = Goal.goal g in + let sigma = Goal.sigma g in + tclUNIT (Tacmach.re_sig k sigma) +end + +let tclINTERP_AST_CLOSURE_TERM_AS_CONSTR c = + tclINDEPENDENTL begin tacSIGMA >>= fun gl -> + let old_ssrterm = mkRHole, Some c.Ssrast.body in + let ist = + option_assert_get c.Ssrast.interp_env + Pp.(str "tclINTERP_AST_CLOSURE_TERM_AS_CONSTR: term with no ist") in + let sigma, t = + interp_wit Stdarg.wit_constr ist gl old_ssrterm in + Unsafe.tclEVARS sigma <*> + tclUNIT t +end + +let tacREDUCE_TO_QUANTIFIED_IND ty = + tacSIGMA >>= fun gl -> + tclUNIT (Tacmach.pf_reduce_to_quantified_ind gl ty) + +let tacTYPEOF c = Goal.enter_one ~__LOC__ (fun g -> + let sigma, env = Goal.sigma g, Goal.env g in + let sigma, ty = Typing.type_of env sigma c in + Unsafe.tclEVARS sigma <*> tclUNIT ty) + +(** This tactic creates a partial proof realizing the introduction rule, but + does not check anything. *) +let unsafe_intro env store decl b = + let open Context.Named.Declaration in + Refine.refine ~typecheck:false begin fun sigma -> + let ctx = Environ.named_context_val env in + let nctx = EConstr.push_named_context_val decl ctx in + let inst = List.map (get_id %> EConstr.mkVar) (Environ.named_context env) in + let ninst = EConstr.mkRel 1 :: inst in + let nb = EConstr.Vars.subst1 (EConstr.mkVar (get_id decl)) b in + let sigma, ev = + Evarutil.new_evar_instance nctx sigma nb ~principal:true ~store ninst in + sigma, EConstr.mkNamedLambda_or_LetIn decl ev + end + +let set_decl_id id = let open Context in function + | Rel.Declaration.LocalAssum(name,ty) -> Named.Declaration.LocalAssum(id,ty) + | Rel.Declaration.LocalDef(name,ty,t) -> Named.Declaration.LocalDef(id,ty,t) + +let rec decompose_assum env sigma orig_goal = + let open Context in + match EConstr.kind sigma orig_goal with + | Prod(name,ty,t) -> + Rel.Declaration.LocalAssum(name,ty), t, true + | LetIn(name,ty,t1,t2) -> Rel.Declaration.LocalDef(name, ty, t1), t2, true + | _ -> + let goal = Reductionops.whd_allnolet env sigma orig_goal in + match EConstr.kind sigma goal with + | Prod(name,ty,t) -> Rel.Declaration.LocalAssum(name,ty), t, false + | LetIn(name,ty,t1,t2) -> Rel.Declaration.LocalDef(name,ty,t1), t2, false + | App(hd,args) when EConstr.isLetIn sigma hd -> (* hack *) + let _,v,_,b = EConstr.destLetIn sigma hd in + let ctx, t, _ = + decompose_assum env sigma + (EConstr.mkApp (EConstr.Vars.subst1 v b, args)) in + ctx, t, false + | _ -> CErrors.user_err + Pp.(str "No assumption in " ++ Printer.pr_econstr_env env sigma goal) + +let tclFULL_BETAIOTA = Goal.enter begin fun gl -> + let r, _ = Redexpr.reduction_of_red_expr (Goal.env gl) + Genredexpr.(Lazy { + rBeta=true; rMatch=true; rFix=true; rCofix=true; + rZeta=false; rDelta=false; rConst=[]}) in + Tactics.e_reduct_in_concl ~check:false (r,Constr.DEFAULTcast) +end + +(** [intro id k] introduces the first premise (product or let-in) of the goal + under the name [id], reducing the head of the goal (using beta, iota, delta + but not zeta) if necessary. If [id] is None, a name is generated, that will + not be user accessible. If the goal does not start with a product or a +let-in even after reduction, it fails. In case of success, the original name +and final id are passed to the continuation [k] which gets evaluated. *) +let tclINTRO ~id ~conclusion:k = Goal.enter begin fun gl -> + let open Context in + let env, sigma, extra, g = Goal.(env gl, sigma gl, extra gl, concl gl) in + let decl, t, no_red = decompose_assum env sigma g in + let original_name = Rel.Declaration.get_name decl in + let already_used = Tacmach.New.pf_ids_of_hyps gl in + let id = match id, original_name with + | Some id, _ -> id + | _, Name id -> + if is_discharged_id id then id + else mk_anon_id (Id.to_string id) already_used + | _, _ -> + let ids = Tacmach.New.pf_ids_of_hyps gl in + mk_anon_id ssr_anon_hyp ids + in + if List.mem id already_used then + errorstrm Pp.(Id.print id ++ str" already used"); + unsafe_intro env extra (set_decl_id id decl) t <*> + (if no_red then tclUNIT () else tclFULL_BETAIOTA) <*> + k ~orig_name:original_name ~new_name:id +end + +let return ~orig_name:_ ~new_name:_ = tclUNIT () + +let tclINTRO_ID id = tclINTRO ~id:(Some id) ~conclusion:return +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 + let concl = Goal.concl gl in + let sigma = Goal.sigma gl in + match EConstr.kind sigma concl with + | Prod(_,src,tgt) -> + convert_concl_no_check EConstr.(mkProd (name,src,tgt)) + | _ -> CErrors.anomaly (Pp.str "rename_hd_prod: no head product") +end + +let tcl0G tac = + numgoals >>= fun ng -> if ng = 0 then tclUNIT () else tac + +let rec tclFIRSTa = function + | [] -> Tacticals.New.tclZEROMSG Pp.(str"No applicable tactic.") + | tac :: rest -> tclORELSE tac (fun _ -> tclFIRSTa rest) + +let rec tclFIRSTi tac n = + if n < 0 then Tacticals.New.tclZEROMSG Pp.(str "tclFIRSTi") + else tclORELSE (tclFIRSTi tac (n-1)) (fun _ -> tac n) + +let tacCONSTR_NAME ?name c = + match name with + | Some n -> tclUNIT n + | None -> + Goal.enter_one ~__LOC__ (fun g -> + let sigma = Goal.sigma g in + tclUNIT (constr_name sigma c)) + +let tacMKPROD c ?name cl = + tacTYPEOF c >>= fun t -> + tacCONSTR_NAME ?name c >>= fun name -> + Goal.enter_one ~__LOC__ begin fun g -> + let sigma, env = Goal.sigma g, Goal.env g in + if name <> Names.Name.Anonymous || EConstr.Vars.noccurn sigma 1 cl + then tclUNIT (EConstr.mkProd (name, t, cl)) + else + let name = Names.Id.of_string (Namegen.hdchar env sigma t) in + tclUNIT (EConstr.mkProd (Names.Name.Name name, t, cl)) +end + +let tacINTERP_CPATTERN cp = + tacSIGMA >>= begin fun gl -> + tclUNIT (Ssrmatching.interp_cpattern gl cp None) +end + +let tacUNIFY a b = + tacSIGMA >>= begin fun gl -> + let gl = Ssrmatching.pf_unify_HO gl a b in + Unsafe.tclEVARS (Tacmach.project gl) +end + +let tclOPTION o d = + match o with + | None -> d >>= tclUNIT + | Some x -> tclUNIT x + +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 ())) +end + +let tclWITHTOP tac = Goal.enter begin fun gl -> + let top = + mk_anon_id "top_assumption" (Tacmach.New.pf_ids_of_hyps gl) in + tclINTRO_ID top <*> + tac (EConstr.mkVar top) <*> + Tactics.clear [top] +end + +let tacMK_SSR_CONST name = Goal.enter_one ~__LOC__ begin fun g -> + let sigma, env = Goal.(sigma g, env g) in + let sigma, c = mkSsrConst name env sigma in + Unsafe.tclEVARS sigma <*> + tclUNIT c +end + +module type StateType = sig + type state + val init : state +end + +module MakeState(S : StateType) = struct + +let state_field : S.state Proofview_monad.StateStore.field = + Proofview_monad.StateStore.field () + +(* FIXME: should not inject fresh_state, but initialize it at the beginning *) +let lift_upd_state upd s = + let open Proofview_monad.StateStore in + let old_state = Option.default S.init (get s state_field) in + upd old_state >>= fun new_state -> + tclUNIT (set s state_field new_state) + +let tacUPDATE upd = Goal.enter begin fun gl -> + let s0 = Goal.state gl in + Goal.enter_one ~__LOC__ (fun _ -> lift_upd_state upd s0) >>= fun s -> + Unsafe.tclGETGOALS >>= fun gls -> + let gls = List.map (fun gs -> + let g = Proofview_monad.drop_state gs in + Proofview_monad.goal_with_state g s) gls in + Unsafe.tclSETGOALS gls +end + +let tclGET k = Goal.enter begin fun gl -> + let open Proofview_monad.StateStore in + k (Option.default S.init (get (Goal.state gl) state_field)) +end + +let tclSET new_s = + let open Proofview_monad.StateStore in + Unsafe.tclGETGOALS >>= fun gls -> + let gls = List.map (fun gs -> + let g = Proofview_monad.drop_state gs in + let s = Proofview_monad.get_state gs in + Proofview_monad.goal_with_state g (set s state_field new_s)) gls in + Unsafe.tclSETGOALS gls + +let get g = + Option.default S.init + (Proofview_monad.StateStore.get (Goal.state g) state_field) + +end + + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli new file mode 100644 index 00000000..2b8f1d54 --- /dev/null +++ b/plugins/ssr/ssrcommon.mli @@ -0,0 +1,482 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Tacmach +open Names +open Environ +open Evd +open Constrexpr +open Ssrast + +open Ltac_plugin +open Genarg + +open Ssrmatching_plugin + +val allocc : ssrocc + +(******************************** hyps ************************************) + +val hyp_id : ssrhyp -> Id.t +val hyps_ids : ssrhyps -> Id.t list +val check_hyp_exists : ('a, 'b) Context.Named.pt -> ssrhyp -> unit +val test_hypname_exists : ('a, 'b) Context.Named.pt -> Id.t -> bool +val check_hyps_uniq : Id.t list -> ssrhyps -> unit +val not_section_id : Id.t -> bool +val hyp_err : ?loc:Loc.t -> string -> Id.t -> 'a +val hoik : (ssrhyp -> 'a) -> ssrhyp_or_id -> 'a +val hoi_id : ssrhyp_or_id -> Id.t + +(******************************* hints ***********************************) + +val mk_hint : 'a -> 'a ssrhint +val mk_orhint : 'a -> bool * 'a +val nullhint : bool * 'a list +val nohint : 'a ssrhint + +(******************************** misc ************************************) + +val errorstrm : Pp.t -> 'a +val anomaly : string -> 'a + +val array_app_tl : 'a array -> 'a list -> 'a list +val array_list_of_tl : 'a array -> 'a list +val array_fold_right_from : int -> ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b + +val option_assert_get : 'a option -> Pp.t -> 'a + +(**************************** lifted tactics ******************************) + +(* tactics with extra data attached to each goals, e.g. the list of + * temporary variables to be cleared *) +type 'a tac_a = (goal * 'a) sigma -> (goal * 'a) list sigma + +(* Thread around names to be cleared or generalized back, and the speed *) +type tac_ctx = { + tmp_ids : (Id.t * Name.t ref) list; + wild_ids : Id.t list; + (* List of variables to be cleared at the end of the sentence *) + delayed_clears : Id.t list; +} + +val new_ctx : unit -> tac_ctx (* REMOVE *) +val pull_ctxs : ('a * tac_ctx) list sigma -> 'a list sigma * tac_ctx list (* REMOVE *) + +val with_fresh_ctx : tac_ctx tac_a -> tactic + +val pull_ctx : ('a * tac_ctx) sigma -> 'a sigma * tac_ctx +val push_ctx : tac_ctx -> 'a sigma -> ('a * tac_ctx) sigma +val push_ctxs : tac_ctx -> 'a list sigma -> ('a * tac_ctx) list sigma +val tac_ctx : tactic -> tac_ctx tac_a +val with_ctx : + (tac_ctx -> 'b * tac_ctx) -> ('a * tac_ctx) sigma -> 'b * ('a * tac_ctx) sigma +val without_ctx : ('a sigma -> 'b) -> ('a * tac_ctx) sigma -> 'b + +(* Standard tacticals lifted to the tac_a type *) +val tclTHENLIST_a : tac_ctx tac_a list -> tac_ctx tac_a +val tclTHEN_i_max : + tac_ctx tac_a -> (int -> int -> tac_ctx tac_a) -> tac_ctx tac_a +val tclTHEN_a : tac_ctx tac_a -> tac_ctx tac_a -> tac_ctx tac_a +val tclTHENS_a : tac_ctx tac_a -> tac_ctx tac_a list -> tac_ctx tac_a + +val tac_on_all : + (goal * tac_ctx) list sigma -> tac_ctx tac_a -> (goal * tac_ctx) list sigma +(************************ ssr tactic arguments ******************************) + + +(*********************** Misc helpers *****************************) +val mkRHole : Glob_term.glob_constr +val mkRHoles : int -> Glob_term.glob_constr list +val isRHoles : Glob_term.glob_constr list -> bool +val mkRApp : Glob_term.glob_constr -> Glob_term.glob_constr list -> Glob_term.glob_constr +val mkRVar : Id.t -> Glob_term.glob_constr +val mkRltacVar : Id.t -> Glob_term.glob_constr +val mkRCast : Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr +val mkRType : Glob_term.glob_constr +val mkRProp : Glob_term.glob_constr +val mkRArrow : Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr +val mkRConstruct : Names.constructor -> Glob_term.glob_constr +val mkRInd : Names.inductive -> Glob_term.glob_constr +val mkRLambda : Name.t -> Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr +val mkRnat : int -> Glob_term.glob_constr + + +val mkCHole : Loc.t option -> constr_expr +val mkCHoles : ?loc:Loc.t -> int -> constr_expr list +val mkCVar : ?loc:Loc.t -> Id.t -> constr_expr +val mkCCast : ?loc:Loc.t -> constr_expr -> constr_expr -> constr_expr +val mkCType : Loc.t option -> constr_expr +val mkCProp : Loc.t option -> constr_expr +val mkCArrow : ?loc:Loc.t -> constr_expr -> constr_expr -> constr_expr +val mkCLambda : ?loc:Loc.t -> Name.t -> constr_expr -> constr_expr -> constr_expr + +val isCHoles : constr_expr list -> bool +val isCxHoles : (constr_expr * 'a option) list -> bool + +val intern_term : + Tacinterp.interp_sign -> env -> + ssrterm -> Glob_term.glob_constr + +val pf_intern_term : + Tacinterp.interp_sign -> Goal.goal Evd.sigma -> + ssrterm -> Glob_term.glob_constr + +val interp_term : + Tacinterp.interp_sign -> Goal.goal Evd.sigma -> + ssrterm -> evar_map * EConstr.t + +val interp_wit : + ('a, 'b, 'c) genarg_type -> ist -> goal sigma -> 'b -> evar_map * 'c + +val interp_hyp : ist -> goal sigma -> ssrhyp -> evar_map * ssrhyp +val interp_hyps : ist -> goal sigma -> ssrhyps -> evar_map * ssrhyps + +val interp_refine : + Tacinterp.interp_sign -> Goal.goal Evd.sigma -> + Glob_term.glob_constr -> evar_map * (evar_map * EConstr.constr) + +val interp_open_constr : + Tacinterp.interp_sign -> Goal.goal Evd.sigma -> + Tacexpr.glob_constr_and_expr -> evar_map * (evar_map * EConstr.t) + +val pf_e_type_of : + Goal.goal Evd.sigma -> + EConstr.constr -> Goal.goal Evd.sigma * EConstr.types + +val splay_open_constr : + Goal.goal Evd.sigma -> + evar_map * EConstr.t -> + (Names.Name.t * EConstr.t) list * EConstr.t +val isAppInd : Environ.env -> Evd.evar_map -> EConstr.types -> bool + +val mk_term : ssrtermkind -> constr_expr -> ssrterm +val mk_lterm : constr_expr -> ssrterm + +val mk_ast_closure_term : + [ `None | `Parens | `DoubleParens | `At ] -> + Constrexpr.constr_expr -> ast_closure_term +val interp_ast_closure_term : Geninterp.interp_sign -> Proof_type.goal +Evd.sigma -> ast_closure_term -> Evd.evar_map * ast_closure_term +val subst_ast_closure_term : Mod_subst.substitution -> ast_closure_term -> ast_closure_term +val glob_ast_closure_term : Genintern.glob_sign -> ast_closure_term -> ast_closure_term +val ssrterm_of_ast_closure_term : ast_closure_term -> ssrterm + +val ssrdgens_of_parsed_dgens : + (ssrdocc * Ssrmatching.cpattern) list list * ssrclear -> ssrdgens + +val is_internal_name : string -> bool +val add_internal_name : (string -> bool) -> unit +val mk_internal_id : string -> Id.t +val mk_tagged_id : string -> int -> Id.t +val mk_evar_name : int -> Name.t +val ssr_anon_hyp : string +val pf_type_id : Goal.goal Evd.sigma -> EConstr.types -> Id.t + +val pf_abs_evars : + Goal.goal Evd.sigma -> + evar_map * EConstr.t -> + int * EConstr.t * Evar.t list * + UState.t +val pf_abs_evars2 : (* ssr2 *) + Goal.goal Evd.sigma -> Evar.t list -> + evar_map * EConstr.t -> + int * EConstr.t * Evar.t list * + UState.t +val pf_abs_cterm : + Goal.goal Evd.sigma -> int -> EConstr.t -> EConstr.t + +val pf_merge_uc : + UState.t -> 'a Evd.sigma -> 'a Evd.sigma +val pf_merge_uc_of : + evar_map -> 'a Evd.sigma -> 'a Evd.sigma +val constr_name : evar_map -> EConstr.t -> Name.t +val pf_type_of : + Goal.goal Evd.sigma -> + Constr.constr -> Goal.goal Evd.sigma * Constr.types +val pfe_type_of : + Goal.goal Evd.sigma -> + EConstr.t -> Goal.goal Evd.sigma * EConstr.types +val pf_abs_prod : + Name.t -> + Goal.goal Evd.sigma -> + EConstr.t -> + EConstr.t -> Goal.goal Evd.sigma * EConstr.types + +val mkSsrRRef : string -> Glob_term.glob_constr * 'a option +val mkSsrRef : string -> Globnames.global_reference +val mkSsrConst : + string -> + env -> evar_map -> evar_map * EConstr.t +val pf_mkSsrConst : + string -> + Goal.goal Evd.sigma -> + EConstr.t * Goal.goal Evd.sigma +val new_wild_id : tac_ctx -> Names.Id.t * tac_ctx + + +val pf_fresh_global : + Globnames.global_reference -> + Goal.goal Evd.sigma -> + Constr.constr * Goal.goal Evd.sigma + +val is_discharged_id : Id.t -> bool +val mk_discharged_id : Id.t -> Id.t +val is_tagged : string -> string -> bool +val has_discharged_tag : string -> bool +val ssrqid : string -> Libnames.qualid +val new_tmp_id : + tac_ctx -> (Names.Id.t * Name.t ref) * tac_ctx +val mk_anon_id : string -> Id.t list -> Id.t +val pf_abs_evars_pirrel : + Goal.goal Evd.sigma -> + evar_map * Constr.constr -> int * Constr.constr +val nbargs_open_constr : Goal.goal Evd.sigma -> Evd.evar_map * EConstr.t -> int +val pf_nbargs : Goal.goal Evd.sigma -> EConstr.t -> int +val gen_tmp_ids : + ?ist:Geninterp.interp_sign -> + (Goal.goal * tac_ctx) Evd.sigma -> + (Goal.goal * tac_ctx) list Evd.sigma + +val ssrevaltac : + Tacinterp.interp_sign -> Tacinterp.Value.t -> unit Proofview.tactic + +val convert_concl_no_check : EConstr.t -> unit Proofview.tactic +val convert_concl : EConstr.t -> unit Proofview.tactic + +val red_safe : + Reductionops.reduction_function -> + env -> evar_map -> EConstr.t -> EConstr.t + +val red_product_skip_id : + env -> evar_map -> EConstr.t -> EConstr.t + +val ssrautoprop_tac : + (Evar.t Evd.sigma -> Evar.t list Evd.sigma) ref + +val mkProt : + EConstr.t -> + EConstr.t -> + Goal.goal Evd.sigma -> + EConstr.t * Goal.goal Evd.sigma + +val mkEtaApp : EConstr.t -> int -> int -> EConstr.t + +val mkRefl : + EConstr.t -> + EConstr.t -> + Goal.goal Evd.sigma -> EConstr.t * Goal.goal Evd.sigma + +val discharge_hyp : + Id.t * (Id.t * string) -> + Goal.goal Evd.sigma -> Evar.t list Evd.sigma + +val clear_wilds_and_tmp_and_delayed_ids : + (Goal.goal * tac_ctx) Evd.sigma -> + (Goal.goal * tac_ctx) list Evd.sigma + +val view_error : string -> ssrterm -> 'a + + +val top_id : Id.t + +val pf_abs_ssrterm : + ?resolve_typeclasses:bool -> + ist -> + Goal.goal Evd.sigma -> + ssrterm -> + evar_map * EConstr.t * UState.t * int + +val pf_interp_ty : + ?resolve_typeclasses:bool -> + Tacinterp.interp_sign -> + Goal.goal Evd.sigma -> + Ssrast.ssrtermkind * + (Glob_term.glob_constr * Constrexpr.constr_expr option) -> + int * EConstr.t * EConstr.t * UState.t + +val ssr_n_tac : string -> int -> v82tac +val donetac : int -> v82tac + +val applyn : + with_evars:bool -> + ?beta:bool -> + ?with_shelve:bool -> + int -> + EConstr.t -> v82tac +exception NotEnoughProducts +val pf_saturate : + ?beta:bool -> + ?bi_types:bool -> + Goal.goal Evd.sigma -> + EConstr.constr -> + ?ty:EConstr.types -> + int -> + EConstr.constr * EConstr.types * (int * EConstr.constr) list * + Goal.goal Evd.sigma +val saturate : + ?beta:bool -> + ?bi_types:bool -> + env -> + evar_map -> + EConstr.constr -> + ?ty:EConstr.types -> + int -> + EConstr.constr * EConstr.types * (int * EConstr.constr) list * evar_map +val refine_with : + ?first_goes_last:bool -> + ?beta:bool -> + ?with_evars:bool -> + evar_map * EConstr.t -> v82tac +(*********************** Wrapped Coq tactics *****************************) + +val rewritetac : ssrdir -> EConstr.t -> tactic + +type name_hint = (int * EConstr.types array) option ref + +val gentac : + Ssrast.ssrdocc * Ssrmatching.cpattern -> v82tac + +val genstac : + ((Ssrast.ssrhyp list option * Ssrmatching.occ) * + Ssrmatching.cpattern) + list * Ssrast.ssrhyp list -> + Tacmach.tactic + +val pf_interp_gen : + Goal.goal Evd.sigma -> + bool -> + (Ssrast.ssrhyp list option * Ssrmatching.occ) * + Ssrmatching.cpattern -> + EConstr.t * EConstr.t * Ssrast.ssrhyp list * + Goal.goal Evd.sigma + +val pf_interp_gen_aux : + Goal.goal Evd.sigma -> + bool -> + (Ssrast.ssrhyp list option * Ssrmatching.occ) * + Ssrmatching.cpattern -> + bool * Ssrmatching.pattern * EConstr.t * + EConstr.t * Ssrast.ssrhyp list * UState.t * + Goal.goal Evd.sigma + +val is_name_in_ipats : + Id.t -> ssripats -> bool + +type profiler = { + profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; + reset : unit -> unit; + print : unit -> unit } + +val mk_profiler : string -> profiler + +(** Basic tactics *) + +val introid : ?orig:Name.t ref -> Id.t -> v82tac +val intro_anon : v82tac + +val interp_clr : + evar_map -> ssrhyps option * (ssrtermkind * EConstr.t) -> ssrhyps + +val genclrtac : + EConstr.constr -> + EConstr.constr list -> Ssrast.ssrhyp list -> Tacmach.tactic +val old_cleartac : ssrhyps -> v82tac +val cleartac : ssrhyps -> unit Proofview.tactic + +val tclMULT : int * ssrmmod -> Tacmach.tactic -> Tacmach.tactic + +val unprotecttac : Goal.goal Evd.sigma -> Goal.goal list Evd.sigma +val is_protect : EConstr.t -> Environ.env -> Evd.evar_map -> bool + +val abs_wgen : + bool -> + (Id.t -> Id.t) -> + 'a * + ((Ssrast.ssrhyp_or_id * string) * + Ssrmatching.cpattern option) + option -> + Goal.goal Evd.sigma * EConstr.t list * EConstr.t -> + Goal.goal Evd.sigma * EConstr.t list * EConstr.t + +val clr_of_wgen : + ssrhyps * ((ssrhyp_or_id * 'a) * 'b option) option -> + Proofview.V82.tac list -> Proofview.V82.tac list + + +val unfold : EConstr.t list -> unit Proofview.tactic + +val apply_type : EConstr.types -> EConstr.t list -> Proofview.V82.tac + +(* New code ****************************************************************) + +(* To call old code *) +val tacSIGMA : Goal.goal Evd.sigma Proofview.tactic + +val tclINTERP_AST_CLOSURE_TERM_AS_CONSTR : + ast_closure_term -> EConstr.t list Proofview.tactic + +val tacREDUCE_TO_QUANTIFIED_IND : + EConstr.types -> + ((Names.inductive * EConstr.EInstance.t) * EConstr.types) Proofview.tactic + +val tacTYPEOF : EConstr.t -> EConstr.types Proofview.tactic + +val tclINTRO_ID : Id.t -> unit Proofview.tactic +val tclINTRO_ANON : unit Proofview.tactic + +(* Lower level API, calls conclusion with the name taken from the prod *) +val tclINTRO : + id:Id.t option -> + conclusion:(orig_name:Name.t -> new_name:Id.t -> unit Proofview.tactic) -> + unit Proofview.tactic + +val tclRENAME_HD_PROD : Name.t -> unit Proofview.tactic + +(* calls the tactic only if there are more than 0 goals *) +val tcl0G : unit Proofview.tactic -> unit Proofview.tactic + +(* like tclFIRST but with 'a tactic *) +val tclFIRSTa : 'a Proofview.tactic list -> 'a Proofview.tactic +val tclFIRSTi : (int -> 'a Proofview.tactic) -> int -> 'a Proofview.tactic + +val tacCONSTR_NAME : ?name:Name.t -> EConstr.t -> Name.t Proofview.tactic + +(* [tacMKPROD t name ctx] (where ctx is a term possibly containing an unbound + * Rel 1) builds [forall name : ty_t, ctx] *) +val tacMKPROD : + EConstr.t -> ?name:Name.t -> EConstr.types -> EConstr.types Proofview.tactic + +val tacINTERP_CPATTERN : Ssrmatching.cpattern -> Ssrmatching.pattern Proofview.tactic +val tacUNIFY : EConstr.t -> EConstr.t -> unit Proofview.tactic + +(* if [(t : eq _ _ _)] then we can inject it *) +val tacIS_INJECTION_CASE : ?ty:EConstr.types -> EConstr.t -> bool Proofview.tactic + +(** 1 shot, hands-on the top of the stack, eg for [=> ->] *) +val tclWITHTOP : (EConstr.t -> unit Proofview.tactic) -> unit Proofview.tactic + +val tacMK_SSR_CONST : string -> EConstr.t Proofview.tactic + +module type StateType = sig + type state + val init : state +end + +module MakeState(S : StateType) : sig + + val tclGET : (S.state -> unit Proofview.tactic) -> unit Proofview.tactic + val tclSET : S.state -> unit Proofview.tactic + val tacUPDATE : (S.state -> S.state Proofview.tactic) -> unit Proofview.tactic + + val get : Proofview.Goal.t -> S.state + +end diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v new file mode 100644 index 00000000..b0a94413 --- /dev/null +++ b/plugins/ssr/ssreflect.v @@ -0,0 +1,453 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* 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. *) +(******************************************************************************) + + +Set Implicit Arguments. +Unset Strict Implicit. +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. *) + +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 *) +Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). + +Reserved Notation "<hidden n >" (at level 200). +Reserved Notation "T (* n *)" (at level 200, format "T (* n *)"). + +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. *) + +Delimit Scope general_if_scope with GEN_IF. + +Notation "'if' c 'then' v1 'else' v2" := + (if c then v1 else v2) + (at level 200, c, v1, v2 at level 200, only parsing) : general_if_scope. + +Notation "'if' c 'return' t 'then' v1 'else' v2" := + (if c return t then v1 else v2) + (at level 200, c, t, v1, v2 at level 200, only parsing) : general_if_scope. + +Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := + (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. *) + +Delimit Scope boolean_if_scope with BOOL_IF. + +Notation "'if' c 'return' t 'then' v1 'else' v2" := + (if c%bool is true in bool return t then v1 else v2) : boolean_if_scope. + +Notation "'if' c 'then' v1 'else' v2" := + (if c%bool is true in bool return _ then v1 else v2) : boolean_if_scope. + +Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := + (if c%bool is true as x in bool return t then v1 else v2) : boolean_if_scope. + +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. *) +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. *) +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". *) +Notation "T : 'Type'" := (T%type : Type) + (at level 100, only parsing) : core_scope. +(* 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 *) +Definition abstract_lock := unit. +Definition abstract_key := tt. + +Definition abstract (statement : Type) (id : nat) (lock : abstract_lock) := + let: tt := lock in statement. + +Notation "<hidden n >" := (abstract _ n _). +Notation "T (* n *)" := (abstract T n abstract_key). + +(* 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. *) + +Module TheCanonical. + +CoInductive 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. + +Definition get_by vT sT of sT -> vT := @get vT sT. + +End TheCanonical. + +Import TheCanonical. (* Note: no export. *) + +Local Arguments get_by _%type_scope _%type_scope _ _ _ _. + +Notation "[ 'the' sT 'of' v 'by' f ]" := + (@get_by _ sT f _ _ ((fun v' (s : sT) => Put v' (f s) s) v _)) + (at level 0, only parsing) : form_scope. + +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. *) + +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. + +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. *) + +Definition argumentType T P & forall x : T, P x := T. +Definition dependentReturnType T P & forall x : T, P x := P. +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. +Arguments phantom : clear implicits. +Arguments Phantom : clear implicits. +CoInductive phant (p : Type) := Phant. + +(* 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). *) + +Notation unkeyed x := (let flex := x in flex). + +(* 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. *) + +Notation nosimpl t := (let: tt := tt in t). + +Lemma master_key : unit. Proof. exact tt. Qed. +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. *) +Lemma not_locked_false_eq_true : locked false <> true. +Proof. unlock; discriminate. Qed. + +(* The basic closing tactic "done". *) +Ltac done := + trivial; hnf; intros; solve + [ do ![solve [trivial | apply: sym_equal; trivial] + | discriminate | contradiction | split] + | case not_locked_false_eq_true; assumption + | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. + +(* Quicker done tactic not including split, syntax: /0/ *) +Ltac ssrdone0 := + trivial; hnf; intros; solve + [ do ![solve [trivial | apply: sym_equal; trivial] + | discriminate | contradiction ] + | case not_locked_false_eq_true; assumption + | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. + +(* 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. + +Notation "[ 'unlockable' 'of' C ]" := (@Unlockable _ _ C (unlock _)) + (at level 0, format "[ 'unlockable' 'of' C ]") : form_scope. + +Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) + (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. + +(* Generic keyed constant locking. *) + +(* 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. *) +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. *) +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. *) +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. *) + +Definition ssr_have Plemma Pgoal (step : Plemma) rest : Pgoal := rest step. +Arguments ssr_have Plemma [Pgoal]. + +Definition ssr_have_let Pgoal Plemma step + (rest : let x : Plemma := step in Pgoal) : Pgoal := rest. +Arguments ssr_have_let [Pgoal]. + +Definition ssr_suff Plemma Pgoal step (rest : Plemma) : Pgoal := step rest. +Arguments ssr_suff Plemma [Pgoal]. + +Definition ssr_wlog := ssr_suff. +Arguments ssr_wlog Plemma [Pgoal]. + +(* Internal N-ary congruence lemmas for the congr tactic. *) + +Fixpoint nary_congruence_statement (n : nat) + : (forall B, (B -> B -> Prop) -> Prop) -> Prop := + match n with + | O => fun k => forall B, k B (fun x1 x2 : B => x1 = x2) + | S n' => + let k' A B e (f1 f2 : A -> B) := + forall x1 x2, x1 = x2 -> (e (f1 x1) (f2 x2) : Prop) in + fun k => forall A, nary_congruence_statement n' (fun B e => k _ (k' A B e)) + end. + +Lemma nary_congruence n (k := fun B e => forall y : B, (e y y : Prop)) : + nary_congruence_statement n k. +Proof. +have: k _ _ := _; rewrite {1}/k. +elim: n k => [|n IHn] k k_P /= A; first exact: k_P. +by apply: IHn => B e He; apply: k_P => f x1 x2 <-. +Qed. + +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. *) + +Section ApplyIff. + +Variables P Q : Prop. +Hypothesis eqPQ : P <-> Q. + +Lemma iffLR : P -> Q. Proof. by case: eqPQ. Qed. +Lemma iffRL : Q -> P. Proof. by case: eqPQ. Qed. + +Lemma iffLRn : ~P -> ~Q. Proof. by move=> nP tQ; case: nP; case: eqPQ tQ. Qed. +Lemma iffRLn : ~Q -> ~P. Proof. by move=> nQ tP; case: nQ; case: eqPQ tP. Qed. + +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. *) +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/ssreflect_plugin.mlpack b/plugins/ssr/ssreflect_plugin.mlpack new file mode 100644 index 00000000..824348fe --- /dev/null +++ b/plugins/ssr/ssreflect_plugin.mlpack @@ -0,0 +1,13 @@ +Ssrast +Ssrprinters +Ssrcommon +Ssrtacticals +Ssrelim +Ssrview +Ssrbwd +Ssrequality +Ssripats +Ssrfwd +Ssrparser +Ssrvernac + diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml new file mode 100644 index 00000000..40af5187 --- /dev/null +++ b/plugins/ssr/ssrelim.ml @@ -0,0 +1,445 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Util +open Names +open Printer +open Term +open Termops +open Globnames +open Misctypes +open Tacmach + +open Ssrmatching_plugin +open Ssrmatching + +open Ssrast +open Ssrprinters +open Ssrcommon + +module RelDecl = Context.Rel.Declaration + +(** The "case" and "elim" tactic *) + +(* TASSI: given the type of an elimination principle, it finds the higher order + * argument (index), it computes it's arity and the arity of the eliminator and + * checks if the eliminator is recursive or not *) +let analyze_eliminator elimty env sigma = + let rec loop ctx t = match EConstr.kind_of_type sigma t with + | AtomicType (hd, args) when EConstr.isRel sigma hd -> + ctx, EConstr.destRel sigma hd, not (EConstr.Vars.noccurn sigma 1 t), Array.length args, t + | CastType (t, _) -> loop ctx t + | ProdType (x, ty, t) -> loop (RelDecl.LocalAssum (x, ty) :: ctx) t + | LetInType (x,b,ty,t) -> loop (RelDecl.LocalDef (x, b, ty) :: ctx) (EConstr.Vars.subst1 b t) + | _ -> + let env' = EConstr.push_rel_context ctx env in + let t' = Reductionops.whd_all env' sigma t in + if not (EConstr.eq_constr sigma t t') then loop ctx t' else + errorstrm Pp.(str"The eliminator has the wrong shape."++spc()++ + str"A (applied) bound variable was expected as the conclusion of "++ + str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_econstr_env env' sigma elimty) in + let ctx, pred_id, elim_is_dep, n_pred_args,concl = loop [] elimty in + let n_elim_args = Context.Rel.nhyps ctx in + let is_rec_elim = + let count_occurn n term = + let count = ref 0 in + let rec occur_rec n c = match EConstr.kind sigma c with + | Rel m -> if m = n then incr count + | _ -> EConstr.iter_with_binders sigma succ occur_rec n c + in + occur_rec n term; !count in + let occurr2 n t = count_occurn n t > 1 in + not (List.for_all_i + (fun i (_,rd) -> pred_id <= i || not (occurr2 (pred_id - i) rd)) + 1 (assums_of_rel_context ctx)) + in + n_elim_args - pred_id, n_elim_args, is_rec_elim, elim_is_dep, n_pred_args, + (ctx,concl) + +let subgoals_tys sigma (relctx, concl) = + let rec aux cur_depth acc = function + | hd :: rest -> + let ty = Context.Rel.Declaration.get_type hd in + if EConstr.Vars.noccurn sigma cur_depth concl && + List.for_all_i (fun i -> function + | Context.Rel.Declaration.LocalAssum(_, t) -> + EConstr.Vars.noccurn sigma i t + | Context.Rel.Declaration.LocalDef (_, b, t) -> + EConstr.Vars.noccurn sigma i t && EConstr.Vars.noccurn sigma i b) 1 rest + then aux (cur_depth - 1) (ty :: acc) rest + else aux (cur_depth - 1) acc rest + | [] -> Array.of_list (List.rev acc) + in + aux (List.length relctx) [] (List.rev relctx) + +(* A case without explicit dependent terms but with both a view and an *) +(* occurrence switch and/or an equation is treated as dependent, with the *) +(* viewed term as the dependent term (the occurrence switch would be *) +(* meaningless otherwise). When both a view and explicit dependents are *) +(* present, it is forbidden to put a (meaningless) occurrence switch on *) +(* the viewed term. *) + +(* This is both elim and case (defaulting to the former). If ~elim is omitted + * the standard eliminator is chosen. The code is made of 4 parts: + * 1. find the eliminator if not given as ~elim and analyze it + * 2. build the patterns to be matched against the conclusion, looking at + * (occ, c), deps and the pattern inferred from the type of the eliminator + * 3. build the new predicate matching the patterns, and the tactic to + * generalize the equality in case eqid is not None + * 4. build the tactic handle intructions and clears as required in ipats and + * by eqid *) +let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac gl = + (* some sanity checks *) + let oc, orig_clr, occ, c_gen, gl = match what with + | `EConstr(_,_,t) when EConstr.isEvar (project gl) t -> + anomaly "elim called on a constr evar" + | `EGen (_, g) when elim = None && is_wildcard g -> + errorstrm Pp.(str"Indeterminate pattern and no eliminator") + | `EGen ((Some clr,occ), g) when is_wildcard g -> + None, clr, occ, None, gl + | `EGen ((None, occ), g) when is_wildcard g -> None,[],occ,None,gl + | `EGen ((_, occ), p as gen) -> + let _, c, clr,gl = pf_interp_gen gl true gen in + Some c, clr, occ, Some p,gl + | `EConstr (clr, occ, c) -> Some c, clr, occ, None,gl in + let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in + ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); + let fire_subst gl t = Reductionops.nf_evar (project gl) t in + let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + let eq = EConstr.of_constr eq in + let is_undef_pat = function + | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) + | _ -> false in + let match_pat env p occ h cl = + let sigma0 = project orig_gl in + ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern p)); + let (c,ucst), cl = + fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in + ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); + c, EConstr.of_constr cl, ucst in + let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env (project gl) t n in + Evd.merge_universe_context sigma ucst, T (EConstr.Unsafe.to_constr t) in + let unif_redex gl (sigma, r as p) t = (* t is a hint for the redex of p *) + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let t, _, _, sigma = saturate ~beta:true env sigma t n in + let sigma = Evd.merge_universe_context sigma ucst in + match r with + | X_In_T (e, p) -> sigma, E_As_X_In_T (EConstr.Unsafe.to_constr t, e, p) + | _ -> + try unify_HO env sigma t (EConstr.of_constr (fst (redex_of_pattern env p))), r + with e when CErrors.noncritical e -> p in + (* finds the eliminator applies it to evars and c saturated as needed *) + (* obtaining "elim ??? (c ???)". pred is the higher order evar *) + (* cty is None when the user writes _ (hence we can't make a pattern *) + let cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = + match elim with + | Some elim -> + let gl, elimty = pf_e_type_of gl elim in + let pred_id, n_elim_args, is_rec, elim_is_dep, n_pred_args,ctx_concl = + analyze_eliminator elimty env (project gl) in + ind := Some (0, subgoals_tys (project gl) ctx_concl); + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let elimty = Reductionops.whd_all env (project gl) elimty in + let cty, gl = + if Option.is_empty oc then None, gl + else + let c = Option.get oc in let gl, c_ty = pfe_type_of gl c in + let pc = match c_gen with + | Some p -> interp_cpattern orig_gl p None + | _ -> mkTpat gl c in + Some(c, c_ty, pc), gl in + cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + | None -> + let c = Option.get oc in let gl, c_ty = pfe_type_of gl c in + let ((kn, i),_ as indu), unfolded_c_ty = + pf_reduce_to_quantified_ind gl c_ty in + let sort = Tacticals.elimination_sort_of_goal gl in + let gl, elim = + if not is_case then + let t,gl= pf_fresh_global (Indrec.lookup_eliminator (kn,i) sort) gl in + gl, t + else + Tacmach.pf_eapply (fun env sigma () -> + let indu = (fst indu, EConstr.EInstance.kind sigma (snd indu)) in + let (sigma, ind) = Indrec.build_case_analysis_scheme env sigma indu true sort in + (sigma, ind)) gl () in + let elim = EConstr.of_constr elim in + let gl, elimty = pfe_type_of gl elim in + let pred_id,n_elim_args,is_rec,elim_is_dep,n_pred_args,ctx_concl = + analyze_eliminator elimty env (project gl) in + if is_case then + let mind,indb = Inductive.lookup_mind_specif env (kn,i) in + ind := Some(mind.Declarations.mind_nparams,Array.map EConstr.of_constr indb.Declarations.mind_nf_lc); + else + ind := Some (0, subgoals_tys (project gl) ctx_concl); + let rctx = fst (EConstr.decompose_prod_assum (project gl) unfolded_c_ty) in + let n_c_args = Context.Rel.length rctx in + let c, c_ty, t_args, gl = pf_saturate gl c ~ty:c_ty n_c_args in + let elim, elimty, elim_args, gl = + pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in + let pred = List.assoc pred_id elim_args in + let pc = match n_c_args, c_gen with + | 0, Some p -> interp_cpattern orig_gl p None + | _ -> mkTpat gl c in + let cty = Some (c, c_ty, pc) in + let elimty = Reductionops.whd_all env (project gl) elimty in + cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + in + ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat (EConstr.Unsafe.to_constr elim))); + ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat (EConstr.Unsafe.to_constr elimty))); + let inf_deps_r = match EConstr.kind_of_type (project gl) elimty with + | AtomicType (_, args) -> List.rev (Array.to_list args) + | _ -> assert false in + let saturate_until gl c c_ty f = + let rec loop n = try + let c, c_ty, _, gl = pf_saturate gl c ~ty:c_ty n in + let gl' = f c c_ty gl in + Some (c, c_ty, gl, gl') + with + | NotEnoughProducts -> None + | e when CErrors.noncritical e -> loop (n+1) in loop 0 in + (* Here we try to understand if the main pattern/term the user gave is + * the first pattern to be matched (i.e. if elimty ends in P t1 .. tn, + * weather tn is the t the user wrote in 'elim: t' *) + let c_is_head_p, gl = match cty with + | None -> true, gl (* The user wrote elim: _ *) + | Some (c, c_ty, _) -> + let res = + (* we try to see if c unifies with the last arg of elim *) + if elim_is_dep then None else + let arg = List.assoc (n_elim_args - 1) elim_args in + let gl, arg_ty = pfe_type_of gl arg in + match saturate_until gl c c_ty (fun c c_ty gl -> + pf_unify_HO (pf_unify_HO gl c_ty arg_ty) arg c) with + | Some (c, _, _, gl) -> Some (false, gl) + | None -> None in + match res with + | Some x -> x + | None -> + (* we try to see if c unifies with the last inferred pattern *) + let inf_arg = List.hd inf_deps_r in + let gl, inf_arg_ty = pfe_type_of gl inf_arg in + match saturate_until gl c c_ty (fun _ c_ty gl -> + pf_unify_HO gl c_ty inf_arg_ty) with + | Some (c, _, _,gl) -> true, gl + | None -> + errorstrm Pp.(str"Unable to apply the eliminator to the term"++ + spc()++pr_econstr_env env (project gl) c++spc()++str"or to unify it's type with"++ + pr_econstr_env env (project gl) inf_arg_ty) in + ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); + let gl, predty = pfe_type_of gl pred in + (* Patterns for the inductive types indexes to be bound in pred are computed + * looking at the ones provided by the user and the inferred ones looking at + * the type of the elimination principle *) + let pp_pat (_,p,_,occ) = Pp.(pr_occ occ ++ pp_pattern p) in + let pp_inf_pat gl (_,_,t,_) = pr_constr_pat (EConstr.Unsafe.to_constr (fire_subst gl t)) in + let patterns, clr, gl = + let rec loop patterns clr i = function + | [],[] -> patterns, clr, gl + | ((oclr, occ), t):: deps, inf_t :: inf_deps -> + let p = interp_cpattern orig_gl t None in + let clr_t = + interp_clr (project gl) (oclr,(tag_of_cpattern t,EConstr.of_constr (fst (redex_of_pattern env p)))) in + (* if we are the index for the equation we do not clear *) + let clr_t = if deps = [] && eqid <> None then [] else clr_t in + let p = if is_undef_pat p then mkTpat gl inf_t else p in + loop (patterns @ [i, p, inf_t, occ]) + (clr_t @ clr) (i+1) (deps, inf_deps) + | [], c :: inf_deps -> + ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_constr_pat (EConstr.Unsafe.to_constr c))); + loop (patterns @ [i, mkTpat gl c, c, allocc]) + clr (i+1) ([], inf_deps) + | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in + let deps, head_p, inf_deps_r = match what, c_is_head_p, cty with + | `EConstr _, _, None -> anomaly "Simple elim with no term" + | _, false, _ -> deps, [], inf_deps_r + | `EGen gen, true, None -> deps @ [gen], [], inf_deps_r + | _, true, Some (c, _, pc) -> + let occ = if occ = None then allocc else occ in + let inf_p, inf_deps_r = List.hd inf_deps_r, List.tl inf_deps_r in + deps, [1, pc, inf_p, occ], inf_deps_r in + let patterns, clr, gl = + loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in + head_p @ patterns, Util.List.uniquize clr, gl + in + ppdebug(lazy Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); + ppdebug(lazy Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + (* Predicate generation, and (if necessary) tactic to generalize the + * equation asked by the user *) + let elim_pred, gen_eq_tac, clr, gl = + let error gl t inf_t = errorstrm Pp.(str"The given pattern matches the term"++ + spc()++pp_term gl t++spc()++str"while the inferred pattern"++ + spc()++pr_constr_pat (EConstr.Unsafe.to_constr (fire_subst gl inf_t))++spc()++ str"doesn't") in + let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = + let p = unif_redex gl p inf_t in + if is_undef_pat p then + let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern p)) in + cl, gl, post @ [h, p, inf_t, occ] + else try + let c, cl, ucst = match_pat env p occ h cl in + let gl = pf_merge_uc ucst gl in + let c = EConstr.of_constr c in + let gl = try pf_unify_HO gl inf_t c + with exn when CErrors.noncritical exn -> error gl c inf_t in + cl, gl, post + with + | NoMatch | NoProgress -> + let e, ucst = redex_of_pattern env p in + let gl = pf_merge_uc ucst gl in + let e = EConstr.of_constr e in + let n, e, _, _ucst = pf_abs_evars gl (fst p, e) in + let e, _, _, gl = pf_saturate ~beta:true gl e n in + let gl = try pf_unify_HO gl inf_t e + with exn when CErrors.noncritical exn -> error gl e inf_t in + cl, gl, post + in + let rec match_all concl gl patterns = + let concl, gl, postponed = + List.fold_left match_or_postpone (concl, gl, []) patterns in + if postponed = [] then concl, gl + else if List.length postponed = List.length patterns then + errorstrm Pp.(str "Some patterns are undefined even after all"++spc()++ + str"the defined ones matched") + else match_all concl gl postponed in + let concl, gl = match_all concl gl patterns in + let pred_rctx, _ = EConstr.decompose_prod_assum (project gl) (fire_subst gl predty) in + let concl, gen_eq_tac, clr, gl = match eqid with + | Some (IPatId _) when not is_rec -> + let k = List.length deps in + let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in + let gl, t = pfe_type_of gl c in + let gen_eq_tac, gl = + let refl = EConstr.mkApp (eq, [|t; c; c|]) in + let new_concl = EConstr.mkArrow refl (EConstr.Vars.lift 1 (pf_concl orig_gl)) in + let new_concl = fire_subst gl new_concl in + let erefl, gl = mkRefl t c gl in + let erefl = fire_subst gl erefl in + apply_type new_concl [erefl], gl in + let rel = k + if c_is_head_p then 1 else 0 in + let src, gl = mkProt EConstr.mkProp EConstr.(mkApp (eq,[|t; c; mkRel rel|])) gl in + let concl = EConstr.mkArrow src (EConstr.Vars.lift 1 concl) in + let clr = if deps <> [] then clr else [] in + concl, gen_eq_tac, clr, gl + | _ -> concl, Tacticals.tclIDTAC, clr, gl in + let mk_lam t r = EConstr.mkLambda_or_LetIn r t in + let concl = List.fold_left mk_lam concl pred_rctx in + let gl, concl = + if eqid <> None && is_rec then + let gl, concls = pfe_type_of gl concl in + let concl, gl = mkProt concls concl gl in + let gl, _ = pfe_type_of gl concl in + gl, concl + else gl, concl in + concl, gen_eq_tac, clr, gl in + let gl, pty = pf_e_type_of gl elim_pred in + ppdebug(lazy Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); + ppdebug(lazy Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); + let gl = pf_unify_HO gl pred elim_pred in + let elim = fire_subst gl elim in + let gl, _ = pf_e_type_of gl elim in + (* check that the patterns do not contain non instantiated dependent metas *) + let () = + let evars_of_term = Evarutil.undefined_evars_of_term (project gl) in + let patterns = List.map (fun (_,_,t,_) -> fire_subst gl t) patterns in + let patterns_ev = List.map evars_of_term patterns in + 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 + Evar.Set.union e (evars_of_term i_ty)) + ev Evar.Set.empty in + let inter = Evar.Set.inter ev ty_ev in + if not (Evar.Set.is_empty inter) then begin + let i = Evar.Set.choose inter in + let pat = List.find (fun t -> Evar.Set.mem i (evars_of_term t)) patterns in + errorstrm Pp.(str"Pattern"++spc()++pr_constr_pat (EConstr.Unsafe.to_constr pat)++spc()++ + str"was not completely instantiated and one of its variables"++spc()++ + str"occurs in the type of another non-instantiated pattern variable"); + end + in + (* the elim tactic, with the eliminator and the predicated we computed *) + let elim = project gl, elim in + let elim_tac gl = + Tacticals.tclTHENLIST [refine_with ~with_evars:false elim; old_cleartac clr] gl in + Tacticals.tclTHENLIST [gen_eq_tac; elim_intro_tac what eqid elim_tac is_rec clr] orig_gl + +let no_intro ?ist what eqid elim_tac is_rec clr = elim_tac + +let elimtac x = + Proofview.V82.tactic ~nf_evars:false + (ssrelim ~is_case:false [] (`EConstr ([],None,x)) None no_intro) +let casetac x = ssrelim ~is_case:true [] (`EConstr ([],None,x)) None no_intro + +let pf_nb_prod gl = nb_prod (project gl) (pf_concl gl) + +let rev_id = mk_internal_id "rev concl" +let injecteq_id = mk_internal_id "injection equation" + +let revtoptac n0 gl = + let n = pf_nb_prod gl - n0 in + let dc, cl = EConstr.decompose_prod_n_assum (project gl) n (pf_concl gl) in + let dc' = dc @ [Context.Rel.Declaration.LocalAssum(Name rev_id, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in + let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in + refine (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|])) gl + +let equality_inj l b id c gl = + let msg = ref "" in + try Proofview.V82.of_tactic (Equality.inj None l b None c) gl + with + | Ploc.Exc(_,CErrors.UserError (_,s)) + | CErrors.UserError (_,s) + when msg := Pp.string_of_ppcmds s; + !msg = "Not a projectable equality but a discriminable one." || + !msg = "Nothing to inject." -> + Feedback.msg_warning (Pp.str !msg); + discharge_hyp (id, (id, "")) gl + +let injectidl2rtac id c gl = + Tacticals.tclTHEN (equality_inj None true id c) (revtoptac (pf_nb_prod gl)) gl + +let injectl2rtac sigma c = match EConstr.kind sigma c with +| Var id -> injectidl2rtac id (EConstr.mkVar id, NoBindings) +| _ -> + let id = injecteq_id in + let xhavetac id c = Proofview.V82.of_tactic (Tactics.pose_proof (Name id) c) in + Tacticals.tclTHENLIST [xhavetac id c; injectidl2rtac id (EConstr.mkVar id, NoBindings); Proofview.V82.of_tactic (Tactics.clear [id])] + +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 ()) + +let perform_injection c gl = + let gl, cty = pfe_type_of gl c in + let mind, t = pf_reduce_to_quantified_ind gl cty in + let dc, eqt = EConstr.decompose_prod (project gl) t in + if dc = [] then injectl2rtac (project gl) c gl else + if not (EConstr.Vars.closed0 (project gl) eqt) then + CErrors.user_err (Pp.str "can't decompose a quantified equality") else + let cl = pf_concl gl in let n = List.length dc in + let c_eq = mkEtaApp c n 2 in + let cl1 = EConstr.mkLambda EConstr.(Anonymous, mkArrow eqt cl, mkApp (mkRel 1, [|c_eq|])) in + let id = injecteq_id in + let id_with_ebind = (EConstr.mkVar id, NoBindings) in + let injtac = Tacticals.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in + Tacticals.tclTHENLAST (Proofview.V82.of_tactic (Tactics.apply (EConstr.compose_lam dc cl1))) injtac gl + +let ssrscase_or_inj_tac c = Proofview.V82.tactic ~nf_evars:false (fun gl -> + if is_injection_case c gl then perform_injection c gl + else casetac c gl) + +let ssrscasetac c = + Proofview.V82.tactic ~nf_evars:false (fun gl -> casetac c gl) diff --git a/plugins/ssr/ssrelim.mli b/plugins/ssr/ssrelim.mli new file mode 100644 index 00000000..c7ffba91 --- /dev/null +++ b/plugins/ssr/ssrelim.mli @@ -0,0 +1,55 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ssrmatching_plugin + +val ssrelim : + ?ind:(int * EConstr.types array) option ref -> + ?is_case:bool -> + ((Ssrast.ssrhyps option * Ssrast.ssrocc) * + Ssrmatching.cpattern) + list -> + ([< `EConstr of + Ssrast.ssrhyp list * Ssrmatching.occ * + EConstr.constr & + 'b + | `EGen of + (Ssrast.ssrhyp list option * + Ssrmatching.occ) * + Ssrmatching.cpattern ] + as 'a) -> + ?elim:EConstr.constr -> + Ssrast.ssripat option -> + ( 'a -> + Ssrast.ssripat option -> + (Goal.goal Evd.sigma -> Goal.goal list Evd.sigma) -> + bool -> Ssrast.ssrhyp list -> Tacmach.tactic) -> + Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + +val elimtac : EConstr.constr -> unit Proofview.tactic + +val casetac : + EConstr.constr -> + Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + +val is_injection_case : EConstr.t -> Goal.goal Evd.sigma -> bool +val perform_injection : + EConstr.constr -> + Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + +val ssrscasetac : + EConstr.constr -> + unit Proofview.tactic + +val ssrscase_or_inj_tac : + EConstr.constr -> + unit Proofview.tactic diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml new file mode 100644 index 00000000..c29203de --- /dev/null +++ b/plugins/ssr/ssrequality.ml @@ -0,0 +1,653 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ltac_plugin +open Util +open Names +open Term +open Constr +open Vars +open Locus +open Printer +open Globnames +open Termops +open Tacinterp + +open Ssrmatching_plugin +open Ssrmatching + +open Ssrast +open Ssrprinters +open Ssrcommon +open Tacticals +open Tacmach + +let ssroldreworder = Summary.ref ~name:"SSR:oldreworder" false +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect 1.3 compatibility flag"; + Goptions.optkey = ["SsrOldRewriteGoalsOrder"]; + Goptions.optread = (fun _ -> !ssroldreworder); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssroldreworder := b) } + +(** The "simpl" tactic *) + +(* We must avoid zeta-converting any "let"s created by the "in" tactical. *) + +let tacred_simpl gl = + let simpl_expr = + Genredexpr.( + Simpl(Redops.make_red_flag[FBeta;FMatch;FZeta;FDeltaBut []],None)) in + let esimpl, _ = Redexpr.reduction_of_red_expr (pf_env gl) simpl_expr in + let esimpl e sigma c = + let (_,t) = esimpl e sigma c in + t in + let simpl env sigma c = (esimpl env sigma c) in + simpl + +let safe_simpltac n gl = + if n = ~-1 then + let cl= red_safe (tacred_simpl gl) (pf_env gl) (project gl) (pf_concl gl) in + Proofview.V82.of_tactic (convert_concl_no_check cl) gl + else + ssr_n_tac "simpl" n gl + +let simpltac = function + | Simpl n -> safe_simpltac n + | Cut n -> tclTRY (donetac n) + | SimplCut (n,m) -> tclTHEN (safe_simpltac m) (tclTRY (donetac n)) + | Nop -> tclIDTAC + +(** The "congr" tactic *) + +let interp_congrarg_at ist gl n rf ty m = + ppdebug(lazy Pp.(str"===interp_congrarg_at===")); + let congrn, _ = mkSsrRRef "nary_congruence" in + let args1 = mkRnat n :: mkRHoles n @ [ty] in + let args2 = mkRHoles (3 * n) in + let rec loop i = + if i + n > m then None else + try + let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in + ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) rt)); + Some (interp_refine ist gl rt) + with _ -> loop (i + 1) in + loop 0 + +let pattern_id = mk_internal_id "pattern value" + +let congrtac ((n, t), ty) ist gl = + ppdebug(lazy (Pp.str"===congr===")); + ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); + let sigma, _ as it = interp_term ist gl t in + let gl = pf_merge_uc_of sigma gl in + let _, f, _, _ucst = pf_abs_evars gl it in + let ist' = {ist with lfun = + Id.Map.add pattern_id (Tacinterp.Value.of_constr f) Id.Map.empty } in + let rf = mkRltacVar pattern_id in + let m = pf_nbargs gl f in + let _, cf = if n > 0 then + match interp_congrarg_at ist' gl n rf ty m with + | Some cf -> cf + | None -> errorstrm Pp.(str "No " ++ int n ++ str "-congruence with " + ++ pr_term t) + else let rec loop i = + if i > m then errorstrm Pp.(str "No congruence with " ++ pr_term t) + else match interp_congrarg_at ist' gl i rf ty m with + | Some cf -> cf + | None -> loop (i + 1) in + loop 1 in + tclTHEN (refine_with cf) (tclTRY (Proofview.V82.of_tactic Tactics.reflexivity)) gl + +let newssrcongrtac arg ist gl = + ppdebug(lazy Pp.(str"===newcongr===")); + ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); + (* utils *) + let fs gl t = Reductionops.nf_evar (project gl) t in + let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = + match try Some (pf_unify_HO gl_c (pf_concl gl) c) + with exn when CErrors.noncritical exn -> None with + | Some gl_c -> + tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) + (t_ok (proj gl_c)) gl + | None -> t_fail () gl in + let mk_evar gl ty = + let env, sigma, si = pf_env gl, project gl, sig_it gl in + let sigma = Evd.create_evar_defs sigma in + let (sigma, x) = Evarutil.new_evar env sigma ty in + x, re_sig si sigma in + let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in + let ssr_congr lr = EConstr.mkApp (arr, lr) in + (* here thw two cases: simple equality or arrow *) + let equality, _, eq_args, gl' = + let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + pf_saturate gl (EConstr.of_constr eq) 3 in + tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) + (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) ty) ist) + (fun () -> + let lhs, gl' = mk_evar gl EConstr.mkProp in let rhs, gl' = mk_evar gl' EConstr.mkProp in + let arrow = EConstr.mkArrow lhs (EConstr.Vars.lift 1 rhs) in + tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) + (fun lr -> tclTHEN (Proofview.V82.of_tactic (Tactics.apply (ssr_congr lr))) (congrtac (arg, mkRType) ist)) + (fun _ _ -> errorstrm Pp.(str"Conclusion is not an equality nor an arrow"))) + gl + +(** 7. Rewriting tactics (rewrite, unlock) *) + +(** Rewrite rules *) + +type ssrwkind = RWred of ssrsimpl | RWdef | RWeq +type ssrrule = ssrwkind * ssrterm + +(** Rewrite arguments *) + +type ssrrwarg = (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) + +let notimes = 0 +let nomult = 1, Once + +let mkocc occ = None, occ +let noclr = mkocc None +let mkclr clr = Some clr, None +let nodocc = mkclr [] + +let is_rw_cut = function RWred (Cut _) -> true | _ -> false + +let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) : ssrrwarg = + if rt <> RWeq then begin + if rt = RWred Nop && not (m = nomult && occ = None && rx = None) + && (clr = None || clr = Some []) then + anomaly "Improper rewrite clear switch"; + if d = R2L && rt <> RWdef then + CErrors.user_err (Pp.str "Right-to-left switch on simplification"); + if n <> 1 && is_rw_cut rt then + CErrors.user_err (Pp.str "Bad or useless multiplier"); + if occ <> None && rx = None && rt <> RWdef then + CErrors.user_err (Pp.str "Missing redex for simplification occurrence") + end; (d, m), ((docc, rx), r) + +let norwmult = L2R, nomult +let norwocc = noclr, None + +let simplintac occ rdx sim gl = + let simptac m gl = + if m <> ~-1 then + CErrors.user_err (Pp.str "Localized custom simpl tactic not supported"); + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let simp env c _ _ = EConstr.Unsafe.to_constr (red_safe Tacred.simpl env sigma0 (EConstr.of_constr c)) in + Proofview.V82.of_tactic + (convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.Unsafe.to_constr concl0) rdx occ simp))) + gl in + match sim with + | Simpl m -> simptac m gl + | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) gl + | _ -> simpltac sim gl + +let rec get_evalref sigma c = match EConstr.kind sigma c with + | Var id -> EvalVarRef id + | Const (k,_) -> EvalConstRef k + | App (c', _) -> get_evalref sigma c' + | Cast (c', _, _) -> get_evalref sigma c' + | Proj(c,_) -> EvalConstRef(Projection.constant c) + | _ -> errorstrm Pp.(str "The term " ++ pr_constr_pat (EConstr.Unsafe.to_constr c) ++ str " is not unfoldable") + +(* Strip a pattern generated by a prenex implicit to its constant. *) +let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with + | App (f, a) when kt = xNoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> + (sigma, f), true + | Const _ | Var _ -> p, true + | Proj _ -> p, true + | _ -> p, false + +let same_proj sigma t1 t2 = + match EConstr.kind sigma t1, EConstr.kind sigma t2 with + | Proj(c1,_), Proj(c2, _) -> Projection.equal c1 c2 + | _ -> false + +let all_ok _ _ = true + +let fake_pmatcher_end () = + mkProp, L2R, (Evd.empty, UState.empty, mkProp) + +let unfoldintac occ rdx t (kt,_) gl = + let fs sigma x = Reductionops.nf_evar sigma x in + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let (sigma, t), const = strip_unfold_term env0 t kt in + let body env t c = + Tacred.unfoldn [AllOccurrences, get_evalref sigma t] env sigma0 c in + let easy = occ = None && rdx = None in + let red_flags = if easy then CClosure.betaiotazeta else CClosure.betaiota in + let beta env = Reductionops.clos_norm_flags red_flags env sigma0 in + let unfold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = Evd.create_evar_defs sigma in + let ise, u = mk_tpattern env0 sigma0 (ise,EConstr.Unsafe.to_constr t) all_ok L2R (EConstr.Unsafe.to_constr t) in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in + (fun env c _ h -> + try find_T env c h ~k:(fun env c _ _ -> EConstr.Unsafe.to_constr (body env t (EConstr.of_constr c))) + with NoMatch when easy -> c + | NoMatch | NoProgress -> errorstrm Pp.(str"No occurrence of " + ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), + (fun () -> try end_T () with + | NoMatch when easy -> fake_pmatcher_end () + | NoMatch -> anomaly "unfoldintac") + | _ -> + (fun env (c as orig_c) _ h -> + if const then + let rec aux c = + match EConstr.kind sigma0 c with + | Const _ when EConstr.eq_constr sigma0 c t -> body env t t + | App (f,a) when EConstr.eq_constr sigma0 f t -> EConstr.mkApp (body env f f,a) + | Proj _ when same_proj sigma0 c t -> body env t c + | _ -> + let c = Reductionops.whd_betaiotazeta sigma0 c in + match EConstr.kind sigma0 c with + | Const _ when EConstr.eq_constr sigma0 c t -> body env t t + | App (f,a) when EConstr.eq_constr sigma0 f t -> EConstr.mkApp (body env f f,a) + | Proj _ when same_proj sigma0 c t -> body env t c + | Const f -> aux (body env c c) + | App (f, a) -> aux (EConstr.mkApp (body env f f, a)) + | _ -> errorstrm Pp.(str "The term "++ pr_constr_env env sigma orig_c++ + str" contains no " ++ pr_econstr_env env sigma t ++ str" even after unfolding") + in EConstr.Unsafe.to_constr @@ aux (EConstr.of_constr c) + else + try EConstr.Unsafe.to_constr @@ body env t (fs (unify_HO env sigma (EConstr.of_constr c) t) t) + with _ -> errorstrm Pp.(str "The term " ++ + pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_constr_pat (EConstr.Unsafe.to_constr t))), + fake_pmatcher_end in + let concl = + let concl0 = EConstr.Unsafe.to_constr concl0 in + try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) + with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_constr_pat (EConstr.Unsafe.to_constr t)) in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl concl) 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 fold, conclude = match rdx with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let ise = Evd.create_evar_defs sigma in + let ut = EConstr.Unsafe.to_constr (red_product_skip_id env0 sigma (EConstr.of_constr t)) in + let ise, ut = mk_tpattern env0 sigma0 (ise,t) all_ok L2R ut in + let find_T, end_T = + mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[ut]) in + (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) + with _ -> errorstrm Pp.(str "fold pattern " ++ pr_constr_pat t ++ spc () + ++ str "does not match redex " ++ pr_constr_pat c)), + fake_pmatcher_end in + let concl0 = EConstr.Unsafe.to_constr concl0 in + let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in + let _ = conclude () in + Proofview.V82.of_tactic (convert_concl (EConstr.of_constr concl)) gl +;; + +let converse_dir = function L2R -> R2L | R2L -> L2R + +let rw_progress rhs lhs ise = not (EConstr.eq_constr ise lhs (Evarutil.nf_evar ise rhs)) + +(* Coq has a more general form of "equation" (any type with a single *) +(* constructor with no arguments with_rect_r elimination lemmas). *) +(* However there is no clear way of determining the LHS and RHS of *) +(* such a generic Leibnitz equation -- short of inspecting the type *) +(* of the elimination lemmas. *) + +let rec strip_prod_assum c = match Constr.kind c with + | Prod (_, _, c') -> strip_prod_assum c' + | LetIn (_, v, _, c') -> strip_prod_assum (subst1 v c) + | Cast (c', _, _) -> strip_prod_assum c' + | _ -> c + +let rule_id = mk_internal_id "rewrite rule" + +exception PRtype_error + +let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = +(* ppdebug(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) + let env = pf_env gl in + let beta = Reductionops.clos_norm_flags CClosure.beta env sigma in + let sigma, p = + let sigma = Evd.create_evar_defs sigma in + let (sigma, ev) = Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in + (sigma, ev) + in + let pred = EConstr.mkNamedLambda pattern_id rdx_ty pred in + let elim, gl = + let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in + let sort = elimination_sort_of_goal gl in + let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in + if dir = R2L then elim, gl else (* taken from Coq's rewrite *) + let elim, _ = destConst elim in + let mp,dp,l = Constant.repr3 (Constant.make1 (Constant.canonical elim)) in + let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in + let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make3 mp dp l')) in + mkConst c1', gl in + let elim = EConstr.of_constr elim in + let proof = EConstr.mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in + (* We check the proof is well typed *) + let sigma, proof_ty = + try Typing.type_of env sigma proof with _ -> raise PRtype_error in + ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr_env env sigma proof_ty)); + try refine_with + ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl + with _ -> + (* we generate a msg like: "Unable to find an instance for the variable" *) + let hd_ty, miss = match EConstr.kind sigma c with + | App (hd, args) -> + let hd_ty = Retyping.get_type_of env sigma hd in + let names = let rec aux t = function 0 -> [] | n -> + let t = Reductionops.whd_all env sigma t in + match EConstr.kind_of_type sigma t with + | ProdType (name, _, t) -> name :: aux t (n-1) + | _ -> assert false in aux hd_ty (Array.length args) in + hd_ty, Util.List.map_filter (fun (t, name) -> + 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)))) + evs in + if open_evs <> [] then Some name else None) + (List.combine (Array.to_list args) names) + | _ -> anomaly "rewrite rule not an application" in + errorstrm Pp.(Himsg.explain_refiner_error env sigma (Logic.UnresolvedBindings miss)++ + (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_econstr_env env sigma hd_ty)) +;; + +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 + +let rwcltac cl rdx dir sr gl = + let n, r_n,_, ucst = pf_abs_evars gl sr in + let r_n' = pf_abs_cterm gl n r_n in + let r' = EConstr.Vars.subst_var pattern_id r_n' in + let gl = pf_unsafe_merge_uc ucst gl in + let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in +(* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) + ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env (pf_env gl) (project gl) (snd sr))); + let cvtac, rwtac, gl = + if EConstr.Vars.closed0 (project gl) r' then + let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.build_coq_eq () in + let sigma, c_ty = Typing.type_of env sigma c in + ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); + match EConstr.kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with + | AtomicType(e, a) when is_ind_ref sigma e c_eq -> + let new_rdx = if dir = L2R then a.(2) else a.(1) in + pirrel_rewrite cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl + | _ -> + let cl' = EConstr.mkApp (EConstr.mkNamedLambda pattern_id rdxt cl, [|rdx|]) in + let sigma, _ = Typing.type_of env sigma cl' in + let gl = pf_merge_uc_of sigma gl in + Proofview.V82.of_tactic (convert_concl cl'), rewritetac dir r', gl + else + let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in + let r3, _, r3t = + try EConstr.destCast (project gl) r2 with _ -> + errorstrm Pp.(str "no cast from " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd sr)) + ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in + let cl' = EConstr.mkNamedProd rule_id (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in + let cl'' = EConstr.mkNamedProd pattern_id rdxt cl' in + let itacs = [introid pattern_id; introid rule_id] in + let cltac = Proofview.V82.of_tactic (Tactics.clear [pattern_id; rule_id]) in + let rwtacs = [rewritetac dir (EConstr.mkVar rule_id); cltac] in + apply_type cl'' [rdx; EConstr.it_mkLambda_or_LetIn r3 dc], tclTHENLIST (itacs @ rwtacs), gl + in + let cvtac' _ = + try cvtac gl with + | PRtype_error -> + if occur_existential (project gl) (Tacmach.pf_concl 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 + +let prof_rwcltac = mk_profiler "rwrxtac.rwcltac";; +let rwcltac cl rdx dir sr gl = + prof_rwcltac.profile (rwcltac cl rdx dir sr) gl +;; + + +let lz_coq_prod = + let prod = lazy (Coqlib.build_prod ()) in fun () -> Lazy.force prod + +let lz_setoid_relation = + let sdir = ["Classes"; "RelationClasses"] in + let last_srel = ref (Environ.empty_env, None) in + fun env -> match !last_srel with + | env', srel when env' == env -> srel + | _ -> + let srel = + try Some (Universes.constr_of_global @@ + Coqlib.coq_reference "Class_setoid" sdir "RewriteRelation") + with _ -> None in + last_srel := (env, srel); srel + +let ssr_is_setoid env = + match lz_setoid_relation env with + | None -> fun _ _ _ -> false + | Some srel -> + fun sigma r args -> + Rewrite.is_applied_rewrite_relation env + sigma [] (EConstr.mkApp (r, args)) <> None + +let prof_rwxrtac_find_rule = mk_profiler "rwrxtac.find_rule";; + +let closed0_check cl p gl = + if closed0 cl then + errorstrm Pp.(str"No occurrence of redex "++ pr_constr_env (pf_env gl) (project gl) p) + +let dir_org = function L2R -> 1 | R2L -> 2 + +let rwprocess_rule dir rule gl = + let env = pf_env gl in + let coq_prod = lz_coq_prod () in + let is_setoid = ssr_is_setoid env in + let r_sigma, rules = + let rec loop d sigma r t0 rs red = + let t = + if red = 1 then Tacred.hnf_constr env sigma t0 + else Reductionops.whd_betaiotazeta sigma t0 in + ppdebug(lazy Pp.(str"rewrule="++pr_constr_pat (EConstr.Unsafe.to_constr t))); + match EConstr.kind sigma t with + | Prod (_, xt, at) -> + let sigma = Evd.create_evar_defs sigma in + let (sigma, x) = Evarutil.new_evar env sigma xt in + loop d sigma EConstr.(mkApp (r, [|x|])) (EConstr.Vars.subst1 x at) rs 0 + | App (pr, a) when is_ind_ref sigma pr coq_prod.Coqlib.typ -> + let sr sigma = match EConstr.kind sigma (Tacred.hnf_constr env sigma r) with + | App (c, ra) when is_construct_ref sigma c coq_prod.Coqlib.intro -> + fun i -> ra.(i + 1), sigma + | _ -> 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 + | _ -> + 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 + let s, sigma = sr sigma 2 in + loop (converse_dir d) sigma s a.(1) rs 0 + else + let s, sigma = sr sigma 2 in + let sigma, rs2 = loop d sigma s a.(1) rs 0 in + let s, sigma = sr sigma 1 in + loop d sigma s a.(0) rs2 0 + | App (r_eq, a) when Hipattern.match_with_equality_type sigma t != None -> + let (ind, u) = EConstr.destInd sigma r_eq and rhs = Array.last a in + let np = Inductiveops.inductive_nparamdecls ind in + let indu = (ind, EConstr.EInstance.kind sigma u) in + let ind_ct = Inductiveops.type_of_constructors env indu in + let lhs0 = last_arg sigma (EConstr.of_constr (strip_prod_assum ind_ct.(0))) in + let rdesc = match EConstr.kind sigma lhs0 with + | Rel i -> + let lhs = a.(np - i) in + let lhs, rhs = if d = L2R then lhs, rhs else rhs, lhs in +(* msgnl (str "RW: " ++ pr_rwdir d ++ str " " ++ pr_constr_pat r ++ str " : " + ++ pr_constr_pat lhs ++ str " ~> " ++ pr_constr_pat rhs); *) + d, r, lhs, rhs +(* + let l_i, r_i = if d = L2R then i, 1 - ndep else 1 - ndep, i in + let lhs = a.(np - l_i) and rhs = a.(np - r_i) in + let a' = Array.copy a in let _ = a'.(np - l_i) <- mkVar pattern_id in + let r' = mkCast (r, DEFAULTcast, mkApp (r_eq, a')) in + (d, r', lhs, rhs) +*) + | _ -> + let lhs = EConstr.Vars.substl (array_list_of_tl (Array.sub a 0 np)) lhs0 in + let lhs, rhs = if d = R2L then lhs, rhs else rhs, lhs in + let d' = if Array.length a = 1 then d else converse_dir d in + d', r, lhs, rhs in + sigma, rdesc :: rs + | App (s_eq, a) when is_setoid sigma s_eq a -> + let np = Array.length a and i = 3 - dir_org d in + let lhs = a.(np - i) and rhs = a.(np + i - 3) in + let a' = Array.copy a in let _ = a'.(np - i) <- EConstr.mkVar pattern_id in + let r' = EConstr.mkCast (r, DEFAULTcast, EConstr.mkApp (s_eq, a')) in + sigma, (d, r', lhs, rhs) :: rs + | _ -> + if red = 0 then loop d sigma r t rs 1 + else errorstrm Pp.(str "not a rewritable relation: " ++ pr_constr_pat (EConstr.Unsafe.to_constr t) + ++ spc() ++ str "in rule " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd rule))) + in + let sigma, r = rule in + let t = Retyping.get_type_of env sigma r in + loop dir sigma r t [] 0 + in + r_sigma, rules + +let rwrxtac occ rdx_pat dir rule gl = + let env = pf_env gl in + let r_sigma, rules = rwprocess_rule dir rule gl in + let find_rule rdx = + let rec rwtac = function + | [] -> + errorstrm Pp.(str "pattern " ++ pr_constr_pat (EConstr.Unsafe.to_constr rdx) ++ + str " does not match " ++ pr_dir_side dir ++ + str " of " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd rule))) + | (d, r, lhs, rhs) :: rs -> + try + let ise = unify_HO env (Evd.create_evar_defs r_sigma) lhs rdx in + if not (rw_progress rhs rdx ise) then raise NoMatch else + d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) + with _ -> rwtac rs in + rwtac rules in + let find_rule rdx = prof_rwxrtac_find_rule.profile find_rule rdx in + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let find_R, conclude = match rdx_pat with + | Some (_, (In_T _ | In_X_In_T _)) | None -> + let upats_origin = dir, EConstr.Unsafe.to_constr (snd rule) in + 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 + 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 + (fun e c _ i -> find_R ~k:(fun _ _ _ h -> mkRel h) e c i), + fun cl -> let rdx,d,r = end_R () in closed0_check cl rdx gl; (d,r),rdx + | Some(_, (T e | X_In_T (_,e) | E_As_X_In_T (e,_,_) | E_In_X_In_T (e,_,_))) -> + 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 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 + let r = Evd.merge_universe_context (pi1 r) (pi2 r), EConstr.of_constr (pi3 r) in + rwcltac (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl +;; + +let prof_rwxrtac = mk_profiler "rwrxtac";; +let rwrxtac occ rdx_pat dir rule gl = + prof_rwxrtac.profile (rwrxtac occ rdx_pat dir rule) gl +;; + +let ssrinstancesofrule ist dir arg gl = + let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let rule = interp_term ist gl arg in + let r_sigma, rules = rwprocess_rule dir rule gl in + let find, conclude = + let upats_origin = dir, EConstr.Unsafe.to_constr (snd rule) in + 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 + 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 + let print env p c _ = Feedback.msg_info Pp.(hov 1 (str"instance:" ++ spc() ++ pr_constr_env env r_sigma p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr_env env r_sigma c)); c in + Feedback.msg_info Pp.(str"BEGIN INSTANCES"); + try + while true do + ignore(find env0 (EConstr.Unsafe.to_constr concl0) 1 ~k:print) + done; raise NoMatch + with NoMatch -> Feedback.msg_info Pp.(str"END INSTANCES"); tclIDTAC gl + +let ipat_rewrite occ dir c gl = rwrxtac occ None dir (project gl, c) gl + +let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = + let fail = ref false in + let interp_rpattern gl gc = + try interp_rpattern gl gc + with _ when snd mult = May -> fail := true; project gl, T mkProp in + let interp gc gl = + try interp_term ist gl gc + with _ when snd mult = May -> fail := true; (project gl, EConstr.mkProp) in + let rwtac gl = + let rx = Option.map (interp_rpattern gl) grx in + let t = interp gt gl in + (match kind with + | RWred sim -> simplintac occ rx sim + | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt + | RWeq -> rwrxtac occ rx dir t) gl in + let ctac = old_cleartac (interp_clr (project gl) (oclr, (fst gt, snd (interp gt gl)))) in + if !fail then ctac gl else tclTHEN (tclMULT mult rwtac) ctac gl + +(** Rewrite argument sequence *) + +(* type ssrrwargs = ssrrwarg list *) + +(** The "rewrite" tactic *) + +let ssrrewritetac ist rwargs = + tclTHENLIST (List.map (rwargtac ist) rwargs) + +(** The "unlock" tactic *) + +let unfoldtac occ ko t kt gl = + let env = pf_env gl in + let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term env t kt)) in + let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref (project gl) c] gl c) cl in + let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in + Proofview.V82.of_tactic + (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl + +let unlocktac ist args gl = + let utac (occ, gt) gl = + unfoldtac occ occ (interp_term ist gl gt) (fst gt) gl in + let locked, gl = pf_mkSsrConst "locked" gl in + let key, gl = pf_mkSsrConst "master_key" gl in + let ktacs = [ + (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); + Ssrelim.casetac key ] in + tclTHENLIST (List.map utac args @ ktacs) gl + diff --git a/plugins/ssr/ssrequality.mli b/plugins/ssr/ssrequality.mli new file mode 100644 index 00000000..bbcd6b90 --- /dev/null +++ b/plugins/ssr/ssrequality.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ssrmatching_plugin +open Ssrast + +type ssrwkind = RWred of ssrsimpl | RWdef | RWeq +type ssrrule = ssrwkind * ssrterm +type ssrrwarg = (ssrdir * ssrmult) * ((ssrdocc * Ssrmatching.rpattern option) * ssrrule) + +val dir_org : ssrdir -> int + +val notimes : int +val nomult : ssrmult +val mkocc : ssrocc -> ssrdocc +val mkclr : ssrclear -> ssrdocc +val nodocc : ssrdocc +val noclr : ssrdocc + +val simpltac : Ssrast.ssrsimpl -> Tacmach.tactic + +val newssrcongrtac : + int * Ssrast.ssrterm -> + Ltac_plugin.Tacinterp.interp_sign -> + Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + + +val mk_rwarg : + Ssrast.ssrdir * (int * Ssrast.ssrmmod) -> + (Ssrast.ssrclear option * Ssrast.ssrocc) * Ssrmatching.rpattern option -> + ssrwkind * Ssrast.ssrterm -> ssrrwarg + +val norwmult : ssrdir * ssrmult +val norwocc : (Ssrast.ssrclear option * Ssrast.ssrocc) * Ssrmatching.rpattern option + +val ssrinstancesofrule : + Ltac_plugin.Tacinterp.interp_sign -> + Ssrast.ssrdir -> + Ssrast.ssrterm -> + Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + +val ssrrewritetac : + Ltac_plugin.Tacinterp.interp_sign -> + ((Ssrast.ssrdir * (int * Ssrast.ssrmmod)) * + (((Ssrast.ssrhyps option * Ssrmatching.occ) * + Ssrmatching.rpattern option) * + (ssrwkind * Ssrast.ssrterm))) + list -> Tacmach.tactic + +val ipat_rewrite : ssrocc -> ssrdir -> EConstr.t -> Tacmach.tactic + +val unlocktac : + Ltac_plugin.Tacinterp.interp_sign -> + (Ssrmatching.occ * Ssrast.ssrterm) list -> + Goal.goal Evd.sigma -> Goal.goal list Evd.sigma diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v new file mode 100644 index 00000000..ac2c7824 --- /dev/null +++ b/plugins/ssr/ssrfun.v @@ -0,0 +1,796 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* 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!. *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Delimit Scope fun_scope with FUN. +Open Scope fun_scope. + +(* 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) + (at level 10, x at level 8, no associativity, format "@^~ x") : fun_scope. + +Delimit Scope pair_scope with PAIR. +Open Scope pair_scope. + +(* 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) + (at level 2, left associativity, format "p .2") : pair_scope. + +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. *) + +Module Option. + +Definition apply aT rT (f : aT -> rT) x u := if u is Some y then f y else x. + +Definition default T := apply (fun x : T => x). + +Definition bind aT rT (f : aT -> option rT) := apply f None. + +Definition map aT rT (f : aT -> rT) := bind (fun x => Some (f x)). + +End Option. + +Notation oapp := Option.apply. +Notation odflt := Option.default. +Notation obind := Option.bind. +Notation omap := Option.map. +Notation some := (@Some _) (only parsing). + +(* 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). +Definition esym := sym_eq. +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. *) +Prenex Implicits esym nesym. + +(* 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 *) + +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. *) + +Reserved Notation "[ 'rec' a0 ]" + (at level 0, format "[ 'rec' a0 ]"). +Reserved Notation "[ 'rec' a0 , a1 ]" + (at level 0, format "[ 'rec' a0 , a1 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]" + (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]" + (at level 0, + format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]"). +Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]" + (at level 0, + format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]"). +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). *) + +Section SimplFun. + +Variables aT rT : Type. + +CoInductive simpl_fun := SimplFun of aT -> rT. + +Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. + +Coercion fun_of_simpl : simpl_fun >-> Funclass. + +End SimplFun. + +Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) + (at level 0, + format "'[hv' [ 'fun' : T => '/ ' E ] ']'") : fun_scope. + +Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) + (at level 0, x ident, + format "'[hv' [ 'fun' x => '/ ' E ] ']'") : fun_scope. + +Notation "[ 'fun' x : T => E ]" := (SimplFun (fun x : T => E)) + (at level 0, x ident, only parsing) : fun_scope. + +Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) + (at level 0, x ident, y ident, + format "'[hv' [ 'fun' x y => '/ ' E ] ']'") : fun_scope. + +Notation "[ 'fun' x y : T => E ]" := (fun x : T => [fun y : T => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'fun' ( x : T ) y => E ]" := (fun x : T => [fun y => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +Notation "[ 'fun' x ( y : T ) => E ]" := (fun x => [fun y : T => E]) + (at level 0, x ident, y ident, only parsing) : fun_scope. + +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. *) +Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. + +(* Extensional equality, for unary and binary functions, including syntactic *) +(* sugar. *) + +Section ExtensionalEquality. + +Variables A B C : Type. + +Definition eqfun (f g : B -> A) : Prop := forall x, f x = g x. + +Definition eqrel (r s : C -> B -> A) : Prop := forall x y, r x y = s x y. + +Lemma frefl f : eqfun f f. Proof. by []. Qed. +Lemma fsym f g : eqfun f g -> eqfun g f. Proof. by move=> eq_fg x. Qed. + +Lemma ftrans f g h : eqfun f g -> eqfun g h -> eqfun f h. +Proof. by move=> eq_fg eq_gh x; rewrite eq_fg. Qed. + +Lemma rrefl r : eqrel r r. Proof. by []. Qed. + +End ExtensionalEquality. + +Typeclasses Opaque eqfun. +Typeclasses Opaque eqrel. + +Hint Resolve frefl rrefl. + +Notation "f1 =1 f2" := (eqfun f1 f2) + (at level 70, no associativity) : fun_scope. +Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) + (at level 70, f2 at next level, A at level 90) : fun_scope. +Notation "f1 =2 f2" := (eqrel f1 f2) + (at level 70, no associativity) : fun_scope. +Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) + (at level 70, f2 at next level, A at level 90) : fun_scope. + +Section Composition. + +Variables A B C : Type. + +Definition funcomp u (f : B -> A) (g : C -> B) x := let: tt := u in f (g x). +Definition catcomp u g f := funcomp u f g. +Local Notation comp := (funcomp tt). + +Definition pcomp (f : B -> option A) (g : C -> option B) x := obind f (g x). + +Lemma eq_comp f f' g g' : f =1 f' -> g =1 g' -> comp f g =1 comp f' g'. +Proof. by move=> eq_ff' eq_gg' x; rewrite /= eq_gg' eq_ff'. Qed. + +End Composition. + +Notation comp := (funcomp tt). +Notation "@ 'comp'" := (fun A B C => @funcomp A B C tt). +Notation "f1 \o f2" := (comp f1 f2) + (at level 50, format "f1 \o '/ ' f2") : fun_scope. +Notation "f1 \; f2" := (catcomp tt f1 f2) + (at level 60, right associativity, format "f1 \; '/ ' f2") : fun_scope. + +Notation "[ 'eta' f ]" := (fun x => f x) + (at level 0, format "[ 'eta' f ]") : fun_scope. + +Notation "'fun' => E" := (fun _ => E) (at level 200, only parsing) : fun_scope. + +Notation id := (fun x => x). +Notation "@ 'id' T" := (fun x : T => x) + (at level 10, T at level 8, only parsing) : fun_scope. + +Definition id_head T u x : T := let: tt := u in x. +Definition explicit_id_key := tt. +Notation idfun := (id_head tt). +Notation "@ 'idfun' T " := (@id_head T explicit_id_key) + (at level 10, T at level 8, format "@ 'idfun' T") : fun_scope. + +Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. + +(* Strong sigma types. *) + +Section Tag. + +Variables (I : Type) (i : I) (T_ U_ : I -> Type). + +Definition tag := projT1. +Definition tagged : forall w, T_(tag w) := @projT2 I [eta T_]. +Definition Tagged x := @existT I [eta T_] i x. + +Definition tag2 (w : @sigT2 I T_ U_) := let: existT2 _ _ i _ _ := w in i. +Definition tagged2 w : T_(tag2 w) := let: existT2 _ _ _ x _ := w in x. +Definition tagged2' w : U_(tag2 w) := let: existT2 _ _ _ _ y := w in y. +Definition Tagged2 x y := @existT2 I [eta T_] [eta U_] i x y. + +End Tag. + +Arguments Tagged [I i]. +Arguments Tagged2 [I i]. +Prenex Implicits tag tagged Tagged tag2 tagged2 tagged2' Tagged2. + +Coercion tag_of_tag2 I T_ U_ (w : @sigT2 I T_ U_) := + Tagged (fun i => T_ i * U_ i)%type (tagged2 w, tagged2' w). + +Lemma all_tag I T U : + (forall x : I, {y : T x & U x y}) -> + {f : forall x, T x & forall x, U x (f x)}. +Proof. by move=> fP; exists (fun x => tag (fP x)) => x; case: (fP x). Qed. + +Lemma all_tag2 I T U V : + (forall i : I, {y : T i & U i y & V i y}) -> + {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. *) + +(* Prenex Implicits and renaming. *) +Notation sval := (@proj1_sig _ _). +Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'"). + +Section Sig. + +Variables (T : Type) (P Q : T -> Prop). + +Lemma svalP (u : sig P) : P (sval u). Proof. by case: u. Qed. + +Definition s2val (u : sig2 P Q) := let: exist2 _ _ x _ _ := u in x. + +Lemma s2valP u : P (s2val u). Proof. by case: u. Qed. + +Lemma s2valP' u : Q (s2val u). Proof. by case: u. Qed. + +End Sig. + +Prenex Implicits svalP s2val s2valP s2valP'. + +Coercion tag_of_sig I P (u : @sig I P) := Tagged P (svalP u). + +Coercion sig_of_sig2 I P Q (u : @sig2 I P Q) := + exist (fun i => P i /\ Q i) (s2val u) (conj (s2valP u) (s2valP' u)). + +Lemma all_sig I T P : + (forall x : I, {y : T x | P x y}) -> + {f : forall x, T x | forall x, P x (f x)}. +Proof. by case/all_tag=> f; exists f. Qed. + +Lemma all_sig2 I T P Q : + (forall x : I, {y : T x | P x y & Q x y}) -> + {f : forall x, T x | forall x, P x (f x) & forall x, Q x (f x)}. +Proof. by case/all_sig=> f /all_pair[]; exists f. Qed. + +Section Morphism. + +Variables (aT rT sT : Type) (f : aT -> rT). + +(* 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 *) +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 *) +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. + +End Morphism. + +Notation "{ 'morph' f : x / a >-> r }" := + (morphism_1 f (fun x => a) (fun x => r)) + (at level 0, f at level 99, x ident, + format "{ 'morph' f : x / a >-> r }") : type_scope. + +Notation "{ 'morph' f : x / a }" := + (morphism_1 f (fun x => a) (fun x => a)) + (at level 0, f at level 99, x ident, + format "{ 'morph' f : x / a }") : type_scope. + +Notation "{ 'morph' f : x y / a >-> r }" := + (morphism_2 f (fun x y => a) (fun x y => r)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'morph' f : x y / a >-> r }") : type_scope. + +Notation "{ 'morph' f : x y / a }" := + (morphism_2 f (fun x y => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'morph' f : x y / a }") : type_scope. + +Notation "{ 'homo' f : x / a >-> r }" := + (homomorphism_1 f (fun x => a) (fun x => r)) + (at level 0, f at level 99, x ident, + format "{ 'homo' f : x / a >-> r }") : type_scope. + +Notation "{ 'homo' f : x / a }" := + (homomorphism_1 f (fun x => a) (fun x => a)) + (at level 0, f at level 99, x ident, + format "{ 'homo' f : x / a }") : type_scope. + +Notation "{ 'homo' f : x y / a >-> r }" := + (homomorphism_2 f (fun x y => a) (fun x y => r)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'homo' f : x y / a >-> r }") : type_scope. + +Notation "{ 'homo' f : x y / a }" := + (homomorphism_2 f (fun x y => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'homo' f : x y / a }") : type_scope. + +Notation "{ 'homo' f : x y /~ a }" := + (homomorphism_2 f (fun y x => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'homo' f : x y /~ a }") : type_scope. + +Notation "{ 'mono' f : x / a >-> r }" := + (monomorphism_1 f (fun x => a) (fun x => r)) + (at level 0, f at level 99, x ident, + format "{ 'mono' f : x / a >-> r }") : type_scope. + +Notation "{ 'mono' f : x / a }" := + (monomorphism_1 f (fun x => a) (fun x => a)) + (at level 0, f at level 99, x ident, + format "{ 'mono' f : x / a }") : type_scope. + +Notation "{ 'mono' f : x y / a >-> r }" := + (monomorphism_2 f (fun x y => a) (fun x y => r)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'mono' f : x y / a >-> r }") : type_scope. + +Notation "{ 'mono' f : x y / a }" := + (monomorphism_2 f (fun x y => a) (fun x y => a)) + (at level 0, f at level 99, x ident, y ident, + format "{ 'mono' f : x y / a }") : type_scope. + +Notation "{ 'mono' f : x y /~ a }" := + (monomorphism_2 f (fun y x => a) (fun 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. *) + +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). *) +Variables (rT aT : Type) (f : aT -> rT). + +Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. + +Definition cancel g := forall x, g (f x) = x. + +Definition pcancel g := forall x, g (f x) = Some x. + +Definition ocancel (g : aT -> option rT) h := forall x, oapp h x (g x) = x. + +Lemma can_pcan g : cancel g -> pcancel (fun y => Some (g y)). +Proof. by move=> fK x; congr (Some _). Qed. + +Lemma pcan_inj g : pcancel g -> injective. +Proof. by move=> fK x y /(congr1 g); rewrite !fK => [[]]. Qed. + +Lemma can_inj g : cancel g -> injective. +Proof. by move/can_pcan; apply: pcan_inj. Qed. + +Lemma canLR g x y : cancel g -> x = f y -> g x = y. +Proof. by move=> fK ->. Qed. + +Lemma canRL g x y : cancel g -> f x = y -> x = g y. +Proof. by move=> fK <-. Qed. + +End Injections. + +Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed. + +(* Force implicits to use as a view. *) +Prenex Implicits Some_inj. + +(* 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. + +Lemma etrans_id T x y (eqxy : x = y :> T) : etrans (erefl x) eqxy = eqxy. +Proof. by case: y / eqxy. Qed. + +Section InjectionsTheory. + +Variables (A B C : Type) (f g : B -> A) (h : C -> B). + +Lemma inj_id : injective (@id A). +Proof. by []. Qed. + +Lemma inj_can_sym f' : cancel f f' -> injective f' -> cancel f' f. +Proof. by move=> fK injf' x; apply: injf'. Qed. + +Lemma inj_comp : injective f -> injective h -> injective (f \o h). +Proof. by move=> injf injh x y /injf; apply: injh. Qed. + +Lemma can_comp f' h' : cancel f f' -> cancel h h' -> cancel (f \o h) (h' \o f'). +Proof. by move=> fK hK x; rewrite /= fK hK. Qed. + +Lemma pcan_pcomp f' h' : + pcancel f f' -> pcancel h h' -> pcancel (f \o h) (pcomp h' f'). +Proof. by move=> fK hK x; rewrite /pcomp fK /= hK. Qed. + +Lemma eq_inj : injective f -> f =1 g -> injective g. +Proof. by move=> injf eqfg x y; rewrite -2!eqfg; apply: injf. Qed. + +Lemma eq_can f' g' : cancel f f' -> f =1 g -> f' =1 g' -> cancel g g'. +Proof. by move=> fK eqfg eqfg' x; rewrite -eqfg -eqfg'. Qed. + +Lemma inj_can_eq f' : cancel f f' -> injective f' -> cancel g f' -> f =1 g. +Proof. by move=> fK injf' gK x; apply: injf'; rewrite fK. Qed. + +End InjectionsTheory. + +Section Bijections. + +Variables (A B : Type) (f : B -> A). + +CoInductive bijective : Prop := Bijective g of cancel f g & cancel g f. + +Hypothesis bijf : bijective. + +Lemma bij_inj : injective f. +Proof. by case: bijf => g fK _; apply: can_inj fK. Qed. + +Lemma bij_can_sym f' : cancel f' f <-> cancel f f'. +Proof. +split=> fK; first exact: inj_can_sym fK bij_inj. +by case: bijf => h _ hK x; rewrite -[x]hK fK. +Qed. + +Lemma bij_can_eq f' f'' : cancel f f' -> cancel f f'' -> f' =1 f''. +Proof. +by move=> fK fK'; apply: (inj_can_eq _ bij_inj); apply/bij_can_sym. +Qed. + +End Bijections. + +Section BijectionsTheory. + +Variables (A B C : Type) (f : B -> A) (h : C -> B). + +Lemma eq_bij : bijective f -> forall g, f =1 g -> bijective g. +Proof. by case=> f' fK f'K g eqfg; exists f'; eapply eq_can; eauto. Qed. + +Lemma bij_comp : bijective f -> bijective h -> bijective (f \o h). +Proof. +by move=> [f' fK f'K] [h' hK h'K]; exists (h' \o f'); apply: can_comp; auto. +Qed. + +Lemma bij_can_bij : bijective f -> forall f', cancel f f' -> bijective f'. +Proof. by move=> bijf; exists f; first by apply/(bij_can_sym bijf). Qed. + +End BijectionsTheory. + +Section Involutions. + +Variables (A : Type) (f : A -> A). + +Definition involutive := cancel f f. + +Hypothesis Hf : involutive. + +Lemma inv_inj : injective f. Proof. exact: can_inj Hf. Qed. +Lemma inv_bij : bijective f. Proof. by exists f. Qed. + +End Involutions. + +Section OperationProperties. + +Variables S T R : Type. + +Section SopTisR. +Implicit Type op : S -> T -> R. +Definition left_inverse e inv op := forall x, op (inv x) x = e. +Definition right_inverse e inv op := forall x, op x (inv x) = e. +Definition left_injective op := forall x, injective (op^~ x). +Definition right_injective op := forall y, injective (op y). +End SopTisR. + + +Section SopTisS. +Implicit Type op : S -> T -> S. +Definition right_id e op := forall x, op x e = x. +Definition left_zero z op := forall x, op z x = z. +Definition right_commutative op := forall x y z, op (op x y) z = op (op x z) y. +Definition left_distributive op add := + forall x y z, op (add x y) z = add (op x z) (op y z). +Definition right_loop inv op := forall y, cancel (op^~ y) (op^~ (inv y)). +Definition rev_right_loop inv op := forall y, cancel (op^~ (inv y)) (op^~ y). +End SopTisS. + +Section SopTisT. +Implicit Type op : S -> T -> T. +Definition left_id e op := forall x, op e x = x. +Definition right_zero z op := forall x, op x z = z. +Definition left_commutative op := forall x y z, op x (op y z) = op y (op x z). +Definition right_distributive op add := + forall x y z, op x (add y z) = add (op x y) (op x z). +Definition left_loop inv op := forall x, cancel (op x) (op (inv x)). +Definition rev_left_loop inv op := forall x, cancel (op (inv x)) (op x). +End SopTisT. + +Section SopSisT. +Implicit Type op : S -> S -> T. +Definition self_inverse e op := forall x, op x x = e. +Definition commutative op := forall x y, op x y = op y x. +End SopSisT. + +Section SopSisS. +Implicit Type op : S -> S -> S. +Definition idempotent op := forall x, op x x = x. +Definition associative op := forall x y z, op x (op y z) = op (op x y) z. +Definition interchange op1 op2 := + forall x y z t, op1 (op2 x y) (op2 z t) = op2 (op1 x z) (op1 y t). +End SopSisS. + +End OperationProperties. + + + + + + + + + + diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml new file mode 100644 index 00000000..a5765feb --- /dev/null +++ b/plugins/ssr/ssrfwd.ml @@ -0,0 +1,319 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Pp +open Names +open Constr +open Tacmach + +open Ssrmatching_plugin.Ssrmatching +open Ssrprinters +open Ssrcommon +open Ssrtacticals + +module RelDecl = Context.Rel.Declaration + +(** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) +(** Defined identifier *) + + +let settac id c = Tactics.letin_tac None (Name id) c None +let posetac id cl = Proofview.V82.of_tactic (settac id cl Locusops.nowhere) + +let ssrposetac (id, (_, t)) gl = + let ist, t = + match t.Ssrast.interp_env with + | Some ist -> ist, Ssrcommon.ssrterm_of_ast_closure_term t + | None -> assert false in + let sigma, t, ucst, _ = pf_abs_ssrterm ist gl t in + posetac id t (pf_merge_uc ucst gl) + +let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = + let pty = Option.map (fun { Ssrast.body; interp_env } -> + let ist = Option.get interp_env in + (mkRHole, Some body), ist) pty in + let pat = interp_cpattern gl pat pty in + let cl, sigma, env = pf_concl gl, project gl, pf_env gl in + let (c, ucst), cl = + let cl = EConstr.Unsafe.to_constr cl in + try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 + with NoMatch -> redex_of_pattern ~resolve_typeclasses:true env pat, cl in + let gl = pf_merge_uc ucst gl in + let c = EConstr.of_constr c in + let cl = EConstr.of_constr cl in + if Termops.occur_existential sigma c then errorstrm(str"The pattern"++spc()++ + pr_constr_pat (EConstr.Unsafe.to_constr c)++spc()++str"did not match and has holes."++spc()++ + str"Did you mean pose?") else + let c, (gl, cty) = match EConstr.kind sigma c with + | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) + | _ -> c, pfe_type_of gl c in + let cl' = EConstr.mkLetIn (Name id, c, cty, cl) in + Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl + +open Util + +open Printer + +open Ssrast +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)) } + + +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) + | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) + | _, (_, (_, None)) -> anomaly "have: mixed C-G constr" + | _ -> anomaly "have: mixed G-C constr" + +let basecuttac name c gl = + let hd, gl = pf_mkSsrConst name gl in + let t = EConstr.mkApp (hd, [|c|]) in + let gl, _ = pf_e_type_of gl t in + Proofview.V82.of_tactic (Tactics.apply t) gl + +let introstac ipats = Proofview.V82.of_tactic (tclIPAT ipats) + +let havetac ist + (transp,((((clr, pats), binders), simpl), (((fk, _), t), hint))) + suff namefst gl += + let concl = pf_concl gl in + let skols, pats = + List.partition (function IPatAbstractVars _ -> true | _ -> false) pats in + let itac_mkabs = introstac skols in + let itac_c = introstac (IPatClear clr :: pats) in + let itac, id, clr = introstac pats, Tacticals.tclIDTAC, old_cleartac clr in + let binderstac n = + let rec aux = function 0 -> [] | n -> IPatAnon One :: aux (n-1) in + Tacticals.tclTHEN (if binders <> [] then introstac (aux n) else Tacticals.tclIDTAC) + (introstac binders) in + let simpltac = introstac simpl in + let fixtc = + not !ssrhaveNOtcresolution && + match fk with FwdHint(_,true) -> false | _ -> true in + let hint = hinttac ist true hint in + let cuttac t gl = + if transp then + let have_let, gl = pf_mkSsrConst "ssr_have_let" gl in + let step = EConstr.mkApp (have_let, [|concl;t|]) in + let gl, _ = pf_e_type_of gl step in + applyn ~with_evars:true ~with_shelve:false 2 step gl + else basecuttac "ssr_have" t gl in + (* Introduce now abstract constants, so that everything sees them *) + let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in + let unlock_abs (idty,args_id) gl = + let gl, _ = pf_e_type_of gl idty in + pf_unify_HO gl args_id.(2) abstract_key in + Tacticals.tclTHENFIRST itac_mkabs (fun gl -> + let mkt t = mk_term xNoFlag t in + let mkl t = (xNoFlag, (t, None)) in + let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in + let interp_ty gl rtc t = + let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc ist gl t in a,b,u in + let open CAst in + let ct, cty, hole, loc = match Ssrcommon.ssrterm_of_ast_closure_term t with + | _, (_, Some { loc; v = CCast (ct, CastConv cty)}) -> + mkt ct, mkt cty, mkt (mkCHole None), loc + | _, (_, Some ct) -> + mkt ct, mkt (mkCHole None), mkt (mkCHole None), None + | _, (t, None) -> + begin match DAst.get t with + | GCast (ct, CastConv cty) -> + mkl ct, mkl cty, mkl mkRHole, t.CAst.loc + | _ -> mkl t, mkl mkRHole, mkl mkRHole, None + end + in + let gl, cut, sol, itac1, itac2 = + match fk, namefst, suff with + | FwdHave, true, true -> + errorstrm (str"Suff have does not accept a proof term") + | FwdHave, false, true -> + let cty = combineCG cty hole (mkCArrow ?loc) mkRArrow in + let _,t,uc,_ = interp gl false (combineCG ct cty (mkCCast ?loc) mkRCast) in + let gl = pf_merge_uc uc gl in + let gl, ty = pfe_type_of gl t in + let ctx, _ = EConstr.decompose_prod_n_assum (project gl) 1 ty in + let assert_is_conv gl = + try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl + with _ -> errorstrm (str "Given proof term is not of type " ++ + pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) concl)) in + gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c + | FwdHave, false, false -> + let skols = List.flatten (List.map (function + | IPatAbstractVars ids -> ids + | _ -> assert false) skols) in + let skols_args = + List.map (fun id -> Ssripats.Internal.examine_abstract (EConstr.mkVar id) gl) skols in + let gl = List.fold_right unlock_abs skols_args gl in + let sigma, t, uc, n_evars = + interp gl false (combineCG ct cty (mkCCast ?loc) mkRCast) in + if skols <> [] && n_evars <> 0 then + CErrors.user_err (Pp.strbrk @@ "Automatic generalization of unresolved implicit "^ + "arguments together with abstract variables is "^ + "not supported"); + let gl = re_sig (sig_it gl) (Evd.merge_universe_context sigma uc) in + 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 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) + (Tacticals.tclTHEN tacopen_skols (fun gl -> + let abstract, gl = pf_mkSsrConst "abstract" gl in + Proofview.V82.of_tactic (unfold [abstract; abstract_key]) gl)) + | _,true,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, EConstr.mkArrow ty concl, hint, itac, clr + | _,false,true -> + let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, EConstr.mkArrow ty concl, hint, id, itac_c + | _, false, false -> + let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in + gl, cty, Tacticals.tclTHEN (binderstac n) hint, id, Tacticals.tclTHEN itac_c simpltac + | _, true, false -> assert false in + Tacticals.tclTHENS (cuttac cut) [ Tacticals.tclTHEN sol itac1; itac2 ] gl) + gl +;; + +let destProd_or_LetIn sigma c = + match EConstr.kind sigma c with + | Prod (n,ty,c) -> RelDecl.LocalAssum (n, ty), c + | LetIn (n,bo,ty,c) -> RelDecl.LocalDef (n, bo, ty), c + | _ -> raise DestKO + +let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = + let mkabs gen = abs_wgen false (fun x -> x) gen in + let mkclr gen clrs = clr_of_wgen gen clrs in + let mkpats = function + | _, Some ((x, _), _) -> fun pats -> IPatId (hoi_id x) :: pats + | _ -> fun x -> x in + let ct = match Ssrcommon.ssrterm_of_ast_closure_term ct with + | (a, (b, Some ct)) -> + begin match ct.CAst.v with + | CCast (_, CastConv cty) -> a, (b, Some cty) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" + end + | (a, (t, None)) -> + begin match DAst.get t with + | GCast (_, CastConv cty) -> a, (cty, None) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" + end + in + let cut_implies_goal = not (suff || ghave <> `NoGen) in + let c, args, ct, gl = + let gens = List.filter (function _, Some _ -> true | _ -> false) gens in + let concl = pf_concl gl in + let c = EConstr.mkProp in + let c = if cut_implies_goal then EConstr.mkArrow c concl else c in + let gl, args, c = List.fold_right mkabs gens (gl,[],c) in + let env, _ = + List.fold_left (fun (env, c) _ -> + let rd, c = destProd_or_LetIn (project gl) c in + EConstr.push_rel rd env, c) (pf_env gl, c) gens in + let sigma = project gl in + let (sigma, ev) = Evarutil.new_evar env sigma EConstr.mkProp in + let k, _ = EConstr.destEvar sigma ev in + let fake_gl = {Evd.it = k; Evd.sigma = sigma} in + let _, ct, _, uc = pf_interp_ty ist fake_gl ct in + let rec var2rel c g s = match EConstr.kind sigma c, g with + | Prod(Anonymous,_,c), [] -> EConstr.mkProd(Anonymous, EConstr.Vars.subst_vars s ct, c) + | Sort _, [] -> EConstr.Vars.subst_vars s ct + | LetIn(Name id as n,b,ty,c), _::g -> EConstr.mkLetIn (n,b,ty,var2rel c g (id::s)) + | Prod(Name id as n,ty,c), _::g -> EConstr.mkProd (n,ty,var2rel c g (id::s)) + | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_econstr_env env sigma c) in + let c = var2rel c gens [] in + let rec pired c = function + | [] -> c + | t::ts as args -> match EConstr.kind sigma c with + | Prod(_,_,c) -> pired (EConstr.Vars.subst1 t c) ts + | LetIn(id,b,ty,c) -> EConstr.mkLetIn (id,b,ty,pired c args) + | _ -> CErrors.anomaly(str"SSR: wlog: pired: " ++ pr_econstr_env env sigma c) in + c, args, pired c args, pf_merge_uc uc gl in + let tacipat pats = introstac pats in + let tacigens = + Tacticals.tclTHEN + (Tacticals.tclTHENLIST(List.rev(List.fold_right mkclr gens [old_cleartac clr0]))) + (introstac (List.fold_right mkpats gens [])) in + let hinttac = hinttac ist true hint in + let cut_kind, fst_goal_tac, snd_goal_tac = + match suff, ghave with + | true, `NoGen -> "ssr_wlog", Tacticals.tclTHEN hinttac (tacipat pats), tacigens + | false, `NoGen -> "ssr_wlog", hinttac, Tacticals.tclTHEN tacigens (tacipat pats) + | true, `Gen _ -> assert false + | false, `Gen id -> + if gens = [] then errorstrm(str"gen have requires some generalizations"); + let clear0 = old_cleartac clr0 in + let id, name_general_hyp, cleanup, pats = match id, pats with + | None, (IPatId id as ip)::pats -> Some id, tacipat [ip], clear0, pats + | None, _ -> None, Tacticals.tclIDTAC, clear0, pats + | Some (Some id),_ -> Some id, introid id, clear0, pats + | Some _,_ -> + let id = mk_anon_id "tmp" (Tacmach.pf_ids_of_hyps gl) in + Some id, introid id, Tacticals.tclTHEN clear0 (Proofview.V82.of_tactic (Tactics.clear [id])), pats in + let tac_specialize = match id with + | None -> Tacticals.tclIDTAC + | Some id -> + if pats = [] then Tacticals.tclIDTAC else + let args = Array.of_list args in + ppdebug(lazy(str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args)))); + ppdebug(lazy(str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct)); + Tacticals.tclTHENS (basecuttac "ssr_have" ct) + [Proofview.V82.of_tactic (Tactics.apply EConstr.(mkApp (mkVar id,args))); Tacticals.tclIDTAC] in + "ssr_have", + (if hint = nohint then tacigens else hinttac), + Tacticals.tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] + in + Tacticals.tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac] gl + +(** The "suffice" tactic *) + +let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = + let htac = Tacticals.tclTHEN (introstac pats) (hinttac ist true hint) in + let c = match Ssrcommon.ssrterm_of_ast_closure_term c with + | (a, (b, Some ct)) -> + begin match ct.CAst.v with + | CCast (_, CastConv cty) -> a, (b, Some cty) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" + end + | (a, (t, None)) -> + begin match DAst.get t with + | GCast (_, CastConv cty) -> a, (cty, None) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" + end + in + let ctac gl = + let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in + basecuttac "ssr_suff" ty gl in + Tacticals.tclTHENS ctac [htac; Tacticals.tclTHEN (old_cleartac clr) (introstac (binders@simpl))] diff --git a/plugins/ssr/ssrfwd.mli b/plugins/ssr/ssrfwd.mli new file mode 100644 index 00000000..8a05e255 --- /dev/null +++ b/plugins/ssr/ssrfwd.mli @@ -0,0 +1,59 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names + +open Ltac_plugin + +open Ssrast + +val ssrsettac : Id.t -> ((ssrfwdfmt * (Ssrmatching_plugin.Ssrmatching.cpattern * ast_closure_term option)) * ssrdocc) -> v82tac + +val ssrposetac : Id.t * (ssrfwdfmt * ast_closure_term) -> v82tac + +val havetac : ist -> + bool * + ((((Ssrast.ssrclear * Ssrast.ssripat list) * Ssrast.ssripats) * + Ssrast.ssripats) * + (((Ssrast.ssrfwdkind * 'a) * ast_closure_term) * + (bool * Tacinterp.Value.t option list))) -> + bool -> + bool -> v82tac + +val basecuttac : + string -> + EConstr.t -> Goal.goal Evd.sigma -> Evar.t list Evd.sigma + +val wlogtac : + Ltac_plugin.Tacinterp.interp_sign -> + ((Ssrast.ssrhyps * Ssrast.ssripats) * 'a) * 'b -> + (Ssrast.ssrhyps * + ((Ssrast.ssrhyp_or_id * string) * + Ssrmatching_plugin.Ssrmatching.cpattern option) + option) + list * + ('c * + ast_closure_term) -> + Ltac_plugin.Tacinterp.Value.t Ssrast.ssrhint -> + bool -> + [< `Gen of Names.Id.t option option | `NoGen > `NoGen ] -> + Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + +val sufftac : + Ssrast.ist -> + (((Ssrast.ssrhyps * Ssrast.ssripats) * Ssrast.ssripat list) * + Ssrast.ssripat list) * + (('a * + ast_closure_term) * + (bool * Tacinterp.Value.t option list)) -> + Tacmach.tactic + diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml new file mode 100644 index 00000000..35036b6c --- /dev/null +++ b/plugins/ssr/ssripats.ml @@ -0,0 +1,712 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Ssrmatching_plugin + +open Util +open Names + +open Proofview +open Proofview.Notations + +open Ssrast + +module IpatMachine : sig + + (* the => tactical. ?eqtac is a tactic to be eventually run + * after the first [..] block. first_case_is_dispatch is the + * ssr exception to elim: and case: *) + val main : ?eqtac:unit tactic -> first_case_is_dispatch:bool -> + ssripats -> unit tactic + +end = struct (* {{{ *) + +module State : sig + + (* to_clear API *) + val isCLR_PUSH : Id.t -> unit tactic + val isCLR_PUSHL : Id.t list -> unit tactic + val isCLR_CONSUME : unit tactic + + (* Some data may expire *) + val isTICK : ssripat -> unit tactic + + val isPRINT : Proofview.Goal.t -> Pp.t + +end = struct (* {{{ *) + +type istate = { + + (* Delayed clear *) + to_clear : Id.t list; + +} + +let empty_state = { + to_clear = []; +} + +include Ssrcommon.MakeState(struct + type state = istate + let init = empty_state +end) + +let isPRINT g = + let state = get g in + Pp.(str"{{ to_clear: " ++ + prlist_with_sep spc Id.print state.to_clear ++ spc () ++ + str" }}") + + +let isCLR_PUSH id = + tclGET (fun { to_clear = ids } -> + tclSET { to_clear = id :: ids }) + +let isCLR_PUSHL more_ids = + tclGET (fun { to_clear = ids } -> + tclSET { to_clear = more_ids @ ids }) + +let isCLR_CONSUME = + tclGET (fun { to_clear = ids } -> + tclSET { to_clear = [] } <*> + Tactics.clear ids) + + +let isTICK _ = tclUNIT () + +end (* }}} *************************************************************** *) + +open State + +(** [=> *] ****************************************************************) +(** [nb_assums] returns the number of dependent premises *) +(** 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) -> + nb_assums (cur+1) env sigma body + | Term.LetIn(name,ty,t1,t2) -> + nb_assums (cur+1) env sigma t2 + | Term.Cast(t,_,_) -> + nb_assums cur env sigma t + | _ -> cur +let nb_assums = nb_assums 0 + +let intro_anon_all = Goal.enter begin fun gl -> + let env = Goal.env gl in + let sigma = Goal.sigma gl in + let g = Goal.concl gl in + let n = nb_assums env sigma g in + Tacticals.New.tclDO n Ssrcommon.tclINTRO_ANON +end + +(** [intro_drop] behaves like [intro_anon] but registers the id of the + introduced assumption for a delayed clear. *) +let intro_drop = + Ssrcommon.tclINTRO ~id:None + ~conclusion:(fun ~orig_name:_ ~new_name -> isCLR_PUSH new_name) + +(** [intro_end] performs the actions that have been delayed. *) +let intro_end = + Ssrcommon.tcl0G (isCLR_CONSUME) + +(** [=> _] *****************************************************************) +let intro_clear ids future_ipats = + 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 + in + Tactics.rename_hyp ren <*> + isCLR_PUSHL clear_ids +end + +let tacCHECK_HYPS_EXIST hyps = Goal.enter begin fun gl -> + let ctx = Goal.hyps gl in + List.iter (Ssrcommon.check_hyp_exists ctx) hyps; + tclUNIT () +end + +(** [=> []] *****************************************************************) +let tac_case t = + Goal.enter begin fun _ -> + Ssrcommon.tacTYPEOF t >>= fun ty -> + Ssrcommon.tacIS_INJECTION_CASE ~ty t >>= fun is_inj -> + if is_inj then + V82.tactic ~nf_evars:false (Ssrelim.perform_injection t) + else + Ssrelim.ssrscasetac t +end + +(** [=> [: id]] ************************************************************) +let mk_abstract_id = + let open Coqlib in + let ssr_abstract_id = Summary.ref ~name:"SSR:abstractid" 0 in +begin fun () -> + let rec nat_of_n n = + if n = 0 then EConstr.mkConstruct path_of_O + else EConstr.mkApp (EConstr.mkConstruct path_of_S, [|nat_of_n (n-1)|]) in + incr ssr_abstract_id; nat_of_n !ssr_abstract_id +end + +let tcltclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> + let env, concl = Goal.(env gl, concl gl) in + let step = begin fun sigma -> + let (sigma, (abstract_proof, abstract_ty)) = + let (sigma, (ty, _)) = + Evarutil.new_type_evar env sigma Evd.univ_flexible_alg in + let (sigma, ablock) = Ssrcommon.mkSsrConst "abstract_lock" env sigma in + let (sigma, lock) = Evarutil.new_evar env sigma ablock in + let (sigma, abstract) = Ssrcommon.mkSsrConst "abstract" env sigma in + let abstract_ty = + EConstr.mkApp(abstract, [|ty;mk_abstract_id ();lock|]) in + let sigma, m = Evarutil.new_evar env sigma abstract_ty in + sigma, (m, abstract_ty) in + let sigma, kont = + let rd = Context.Rel.Declaration.LocalAssum (Name id, abstract_ty) in + let sigma, ev = Evarutil.new_evar (EConstr.push_rel rd env) sigma concl in + sigma, ev + in + let term = + EConstr.(mkApp (mkLambda(Name id,abstract_ty,kont),[|abstract_proof|])) in + let sigma, _ = Typing.type_of env sigma term in + sigma, term + end in + Tactics.New.refine ~typecheck:false step <*> + tclFOCUS 1 3 Proofview.shelve +end + +let tclMK_ABSTRACT_VARS ids = + List.fold_right (fun id tac -> + Tacticals.New.tclTHENFIRST (tcltclMK_ABSTRACT_VAR id) tac) ids (tclUNIT ()) + +(* Debugging *) +let tclLOG p t = + tclUNIT () >>= begin fun () -> + Ssrprinters.ppdebug (lazy Pp.(str "exec: " ++ Ssrprinters.pr_ipat p)); + tclUNIT () + end <*> + Goal.enter begin fun g -> + Ssrprinters.ppdebug (lazy Pp.(str" on state:" ++ spc () ++ + isPRINT g ++ + str" goal:" ++ spc () ++ Printer.pr_goal (Goal.print g))); + tclUNIT () + end + <*> + t p + <*> + Goal.enter begin fun g -> + Ssrprinters.ppdebug (lazy Pp.(str "done: " ++ isPRINT g)); + tclUNIT () + end + +let rec ipat_tac1 future_ipats 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 ()) [] + + | IPatId id -> Ssrcommon.tclINTRO_ID id + + | IPatCase ipatss -> + tclIORPAT (Ssrcommon.tclWITHTOP tac_case) future_ipats ipatss + | IPatInj ipatss -> + tclIORPAT (Ssrcommon.tclWITHTOP + (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) + future_ipats ipatss + + | IPatAnon Drop -> intro_drop + | IPatAnon One -> Ssrcommon.tclINTRO_ANON + | IPatAnon All -> intro_anon_all + + | IPatNoop -> tclUNIT () + | IPatSimpl Nop -> tclUNIT () + + | IPatClear ids -> + tacCHECK_HYPS_EXIST ids <*> + intro_clear (List.map Ssrcommon.hyp_id ids) future_ipats + + | IPatSimpl (Simpl n) -> + V82.tactic ~nf_evars:false (Ssrequality.simpltac (Simpl n)) + | IPatSimpl (Cut n) -> + V82.tactic ~nf_evars:false (Ssrequality.simpltac (Cut n)) + | IPatSimpl (SimplCut (n,m)) -> + V82.tactic ~nf_evars:false (Ssrequality.simpltac (SimplCut (n,m))) + + | IPatRewrite (occ,dir) -> + Ssrcommon.tclWITHTOP + (fun x -> V82.tactic ~nf_evars:false (Ssrequality.ipat_rewrite occ dir x)) + + | IPatAbstractVars ids -> tclMK_ABSTRACT_VARS ids + + | IPatTac t -> t + +and ipat_tac future_ipats pl : unit tactic = + match pl with + | [] -> tclUNIT () + | pat :: pl -> + Ssrcommon.tcl0G (tclLOG pat (ipat_tac1 (pl @ future_ipats))) <*> + isTICK pat <*> + ipat_tac future_ipats pl + +and tclIORPAT tac future_ipats = function + | [[]] -> tac + | p -> Tacticals.New.tclTHENS tac (List.map (ipat_tac future_ipats) p) + +let split_at_first_case ipats = + let rec loop acc = function + | (IPatSimpl _ | IPatClear _) as x :: rest -> loop (x :: acc) rest + | IPatCase _ as x :: xs -> CList.rev acc, Some x, xs + | pats -> CList.rev acc, None, pats + in + loop [] ipats + +let ssr_exception is_on = function + | Some (IPatCase l) when is_on -> Some (IPatDispatch l) + | x -> x + +let option_to_list = function None -> [] | Some x -> [x] + +let main ?eqtac ~first_case_is_dispatch ipats = + 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) + +end (* }}} *) + +let tclIPAT_EQ eqtac ip = + Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + IpatMachine.main ~eqtac ~first_case_is_dispatch:true ip + +let tclIPATssr ip = + Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + IpatMachine.main ~first_case_is_dispatch:true ip + +(* Common code to handle generalization lists along with the defective case *) +let with_defective maintac deps clr = Goal.enter begin fun g -> + let sigma, concl = Goal.(sigma g, concl g) in + let top_id = + match EConstr.kind_of_type sigma concl with + | Term.ProdType (Name id, _, _) + when Ssrcommon.is_discharged_id id -> id + | _ -> Ssrcommon.top_id in + let top_gen = Ssrequality.mkclr clr, Ssrmatching.cpattern_of_id top_id in + Ssrcommon.tclINTRO_ID top_id <*> maintac deps top_gen +end + +let with_dgens { dgens; gens; clr } maintac = match gens with + | [] -> with_defective maintac dgens clr + | gen :: gens -> + V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, clr)) <*> maintac dgens gen + +let mkCoqEq env sigma = + let eq = Coqlib.((build_coq_eq_data ()).eq) in + let sigma, eq = EConstr.fresh_global env sigma eq in + eq, sigma + +let mkCoqRefl t c env sigma = + let refl = Coqlib.((build_coq_eq_data()).refl) in + let sigma, refl = EConstr.fresh_global env sigma refl in + EConstr.mkApp (refl, [|t; c|]), sigma + +(** Intro patterns processing for elim tactic, in particular when used in + conjunction with equation generation as in [elim E: x] *) +let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = + let intro_eq = + match eqid with + | Some (IPatId ipat) when not is_rec -> + let rec intro_eq () = Goal.enter begin fun g -> + let sigma, env, concl = Goal.(sigma g, env g, concl g) in + match EConstr.kind_of_type sigma concl with + | Term.ProdType (_, src, tgt) -> begin + match EConstr.kind_of_type sigma src with + | Term.AtomicType (hd, _) when Ssrcommon.is_protect hd env sigma -> + V82.tactic ~nf_evars:false Ssrcommon.unprotecttac <*> + Ssrcommon.tclINTRO_ID ipat + | _ -> Ssrcommon.tclINTRO_ANON <*> intro_eq () + end + |_ -> Ssrcommon.errorstrm (Pp.str "Too many names in intro pattern") + end in + intro_eq () + | Some (IPatId ipat) -> + let intro_lhs = Goal.enter begin fun g -> + let sigma = Goal.sigma g in + let elim_name = match clr, what with + | [SsrHyp(_, x)], _ -> x + | _, `EConstr(_,_,t) when EConstr.isVar sigma t -> + EConstr.destVar sigma t + | _ -> Ssrcommon.mk_anon_id "K" (Tacmach.New.pf_ids_of_hyps g) in + let elim_name = + if Ssrcommon.is_name_in_ipats elim_name ipats then + Ssrcommon.mk_anon_id "K" (Tacmach.New.pf_ids_of_hyps g) + else elim_name + in + Ssrcommon.tclINTRO_ID elim_name + end in + let rec gen_eq_tac () = Goal.enter begin fun g -> + let sigma, env, concl = Goal.(sigma g, env g, concl g) in + let sigma, eq = + EConstr.fresh_global env sigma (Coqlib.build_coq_eq ()) in + 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 + | _ -> assert false in + let case = args.(Array.length args-1) in + if not(EConstr.Vars.closed0 sigma case) + then Ssrcommon.tclINTRO_ANON <*> gen_eq_tac () + else + Ssrcommon.tacTYPEOF case >>= fun case_ty -> + let open EConstr in + let refl = + mkApp (eq, [|Vars.lift 1 case_ty; mkRel 1; Vars.lift 1 case|]) in + let name = Ssrcommon.mk_anon_id "K" (Tacmach.New.pf_ids_of_hyps g) in + + let new_concl = + mkProd (Name name, case_ty, mkArrow refl (Vars.lift 2 concl)) in + let erefl, sigma = mkCoqRefl case_ty case env sigma in + Proofview.Unsafe.tclEVARS sigma <*> + Tactics.apply_type ~typecheck:true new_concl [case;erefl] + end in + gen_eq_tac () <*> + intro_lhs <*> + Ssrcommon.tclINTRO_ID ipat + | _ -> tclUNIT () in + let unprot = + if eqid <> None && is_rec + then V82.tactic ~nf_evars:false Ssrcommon.unprotecttac else tclUNIT () in + V82.of_tactic begin + V82.tactic ~nf_evars:false ssrelim <*> + tclIPAT_EQ (intro_eq <*> unprot) ipats + end + +let mkEq dir cl c t n env sigma = + let open EConstr in + let eqargs = [|t; c; c|] in + eqargs.(Ssrequality.dir_org dir) <- mkRel n; + let eq, sigma = mkCoqEq env sigma in + let refl, sigma = mkCoqRefl t c env sigma in + mkArrow (mkApp (eq, eqargs)) (Vars.lift 1 cl), refl, sigma + +(** in [tac/v: last gens..] the first (last to be run) generalization is + "special" in that is it also the main argument of [tac] and is eventually + to be processed forward with view [v]. The behavior implemented is + very close to [tac: (v last) gens..] but: + - [v last] may use a view adaptor + - eventually clear for [last] is taken into account + - [tac/v {clr}] is also supported, and [{clr}] is to be run later + The code here does not "grab" [v last] nor apply [v] to [last], see the + [tacVIEW_THEN_GRAB] combinator. *) +let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin + Ssrcommon.tacSIGMA >>= fun sigma0 -> + 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 (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 + let sigma = Evd.merge_universe_context sigma ucst in + let c, cl = EConstr.of_constr c, EConstr.of_constr cl in + let clr = + Ssrcommon.interp_clr sigma (oclr, (Ssrmatching.tag_of_cpattern t,c)) in + (* Historically in Coq, and hence in ssr, [case t] accepts [t] of type + [A.. -> Ind] and opens new goals for [A..] as well as for the branches + of [Ind], see the [~to_ind] argument *) + if not(Termops.occur_existential sigma c) then + if Ssrmatching.tag_of_cpattern t = Ssrprinters.xWithAt then + if not (EConstr.isVar sigma c) then + Ssrcommon.errorstrm Pp.(str "@ can be used with variables only") + else match Context.Named.lookup (EConstr.destVar sigma c) hyps with + | Context.Named.Declaration.LocalAssum _ -> + Ssrcommon.errorstrm Pp.(str "@ can be used with let-ins only") + | Context.Named.Declaration.LocalDef (name, b, ty) -> + Unsafe.tclEVARS sigma <*> + tclUNIT (true, EConstr.mkLetIn (Name name,b,ty,cl), c, clr) + else + Unsafe.tclEVARS sigma <*> + Ssrcommon.tacMKPROD c cl >>= fun ccl -> + tclUNIT (false, ccl, c, clr) + else + if to_ind && occ = None then + let _, p, _, ucst' = + (* TODO: use abs_evars2 *) + Ssrcommon.pf_abs_evars sigma0 (fst pat, c) in + let sigma = Evd.merge_universe_context sigma ucst' in + Unsafe.tclEVARS sigma <*> + Ssrcommon.tacTYPEOF p >>= fun pty -> + (* TODO: check bug: cl0 no lift? *) + let ccl = EConstr.mkProd (Ssrcommon.constr_name sigma c, pty, cl0) in + tclUNIT (false, ccl, p, clr) + else + Ssrcommon.errorstrm Pp.(str "generalized term didn't match") +end end >>= begin + fun infos -> tclDISPATCH (infos |> List.map conclusion) +end + +(** a typical mate of [tclLAST_GEN] doing the job of applying the views [cs] + to [c] and generalizing the resulting term *) +let tacVIEW_THEN_GRAB ?(simple_types=true) + vs ~conclusion (is_letin, new_concl, c, clear) += + Ssrview.tclWITH_FWD_VIEWS ~simple_types ~subject:c ~views:vs + ~conclusion:(fun t -> + Ssrcommon.tacCONSTR_NAME c >>= fun name -> + Goal.enter_one ~__LOC__ begin fun g -> + let sigma, env = Goal.sigma g, Goal.env g in + Ssrcommon.tacMKPROD t ~name + (Termops.subst_term sigma t (* NOTE: we grab t here *) + (Termops.prod_applist sigma new_concl [c])) >>= + conclusion is_letin t clear + end) + +(* Elim views are elimination lemmas, so the eliminated term is not added *) +(* to the dependent terms as for "case", unless it actually occurs in the *) +(* goal, the "all occurrences" {+} switch is used, or the equation switch *) +(* is used and there are no dependents. *) + +let ssrelimtac (view, (eqid, (dgens, ipats))) = + let ndefectelimtac view eqid ipats deps gen = + match view with + | [v] -> + Ssrcommon.tclINTERP_AST_CLOSURE_TERM_AS_CONSTR v >>= fun cs -> + tclDISPATCH (List.map (fun elim -> + V82.tactic ~nf_evars:false + (Ssrelim.ssrelim deps (`EGen gen) ~elim eqid (elim_intro_tac ipats))) + cs) + | [] -> + tclINDEPENDENT + (V82.tactic ~nf_evars:false + (Ssrelim.ssrelim deps (`EGen gen) eqid (elim_intro_tac ipats))) + | _ -> + Ssrcommon.errorstrm + Pp.(str "elim: only one elimination lemma can be provided") + in + with_dgens dgens (ndefectelimtac view eqid ipats) + +let ssrcasetac (view, (eqid, (dgens, ipats))) = + let ndefectcasetac view eqid ipats deps ((_, occ), _ as gen) = + tclLAST_GEN ~to_ind:true gen (fun (_, cl, c, clear as info) -> + let conclusion _ vc _clear _cl = + Ssrcommon.tacIS_INJECTION_CASE vc >>= fun inj -> + let simple = (eqid = None && deps = [] && occ = None) in + if simple && inj then + V82.tactic ~nf_evars:false (Ssrelim.perform_injection vc) <*> + Tactics.clear (List.map Ssrcommon.hyp_id clear) <*> + tclIPATssr ipats + else + (* macro for "case/v E: x" ---> "case E: x / (v x)" *) + let deps, clear, occ = + if view <> [] && eqid <> None && deps = [] + then [gen], [], None + else deps, clear, occ in + V82.tactic ~nf_evars:false + (Ssrelim.ssrelim ~is_case:true deps (`EConstr (clear, occ, vc)) + eqid (elim_intro_tac ipats)) + in + if view = [] then conclusion false c clear c + else tacVIEW_THEN_GRAB ~simple_types:false view ~conclusion info) + in + with_dgens dgens (ndefectcasetac view eqid ipats) + +let ssrscasetoptac = Ssrcommon.tclWITHTOP Ssrelim.ssrscase_or_inj_tac +let ssrselimtoptac = Ssrcommon.tclWITHTOP Ssrelim.elimtac + +(** [move] **************************************************************) +let pushmoveeqtac cl c = Goal.enter begin fun g -> + let env, sigma = Goal.(env g, sigma g) in + let x, t, cl1 = EConstr.destProd sigma cl in + let cl2, eqc, sigma = mkEq R2L cl1 c t 1 env sigma in + Unsafe.tclEVARS sigma <*> + Tactics.apply_type ~typecheck:true (EConstr.mkProd (x, t, cl2)) [c; eqc] +end + +let eqmovetac _ gen = Goal.enter begin fun g -> + Ssrcommon.tacSIGMA >>= fun gl -> + let cl, c, _, gl = Ssrcommon.pf_interp_gen gl false gen in + Unsafe.tclEVARS (Tacmach.project gl) <*> + pushmoveeqtac cl c +end + +let rec eqmoveipats eqpat = function + | (IPatSimpl _ | IPatClear _ as ipat) :: ipats -> + ipat :: eqmoveipats eqpat ipats + | (IPatAnon All :: _ | []) as ipats -> + IPatAnon One :: eqpat :: ipats + | ipat :: ipats -> + ipat :: eqpat :: ipats + +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 () + | _ -> Tactics.hnf_in_concl +end + +let tclIPAT ip = + Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + IpatMachine.main ~first_case_is_dispatch:false ip + +let ssrmovetac = function + | _::_ as view, (_, ({ gens = lastgen :: gens; clr }, ipats)) -> + let gentac = V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, [])) in + let conclusion _ t clear ccl = + Tactics.apply_type ~typecheck:true ccl [t] <*> + Tactics.clear (List.map Ssrcommon.hyp_id clear) in + gentac <*> + tclLAST_GEN ~to_ind:false lastgen + (tacVIEW_THEN_GRAB view ~conclusion) <*> + tclIPAT (IPatClear clr :: ipats) + | _::_ as view, (_, ({ gens = []; clr }, ipats)) -> + tclIPAT (IPatView view :: IPatClear clr :: ipats) + | _, (Some pat, (dgens, ipats)) -> + let dgentac = with_dgens dgens eqmovetac in + dgentac <*> tclIPAT (eqmoveipats pat ipats) + | _, (_, ({ gens = (_ :: _ as gens); dgens = []; clr}, ipats)) -> + let gentac = V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, clr)) in + gentac <*> tclIPAT ipats + | _, (_, ({ clr }, ipats)) -> + Tacticals.New.tclTHENLIST [ssrsmovetac; Tactics.clear (List.map Ssrcommon.hyp_id clr); tclIPAT ipats] + +(** [abstract: absvar gens] **************************************************) +let rec is_Evar_or_CastedMeta sigma x = + EConstr.isEvar sigma x || + EConstr.isMeta sigma x || + (EConstr.isCast sigma x && + is_Evar_or_CastedMeta sigma (pi1 (EConstr.destCast 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 + | _ -> EConstr.iter sigma occrec c + in + try occrec c; false + with Not_found -> true + +let tacEXAMINE_ABSTRACT id = Ssrcommon.tacTYPEOF id >>= begin fun tid -> + Ssrcommon.tacMK_SSR_CONST "abstract" >>= fun abstract -> + Goal.enter_one ~__LOC__ begin fun g -> + let sigma, env = Goal.(sigma g, env g) in + let err () = + Ssrcommon.errorstrm + Pp.(strbrk"not a proper abstract constant: "++ + Printer.pr_econstr_env env sigma id) in + if not (EConstr.isApp sigma tid) then err (); + let hd, args_id = EConstr.destApp sigma tid in + if not (EConstr.eq_constr_nounivs sigma hd abstract) then err (); + if Array.length args_id <> 3 then err (); + if not (is_Evar_or_CastedMeta sigma args_id.(2)) then + Ssrcommon.errorstrm Pp.(strbrk"abstract constant "++ + Printer.pr_econstr_env env sigma id++str" already used"); + tclUNIT (tid, args_id) +end end + +let tacFIND_ABSTRACT_PROOF check_lock abstract_n = + Ssrcommon.tacMK_SSR_CONST "abstract" >>= fun abstract -> + 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|]) + when (not check_lock || + (occur_existential_or_casted_meta sigma ty && + is_Evar_or_CastedMeta sigma lock)) && + EConstr.eq_constr_nounivs sigma hd abstract && + EConstr.eq_constr_nounivs sigma n abstract_n -> e :: l + | _ -> l) sigma [] in + match l with + | [e] -> tclUNIT e + | _ -> Ssrcommon.errorstrm + Pp.(strbrk"abstract constant "++ + Printer.pr_econstr_env env sigma abstract_n ++ + strbrk" not found in the evar map exactly once. "++ + strbrk"Did you tamper with it?") +end + +let ssrabstract dgens = + let main _ (_,cid) = Goal.enter begin fun g -> + Ssrcommon.tacMK_SSR_CONST "abstract" >>= fun abstract -> + Ssrcommon.tacMK_SSR_CONST "abstract_key" >>= fun abstract_key -> + Ssrcommon.tacINTERP_CPATTERN cid >>= fun cid -> + let id = EConstr.mkVar (Option.get (Ssrmatching.id_of_pattern cid)) in + tacEXAMINE_ABSTRACT id >>= fun (idty, args_id) -> + let abstract_n = args_id.(1) in + tacFIND_ABSTRACT_PROOF true abstract_n >>= fun abstract_proof -> + let tacFIND_HOLE = Goal.enter_one ~__LOC__ begin fun g -> + 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,_,_) + when EConstr.isEvar sigma m || EConstr.isMeta sigma m -> + Ssrcommon.tacUNIFY concl t <*> tclUNIT id + | _ -> + Ssrcommon.errorstrm + Pp.(strbrk"abstract constant "++ + Printer.pr_econstr_env env sigma abstract_n ++ + strbrk" has an unexpected shape. Did you tamper with it?") + end in + tacFIND_HOLE >>= fun proof -> + Ssrcommon.tacUNIFY abstract_key args_id.(2) <*> + Ssrcommon.tacTYPEOF idty >>= fun _ -> + Unsafe.tclGETGOALS >>= fun goals -> + (* Here we jump in the proof tree: we move from the current goal to + the evar that inhabits the abstract variable with the current goal *) + Unsafe.tclSETGOALS + (goals @ [Proofview_monad.with_empty_state abstract_proof]) <*> + tclDISPATCH [ + Tacticals.New.tclSOLVE [Tactics.apply proof]; + Ssrcommon.unfold[abstract;abstract_key] + ] + end in + let interp_gens { gens } ~conclusion = Goal.enter begin fun g -> + Ssrcommon.tacSIGMA >>= fun gl0 -> + let open Ssrmatching in + let ipats = List.map (fun (_,cp) -> + match id_of_pattern (interp_cpattern gl0 cp None) with + | None -> IPatAnon One + | Some id -> IPatId id) + (List.tl gens) in + conclusion ipats + end in + interp_gens dgens ~conclusion:(fun ipats -> + with_dgens dgens main <*> + tclIPATssr ipats) + +module Internal = struct + + let pf_find_abstract_proof b gl t = + let res = ref None in + let _ = V82.of_tactic (tacFIND_ABSTRACT_PROOF b (EConstr.of_constr t) >>= fun x -> res := Some x; tclUNIT ()) gl in + match !res with + | None -> assert false + | Some x -> x + + let examine_abstract t gl = + let res = ref None in + let _ = V82.of_tactic (tacEXAMINE_ABSTRACT t >>= fun x -> res := Some x; tclUNIT ()) gl in + match !res with + | None -> assert false + | Some x -> x + +end + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssripats.mli b/plugins/ssr/ssripats.mli new file mode 100644 index 00000000..89cba4be --- /dev/null +++ b/plugins/ssr/ssripats.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file implements: + - the [=>] tactical + - the [:] pseudo-tactical for move, case, elim and abstract + + Putting these two features in the same file lets one hide much of the + interaction between [tac E:] and [=>] ([E] has to be processed by [=>], + not by [:] +*) + +open Ssrast + +(* The => tactical *) +val tclIPAT : ssripats -> unit Proofview.tactic + +(* As above but with the SSR exception: first case is dispatch *) +val tclIPATssr : ssripats -> unit Proofview.tactic + +(* Wrappers to deal with : and eqn generation/naming: + [tac E: gens => ipats] + where [E] is injected into [ipats] (at the right place) and [gens] are + generalized before calling [tac] *) +val ssrmovetac : ssrdgens ssrmovearg -> unit Proofview.tactic +val ssrsmovetac : unit Proofview.tactic +val ssrelimtac : ssrdgens ssrmovearg -> unit Proofview.tactic +val ssrselimtoptac : unit Proofview.tactic +val ssrcasetac : ssrdgens ssrmovearg -> unit Proofview.tactic +val ssrscasetoptac : unit Proofview.tactic + +(* The implementation of abstract: is half here, for the [[: var ]] + * ipat, and in ssrfwd for the integration with [have] *) +val ssrabstract : ssrdgens -> unit Proofview.tactic + +(* Handling of [[:var]], needed in ssrfwd. Since ssrfwd is still outside the + * tactic monad we export code with the V82 interface *) +module Internal : sig +val examine_abstract : + EConstr.t -> Goal.goal Evd.sigma -> EConstr.types * EConstr.t array +val pf_find_abstract_proof : + bool -> Goal.goal Evd.sigma -> Constr.constr -> Evar.t +end diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 new file mode 100644 index 00000000..5f396744 --- /dev/null +++ b/plugins/ssr/ssrparser.ml4 @@ -0,0 +1,2337 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Pp +open Pcoq +open Ltac_plugin +open Genarg +open Stdarg +open Tacarg +open Term +open Libnames +open Tactics +open Tacmach +open Util +open Tacexpr +open Tacinterp +open Pltac +open Extraargs +open Ppconstr + +open Misctypes +open Decl_kinds +open Constrexpr +open Constrexpr_ops + +open Proofview +open Proofview.Notations + +open Ssrprinters +open Ssrcommon +open Ssrtacticals +open Ssrbwd +open Ssrequality +open Ssripats + +(** Ssreflect load check. *) + +(* To allow ssrcoq to be fully compatible with the "plain" Coq, we only *) +(* turn on its incompatible features (the new rewrite syntax, and the *) +(* reserved identifiers) when the theory library (ssreflect.v) has *) +(* has actually been required, or is being defined. Because this check *) +(* needs to be done often (for each identifier lookup), we implement *) +(* some caching, repeating the test only when the environment changes. *) +(* We check for protect_term because it is the first constant loaded; *) +(* ssr_have would ultimately be a better choice. *) +let ssr_loaded = Summary.ref ~name:"SSR:loaded" false +let is_ssr_loaded () = + !ssr_loaded || + (if CLexer.is_keyword "SsrSyntax_is_Imported" then ssr_loaded:=true; + !ssr_loaded) + +DECLARE PLUGIN "ssreflect_plugin" +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = CLexer.get_keyword_state () ;; + +let tacltop = (5,Notation_term.E) + +let pr_ssrtacarg _ _ prt = prt tacltop +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg +| [ "YouShouldNotTypeThis" ] -> [ CErrors.anomaly (Pp.str "Grammar placeholder match") ] +END +GEXTEND Gram + GLOBAL: ssrtacarg; + ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> tac ]]; +END + +(* Lexically closed tactic for tacticals. *) +let pr_ssrtclarg _ _ prt tac = prt tacltop tac +ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg + PRINTED BY pr_ssrtclarg +| [ ssrtacarg(tac) ] -> [ tac ] +END + +open Genarg + +(** 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 + +(** Primitive parsing to avoid syntax conflicts with basic tactics. *) + +let accept_before_syms syms strm = + match Util.stream_nth 1 strm with + | Tok.KEYWORD sym when List.mem sym syms -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_any_id syms strm = + match Util.stream_nth 1 strm with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT _ -> () + | _ -> raise Stream.Failure + +let accept_before_syms_or_ids syms ids strm = + match Util.stream_nth 1 strm with + | Tok.KEYWORD sym when List.mem sym syms -> () + | Tok.IDENT id when List.mem id ids -> () + | _ -> raise Stream.Failure + +open Ssrast +let pr_id = Ppconstr.pr_id +let pr_name = function Name id -> pr_id id | Anonymous -> str "_" +let pr_spc () = str " " +let pr_list = prlist_with_sep + +(**************************** ssrhyp **************************************) + +let pr_ssrhyp _ _ _ = pr_hyp + +let wit_ssrhyprep = add_genarg "ssrhyprep" pr_hyp + +let intern_hyp ist (SsrHyp (loc, id) as hyp) = + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_var) CAst.(make ?loc id)) in + if not_section_id id then hyp else + hyp_err ?loc "Can't clear section hypothesis " id + +open Pcoq.Prim + +ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY pr_ssrhyp + INTERPRETED BY interp_hyp + GLOBALIZED BY intern_hyp + | [ ident(id) ] -> [ SsrHyp (Loc.tag ~loc id) ] +END + + +let pr_hoi = hoik pr_hyp +let pr_ssrhoi _ _ _ = pr_hoi + +let wit_ssrhoirep = add_genarg "ssrhoirep" pr_hoi + +let intern_ssrhoi ist = function + | Hyp h -> Hyp (intern_hyp ist h) + | Id (SsrHyp (_, id)) as hyp -> + let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_ident) id) in + hyp + +let interp_ssrhoi ist gl = function + | Hyp h -> let s, h' = interp_hyp ist gl h in s, Hyp h' + | Id (SsrHyp (loc, id)) -> + let s, id' = interp_wit wit_ident ist gl id in + s, Id (SsrHyp (loc, id')) + +ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Hyp (SsrHyp(Loc.tag ~loc id)) ] +END +ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY pr_ssrhoi + INTERPRETED BY interp_ssrhoi + GLOBALIZED BY intern_ssrhoi + | [ ident(id) ] -> [ Id (SsrHyp(Loc.tag ~loc id)) ] +END + + +let pr_ssrhyps _ _ _ = pr_hyps + +ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY pr_ssrhyps + INTERPRETED BY interp_hyps + | [ ssrhyp_list(hyps) ] -> [ check_hyps_uniq [] hyps; hyps ] +END + +(** Rewriting direction *) + + +let pr_rwdir = function L2R -> mt() | R2L -> str "-" + +let wit_ssrdir = add_genarg "ssrdir" pr_dir + +(** Simpl switch *) + +let pr_ssrsimpl _ _ _ = pr_simpl + +let wit_ssrsimplrep = add_genarg "ssrsimplrep" pr_simpl + +let test_ssrslashnum b1 b2 strm = + match Util.stream_nth 0 strm with + | Tok.KEYWORD "/" -> + (match Util.stream_nth 1 strm with + | Tok.INT _ when b1 -> + (match Util.stream_nth 2 strm with + | Tok.KEYWORD "=" | Tok.KEYWORD "/=" when not b2 -> () + | Tok.KEYWORD "/" -> + if not b2 then () else begin + match Util.stream_nth 3 strm with + | Tok.INT _ -> () + | _ -> raise Stream.Failure + end + | _ -> raise Stream.Failure) + | Tok.KEYWORD "/" when not b1 -> + (match Util.stream_nth 2 strm with + | Tok.KEYWORD "=" when not b2 -> () + | Tok.INT _ when b2 -> + (match Util.stream_nth 3 strm with + | Tok.KEYWORD "=" -> () + | _ -> raise Stream.Failure) + | _ when not b2 -> () + | _ -> raise Stream.Failure) + | Tok.KEYWORD "=" when not b1 && not b2 -> () + | _ -> raise Stream.Failure) + | Tok.KEYWORD "//" when not b1 -> + (match Util.stream_nth 1 strm with + | Tok.KEYWORD "=" when not b2 -> () + | Tok.INT _ when b2 -> + (match Util.stream_nth 2 strm with + | Tok.KEYWORD "=" -> () + | _ -> raise Stream.Failure) + | _ when not b2 -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure + +let test_ssrslashnum10 = test_ssrslashnum true false +let test_ssrslashnum11 = test_ssrslashnum true true +let test_ssrslashnum01 = test_ssrslashnum false true +let test_ssrslashnum00 = test_ssrslashnum false false + +let negate_parser f x = + let rc = try Some (f x) with Stream.Failure -> None in + match rc with + | None -> () + | Some _ -> raise Stream.Failure + +let test_not_ssrslashnum = + Pcoq.Gram.Entry.of_parser + "test_not_ssrslashnum" (negate_parser test_ssrslashnum10) +let test_ssrslashnum00 = + Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum00 +let test_ssrslashnum10 = + Pcoq.Gram.Entry.of_parser "test_ssrslashnum10" test_ssrslashnum10 +let test_ssrslashnum11 = + Pcoq.Gram.Entry.of_parser "test_ssrslashnum11" test_ssrslashnum11 +let test_ssrslashnum01 = + Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum01 + + +ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ "//=" ] -> [ SimplCut (~-1,~-1) ] +| [ "/=" ] -> [ Simpl ~-1 ] +END + +Pcoq.(Prim.( +GEXTEND Gram + GLOBAL: ssrsimpl_ne; + ssrsimpl_ne: [ + [ test_ssrslashnum11; "/"; n = natural; "/"; m = natural; "=" -> SimplCut(n,m) + | test_ssrslashnum10; "/"; n = natural; "/" -> Cut n + | test_ssrslashnum10; "/"; n = natural; "=" -> Simpl n + | test_ssrslashnum10; "/"; n = natural; "/=" -> SimplCut (n,~-1) + | test_ssrslashnum10; "/"; n = natural; "/"; "=" -> SimplCut (n,~-1) + | test_ssrslashnum01; "//"; m = natural; "=" -> SimplCut (~-1,m) + | test_ssrslashnum00; "//" -> Cut ~-1 + ]]; + +END +)) + +ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl +| [ ssrsimpl_ne(sim) ] -> [ sim ] +| [ ] -> [ Nop ] +END + + +let pr_ssrclear _ _ _ = pr_clear mt + +ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY pr_ssrclear +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ check_hyps_uniq [] clr; clr ] +END + +ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY pr_ssrclear +| [ ssrclear_ne(clr) ] -> [ clr ] +| [ ] -> [ [] ] +END + +(** Indexes *) + +(* Since SSR indexes are always positive numbers, we use the 0 value *) +(* to encode an omitted index. We reuse the in or_var type, but we *) +(* supply our own interpretation function, which checks for non *) +(* positive values, and allows the use of constr numerals, so that *) +(* e.g., "let n := eval compute in (1 + 3) in (do n!clear)" works. *) + + +let pr_index = function + | Misctypes.ArgVar {CAst.v=id} -> pr_id id + | Misctypes.ArgArg n when n > 0 -> int n + | _ -> mt () +let pr_ssrindex _ _ _ = pr_index + +let noindex = Misctypes.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) + | iv -> iv + +let interp_index ist gl idx = + Tacmach.project gl, + match idx with + | Misctypes.ArgArg _ -> idx + | Misctypes.ArgVar id -> + let i = + try + let v = Id.Map.find id.CAst.v ist.Tacinterp.lfun in + begin match Tacinterp.Value.to_int v with + | Some i -> i + | None -> + begin match Tacinterp.Value.to_constr v with + | Some c -> + let rc = Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) c in + begin match Notation.uninterp_prim_token rc with + | _, Constrexpr.Numeral (s,b) -> + let n = int_of_string s in if b then n else -n + | _ -> raise Not_found + end + | 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) + +open Pltac + +ARGUMENT EXTEND ssrindex TYPED AS ssrindex PRINTED BY pr_ssrindex + INTERPRETED BY interp_index +| [ int_or_var(i) ] -> [ mk_index ~loc i ] +END + + +(** Occurrence switch *) + +(* The standard syntax of complemented occurrence lists involves a single *) +(* initial "-", e.g., {-1 3 5}. An initial *) +(* "+" may be used to indicate positive occurrences (the default). The *) +(* "+" is optional, except if the list of occurrences starts with a *) +(* variable or is empty (to avoid confusion with a clear switch). The *) +(* empty positive switch "{+}" selects no occurrences, while the empty *) +(* negative switch "{-}" selects all occurrences explicitly; this is the *) +(* default, but "{-}" prevents the implicit clear, and can be used to *) +(* force dependent elimination -- see ndefectelimtac below. *) + + +let pr_ssrocc _ _ _ = pr_occ + +open Pcoq.Prim + +ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY pr_ssrocc +| [ natural(n) natural_list(occ) ] -> [ + Some (false, List.map (check_index ~loc) (n::occ)) ] +| [ "-" natural_list(occ) ] -> [ Some (true, occ) ] +| [ "+" natural_list(occ) ] -> [ Some (false, occ) ] +END + + +(* modality *) + + +let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () + +let wit_ssrmmod = add_genarg "ssrmmod" pr_mmod +let ssrmmod = Pcoq.create_generic_entry Pcoq.utactic "ssrmmod" (Genarg.rawwit wit_ssrmmod);; + +GEXTEND Gram + GLOBAL: ssrmmod; + ssrmmod: [[ "!" -> Must | LEFTQMARK -> May | "?" -> May]]; +END + +(** Rewrite multiplier: !n ?n *) + +let pr_mult (n, m) = + if n > 0 && m <> Once then int n ++ pr_mmod m else pr_mmod m + +let pr_ssrmult _ _ _ = pr_mult + +ARGUMENT EXTEND ssrmult_ne TYPED AS int * ssrmmod PRINTED BY pr_ssrmult + | [ natural(n) ssrmmod(m) ] -> [ check_index ~loc n, m ] + | [ ssrmmod(m) ] -> [ notimes, m ] +END + +ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY pr_ssrmult + | [ ssrmult_ne(m) ] -> [ m ] + | [ ] -> [ nomult ] +END + +(** Discharge occ switch (combined occurrence / clear switch *) + +let pr_docc = function + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear mt clr + +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 ] +END + +(* Old kinds of terms *) + +let input_ssrtermkind strm = match Util.stream_nth 0 strm with + | Tok.KEYWORD "(" -> xInParens + | Tok.KEYWORD "@" -> xWithAt + | _ -> xNoFlag + +let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind + +(* New kinds of terms *) + +let input_term_annotation strm = + match Stream.npeek 2 strm with + | Tok.KEYWORD "(" :: Tok.KEYWORD "(" :: _ -> `DoubleParens + | Tok.KEYWORD "(" :: _ -> `Parens + | Tok.KEYWORD "@" :: _ -> `At + | _ -> `None +let term_annotation = + Gram.Entry.of_parser "term_annotation" input_term_annotation + +(* terms *) + +(** Terms parsing. ********************************************************) + +(* Because we allow wildcards in term references, we need to stage the *) +(* interpretation of terms so that it occurs at the right time during *) +(* the execution of the tactic (e.g., so that we don't report an error *) +(* for a term that isn't actually used in the execution). *) +(* The term representation tracks whether the concrete initial term *) +(* started with an opening paren, which might avoid a conflict between *) +(* the ssrreflect term syntax and Gallina notation. *) + +(* Old terms *) +let pr_ssrterm _ _ _ = pr_term +let glob_ssrterm gs = function + | k, (_, Some c) -> k, Tacintern.intern_constr gs c + | ct -> ct +let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c +let interp_ssrterm _ gl t = Tacmach.project gl, t + +open Pcoq.Constr + +ARGUMENT EXTEND ssrterm + PRINTED BY pr_ssrterm + INTERPRETED BY interp_ssrterm + GLOBALIZED BY glob_ssrterm SUBSTITUTED BY subst_ssrterm + RAW_PRINTED BY pr_ssrterm + GLOB_PRINTED BY pr_ssrterm +| [ "YouShouldNotTypeThis" constr(c) ] -> [ mk_lterm c ] +END + + +GEXTEND Gram + GLOBAL: ssrterm; + ssrterm: [[ k = ssrtermkind; c = Pcoq.Constr.constr -> mk_term k c ]]; +END + +(* New terms *) + +let pp_ast_closure_term _ _ _ = pr_ast_closure_term + +ARGUMENT EXTEND ast_closure_term + PRINTED BY pp_ast_closure_term + INTERPRETED BY interp_ast_closure_term + GLOBALIZED BY glob_ast_closure_term + SUBSTITUTED BY subst_ast_closure_term + RAW_PRINTED BY pp_ast_closure_term + GLOB_PRINTED BY pp_ast_closure_term + | [ term_annotation(a) constr(c) ] -> [ mk_ast_closure_term a c ] +END +ARGUMENT EXTEND ast_closure_lterm + PRINTED BY pp_ast_closure_term + INTERPRETED BY interp_ast_closure_term + GLOBALIZED BY glob_ast_closure_term + SUBSTITUTED BY subst_ast_closure_term + RAW_PRINTED BY pp_ast_closure_term + GLOB_PRINTED BY pp_ast_closure_term + | [ term_annotation(a) lconstr(c) ] -> [ mk_ast_closure_term a c ] +END + +(* Old Views *) + +let pr_view = pr_list mt (fun c -> str "/" ++ pr_term c) + +let pr_ssrbwdview _ _ _ = pr_view + +ARGUMENT EXTEND ssrbwdview TYPED AS ssrterm list + PRINTED BY pr_ssrbwdview +| [ "YouShouldNotTypeThis" ] -> [ [] ] +END + +Pcoq.( +GEXTEND Gram + GLOBAL: ssrbwdview; + ssrbwdview: [ + [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> [mk_term xNoFlag c] + | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrbwdview -> + (mk_term xNoFlag c) :: w ]]; +END +) + +(* New Views *) + + +let pr_ssrfwdview _ _ _ = pr_view2 + +ARGUMENT EXTEND ssrfwdview TYPED AS ast_closure_term list + PRINTED BY pr_ssrfwdview +| [ "YouShouldNotTypeThis" ] -> [ [] ] +END + +Pcoq.( +GEXTEND Gram + GLOBAL: ssrfwdview; + ssrfwdview: [ + [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> + [mk_ast_closure_term `None c] + | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrfwdview -> + (mk_ast_closure_term `None c) :: w ]]; +END +) + +(* }}} *) + +(* ipats *) + + +let remove_loc x = x.CAst.v + +let ipat_of_intro_pattern p = Misctypes.( + let rec ipat_of_intro_pattern = function + | IntroNaming (IntroIdentifier id) -> IPatId id + | IntroAction IntroWildcard -> IPatAnon Drop + | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> + IPatCase + (List.map (List.map ipat_of_intro_pattern) + (List.map (List.map remove_loc) iorpat)) + | IntroAction (IntroOrAndPattern (IntroAndPattern iandpat)) -> + IPatCase + [List.map ipat_of_intro_pattern (List.map remove_loc iandpat)] + | IntroNaming IntroAnonymous -> IPatAnon One + | IntroAction (IntroRewrite b) -> IPatRewrite (allocc, if b then L2R else R2L) + | IntroNaming (IntroFresh id) -> IPatAnon One + | IntroAction (IntroApplyOn _) -> (* to do *) CErrors.user_err (Pp.str "TO DO") + | IntroAction (IntroInjection ips) -> + IPatInj [List.map ipat_of_intro_pattern (List.map remove_loc ips)] + | IntroForthcoming _ -> + (* Unable to determine which kind of ipat interp_introid could + * return [HH] *) + assert false + in + ipat_of_intro_pattern p +) + +let rec map_ipat map_id map_ssrhyp map_ast_closure_term = function + | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x + | IPatId id -> IPatId (map_id id) + | 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) + | 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) + | IPatTac _ -> assert false (*internal usage only *) + +let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat + +let pr_ssripat _ _ _ = pr_ipat +let pr_ssripats _ _ _ = pr_ipats +let pr_ssriorpat _ _ _ = pr_iorpat + +let intern_ipat ist = + map_ipat + (fun id -> id) + (intern_hyp ist) + (glob_ast_closure_term ist) + +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.( + 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 {CAst.loc=loc;v=ipat} = ipat in + match ipat with + | IntroNaming (IntroIdentifier id) -> + if not_section_id id then SsrHyp (loc, id) :: hyps else + hyp_err ?loc "Can't delete section hypothesis " id + | IntroAction IntroWildcard -> hyps + | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> + List.fold_right (List.fold_right add_intro_pattern_hyps) iorpat hyps + | IntroAction (IntroOrAndPattern (IntroAndPattern iandpat)) -> + List.fold_right add_intro_pattern_hyps iandpat hyps + | IntroNaming IntroAnonymous -> [] + | IntroNaming (IntroFresh _) -> [] + | IntroAction (IntroRewrite _) -> hyps + | IntroAction (IntroInjection ips) -> List.fold_right add_intro_pattern_hyps ips hyps + | IntroAction (IntroApplyOn (c,pat)) -> add_intro_pattern_hyps pat hyps + | 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) *) +let interp_ipat ist gl = + let ltacvar id = Id.Map.mem id ist.Tacinterp.lfun in + let rec interp = function + | IPatId id when ltacvar id -> + ipat_of_intro_pattern (interp_introid ist gl id) + | IPatId _ as x -> x + | IPatClear clr -> + let add_hyps (SsrHyp (loc, id) as hyp) hyps = + if not (ltacvar id) then hyp :: hyps else + add_intro_pattern_hyps CAst.(make ?loc (interp_introid ist gl id)) hyps in + let clr' = List.fold_right add_hyps clr [] in + check_hyps_uniq [] clr'; IPatClear clr' + | IPatCase(iorpat) -> + IPatCase(List.map (List.map interp) iorpat) + | IPatDispatch(iorpat) -> + IPatDispatch(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 + gl x)) l) + | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x + | IPatTac _ -> assert false (*internal usage only *) + in + interp + +let interp_ipats ist gl l = project gl, List.map (interp_ipat ist gl) l + +let pushIPatRewrite = function + | pats :: orpat -> (IPatRewrite (allocc, L2R) :: pats) :: orpat + | [] -> [] + +let pushIPatNoop = function + | pats :: orpat -> (IPatNoop :: pats) :: orpat + | [] -> [] + +ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats + INTERPRETED BY interp_ipats + GLOBALIZED BY intern_ipats + | [ "_" ] -> [ [IPatAnon Drop] ] + | [ "*" ] -> [ [IPatAnon All] ] + (* + | [ "^" "*" ] -> [ [IPatFastMode] ] + | [ "^" "_" ] -> [ [IPatSeed `Wild] ] + | [ "^_" ] -> [ [IPatSeed `Wild] ] + | [ "^" "?" ] -> [ [IPatSeed `Anon] ] + | [ "^?" ] -> [ [IPatSeed `Anon] ] + | [ "^" ident(id) ] -> [ [IPatSeed (`Id(id,`Pre))] ] + | [ "^" "~" ident(id) ] -> [ [IPatSeed (`Id(id,`Post))] ] + | [ "^~" ident(id) ] -> [ [IPatSeed (`Id(id,`Post))] ] + *) + | [ ident(id) ] -> [ [IPatId id] ] + | [ "?" ] -> [ [IPatAnon One] ] +(* TODO | [ "+" ] -> [ [IPatAnon Temporary] ] *) + | [ ssrsimpl_ne(sim) ] -> [ [IPatSimpl sim] ] + | [ ssrdocc(occ) "->" ] -> [ match occ with + | None, occ -> [IPatRewrite (occ, L2R)] + | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, L2R)]] + | [ ssrdocc(occ) "<-" ] -> [ match occ with + | None, occ -> [IPatRewrite (occ, R2L)] + | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, R2L)]] + | [ ssrdocc(occ) ] -> [ match occ with + | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl] + | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here")] + | [ "->" ] -> [ [IPatRewrite (allocc, L2R)] ] + | [ "<-" ] -> [ [IPatRewrite (allocc, R2L)] ] + | [ "-" ] -> [ [IPatNoop] ] + | [ "-/" "=" ] -> [ [IPatNoop;IPatSimpl(Simpl ~-1)] ] + | [ "-/=" ] -> [ [IPatNoop;IPatSimpl(Simpl ~-1)] ] + | [ "-/" "/" ] -> [ [IPatNoop;IPatSimpl(Cut ~-1)] ] + | [ "-//" ] -> [ [IPatNoop;IPatSimpl(Cut ~-1)] ] + | [ "-/" integer(n) "/" ] -> [ [IPatNoop;IPatSimpl(Cut n)] ] + | [ "-/" "/=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] + | [ "-//" "=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] + | [ "-//=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] + | [ "-/" integer(n) "/=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (n,~-1))] ] + | [ "-/" integer(n) "/" integer (m) "=" ] -> + [ [IPatNoop;IPatSimpl(SimplCut(n,m))] ] + | [ ssrfwdview(v) ] -> [ [IPatView v] ] + | [ "[" ":" ident_list(idl) "]" ] -> [ [IPatAbstractVars idl] ] + | [ "[:" ident_list(idl) "]" ] -> [ [IPatAbstractVars idl] ] +END + +ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] + | [ ] -> [ [] ] +END + +ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY pr_ssriorpat +| [ ssripats(pats) "|" ssriorpat(orpat) ] -> [ pats :: orpat ] +| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> [ pats :: pushIPatRewrite orpat ] +| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> [ pats :: pushIPatNoop orpat ] +| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> [ pats :: pushIPatRewrite orpat ] +| [ ssripats(pats) "||" ssriorpat(orpat) ] -> [ pats :: [] :: orpat ] +| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> [ pats :: [] :: [] :: orpat ] +| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> [ [pats; []; []; []] @ orpat ] +| [ ssripats(pats) ] -> [ [pats] ] +END + +let reject_ssrhid strm = + match Util.stream_nth 0 strm with + | Tok.KEYWORD "[" -> + (match Util.stream_nth 1 strm with + | Tok.KEYWORD ":" -> raise Stream.Failure + | _ -> ()) + | _ -> () + +let test_nohidden = Pcoq.Gram.Entry.of_parser "test_ssrhid" reject_ssrhid + +ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> [ IPatCase(x) ] +END + +Pcoq.( +GEXTEND Gram + GLOBAL: ssrcpat; + ssrcpat: [ + [ test_nohidden; "["; iorpat = ssriorpat; "]" -> +(* check_no_inner_seed !@loc false iorpat; + IPatCase (understand_case_type iorpat) *) + IPatCase iorpat +(* + | test_nohidden; "("; iorpat = ssriorpat; ")" -> +(* check_no_inner_seed !@loc false iorpat; + IPatCase (understand_case_type iorpat) *) + IPatDispatch iorpat +*) + | test_nohidden; "[="; iorpat = ssriorpat; "]" -> +(* check_no_inner_seed !@loc false iorpat; *) + IPatInj iorpat ]]; +END +);; + +Pcoq.( +GEXTEND Gram + GLOBAL: ssripat; + ssripat: [[ pat = ssrcpat -> [pat] ]]; +END +) + +ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY pr_ssripats + | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] + END + +(* subsets of patterns *) + +(* TODO: review what this function does, it looks suspicious *) +let check_ssrhpats loc w_binders ipats = + let err_loc s = CErrors.user_err ~loc ~hdr:"ssreflect" s in + let clr, ipats = + let rec aux clr = function + | IPatClear cl :: tl -> aux (clr @ cl) tl +(* | IPatSimpl (cl, sim) :: tl -> clr @ cl, IPatSimpl ([], sim) :: tl *) + | tl -> clr, tl + in aux [] ipats in + let simpl, ipats = + match List.rev ipats with + | IPatSimpl _ as s :: tl -> [s], List.rev tl + | _ -> [], ipats in + if simpl <> [] && not w_binders then + err_loc (str "No s-item allowed here: " ++ pr_ipats simpl); + let ipat, binders = + let rec loop ipat = function + | [] -> ipat, [] + | ( IPatId _| IPatAnon _| IPatCase _ | IPatDispatch _ | IPatRewrite _ as i) :: tl -> + if w_binders then + if simpl <> [] && tl <> [] then + err_loc(str"binders XOR s-item allowed here: "++pr_ipats(tl@simpl)) + else if not (List.for_all (function IPatId _ -> true | _ -> false) tl) + then err_loc (str "Only binders allowed here: " ++ pr_ipats tl) + else ipat @ [i], tl + else + if tl = [] then ipat @ [i], [] + else err_loc (str "No binder or s-item allowed here: " ++ pr_ipats tl) + | hd :: tl -> loop (ipat @ [hd]) tl + in loop [] ipats in + ((clr, ipat), binders), simpl + +let pr_hpats (((clr, ipat), binders), simpl) = + pr_clear mt clr ++ pr_ipats ipat ++ pr_ipats binders ++ pr_ipats simpl +let pr_ssrhpats _ _ _ = pr_hpats +let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x + +ARGUMENT EXTEND ssrhpats TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat +PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc true i ] +END + +ARGUMENT EXTEND ssrhpats_wtransp + TYPED AS bool * (((ssrclear * ssripats) * ssripats) * ssripats) + PRINTED BY pr_ssrhpats_wtransp + | [ ssripats(i) ] -> [ false,check_ssrhpats loc true i ] + | [ ssripats(i) "@" ssripats(j) ] -> [ true,check_ssrhpats loc true (i @ j) ] +END + +ARGUMENT EXTEND ssrhpats_nobs +TYPED AS ((ssrclear * ssripats) * ssripats) * ssripats PRINTED BY pr_ssrhpats + | [ ssripats(i) ] -> [ check_ssrhpats loc false i ] +END + +ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY pr_ssripat + | [ "->" ] -> [ IPatRewrite (allocc, L2R) ] + | [ "<-" ] -> [ IPatRewrite (allocc, R2L) ] +END + +let pr_intros sep intrs = + if intrs = [] then mt() else sep () ++ str "=>" ++ pr_ipats intrs +let pr_ssrintros _ _ _ = pr_intros mt + +ARGUMENT EXTEND ssrintros_ne TYPED AS ssripat + PRINTED BY pr_ssrintros + | [ "=>" ssripats_ne(pats) ] -> [ pats ] +(* TODO | [ "=>" ">" ssripats_ne(pats) ] -> [ IPatFastMode :: pats ] + | [ "=>>" ssripats_ne(pats) ] -> [ IPatFastMode :: pats ] *) +END + +ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY pr_ssrintros + | [ ssrintros_ne(intrs) ] -> [ intrs ] + | [ ] -> [ [] ] +END + +let pr_ssrintrosarg _ _ prt (tac, ipats) = + prt tacltop tac ++ pr_intros spc ipats + +ARGUMENT EXTEND ssrintrosarg TYPED AS tactic * ssrintros + PRINTED BY pr_ssrintrosarg +| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> [ arg, ipats ] +END + +TACTIC EXTEND ssrtclintros +| [ "YouShouldNotTypeThis" ssrintrosarg(arg) ] -> + [ let tac, intros = arg in + ssrevaltac ist tac <*> tclIPATssr intros ] +END + +(** Defined identifier *) +let pr_ssrfwdid id = pr_spc () ++ pr_id id + +let pr_ssrfwdidx _ _ _ = pr_ssrfwdid + +(* We use a primitive parser for the head identifier of forward *) +(* tactis to avoid syntactic conflicts with basic Coq tactics. *) +ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY pr_ssrfwdidx + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssrfwdid strm = + match stream_nth 0 strm with + | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm + | _ -> raise Stream.Failure + + +let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid + +GEXTEND Gram + GLOBAL: ssrfwdid; + ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> id ]]; + END + + +(* by *) +(** Tactical arguments. *) + +(* We have four kinds: simple tactics, [|]-bracketed lists, hints, and swaps *) +(* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) +(* and subgoal reordering tacticals (; first & ; last), respectively. *) + + +let pr_ortacs prt = + let rec pr_rec = function + | [None] -> spc() ++ str "|" ++ spc() + | None :: tacs -> spc() ++ str "|" ++ pr_rec tacs + | Some tac :: tacs -> spc() ++ str "| " ++ prt tacltop tac ++ pr_rec tacs + | [] -> mt() in + function + | [None] -> spc() + | None :: tacs -> pr_rec tacs + | Some tac :: tacs -> prt tacltop tac ++ pr_rec tacs + | [] -> mt() +let pr_ssrortacs _ _ = pr_ortacs + +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY pr_ssrortacs +| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> [ Some tac :: tacs ] +| [ ssrtacarg(tac) "|" ] -> [ [Some tac; None] ] +| [ ssrtacarg(tac) ] -> [ [Some tac] ] +| [ "|" ssrortacs(tacs) ] -> [ None :: tacs ] +| [ "|" ] -> [ [None; None] ] +END + +let pr_hintarg prt = function + | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") + | false, [Some tac] -> prt tacltop tac + | _, _ -> mt() + +let pr_ssrhintarg _ _ = pr_hintarg + + +ARGUMENT EXTEND ssrhintarg TYPED AS bool * ssrortacs PRINTED BY pr_ssrhintarg +| [ "[" "]" ] -> [ nullhint ] +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +| [ ssrtacarg(arg) ] -> [ mk_hint arg ] +END + +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY pr_ssrhintarg +| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +END + + +let pr_hint prt arg = + if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg +let pr_ssrhint _ _ = pr_hint + +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY pr_ssrhint +| [ ] -> [ nohint ] +END +(** The "in" pseudo-tactical *)(* {{{ **********************************************) + +(* We can't make "in" into a general tactical because this would create a *) +(* crippling conflict with the ltac let .. in construct. Hence, we add *) +(* explicitly an "in" suffix to all the extended tactics for which it is *) +(* relevant (including move, case, elim) and to the extended do tactical *) +(* below, which yields a general-purpose "in" of the form do [...] in ... *) + +(* This tactical needs to come before the intro tactics because the latter *) +(* must take precautions in order not to interfere with the discharged *) +(* assumptions. This is especially difficult for discharged "let"s, which *) +(* the default simpl and unfold tactics would erase blindly. *) + +open Ssrmatching_plugin.Ssrmatching + +let pr_wgen = function + | (clr, Some((id,k),None)) -> spc() ++ pr_clear mt clr ++ str k ++ pr_hoi id + | (clr, Some((id,k),Some p)) -> + spc() ++ pr_clear mt clr ++ str"(" ++ str k ++ pr_hoi id ++ str ":=" ++ + pr_cpattern p ++ str ")" + | (clr, None) -> spc () ++ pr_clear mt clr +let pr_ssrwgen _ _ _ = pr_wgen + +(* no globwith for char *) +ARGUMENT EXTEND ssrwgen + TYPED AS ssrclear * ((ssrhoi_hyp * string) * cpattern option) option + PRINTED BY pr_ssrwgen +| [ ssrclear_ne(clr) ] -> [ clr, None ] +| [ ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, " "), None) ] +| [ "@" ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, "@"), None) ] +| [ "(" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id," "),Some p) ] +| [ "(" ssrhoi_id(id) ")" ] -> [ [], Some ((id,"("), None) ] +| [ "(@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +| [ "(" "@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> + [ [], Some ((id,"@"),Some p) ] +END + +let pr_clseq = function + | InGoal | InHyps -> mt () + | InSeqGoal -> str "|- *" + | InHypsSeqGoal -> str " |- *" + | InHypsGoal -> str " *" + | InAll -> str "*" + | InHypsSeq -> str " |-" + | InAllHyps -> str "* |-" + +let wit_ssrclseq = add_genarg "ssrclseq" pr_clseq +let pr_clausehyps = pr_list pr_spc pr_wgen +let pr_ssrclausehyps _ _ _ = pr_clausehyps + +ARGUMENT EXTEND ssrclausehyps +TYPED AS ssrwgen list PRINTED BY pr_ssrclausehyps +| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> [ hyp :: hyps ] +| [ ssrwgen(hyp) ] -> [ [hyp] ] +END + +(* type ssrclauses = ssrahyps * ssrclseq *) + +let pr_clauses (hyps, clseq) = + if clseq = InGoal then mt () + else str "in " ++ pr_clausehyps hyps ++ pr_clseq clseq +let pr_ssrclauses _ _ _ = pr_clauses + +ARGUMENT EXTEND ssrclauses TYPED AS ssrwgen list * ssrclseq + PRINTED BY pr_ssrclauses + | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> [ hyps, InHypsSeqGoal ] + | [ "in" ssrclausehyps(hyps) "|-" ] -> [ hyps, InHypsSeq ] + | [ "in" ssrclausehyps(hyps) "*" ] -> [ hyps, InHypsGoal ] + | [ "in" ssrclausehyps(hyps) ] -> [ hyps, InHyps ] + | [ "in" "|-" "*" ] -> [ [], InSeqGoal ] + | [ "in" "*" ] -> [ [], InAll ] + | [ "in" "*" "|-" ] -> [ [], InAllHyps ] + | [ ] -> [ [], InGoal ] +END + + + + +(** Definition value formatting *) + +(* We use an intermediate structure to correctly render the binder list *) +(* abbreviations. We use a list of hints to extract the binders and *) +(* base term from a term, for the two first levels of representation of *) +(* of constr terms. *) + +let pr_binder prl = function + | Bvar x -> + pr_name x + | Bdecl (xs, t) -> + str "(" ++ pr_list pr_spc pr_name xs ++ str " : " ++ prl t ++ str ")" + | Bdef (x, None, v) -> + str "(" ++ pr_name x ++ str " := " ++ prl v ++ str ")" + | Bdef (x, Some t, v) -> + str "(" ++ pr_name x ++ str " : " ++ prl t ++ + str " := " ++ prl v ++ str ")" + | Bstruct x -> + str "{struct " ++ pr_name x ++ str "}" + | Bcast t -> + str ": " ++ prl t + +let rec format_local_binders h0 bl0 = match h0, bl0 with + | BFvar :: h, CLocalAssum ([{CAst.v=x}], _, _) :: bl -> + Bvar x :: format_local_binders h bl + | BFdecl _ :: h, CLocalAssum (lxs, _, t) :: bl -> + Bdecl (List.map (fun x -> x.CAst.v) lxs, t) :: format_local_binders h bl + | BFdef :: h, CLocalDef ({CAst.v=x}, v, oty) :: bl -> + Bdef (x, oty, v) :: format_local_binders h bl + | _ -> [] + +let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with + | BFvar :: h, { v = CLambdaN ([CLocalAssum([{CAst.v=x}], _, _)], c) } -> + let bs, c' = format_constr_expr h c in + Bvar x :: bs, c' + | BFdecl _:: h, { v = CLambdaN ([CLocalAssum(lxs, _, t)], c) } -> + let bs, c' = format_constr_expr h c in + Bdecl (List.map (fun x -> x.CAst.v) lxs, t) :: bs, c' + | 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) } -> + [Bcast t], c + | BFrec (has_str, has_cast) :: h, + { v = CFix ( _, [_, (Some locn, CStructRec), bl, t, c]) } -> + let bs = format_local_binders h bl in + let bstr = if has_str then [Bstruct (Name locn.CAst.v)] else [] in + bs @ bstr @ (if has_cast then [Bcast t] else []), c + | BFrec (_, has_cast) :: h, { v = CCoFix ( _, [_, bl, t, c]) } -> + format_local_binders h bl @ (if has_cast then [Bcast t] else []), c + | _, c -> + [], c + +(** Forward chaining argument *) + +(* There are three kinds of forward definitions: *) +(* - Hint: type only, cast to Type, may have proof hint. *) +(* - Have: type option + value, no space before type *) +(* - Pose: binders + value, space before binders. *) + +let pr_fwdkind = function + | FwdHint (s,_) -> str (s ^ " ") | _ -> str " :=" ++ spc () +let pr_fwdfmt (fk, _ : ssrfwdfmt) = pr_fwdkind fk + +let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt + +(* type ssrfwd = ssrfwdfmt * ssrterm *) + +let mkFwdVal fk c = ((fk, []), c) +let mkssrFwdVal fk c = ((fk, []), (c,None)) +let dC t = CastConv t + +let same_ist { interp_env = x } { interp_env = y } = + match x,y with + | None, None -> true + | Some a, Some b -> a == b + | _ -> false + +let mkFwdCast fk ?loc ?c t = + let c = match c with + | None -> mkCHole loc + | Some c -> assert (same_ist t c); c.body in + ((fk, [BFcast]), + { t with annotation = `None; + body = (CAst.make ?loc @@ CCast (c, dC t.body)) }) + +let mkssrFwdCast fk loc t c = ((fk, [BFcast]), (c, Some t)) + +let mkFwdHint s t = + let loc = Constrexpr_ops.constr_loc t.body in + mkFwdCast (FwdHint (s,false)) ?loc t +let mkFwdHintNoTC s t = + let loc = Constrexpr_ops.constr_loc t.body in + mkFwdCast (FwdHint (s,true)) ?loc t + +let pr_gen_fwd prval prc prlc fk (bs, c) = + let prc s = str s ++ spc () ++ prval prc prlc c in + match fk, bs with + | FwdHint (s,_), [Bcast t] -> str s ++ spc () ++ prlc t + | FwdHint (s,_), _ -> prc (s ^ "(* typeof *)") + | FwdHave, [Bcast t] -> str ":" ++ spc () ++ prlc t ++ prc " :=" + | _, [] -> prc " :=" + | _, _ -> spc () ++ pr_list spc (pr_binder prlc) bs ++ prc " :=" + +let pr_fwd_guarded prval prval' = function +| (fk, h), c -> + pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c.body) + +let pr_unguarded prc prlc = prlc + +let pr_fwd = pr_fwd_guarded pr_unguarded pr_unguarded +let pr_ssrfwd _ _ _ = pr_fwd + +ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ast_closure_lterm) PRINTED BY pr_ssrfwd + | [ ":=" ast_closure_lterm(c) ] -> [ mkFwdVal FwdPose c ] + | [ ":" ast_closure_lterm (t) ":=" ast_closure_lterm(c) ] -> [ mkFwdCast FwdPose ~loc t ~c ] +END + +(** Independent parsing for binders *) + +(* The pose, pose fix, and pose cofix tactics use these internally to *) +(* parse argument fragments. *) + +let pr_ssrbvar prc _ _ v = prc v + +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar +| [ ident(id) ] -> [ mkCVar ~loc id ] +| [ "_" ] -> [ mkCHole (Some loc) ] +END + +let bvar_lname = let open CAst in function + | { v = CRef ({loc;v=Ident id}, _) } -> CAst.make ?loc @@ Name id + | { loc = loc } -> CAst.make ?loc Anonymous + +let pr_ssrbinder prc _ _ (_, c) = prc c + +ARGUMENT EXTEND ssrbinder TYPED AS ssrfwdfmt * constr PRINTED BY pr_ssrbinder + | [ ssrbvar(bv) ] -> + [ let { CAst.loc=xloc } as x = bvar_lname bv in + (FwdPose, [BFvar]), + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) ] + | [ "(" ssrbvar(bv) ")" ] -> + [ let { CAst.loc=xloc } as x = bvar_lname bv in + (FwdPose, [BFvar]), + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) ] + | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> + [ let x = bvar_lname bv in + (FwdPose, [BFdecl 1]), + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Explicit, t)], mkCHole (Some loc)) ] + | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> + [ let xs = List.map bvar_lname (bv :: bvs) in + let n = List.length xs in + (FwdPose, [BFdecl n]), + CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Explicit, t)], mkCHole (Some loc)) ] + | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> + [ (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, Some t, mkCHole (Some loc)) ] + | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> + [ (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, None, mkCHole (Some loc)) ] + END + +GEXTEND Gram + GLOBAL: ssrbinder; + ssrbinder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + let loc = !@loc in + (FwdPose, [BFvar]), + CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Explicit,c)],mkCHole (Some loc)) ] + ]; +END + +let rec binders_fmts = function + | ((_, h), _) :: bs -> h @ binders_fmts bs + | _ -> [] + +let push_binders c2 bs = + let loc2 = constr_loc c2 in let mkloc loc1 = Loc.merge_opt loc1 loc2 in + let open CAst in + let rec loop ty c = function + | (_, { loc = loc1; v = CLambdaN (b, _) } ) :: bs when ty -> + CAst.make ?loc:(mkloc loc1) @@ CProdN (b, loop ty c bs) + | (_, { loc = loc1; v = CLambdaN (b, _) } ) :: bs -> + CAst.make ?loc:(mkloc loc1) @@ CLambdaN (b, loop ty c bs) + | (_, { loc = loc1; v = CLetIn (x, v, oty, _) } ) :: bs -> + CAst.make ?loc:(mkloc loc1) @@ CLetIn (x, v, oty, loop ty c 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))) + | ct -> loop false ct bs + +let rec fix_binders = let open CAst in function + | (_, { v = CLambdaN ([CLocalAssum(xs, _, t)], _) } ) :: bs -> + CLocalAssum (xs, Default Explicit, t) :: fix_binders bs + | (_, { v = CLetIn (x, v, oty, _) } ) :: bs -> + CLocalDef (x, v, oty) :: fix_binders bs + | _ -> [] + +let pr_ssrstruct _ _ _ = function + | Some id -> str "{struct " ++ pr_id id ++ str "}" + | None -> mt () + +ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY pr_ssrstruct +| [ "{" "struct" ident(id) "}" ] -> [ Some id ] +| [ ] -> [ None ] +END + +(** The "pose" tactic *) + +(* The plain pose form. *) + +let bind_fwd bs ((fk, h), c) = + (fk,binders_fmts bs @ h), { c with body = push_binders c.body bs } + +ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY pr_ssrfwd + | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> [ bind_fwd bs fwd ] +END + +(* The pose fix form. *) + +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 + | _ -> CErrors.user_err (Pp.str "Missing identifier after \"(co)fix\"") + + +ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd + | [ "fix" ssrbvar(bv) ssrbinder_list(bs) ssrstruct(sid) ssrfwd(fwd) ] -> + [ let { CAst.v=id } as lid = bvar_locid bv in + let (fk, h), ac = fwd in + let c = ac.body in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let lb = fix_binders bs in + let has_struct, i = + let rec loop = function + | {CAst.loc=l'; v=Name id'} :: _ when Option.equal Id.equal sid (Some id') -> + true, CAst.make ?loc:l' id' + | [{CAst.loc=l';v=Name id'}] when sid = None -> + false, CAst.make ?loc:l' id' + | _ :: bn -> loop bn + | [] -> CErrors.user_err (Pp.str "Bad structural argument") in + loop (names_of_local_assums lb) in + let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in + let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some i, CStructRec), lb, t', c']) in + id, ((fk, h'), { ac with body = fix }) ] +END + + +(* The pose cofix form. *) + +let pr_ssrcofixfwd _ _ _ (id, fwd) = str " cofix " ++ pr_id id ++ pr_fwd fwd + +ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd + | [ "cofix" ssrbvar(bv) ssrbinder_list(bs) ssrfwd(fwd) ] -> + [ let { CAst.v=id } as lid = bvar_locid bv in + let (fk, h), ac = fwd in + let c = ac.body in + let has_cast, t', c' = match format_constr_expr h c with + | [Bcast t'], c' -> true, t', c' + | _ -> false, mkCHole (constr_loc c), c in + let h' = BFrec (false, has_cast) :: binders_fmts bs in + let cofix = CAst.make ~loc @@ CCoFix (lid, [lid, fix_binders bs, t', c']) in + id, ((fk, h'), { ac with body = cofix }) + ] +END + +(* This does not print the type, it should be fixed... *) +let pr_ssrsetfwd _ _ _ (((fk,_),(t,_)), docc) = + pr_gen_fwd (fun _ _ -> pr_cpattern) + (fun _ -> mt()) (fun _ -> mt()) fk ([Bcast ()],t) + +ARGUMENT EXTEND ssrsetfwd +TYPED AS (ssrfwdfmt * (lcpattern * ast_closure_lterm option)) * ssrdocc +PRINTED BY pr_ssrsetfwd +| [ ":" ast_closure_lterm(t) ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdCast FwdPose loc t c, mkocc occ ] +| [ ":" ast_closure_lterm(t) ":=" lcpattern(c) ] -> + [ mkssrFwdCast FwdPose loc t c, nodocc ] +| [ ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> + [ mkssrFwdVal FwdPose c, mkocc occ ] +| [ ":=" lcpattern(c) ] -> [ mkssrFwdVal FwdPose c, nodocc ] +END + + +let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwd TYPED AS ssrfwd * ssrhint PRINTED BY pr_ssrhavefwd +| [ ":" ast_closure_lterm(t) ssrhint(hint) ] -> [ mkFwdHint ":" t, hint ] +| [ ":" ast_closure_lterm(t) ":=" ast_closure_lterm(c) ] -> [ mkFwdCast FwdHave ~loc t ~c, nohint ] +| [ ":" ast_closure_lterm(t) ":=" ] -> [ mkFwdHintNoTC ":" t, nohint ] +| [ ":=" ast_closure_lterm(c) ] -> [ mkFwdVal FwdHave c, nohint ] +END + +let intro_id_to_binder = List.map (function + | IPatId id -> + let { CAst.loc=xloc } as x = bvar_lname (mkCVar id) in + (FwdPose, [BFvar]), + CAst.make @@ CLambdaN ([CLocalAssum([x], Default Explicit, mkCHole xloc)], + mkCHole None) + | _ -> anomaly "non-id accepted as binder") + +let binder_to_intro_id = CAst.(List.map (function + | (FwdPose, [BFvar]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } + | (FwdPose, [BFdecl _]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } -> + List.map (function {v=Name id} -> IPatId id | _ -> IPatAnon One) ids + | (FwdPose, [BFdef]), { v = CLetIn ({v=Name id},_,_,_) } -> [IPatId id] + | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon One] + | _ -> anomaly "ssrbinder is not a binder")) + +let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrhavefwdwbinders + TYPED AS bool * (ssrhpats * (ssrfwd * ssrhint)) + PRINTED BY pr_ssrhavefwdwbinders +| [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> + [ let tr, pats = trpats in + let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let hint = bind_fwd allbs (fst fwd), snd fwd in + tr, ((((clr, pats), allbinders), simpl), hint) ] +END + + +let pr_ssrdoarg prc _ prt (((n, m), tac), clauses) = + pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses + +ARGUMENT EXTEND ssrdoarg + TYPED AS ((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses + PRINTED BY pr_ssrdoarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +(* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) + +let pr_seqtacarg prt = function + | (is_first, []), _ -> str (if is_first then "first" else "last") + | tac, Some dtac -> + hv 0 (pr_hintarg prt tac ++ spc() ++ str "|| " ++ prt tacltop dtac) + | tac, _ -> pr_hintarg prt tac + +let pr_ssrseqarg _ _ prt = function + | ArgArg 0, tac -> pr_seqtacarg prt tac + | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac + +(* We must parse the index separately to resolve the conflict with *) +(* an unindexed tactic. *) +ARGUMENT EXTEND ssrseqarg TYPED AS ssrindex * (ssrhintarg * tactic option) + PRINTED BY pr_ssrseqarg +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let sq_brace_tacnames = + ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] + (* "by" is a keyword *) +let accept_ssrseqvar strm = + match stream_nth 0 strm with + | Tok.IDENT id when not (List.mem id sq_brace_tacnames) -> + accept_before_syms_or_ids ["["] ["first";"last"] strm + | _ -> raise Stream.Failure + +let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar + +let swaptacarg (loc, b) = (b, []), Some (TacId []) + +let check_seqtacarg dir arg = match snd arg, dir with + | ((true, []), Some (TacAtom (loc, _))), L2R -> + CErrors.user_err ?loc (str "expected \"last\"") + | ((false, []), Some (TacAtom (loc, _))), R2L -> + CErrors.user_err ?loc (str "expected \"first\"") + | _, _ -> arg + +let ssrorelse = Gram.entry_create "ssrorelse" +GEXTEND Gram + GLOBAL: ssrorelse ssrseqarg; + ssrseqidx: [ + [ test_ssrseqvar; id = Prim.ident -> ArgVar (CAst.make ~loc:!@loc id) + | n = Prim.natural -> ArgArg (check_index ~loc:!@loc n) + ] ]; + ssrswap: [[ IDENT "first" -> !@loc, true | IDENT "last" -> !@loc, false ]]; + ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> tac ]]; + ssrseqarg: [ + [ arg = ssrswap -> noindex, swaptacarg arg + | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> i, (tac, def) + | i = ssrseqidx; arg = ssrswap -> i, swaptacarg arg + | tac = tactic_expr LEVEL "3" -> noindex, (mk_hint tac, None) + ] ]; +END + +let tactic_expr = Pltac.tactic_expr + +(** 1. Utilities *) + +(** Tactic-level diagnosis *) + +(* debug *) + +(* Let's play with the new proof engine API *) +let old_tac = V82.tactic + + +(** Name generation *)(* {{{ *******************************************************) + +(* Since Coq now does repeated internal checks of its external lexical *) +(* rules, we now need to carve ssreflect reserved identifiers out of *) +(* out of the user namespace. We use identifiers of the form _id_ for *) +(* this purpose, e.g., we "anonymize" an identifier id as _id_, adding *) +(* an extra leading _ if this might clash with an internal identifier. *) +(* We check for ssreflect identifiers in the ident grammar rule; *) +(* when the ssreflect Module is present this is normally an error, *) +(* but we provide a compatibility flag to reduce this to a warning. *) + +let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true + +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect identifiers"; + Goptions.optkey = ["SsrIdents"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !ssr_reserved_ids); + Goptions.optwrite = (fun b -> ssr_reserved_ids := b) + } + +let is_ssr_reserved s = + let n = String.length s in n > 2 && s.[0] = '_' && s.[n - 1] = '_' + +let ssr_id_of_string loc s = + if is_ssr_reserved s && is_ssr_loaded () then begin + if !ssr_reserved_ids then + CErrors.user_err ~loc (str ("The identifier " ^ s ^ " is reserved.")) + else if is_internal_name s then + Feedback.msg_warning (str ("Conflict between " ^ s ^ " and ssreflect internal names.")) + else Feedback.msg_warning (str ( + "The name " ^ s ^ " fits the _xxx_ format used for anonymous variables.\n" + ^ "Scripts with explicit references to anonymous variables are fragile.")) + end; Id.of_string s + +let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) + +let (!@) = Pcoq.to_coqloc + +GEXTEND Gram + GLOBAL: Prim.ident; + Prim.ident: [[ s = IDENT; ssr_null_entry -> ssr_id_of_string !@loc s ]]; +END + +let perm_tag = "_perm_Hyp_" +let _ = add_internal_name (is_tagged perm_tag) + +(* }}} *) + +(* We must not anonymize context names discharged by the "in" tactical. *) + +(** Tactical extensions. *)(* {{{ **************************************************) + +(* The TACTIC EXTEND facility can't be used for defining new user *) +(* tacticals, because: *) +(* - the concrete syntax must start with a fixed string *) +(* We use the following workaround: *) +(* - We use the (unparsable) "YouShouldNotTypeThis" token for tacticals that *) +(* don't start with a token, then redefine the grammar and *) +(* printer using GEXTEND and set_pr_ssrtac, respectively. *) + +type ssrargfmt = ArgSsr of string | ArgSep of string + +let ssrtac_name name = { + mltac_plugin = "ssreflect_plugin"; + mltac_tactic = "ssr" ^ name; +} + +let ssrtac_entry name n = { + mltac_name = ssrtac_name name; + mltac_index = n; +} + +let set_pr_ssrtac name prec afmt = (* FIXME *) () (* + let fmt = List.map (function + | ArgSep s -> Egramml.GramTerminal s + | ArgSsr s -> Egramml.GramTerminal s + | ArgCoq at -> Egramml.GramTerminal "COQ_ARG") afmt in + let tacname = ssrtac_name name in () *) + +let ssrtac_atom ?loc name args = TacML (Loc.tag ?loc (ssrtac_entry name 0, args)) +let ssrtac_expr ?loc name args = ssrtac_atom ?loc name args + +let tclintros_expr ?loc tac ipats = + let args = [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrintrosarg) (tac, ipats))] in + ssrtac_expr ?loc "tclintros" args + +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "1" [ RIGHTA + [ tac = tactic_expr; intros = ssrintros_ne -> tclintros_expr ~loc:!@loc tac intros + ] ]; +END + +(* }}} *) + + +(** Bracketing tactical *) + +(* The tactic pretty-printer doesn't know that some extended tactics *) +(* are actually tacticals. To prevent it from improperly removing *) +(* parentheses we override the parsing rule for bracketed tactic *) +(* expressions so that the pretty-print always reflects the input. *) +(* (Removing user-specified parentheses is dubious anyway). *) + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> Loc.tag ~loc:!@loc (Tacexp tac) ]]; + tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> TacArg arg ]]; +END + +(** The internal "done" and "ssrautoprop" tactics. *) + +(* For additional flexibility, "done" and "ssrautoprop" are *) +(* defined in Ltac. *) +(* Although we provide a default definition in ssreflect, *) +(* we look up the definition dynamically at each call point, *) +(* to allow for user extensions. "ssrautoprop" defaults to *) +(* trivial. *) + +let ssrautoprop gl = + try + let tacname = + try Tacenv.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) + with Not_found -> Tacenv.locate_tactic (ssrqid "ssrautoprop") in + let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl + with Not_found -> V82.of_tactic (Auto.full_trivial []) gl + +let () = ssrautoprop_tac := ssrautoprop + +let tclBY tac = Tacticals.tclTHEN tac (donetac ~-1) + +(** Tactical arguments. *) + +(* We have four kinds: simple tactics, [|]-bracketed lists, hints, and swaps *) +(* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) +(* and subgoal reordering tacticals (; first & ; last), respectively. *) + +(* Force use of the tactic_expr parsing entry, to rule out tick marks. *) + +(** The "by" tactical. *) + + +open Ssrfwd + +TACTIC EXTEND ssrtclby +| [ "by" ssrhintarg(tac) ] -> [ V82.tactic (hinttac ist true tac) ] +END + +(* }}} *) +(* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) +(* into a keyword in ssreflect.v; so we anticipate this in GEXTEND. *) + +GEXTEND Gram + GLOBAL: ssrhint simple_tactic; + ssrhint: [[ "by"; arg = ssrhintarg -> arg ]]; +END + +(** The "do" tactical. ********************************************************) + +(* +type ssrdoarg = ((ssrindex * ssrmmod) * ssrhint) * ssrclauses +*) +TACTIC EXTEND ssrtcldo +| [ "YouShouldNotTypeThis" "do" ssrdoarg(arg) ] -> [ V82.tactic (ssrdotac ist arg) ] +END +set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] + +let ssrdotac_expr ?loc n m tac clauses = + let arg = ((n, m), tac), clauses in + ssrtac_expr ?loc "tcldo" [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrdoarg) arg)] + +GEXTEND Gram + GLOBAL: tactic_expr; + ssrdotac: [ + [ tac = tactic_expr LEVEL "3" -> mk_hint tac + | tacs = ssrortacarg -> tacs + ] ]; + tactic_expr: LEVEL "3" [ RIGHTA + [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr ~loc:!@loc noindex m tac clauses + | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> + ssrdotac_expr ~loc:!@loc noindex Once tac clauses + | IDENT "do"; n = int_or_var; m = ssrmmod; + tac = ssrdotac; clauses = ssrclauses -> + ssrdotac_expr ~loc:!@loc (mk_index ~loc:!@loc n) m tac clauses + ] ]; +END +(* }}} *) + + +(* We can't actually parse the direction separately because this *) +(* would introduce conflicts with the basic ltac syntax. *) +let pr_ssrseqdir _ _ _ = function + | L2R -> str ";" ++ spc () ++ str "first " + | R2L -> str ";" ++ spc () ++ str "last " + +ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY pr_ssrseqdir +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +TACTIC EXTEND ssrtclseq +| [ "YouShouldNotTypeThis" ssrtclarg(tac) ssrseqdir(dir) ssrseqarg(arg) ] -> + [ V82.tactic (tclSEQAT ist tac dir arg) ] +END +set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] + +let tclseq_expr ?loc tac dir arg = + let arg1 = in_gen (rawwit wit_ssrtclarg) tac in + let arg2 = in_gen (rawwit wit_ssrseqdir) dir in + let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in + ssrtac_expr ?loc "tclseq" (List.map (fun x -> Tacexpr.TacGeneric x) [arg1; arg2; arg3]) + +GEXTEND Gram + GLOBAL: tactic_expr; + ssr_first: [ + [ tac = ssr_first; ipats = ssrintros_ne -> tclintros_expr ~loc:!@loc tac ipats + | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> TacFirst tacl + ] ]; + ssr_first_else: [ + [ tac1 = ssr_first; tac2 = ssrorelse -> TacOrelse (tac1, tac2) + | tac = ssr_first -> tac ]]; + tactic_expr: LEVEL "4" [ LEFTA + [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> + TacThen (tac1, tac2) + | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> + tclseq_expr ~loc:!@loc tac L2R arg + | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> + tclseq_expr ~loc:!@loc tac R2L arg + ] ]; +END +(* }}} *) + +(** 5. Bookkeeping tactics (clear, move, case, elim) *) + +(** Generalization (discharge) item *) + +(* An item is a switch + term pair. *) + +(* type ssrgen = ssrdocc * ssrterm *) + +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 ] +| [ cpattern(dt) ] -> [ nodocc, dt ] +END + +let has_occ ((_, occ), _) = occ <> None + +(** Generalization (discharge) sequence *) + +(* A discharge sequence is represented as a list of up to two *) +(* lists of d-items, plus an ident list set (the possibly empty *) +(* final clear switch). The main list is empty iff the command *) +(* is defective, and has length two if there is a sequence of *) +(* dependent terms (and in that case it is the first of the two *) +(* lists). Thus, the first of the two lists is never empty. *) + +(* type ssrgens = ssrgen list *) +(* type ssrdgens = ssrgens list * ssrclear *) + +let gens_sep = function [], [] -> mt | _ -> spc + +let pr_dgens pr_gen (gensl, clr) = + let prgens s gens = str s ++ pr_list spc pr_gen gens in + let prdeps deps = prgens ": " deps ++ spc () ++ str "/" in + match gensl with + | [deps; []] -> prdeps deps ++ pr_clear pr_spc clr + | [deps; gens] -> prdeps deps ++ prgens " " gens ++ pr_clear spc clr + | [gens] -> prgens ": " gens ++ pr_clear spc clr + | _ -> pr_clear pr_spc clr + +let pr_ssrdgens _ _ _ = pr_dgens pr_gen + +let cons_gen gen = function + | gens :: gensl, clr -> (gen :: gens) :: gensl, clr + | _ -> anomaly "missing gen list" + +let cons_dep (gensl, clr) = + if List.length gensl = 1 then ([] :: gensl, clr) else + CErrors.user_err (Pp.str "multiple dependents switches '/'") + +ARGUMENT EXTEND ssrdgens_tl TYPED AS ssrgen list list * ssrclear + PRINTED BY pr_ssrdgens +| [ "{" ne_ssrhyp_list(clr) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkclr clr, dt) dgens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> + [ [[]], clr ] +| [ "{" ssrocc(occ) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (mkocc occ, dt) dgens ] +| [ "/" ssrdgens_tl(dgens) ] -> + [ cons_dep dgens ] +| [ cpattern(dt) ssrdgens_tl(dgens) ] -> + [ cons_gen (nodocc, dt) dgens ] +| [ ] -> + [ [[]], [] ] +END + +ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY pr_ssrdgens +| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> [ cons_gen gen dgens ] +END + +(** Equations *) + +(* argument *) + +let pr_eqid = function Some pat -> str " " ++ pr_ipat pat | None -> mt () +let pr_ssreqid _ _ _ = pr_eqid + +(* We must use primitive parsing here to avoid conflicts with the *) +(* basic move, case, and elim tactics. *) +ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY pr_ssreqid +| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let accept_ssreqid strm = + match Util.stream_nth 0 strm with + | Tok.IDENT _ -> accept_before_syms [":"] strm + | Tok.KEYWORD ":" -> () + | Tok.KEYWORD pat when List.mem pat ["_"; "?"; "->"; "<-"] -> + accept_before_syms [":"] strm + | _ -> raise Stream.Failure + +let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid + +GEXTEND Gram + GLOBAL: ssreqid; + ssreqpat: [ + [ id = Prim.ident -> IPatId id + | "_" -> IPatAnon Drop + | "?" -> IPatAnon One + | occ = ssrdocc; "->" -> (match occ with + | None, occ -> IPatRewrite (occ, L2R) + | _ -> CErrors.user_err ~loc:!@loc (str"Only occurrences are allowed here")) + | occ = ssrdocc; "<-" -> (match occ with + | None, occ -> IPatRewrite (occ, R2L) + | _ -> CErrors.user_err ~loc:!@loc (str "Only occurrences are allowed here")) + | "->" -> IPatRewrite (allocc, L2R) + | "<-" -> IPatRewrite (allocc, R2L) + ]]; + ssreqid: [ + [ test_ssreqid; pat = ssreqpat -> Some pat + | test_ssreqid -> None + ]]; +END + +(** Bookkeeping (discharge-intro) argument *) + +(* Since all bookkeeping ssr commands have the same discharge-intro *) +(* argument format we use a single grammar entry point to parse them. *) +(* the entry point parses only non-empty arguments to avoid conflicts *) +(* with the basic Coq tactics. *) + +(* type ssrarg = ssrbwdview * (ssreqid * (ssrdgens * ssripats)) *) + +let pr_ssrarg _ _ _ (view, (eqid, (dgens, ipats))) = + let pri = pr_intros (gens_sep dgens) in + pr_view2 view ++ pr_eqid eqid ++ pr_dgens pr_gen dgens ++ pri ipats + +ARGUMENT EXTEND ssrarg TYPED AS ssrfwdview * (ssreqid * (ssrdgens * ssrintros)) + PRINTED BY pr_ssrarg +| [ ssrfwdview(view) ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ view, (eqid, (dgens, ipats)) ] +| [ ssrfwdview(view) ssrclear(clr) ssrintros(ipats) ] -> + [ view, (None, (([], clr), ipats)) ] +| [ ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> + [ [], (eqid, (dgens, ipats)) ] +| [ ssrclear_ne(clr) ssrintros(ipats) ] -> + [ [], (None, (([], clr), ipats)) ] +| [ ssrintros_ne(ipats) ] -> + [ [], (None, (([], []), ipats)) ] +END + +(** The "clear" tactic *) + +(* We just add a numeric version that clears the n top assumptions. *) + +TACTIC EXTEND ssrclear + | [ "clear" natural(n) ] -> [ tclIPAT (List.init n (fun _ -> IPatAnon Drop)) ] +END + +(** The "move" tactic *) + +(* TODO: review this, in particular the => _ and => [] cases *) +let rec improper_intros = function + | IPatSimpl _ :: ipats -> improper_intros ipats + | (IPatId _ | IPatAnon _ | IPatCase _ | IPatDispatch _) :: _ -> false + | _ -> true (* FIXME *) + +let check_movearg = function + | view, (eqid, _) when view <> [] && eqid <> None -> + CErrors.user_err (Pp.str "incompatible view and equation in move tactic") + | view, (_, (([gen :: _], _), _)) when view <> [] && has_occ gen -> + CErrors.user_err (Pp.str "incompatible view and occurrence switch in move tactic") + | _, (_, ((dgens, _), _)) when List.length dgens > 1 -> + CErrors.user_err (Pp.str "dependents switch `/' in move tactic") + | _, (eqid, (_, ipats)) when eqid <> None && improper_intros ipats -> + CErrors.user_err (Pp.str "no proper intro pattern for equation in move tactic") + | arg -> arg + +ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_movearg arg ] +END + +let movearg_of_parsed_movearg (v,(eq,(dg,ip))) = + (v,(eq,(ssrdgens_of_parsed_dgens dg,ip))) + +TACTIC EXTEND ssrmove +| [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> + [ ssrmovetac (movearg_of_parsed_movearg arg) <*> tclIPAT [pat] ] +| [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> + [ tclCLAUSES (ssrmovetac (movearg_of_parsed_movearg arg)) clauses ] +| [ "move" ssrrpat(pat) ] -> [ tclIPAT [pat] ] +| [ "move" ] -> [ ssrsmovetac ] +END + +let check_casearg = function +| view, (_, (([_; gen :: _], _), _)) when view <> [] && has_occ gen -> + CErrors.user_err (Pp.str "incompatible view and occurrence switch in dependent case tactic") +| arg -> arg + +ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY pr_ssrarg +| [ ssrarg(arg) ] -> [ check_casearg arg ] +END + +TACTIC EXTEND ssrcase +| [ "case" ssrcasearg(arg) ssrclauses(clauses) ] -> + [ tclCLAUSES (ssrcasetac (movearg_of_parsed_movearg arg)) clauses ] +| [ "case" ] -> [ ssrscasetoptac ] +END + +(** The "elim" tactic *) + +TACTIC EXTEND ssrelim +| [ "elim" ssrarg(arg) ssrclauses(clauses) ] -> + [ tclCLAUSES (ssrelimtac (movearg_of_parsed_movearg arg)) clauses ] +| [ "elim" ] -> [ ssrselimtoptac ] +END + +(** 6. Backward chaining tactics: apply, exact, congr. *) + +(** The "apply" tactic *) + +let pr_agen (docc, dt) = pr_docc docc ++ pr_term dt +let pr_ssragen _ _ _ = pr_agen +let pr_ssragens _ _ _ = pr_dgens pr_agen + +ARGUMENT EXTEND ssragen TYPED AS ssrdocc * ssrterm PRINTED BY pr_ssragen +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> [ mkclr clr, dt ] +| [ ssrterm(dt) ] -> [ nodocc, dt ] +END + +ARGUMENT EXTEND ssragens TYPED AS ssragen list list * ssrclear +PRINTED BY pr_ssragens +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (mkclr clr, dt) agens ] +| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ [[]], clr] +| [ ssrterm(dt) ssragens(agens) ] -> + [ cons_gen (nodocc, dt) agens ] +| [ ] -> [ [[]], [] ] +END + +let mk_applyarg views agens intros = views, (agens, intros) + +let pr_ssraarg _ _ _ (view, (dgens, ipats)) = + let pri = pr_intros (gens_sep dgens) in + pr_view view ++ pr_dgens pr_agen dgens ++ pri ipats + +ARGUMENT EXTEND ssrapplyarg +TYPED AS ssrbwdview * (ssragens * ssrintros) +PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg [] (cons_gen gen dgens) intros ] +| [ ssrclear_ne(clr) ssrintros(intros) ] -> + [ mk_applyarg [] ([], clr) intros ] +| [ ssrintros_ne(intros) ] -> + [ mk_applyarg [] ([], []) intros ] +| [ ssrbwdview(view) ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> + [ mk_applyarg view (cons_gen gen dgens) intros ] +| [ ssrbwdview(view) ssrclear(clr) ssrintros(intros) ] -> + [ mk_applyarg view ([], clr) intros ] + END + +TACTIC EXTEND ssrapply +| [ "apply" ssrapplyarg(arg) ] -> [ + let views, (gens_clr, intros) = arg in + inner_ssrapplytac views gens_clr ist <*> tclIPATssr intros ] +| [ "apply" ] -> [ apply_top_tac ] +END + +(** The "exact" tactic *) + +let mk_exactarg views dgens = mk_applyarg views dgens [] + +ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg +| [ ":" ssragen(gen) ssragens(dgens) ] -> + [ mk_exactarg [] (cons_gen gen dgens) ] +| [ ssrbwdview(view) ssrclear(clr) ] -> + [ mk_exactarg view ([], clr) ] +| [ ssrclear_ne(clr) ] -> + [ mk_exactarg [] ([], clr) ] +END + +let vmexacttac pf = + Goal.nf_enter begin fun gl -> + exact_no_check (EConstr.mkCast (pf, VMcast, Tacmach.New.pf_concl gl)) + end + +TACTIC EXTEND ssrexact +| [ "exact" ssrexactarg(arg) ] -> [ + let views, (gens_clr, _) = arg in + V82.tactic (tclBY (V82.of_tactic (inner_ssrapplytac views gens_clr ist))) ] +| [ "exact" ] -> [ + V82.tactic (Tacticals.tclORELSE (donetac ~-1) (tclBY (V82.of_tactic apply_top_tac))) ] +| [ "exact" "<:" lconstr(pf) ] -> [ vmexacttac pf ] +END + +(** The "congr" tactic *) + +(* type ssrcongrarg = open_constr * (int * constr) *) + +let pr_ssrcongrarg _ _ _ ((n, f), dgens) = + (if n <= 0 then mt () else str " " ++ int n) ++ + str " " ++ pr_term f ++ pr_dgens pr_gen dgens + +ARGUMENT EXTEND ssrcongrarg TYPED AS (int * ssrterm) * ssrdgens + PRINTED BY pr_ssrcongrarg +| [ natural(n) constr(c) ssrdgens(dgens) ] -> [ (n, mk_term xNoFlag c), dgens ] +| [ natural(n) constr(c) ] -> [ (n, mk_term xNoFlag c),([[]],[]) ] +| [ constr(c) ssrdgens(dgens) ] -> [ (0, mk_term xNoFlag c), dgens ] +| [ constr(c) ] -> [ (0, mk_term xNoFlag c), ([[]],[]) ] +END + + + +TACTIC EXTEND ssrcongr +| [ "congr" ssrcongrarg(arg) ] -> +[ let arg, dgens = arg in + V82.tactic begin + match dgens with + | [gens], clr -> Tacticals.tclTHEN (genstac (gens,clr)) (newssrcongrtac arg ist) + | _ -> errorstrm (str"Dependent family abstractions not allowed in congr") + end] +END + +(** 7. Rewriting tactics (rewrite, unlock) *) + +(** Coq rewrite compatibility flag *) + +(** Rewrite clear/occ switches *) + +let pr_rwocc = function + | None, None -> mt () + | None, occ -> pr_occ occ + | Some clr, _ -> pr_clear_ne clr + +let pr_ssrrwocc _ _ _ = pr_rwocc + +ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY pr_ssrrwocc +| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +| [ ] -> [ noclr ] +END + +(** Rewrite rules *) + +let pr_rwkind = function + | RWred s -> pr_simpl s + | RWdef -> str "/" + | RWeq -> mt () + +let wit_ssrrwkind = add_genarg "ssrrwkind" pr_rwkind + +let pr_rule = function + | RWred s, _ -> pr_simpl s + | RWdef, r-> str "/" ++ pr_term r + | RWeq, r -> pr_term r + +let pr_ssrrule _ _ _ = pr_rule + +let noruleterm loc = mk_term xNoFlag (mkCProp loc) + +ARGUMENT EXTEND ssrrule_ne TYPED AS ssrrwkind * ssrterm PRINTED BY pr_ssrrule + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +GEXTEND Gram + GLOBAL: ssrrule_ne; + ssrrule_ne : [ + [ test_not_ssrslashnum; x = + [ "/"; t = ssrterm -> RWdef, t + | t = ssrterm -> RWeq, t + | s = ssrsimpl_ne -> RWred s, noruleterm (Some !@loc) + ] -> x + | s = ssrsimpl_ne -> RWred s, noruleterm (Some !@loc) + ]]; +END + +ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY pr_ssrrule + | [ ssrrule_ne(r) ] -> [ r ] + | [ ] -> [ RWred Nop, noruleterm (Some loc) ] +END + +(** Rewrite arguments *) + +let pr_option f = function None -> mt() | Some x -> f x +let pr_pattern_squarep= pr_option (fun r -> str "[" ++ pr_rpattern r ++ str "]") +let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep +let pr_rwarg ((d, m), ((docc, rx), r)) = + pr_rwdir d ++ pr_mult m ++ pr_rwocc docc ++ pr_pattern_squarep rx ++ pr_rule r + +let pr_ssrrwarg _ _ _ = pr_rwarg + +ARGUMENT EXTEND ssrpattern_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] + | [ ] -> [ None ] +END + +ARGUMENT EXTEND ssrpattern_ne_squarep +TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep + | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] +END + + +ARGUMENT EXTEND ssrrwarg + TYPED AS (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) + PRINTED BY pr_ssrrwarg + | [ "-" ssrmult(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (R2L, m) (docc, rx) r ] + | [ "-/" ssrterm(t) ] -> (* just in case '-/' should become a token *) + [ mk_rwarg (R2L, nomult) norwocc (RWdef, t) ] + | [ ssrmult_ne(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg (L2R, m) (docc, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkclr clr, rx) r ] + | [ "{" ne_ssrhyp_list(clr) "}" ssrrule(r) ] -> + [ mk_rwarg norwmult (mkclr clr, None) r ] + | [ "{" ssrocc(occ) "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (mkocc occ, rx) r ] + | [ "{" "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (nodocc, rx) r ] + | [ ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> + [ mk_rwarg norwmult (noclr, rx) r ] + | [ ssrrule_ne(r) ] -> + [ mk_rwarg norwmult norwocc r ] +END + +TACTIC EXTEND ssrinstofruleL2R +| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> [ V82.tactic (ssrinstancesofrule ist L2R arg) ] +END +TACTIC EXTEND ssrinstofruleR2L +| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> [ V82.tactic (ssrinstancesofrule ist R2L arg) ] +END + +(** Rewrite argument sequence *) + +(* type ssrrwargs = ssrrwarg list *) + +let pr_ssrrwargs _ _ _ rwargs = pr_list spc pr_rwarg rwargs + +ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY pr_ssrrwargs + | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +END + +let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true + +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect rewrite"; + Goptions.optkey = ["SsrRewrite"]; + Goptions.optread = (fun _ -> !ssr_rw_syntax); + Goptions.optdepr = false; + Goptions.optwrite = (fun b -> ssr_rw_syntax := b) } + +let test_ssr_rw_syntax = + let test strm = + if not !ssr_rw_syntax then raise Stream.Failure else + if is_ssr_loaded () then () else + match Util.stream_nth 0 strm with + | Tok.KEYWORD key when List.mem key.[0] ['{'; '['; '/'] -> () + | _ -> raise Stream.Failure in + Gram.Entry.of_parser "test_ssr_rw_syntax" test + +GEXTEND Gram + GLOBAL: ssrrwargs; + ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> a ]]; +END + +(** The "rewrite" tactic *) + +TACTIC EXTEND ssrrewrite + | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> + [ tclCLAUSES (old_tac (ssrrewritetac ist args)) clauses ] +END + +(** The "unlock" tactic *) + +let pr_unlockarg (occ, t) = pr_occ occ ++ pr_term t +let pr_ssrunlockarg _ _ _ = pr_unlockarg + +ARGUMENT EXTEND ssrunlockarg TYPED AS ssrocc * ssrterm + PRINTED BY pr_ssrunlockarg + | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> [ occ, t ] + | [ ssrterm(t) ] -> [ None, t ] +END + +let pr_ssrunlockargs _ _ _ args = pr_list spc pr_unlockarg args + +ARGUMENT EXTEND ssrunlockargs TYPED AS ssrunlockarg list + PRINTED BY pr_ssrunlockargs + | [ ssrunlockarg_list(args) ] -> [ args ] +END + +TACTIC EXTEND ssrunlock + | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> + [ tclCLAUSES (old_tac (unlocktac ist args)) clauses ] +END + +(** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) + + +TACTIC EXTEND ssrpose +| [ "pose" ssrfixfwd(ffwd) ] -> [ V82.tactic (ssrposetac ffwd) ] +| [ "pose" ssrcofixfwd(ffwd) ] -> [ V82.tactic (ssrposetac ffwd) ] +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> [ V82.tactic (ssrposetac (id, fwd)) ] +END + +(** The "set" tactic *) + +(* type ssrsetfwd = ssrfwd * ssrdocc *) + +TACTIC EXTEND ssrset +| [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> + [ tclCLAUSES (old_tac (ssrsettac id fwd)) clauses ] +END + +(** The "have" tactic *) + +(* type ssrhavefwd = ssrfwd * ssrhint *) + + +(* Pltac. *) + +(* The standard TACTIC EXTEND does not work for abstract *) +GEXTEND Gram + GLOBAL: tactic_expr; + tactic_expr: LEVEL "3" + [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> + ssrtac_expr ~loc:!@loc "abstract" + [Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] ]]; +END +TACTIC EXTEND ssrabstract +| [ "abstract" ssrdgens(gens) ] -> [ + if List.length (fst gens) <> 1 then + errorstrm (str"dependents switches '/' not allowed here"); + Ssripats.ssrabstract (ssrdgens_of_parsed_dgens gens) ] +END + +TACTIC EXTEND ssrhave +| [ "have" ssrhavefwdwbinders(fwd) ] -> + [ V82.tactic (havetac ist fwd false false) ] +END + +TACTIC EXTEND ssrhavesuff +| [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrhavesuffices +| [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ V82.tactic (havetac ist (false,(pats,fwd)) true false) ] +END + +TACTIC EXTEND ssrsuffhave +| [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +TACTIC EXTEND ssrsufficeshave +| [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> + [ V82.tactic (havetac ist (false,(pats,fwd)) true true) ] +END + +(** The "suffice" tactic *) + +let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint + +ARGUMENT EXTEND ssrsufffwd + TYPED AS ssrhpats * (ssrfwd * ssrhint) PRINTED BY pr_ssrsufffwdwbinders +| [ ssrhpats(pats) ssrbinder_list(bs) ":" ast_closure_lterm(t) ssrhint(hint) ] -> + [ let ((clr, pats), binders), simpl = pats in + let allbs = intro_id_to_binder binders @ bs in + let allbinders = binders @ List.flatten (binder_to_intro_id bs) in + let fwd = mkFwdHint ":" t in + (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) ] +END + + +TACTIC EXTEND ssrsuff +| [ "suff" ssrsufffwd(fwd) ] -> [ V82.tactic (sufftac ist fwd) ] +END + +TACTIC EXTEND ssrsuffices +| [ "suffices" ssrsufffwd(fwd) ] -> [ V82.tactic (sufftac ist fwd) ] +END + +(** The "wlog" (Without Loss Of Generality) tactic *) + +(* type ssrwlogfwd = ssrwgen list * ssrfwd *) + +let pr_ssrwlogfwd _ _ _ (gens, t) = + str ":" ++ pr_list mt pr_wgen gens ++ spc() ++ pr_fwd t + +ARGUMENT EXTEND ssrwlogfwd TYPED AS ssrwgen list * ssrfwd + PRINTED BY pr_ssrwlogfwd +| [ ":" ssrwgen_list(gens) "/" ast_closure_lterm(t) ] -> [ gens, mkFwdHint "/" t] +END + + +TACTIC EXTEND ssrwlog +| [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwlogs +| [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwlogss +| [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutloss +| [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlosss +| [ "without" "loss" "suff" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +TACTIC EXTEND ssrwithoutlossss +| [ "without" "loss" "suffices" + ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> + [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] +END + +(* Generally have *) +let pr_idcomma _ _ _ = function + | None -> mt() + | Some None -> str"_, " + | Some (Some id) -> pr_id id ++ str", " + +ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY pr_idcomma + | [ ] -> [ None ] +END + +let accept_idcomma strm = + match stream_nth 0 strm with + | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm + | _ -> raise Stream.Failure + +let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma + +GEXTEND Gram + GLOBAL: ssr_idcomma; + ssr_idcomma: [ [ test_idcomma; + ip = [ id = IDENT -> Some (Id.of_string id) | "_" -> None ]; "," -> + Some ip + ] ]; +END + +let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) + +TACTIC EXTEND ssrgenhave +| [ "gen" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +END + +TACTIC EXTEND ssrgenhave2 +| [ "generally" "have" ssrclear(clr) + ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> + [ let pats = augment_preclr clr pats in + V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] +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/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli new file mode 100644 index 00000000..2ac7c7e2 --- /dev/null +++ b/plugins/ssr/ssrparser.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ltac_plugin + +val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry +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 ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry +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 add_genarg : string -> ('a -> Pp.t) -> 'a Genarg.uniform_genarg_type + +(* Parsing witnesses, needed to serialize ssreflect syntax *) +open Ssrmatching_plugin +open Ssrmatching +open Ssrast +open Ssrequality + +val wit_ssrrwargs : ssrrwarg list Genarg.uniform_genarg_type +val wit_ssrclauses : clauses Genarg.uniform_genarg_type +val wit_ssrcasearg : (cpattern ssragens) ssrmovearg Genarg.uniform_genarg_type +val wit_ssrmovearg : (cpattern ssragens) ssrmovearg Genarg.uniform_genarg_type +val wit_ssrapplyarg : ssrapplyarg Genarg.uniform_genarg_type +val wit_ssrhavefwdwbinders : + (Tacexpr.raw_tactic_expr fwdbinders, Tacexpr.glob_tactic_expr fwdbinders, Tacinterp.Value.t fwdbinders) Genarg.genarg_type diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml new file mode 100644 index 00000000..11369228 --- /dev/null +++ b/plugins/ssr/ssrprinters.ml @@ -0,0 +1,130 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Pp +open Names +open Printer +open Tacmach + +open Ssrmatching_plugin +open Ssrast + +let pr_spc () = str " " +let pr_bar () = Pp.cut() ++ str "|" +let pr_list = prlist_with_sep + +let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> + hd ++ List.fold_left (fun acc x -> acc ++ sep ++ x) x xs + +let pp_term gl t = + let t = Reductionops.nf_evar (project gl) t in pr_econstr_env (pf_env gl) (project gl) t + +(* FIXME *) +(* terms are pre constr, the kind is parsing/printing flag to distinguish + * between x, @x and (x). It affects automatic clear and let-in preservation. + * Cpattern is a temporary flag that becomes InParens ASAP. *) +(* type ssrtermkind = InParens | WithAt | NoFlag | Cpattern *) +let xInParens = '(' +let xWithAt = '@' +let xNoFlag = ' ' +let xCpattern = 'x' + +(* 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 = xInParens + +(* We also guard characters that might interfere with the ssreflect *) +(* tactic syntax. *) +let pr_guarded guard prc c = + pp_with Format.str_formatter (prc c); + let s = Format.flush_str_formatter () ^ "$" in + if guard s (skip_wschars s 0) then pr_paren prc c else prc c + +let prl_constr_expr = Ppconstr.pr_lconstr_expr +let pr_glob_constr c = Printer.pr_glob_constr_env (Global.env ()) c +let prl_glob_constr c = Printer.pr_lglob_constr_env (Global.env ()) c +let pr_glob_constr_and_expr = function + | _, Some c -> Ppconstr.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 pr_hyp (SsrHyp (_, id)) = Id.print id +let pr_hyps = pr_list pr_spc pr_hyp + +let pr_occ = function + | Some (true, occ) -> str "{-" ++ pr_list pr_spc int occ ++ str "}" + | Some (false, occ) -> str "{+" ++ pr_list pr_spc int occ ++ str "}" + | None -> str "{}" + +let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" +let pr_clear sep clr = if clr = [] then mt () else sep () ++ pr_clear_ne clr + +let pr_dir = function L2R -> str "->" | R2L -> str "<-" + +let pr_simpl = function + | Simpl -1 -> str "/=" + | Cut -1 -> str "//" + | Simpl n -> str "/" ++ int n ++ str "=" + | Cut n -> str "/" ++ int n ++ str"/" + | SimplCut (-1,-1) -> str "//=" + | SimplCut (n,-1) -> str "/" ++ int n ++ str "/=" + | SimplCut (-1,n) -> str "//" ++ int n ++ str "=" + | SimplCut (n,m) -> str "/" ++ int n ++ str "/" ++ int m ++ str "=" + | Nop -> mt () + +(* New terms *) + +let pr_ast_closure_term { body } = Ppconstr.pr_constr_expr body + +let pr_view2 = pr_list mt (fun c -> str "/" ++ pr_ast_closure_term c) + +let rec pr_ipat p = + match p with + | IPatId id -> Id.print id + | 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 "]") + | 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 + | IPatNoop -> str "-" + | IPatAbstractVars l -> str "[:" ++ pr_list spc Id.print l ++ str "]" + | IPatTac _ -> str "<tac>" +(* TODO | IPatAnon Temporary -> str "+" *) +and pr_ipats ipats = pr_list spc pr_ipat ipats +and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat + +(* 0 cost pp function. Active only if Debug Ssreflect is Set *) +let ppdebug_ref = ref (fun _ -> ()) +let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) +let _ = + Goptions.declare_bool_option + { Goptions.optname = "ssreflect debugging"; + Goptions.optkey = ["Debug";"Ssreflect"]; + Goptions.optdepr = false; + Goptions.optread = (fun _ -> !ppdebug_ref == ssr_pp); + Goptions.optwrite = (fun b -> + Ssrmatching.debug b; + if b then ppdebug_ref := ssr_pp else ppdebug_ref := fun _ -> ()) } +let ppdebug s = !ppdebug_ref s diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli new file mode 100644 index 00000000..31c360ad --- /dev/null +++ b/plugins/ssr/ssrprinters.mli @@ -0,0 +1,59 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ssrast + +val pp_term : + Goal.goal Evd.sigma -> EConstr.constr -> Pp.t + +val pr_spc : unit -> Pp.t +val pr_bar : unit -> Pp.t +val pr_list : + (unit -> Pp.t) -> ('a -> Pp.t) -> 'a list -> Pp.t + +val pp_concat : + Pp.t -> + ?sep:Pp.t -> Pp.t list -> Pp.t + +val xInParens : ssrtermkind +val xWithAt : ssrtermkind +val xNoFlag : ssrtermkind +val xCpattern : ssrtermkind + +val pr_clear : (unit -> Pp.t) -> ssrclear -> Pp.t +val pr_clear_ne : ssrclear -> Pp.t +val pr_dir : ssrdir -> Pp.t +val pr_simpl : ssrsimpl -> Pp.t + +val pr_term : + ssrtermkind * (Glob_term.glob_constr * Constrexpr.constr_expr option) -> + Pp.t + +val pr_ast_closure_term : ast_closure_term -> Pp.t +val pr_view2 : ast_closure_term list -> Pp.t +val pr_ipat : ssripat -> Pp.t +val pr_ipats : ssripats -> Pp.t +val pr_iorpat : ssripatss -> Pp.t + +val pr_hyp : ssrhyp -> Pp.t +val pr_hyps : ssrhyps -> Pp.t + +val prl_constr_expr : Constrexpr.constr_expr -> Pp.t +val prl_glob_constr : Glob_term.glob_constr -> Pp.t + +val pr_guarded : + (string -> int -> bool) -> ('a -> Pp.t) -> 'a -> Pp.t + +val pr_occ : ssrocc -> Pp.t + +val ppdebug : Pp.t Lazy.t -> unit + diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml new file mode 100644 index 00000000..9cc4f5ce --- /dev/null +++ b/plugins/ssr/ssrtacticals.ml @@ -0,0 +1,165 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +open Termops +open Tacmach +open Misctypes +open Locusops + +open Ssrast +open Ssrcommon + +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + +(** Tacticals (+, -, *, done, by, do, =>, first, and last). *) + +let get_index = function ArgArg i -> i | _ -> + anomaly "Uninterpreted index" +(* Toplevel constr must be globalized twice ! *) + +(** The "first" and "last" tacticals. *) + +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 rot_hyps dir i hyps = + let n = List.length hyps in + if i = 0 then List.rev hyps else + if i > n then CErrors.user_err (Pp.str "Not enough subgoals") else + let rec rot i l_hyps = function + | hyp :: hyps' when i > 0 -> rot (i - 1) (hyp :: l_hyps) hyps' + | hyps' -> hyps' @ (List.rev l_hyps) in + rot (match dir with L2R -> i | R2L -> n - i) [] hyps + +let tclSEQAT ist atac1 dir (ivar, ((_, atacs2), atac3)) = + let i = get_index ivar in + let evtac t = Proofview.V82.of_tactic (ssrevaltac ist t) in + let tac1 = evtac atac1 in + if atacs2 = [] && atac3 <> None then tclPERM (rot_hyps dir i) tac1 else + let evotac = function Some atac -> evtac atac | _ -> Tacticals.tclIDTAC in + let tac3 = evotac atac3 in + let rec mk_pad n = if n > 0 then tac3 :: mk_pad (n - 1) else [] in + match dir, mk_pad (i - 1), List.map evotac atacs2 with + | L2R, [], [tac2] when atac3 = None -> Tacticals.tclTHENFIRST tac1 tac2 + | L2R, [], [tac2] when atac3 = None -> Tacticals.tclTHENLAST tac1 tac2 + | L2R, pad, tacs2 -> Tacticals.tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 + | R2L, pad, tacs2 -> Tacticals.tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) + +(** The "in" pseudo-tactical *)(* {{{ **********************************************) + +let hidden_goal_tag = "the_hidden_goal" + +let check_wgen_uniq gens = + let clears = List.flatten (List.map fst gens) in + check_hyps_uniq [] clears; + let ids = CList.map_filter + (function (_,Some ((id,_),_)) -> Some (hoi_id id) | _ -> None) gens in + let rec check ids = function + | id :: _ when List.mem id ids -> + errorstrm Pp.(str"Duplicate generalization " ++ Id.print id) + | id :: hyps -> check (id :: ids) hyps + | [] -> () in + check [] ids + +let pf_clauseids gl gens clseq = + let keep_clears = List.map (fun (x, _) -> x, None) in + if gens <> [] then (check_wgen_uniq gens; gens) else + if clseq <> InAll && clseq <> InAllHyps then keep_clears gens else + CErrors.user_err (Pp.str "assumptions should be named explicitly") + +let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false + +let settac id c = Tactics.letin_tac None (Name id) c None +let posetac id cl = Proofview.V82.of_tactic (settac id cl nowhere) + +let hidetacs clseq idhide cl0 = + if not (hidden_clseq clseq) then [] else + [posetac idhide cl0; + Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkVar idhide))] + +let endclausestac id_map clseq gl_id cl0 gl = + let not_hyp' id = not (List.mem_assoc id id_map) in + let orig_id id = try List.assoc id id_map with Not_found -> id in + let dc, c = EConstr.decompose_prod_assum (project gl) (pf_concl gl) in + let hide_goal = hidden_clseq clseq in + let c_hidden = + hide_goal && EConstr.eq_constr (project gl) c (EConstr.mkVar gl_id) in + let rec fits forced = function + | (id, _) :: ids, decl :: dc' when RelDecl.get_name decl = Name id -> + fits true (ids, dc') + | 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 -> + EConstr.mkProd (Name (orig_id id), unmark t, unmark c') + | Term.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 = + Proofview.V82.of_tactic + (Tactics.convert_hyp_no_check (NamedDecl.map_constr unmark hyp)) in + let utacs = List.map utac (pf_hyps gl) in + let ugtac gl' = + Proofview.V82.of_tactic + (convert_concl_no_check (unmark (pf_concl gl'))) gl' in + let ctacs = + if hide_goal then [Proofview.V82.of_tactic (Tactics.clear [gl_id])] + else [] in + let mktac itacs = Tacticals.tclTHENLIST (itacs @ utacs @ ugtac :: ctacs) in + let itac (_, id) = Proofview.V82.of_tactic (Tactics.introduction id) in + if fits false (id_map, List.rev dc) then mktac (List.map itac id_map) gl else + let all_ids = ids_of_rel_context dc @ pf_ids_of_hyps gl in + if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else + errorstrm Pp.(str "tampering with discharged assumptions of \"in\" tactical") + +let tclCLAUSES tac (gens, clseq) gl = + if clseq = InGoal || clseq = InSeqGoal then tac gl else + let clr_gens = pf_clauseids gl gens clseq in + let clear = Tacticals.tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in + let gl_id = mk_anon_id hidden_goal_tag (Tacmach.pf_ids_of_hyps gl) in + let cl0 = pf_concl gl in + let dtac gl = + let c = pf_concl gl in + let gl, args, c = + List.fold_right (abs_wgen true mk_discharged_id) gens (gl,[], c) in + apply_type c args gl in + let endtac = + let id_map = CList.map_filter (function + | _, Some ((x,_),_) -> let id = hoi_id x in Some (mk_discharged_id id, id) + | _, None -> None) gens in + endclausestac id_map clseq gl_id cl0 in + Tacticals.tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) gl + +(** The "do" tactical. ********************************************************) + +let hinttac ist is_by (is_or, atacs) = + let dtac = if is_by then donetac ~-1 else Tacticals.tclIDTAC in + let mktac = function + | Some atac -> Tacticals.tclTHEN (Proofview.V82.of_tactic (ssrevaltac ist atac)) dtac + | _ -> dtac in + match List.map mktac atacs with + | [] -> if is_or then dtac else Tacticals.tclIDTAC + | [tac] -> tac + | tacs -> Tacticals.tclFIRST tacs + +let ssrdotac ist (((n, m), tac), clauses) = + let mul = get_index n, m in + tclCLAUSES (tclMULT mul (hinttac ist false tac)) clauses + +let tclCLAUSES tac g_c = + Proofview.V82.(tactic (tclCLAUSES (of_tactic tac) g_c)) diff --git a/plugins/ssr/ssrtacticals.mli b/plugins/ssr/ssrtacticals.mli new file mode 100644 index 00000000..a5636ad0 --- /dev/null +++ b/plugins/ssr/ssrtacticals.mli @@ -0,0 +1,48 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Ltac_plugin +open Ssrmatching_plugin + +val tclSEQAT : + Tacinterp.interp_sign -> + Tacinterp.Value.t -> + Ssrast.ssrdir -> + int Misctypes.or_var * + (('a * Tacinterp.Value.t option list) * + Tacinterp.Value.t option) -> + Tacmach.tactic + +val tclCLAUSES : + unit Proofview.tactic -> + (Ssrast.ssrhyps * + ((Ssrast.ssrhyp_or_id * string) * + Ssrmatching.cpattern option) + option) + list * Ssrast.ssrclseq -> + unit Proofview.tactic + +val hinttac : + Tacinterp.interp_sign -> + bool -> bool * Tacinterp.Value.t option list -> Ssrast.v82tac + +val ssrdotac : + Tacinterp.interp_sign -> + ((int Misctypes.or_var * Ssrast.ssrmmod) * + (bool * Tacinterp.Value.t option list)) * + ((Ssrast.ssrhyps * + ((Ssrast.ssrhyp_or_id * string) * + Ssrmatching.cpattern option) + option) + list * Ssrast.ssrclseq) -> + Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 new file mode 100644 index 00000000..05dbf0a8 --- /dev/null +++ b/plugins/ssr/ssrvernac.ml4 @@ -0,0 +1,627 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +open Names +module CoqConstr = Constr +open CoqConstr +open Termops +open Constrexpr +open Constrexpr_ops +open Pcoq +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.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 +open Util +open Extraargs +open Evar_kinds +open Ssrprinters +open Ssrcommon +open Ssrparser +DECLARE PLUGIN "ssreflect_plugin" + +let (!@) = Pcoq.to_coqloc + +(* Defining grammar rules with "xx" in it automatically declares keywords too, + * we thus save the lexer to restore it at the end of the file *) +let frozen_lexer = CLexer.get_keyword_state () ;; + +(* global syntactic changes and vernacular commands *) + +(** Alternative notations for "match" and anonymous arguments. *)(* {{{ ************) + +(* Syntax: *) +(* if <term> is <pattern> then ... else ... *) +(* if <term> is <pattern> [in ..] return ... then ... else ... *) +(* let: <pattern> := <term> in ... *) +(* let: <pattern> [in ...] := <term> return ... in ... *) +(* The scope of a top-level 'as' in the pattern extends over the *) +(* 'return' type (dependent if/let). *) +(* Note that the optional "in ..." appears next to the <pattern> *) +(* rather than the <term> in then "let:" syntax. The alternative *) +(* would lead to ambiguities in, e.g., *) +(* let: p1 := (*v---INNER LET:---v *) *) +(* let: p2 := let: p3 := e3 in k return t in k2 in k1 return t' *) +(* in b (*^--ALTERNATIVE INNER LET--------^ *) *) + +(* Caveat : There is no pretty-printing support, since this would *) +(* require a modification to the Coq kernel (adding a new match *) +(* display style -- why aren't these strings?); also, the v8.1 *) +(* pretty-printer only allows extension hooks for printing *) +(* integer or string literals. *) +(* Also note that in the v8 grammar "is" needs to be a keyword; *) +(* as this can't be done from an ML extension file, the new *) +(* syntax will only work when ssreflect.v is imported. *) + +let no_ct = None, None and no_rt = None in +let aliasvar = function + | [[{ CAst.v = CPatAlias (_, na); loc }]] -> Some na + | _ -> None in +let mk_cnotype mp = aliasvar mp, None in +let mk_ctype mp t = aliasvar mp, Some t in +let mk_rtype t = Some t in +let mk_dthen ?loc (mp, ct, rt) c = (CAst.make ?loc (mp, c)), ct, rt in +let mk_let ?loc rt ct mp c1 = + CAst.make ?loc @@ CCases (LetPatternStyle, rt, ct, [CAst.make ?loc (mp, c1)]) in +let mk_pat c (na, t) = (c, na, t) in +GEXTEND Gram + GLOBAL: binder_constr; + ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> mk_rtype t ]]; + ssr_mpat: [[ p = pattern -> [[p]] ]]; + ssr_dpat: [ + [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> mp, mk_ctype mp t, rt + | mp = ssr_mpat; rt = ssr_rtype -> mp, mk_cnotype mp, rt + | mp = ssr_mpat -> mp, no_ct, no_rt + ] ]; + ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> mk_dthen ~loc:!@loc dp c ]]; + ssr_elsepat: [[ "else" -> [[CAst.make ~loc:!@loc @@ CPatAtom None]] ]]; + ssr_else: [[ mp = ssr_elsepat; c = lconstr -> CAst.make ~loc:!@loc (mp, c) ]]; + binder_constr: [ + [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in CAst.make ~loc:!@loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) + | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> + let b1, ct, rt = db1 in + let b1, b2 = let open CAst in + let {loc=l1; v=(p1, r1)}, {loc=l2; v=(p2, r2)} = b1, b2 in + (make ?loc:l1 (p1, r2), make ?loc:l2 (p2, r1)) + in + CAst.make ~loc:!@loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; "in"; c1 = lconstr -> + mk_let ~loc:!@loc no_rt [mk_pat c no_ct] mp c1 + | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let ~loc:!@loc rt [mk_pat c (mk_cnotype mp)] mp c1 + | "let"; ":"; mp = ssr_mpat; "in"; t = pattern; ":="; c = lconstr; + rt = ssr_rtype; "in"; c1 = lconstr -> + mk_let ~loc:!@loc rt [mk_pat c (mk_ctype mp t)] mp c1 + ] ]; +END + +GEXTEND Gram + GLOBAL: closed_binder; + closed_binder: [ + [ ["of" | "&"]; c = operconstr LEVEL "99" -> + [CLocalAssum ([CAst.make ~loc:!@loc Anonymous], Default Explicit, c)] + ] ]; +END +(* }}} *) + +(** Vernacular commands: Prenex Implicits and Search *)(* {{{ **********************) + +(* This should really be implemented as an extension to the implicit *) +(* arguments feature, but unfortuately that API is sealed. The current *) +(* workaround uses a combination of notations that works reasonably, *) +(* with the following caveats: *) +(* - The pretty-printing always elides prenex implicits, even when *) +(* they are obviously needed. *) +(* - Prenex Implicits are NEVER exported from a module, because this *) +(* would lead to faulty pretty-printing and scoping errors. *) +(* - The command "Import Prenex Implicits" can be used to reassert *) +(* Prenex Implicits for all the visible constants that had been *) +(* declared as Prenex Implicits. *) + +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 + 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) + | _ -> [] in + let impls = + match Impargs.implicits_of_global fref with + | [cond,impls] -> impls + | [] -> errorstrm (str "Expected some implicits for " ++ pr_reference f) + | _ -> errorstrm (str "Multiple implicits not supported") in + match loop impls with + | [] -> + errorstrm (str "Expected some implicits for " ++ pr_reference f) + | impls -> + Impargs.declare_manual_implicits locality fref ~enriching:false [impls] + +VERNAC COMMAND FUNCTIONAL EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF + | [ "Prenex" "Implicits" ne_global_list(fl) ] + -> [ fun ~atts ~st -> + let open Vernacinterp in + let locality = Locality.make_section_locality atts.locality in + List.iter (declare_one_prenex_implicit locality) fl; + st + ] +END + +(* Vernac grammar visibility patch *) + +GEXTEND Gram + GLOBAL: gallina_ext; + gallina_ext: + [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> + Vernacexpr.VernacUnsetOption (false, ["Printing"; "Implicit"; "Defensive"]) + ] ] + ; +END + +(** Extend Search to subsume SearchAbout, also adding hidden Type coercions. *) + +(* Main prefilter *) + +type raw_glob_search_about_item = + | RGlobSearchSubPattern of constr_expr + | RGlobSearchString of Loc.t * string * string option + +let pr_search_item = function + | RGlobSearchString (_,s,_) -> str s + | RGlobSearchSubPattern p -> pr_constr_expr p + +let wit_ssr_searchitem = add_genarg "ssr_searchitem" pr_search_item + +let pr_ssr_search_item _ _ _ = pr_search_item + +(* Workaround the notation API that can only print notations *) + +let is_ident s = try CLexer.check_ident s; true with _ -> false + +let is_ident_part s = is_ident ("H" ^ s) + +let interp_search_notation ?loc tag okey = + let err msg = CErrors.user_err ?loc ~hdr:"interp_search_notation" msg in + let mk_pntn s for_key = + let n = String.length s in + let s' = Bytes.make (n + 2) ' ' in + let rec loop i i' = + if i >= n then s', i' - 2 else if s.[i] = ' ' then loop (i + 1) i' else + let j = try String.index_from s (i + 1) ' ' with _ -> n in + let m = j - i in + if s.[i] = '\'' && i < j - 2 && s.[j - 1] = '\'' then + (String.blit s (i + 1) s' i' (m - 2); loop (j + 1) (i' + m - 1)) + else if for_key && is_ident (String.sub s i m) then + (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 pr_and_list pr = function + | [x] -> pr x + | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x + | [] -> mt () in + let pr_sc sc = str (if sc = "" then "independently" else sc) in + let pr_scs = function + | [""] -> pr_sc "" + | scs -> str "in " ++ pr_and_list pr_sc scs in + let generator, pr_tag_sc = + let ign _ = mt () in match okey with + | Some key -> + let sc = Notation.find_delimiters_scope ?loc key in + let pr_sc s_in = str s_in ++ spc() ++ str sc ++ pr_comma() in + Notation.pr_scope ign sc, pr_sc + | None -> Notation.pr_scopes ign, ign in + let qtag s_in = pr_tag_sc s_in ++ qstring tag ++ spc()in + let ptag, ttag = + let ptag, m = mk_pntn tag false in + if m <= 0 then err (str "empty notation fragment"); + ptag, trim_ntn (ptag, m) in + let last = ref "" and last_sc = ref "" in + let scs = ref [] and ntns = ref [] in + let push_sc sc = match !scs with + | "" :: scs' -> scs := "" :: sc :: scs' + | scs' -> scs := sc :: scs' in + let get s _ _ = match !last with + | "Scope " -> last_sc := s; last := "" + | "Lonely notation" -> last_sc := ""; last := "" + | "\"" -> + let pntn, m = mk_pntn s true in + if String.string_contains ~where:(Bytes.to_string pntn) ~what:(Bytes.to_string ptag) then begin + let ntn = trim_ntn (pntn, m) in + match !ntns with + | [] -> ntns := [ntn]; scs := [!last_sc] + | ntn' :: _ when ntn' = ntn -> push_sc !last_sc + | _ when ntn = ttag -> ntns := ntn :: !ntns; scs := [!last_sc] + | _ :: ntns' when List.mem ntn ntns' -> () + | ntn' :: ntns' -> ntns := ntn' :: ntn :: ntns' + end; + last := "" + | _ -> last := s in + pp_with (Format.make_formatter get (fun _ -> ())) generator; + let ntn = match !ntns with + | [] -> + err (hov 0 (qtag "in" ++ str "does not occur in any notation")) + | ntn :: ntns' when ntn = ttag -> + if ntns' <> [] then begin + let pr_ntns' = pr_and_list pr_ntn ntns' in + Feedback.msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) + end; ntn + | [ntn] -> + Feedback.msg_info (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn + | ntns' -> + let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in + err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in + let (nvars, body), ((_, pat), osc) = match !scs with + | [sc] -> Notation.interp_notation ?loc ntn (None, [sc]) + | scs' -> + try Notation.interp_notation ?loc ntn (None, []) with _ -> + let e = pr_ntn ntn ++ spc() ++ str "is defined " ++ pr_scs scs' in + err (hov 4 (str "ambiguous: " ++ pr_tag_sc "in" ++ e)) in + let sc = Option.default "" osc in + let _ = + let m_sc = + if osc <> None then str "In " ++ str sc ++ pr_comma() else mt() in + let ntn_pat = trim_ntn (mk_pntn pat false) in + let rbody = glob_constr_of_notation_constr ?loc body in + let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in + let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in + Feedback.msg_info (hov 0 m) in + if List.length !scs > 1 then + 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 + err (pr_ntn ntn ++ str " is an n-ary notation"); + let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in + let rec sub () = function + | NVar x when List.mem_assoc x nvars -> DAst.make ?loc @@ GPatVar (FirstOrderPatVar x) + | c -> + glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), None, x) sub () c in + let _, npat = Patternops.pattern_of_glob_constr (sub () body) in + Search.GlobSearchSubPattern npat + +ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem + PRINTED BY pr_ssr_search_item + | [ string(s) ] -> [ RGlobSearchString (loc,s,None) ] + | [ string(s) "%" preident(key) ] -> [ RGlobSearchString (loc,s,Some key) ] + | [ constr_pattern(p) ] -> [ RGlobSearchSubPattern p ] +END + +let pr_ssr_search_arg _ _ _ = + let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in + pr_list spc pr_item + +ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list + PRINTED BY pr_ssr_search_arg + | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> [ (false, p) :: a ] + | [ ssr_search_item(p) ssr_search_arg(a) ] -> [ (true, p) :: a ] + | [ ] -> [ [] ] +END + +(* Main type conclusion pattern filter *) + +let rec splay_search_pattern na = function + | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp + | Pattern.PLetIn (_, _, _, bp) -> splay_search_pattern na bp + | Pattern.PRef hr -> hr, na + | _ -> CErrors.user_err (Pp.str "no head constant in head search pattern") + +let push_rels_assum l e = + let l = List.map (fun (n,t) -> n, EConstr.Unsafe.to_constr t) l in + push_rels_assum l e + +let coerce_search_pattern_to_sort hpat = + let env = Global.env () in + let sigma = Evd.(from_env env) in + let mkPApp fp n_imps args = + let args' = Array.append (Array.make n_imps (Pattern.PMeta None)) args in + Pattern.PApp (fp, args') in + let hr, na = splay_search_pattern 0 hpat in + let dc, ht = + let hr, _ = Global.type_of_global_in_context (Global.env ()) hr (** FIXME *) in + Reductionops.splay_prod env sigma (EConstr.of_constr hr) in + let np = List.length dc in + if np < na then CErrors.user_err (Pp.str "too many arguments in head search pattern") else + let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in + let warn () = + Feedback.msg_warning (str "Listing only lemmas with conclusion matching " ++ + pr_constr_pattern_env env sigma hpat') in + if EConstr.isSort sigma ht then begin warn (); true, hpat' end else + let filter_head, coe_path = + try + let _, cp = + Classops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in + warn (); + true, cp + with _ -> false, [] in + let coerce hp coe_index = + let coe = Classops.get_coercion_value coe_index 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 () + ++ str "to interpret head search pattern as type") in + filter_head, List.fold_left coerce hpat' coe_path + +let interp_head_pat hpat = + let filter_head, p = coerce_search_pattern_to_sort hpat in + let rec loop c = match CoqConstr.kind c with + | 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 + filter_head, loop + +let all_true _ = true + +let rec interp_search_about args accu = match args with +| [] -> accu +| (flag, arg) :: rem -> + fun gr env typ -> + let ans = Search.search_about_filter arg gr env typ in + (if flag then ans else not ans) && interp_search_about rem accu gr env typ + +let interp_search_arg arg = + let arg = List.map (fun (x,arg) -> x, match arg with + | RGlobSearchString (loc,s,key) -> + if is_ident_part s then Search.GlobSearchString s else + interp_search_notation ~loc s key + | RGlobSearchSubPattern p -> + try + let env = Global.env () in + let _, p = Constrintern.intern_constr_pattern env (Evd.from_env env) p in + Search.GlobSearchSubPattern p + with e -> let e = CErrors.push e in iraise (ExplainErr.process_vernac_interp_error e)) arg in + let hpat, a1 = match arg with + | (_, Search.GlobSearchSubPattern (Pattern.PMeta _)) :: a' -> all_true, a' + | (true, Search.GlobSearchSubPattern p) :: a' -> + let filter_head, p = interp_head_pat p in + if filter_head then p, a' else all_true, arg + | _ -> all_true, arg in + let is_string = + function (_, Search.GlobSearchString _) -> true | _ -> false in + let a2, a3 = List.partition is_string a1 in + interp_search_about (a2 @ a3) (fun gr env typ -> hpat typ) + +(* Module path postfilter *) + +let pr_modloc (b, m) = if b then str "-" ++ pr_reference m else pr_reference m + +let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc + +let pr_ssr_modlocs _ _ _ ml = + if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml + +ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY pr_ssr_modlocs + | [ ] -> [ [] ] +END + +GEXTEND Gram + GLOBAL: ssr_modlocs; + modloc: [[ "-"; m = global -> true, m | m = global -> false, m]]; + ssr_modlocs: [[ "in"; ml = LIST1 modloc -> ml ]]; +END + +let interp_modloc mr = + let interp_mod (_, mr) = + let {CAst.loc=loc; v=qid} = qualid_of_reference mr in + try Nametab.full_name_module qid with Not_found -> + CErrors.user_err ?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 + | rmods -> Search.module_filter (List.map interp_mod rmods, b) in + let is_in = interp_bmod false mr_in and is_out = interp_bmod true mr_out in + fun gr env typ -> is_in gr env typ && is_out gr env typ + +(* The unified, extended vernacular "Search" command *) + +let ssrdisplaysearch gr env t = + let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in + Feedback.msg_info (hov 2 pr_res ++ fnl ()) + +VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY +| [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> + [ let hpat = interp_search_arg a in + let in_mod = interp_modloc mr in + let post_filter gr env typ = in_mod gr env typ && hpat gr env typ in + let display gr env typ = + if post_filter gr env typ then ssrdisplaysearch gr env typ + in + Search.generic_search None display ] +END + +(* }}} *) + +(** View hint database and View application. *)(* {{{ ******************************) + +(* There are three databases of lemmas used to mediate the application *) +(* of reflection lemmas: one for forward chaining, one for backward *) +(* chaining, and one for secondary backward chaining. *) + +(* View hints *) + +let pr_raw_ssrhintref prc _ _ = let open CAst in function + | { v = CAppExpl ((None, r,x), args) } when isCHoles args -> + prc (CAst.make @@ CRef (r,x)) ++ str "|" ++ int (List.length args) + | { v = CApp ((_, { v = CRef _ }), _) } as c -> prc c + | { v = CApp ((_, c), args) } when isCxHoles args -> + prc c ++ str "|" ++ int (List.length args) + | c -> prc c + +let pr_rawhintref c = + let _, env = Pfedit.get_current_context () in + match DAst.get c with + | GApp (f, args) when isRHoles args -> + pr_glob_constr_env env f ++ str "|" ++ int (List.length args) + | _ -> pr_glob_constr_env env c + +let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c + +let pr_ssrhintref prc _ _ = prc + +let mkhintref ?loc c n = match c.CAst.v with + | CRef (r,x) -> CAst.make ?loc @@ CAppExpl ((None, r, x), mkCHoles ?loc n) + | _ -> mkAppC (c, mkCHoles ?loc n) + +ARGUMENT EXTEND ssrhintref + PRINTED BY pr_ssrhintref + RAW_TYPED AS constr RAW_PRINTED BY pr_raw_ssrhintref + GLOB_TYPED AS constr GLOB_PRINTED BY pr_glob_ssrhintref + | [ constr(c) ] -> [ c ] + | [ constr(c) "|" natural(n) ] -> [ mkhintref ~loc c n ] +END + +(* View purpose *) + +let pr_viewpos = function + | Some Ssrview.AdaptorDb.Forward -> str " for move/" + | Some Ssrview.AdaptorDb.Backward -> str " for apply/" + | Some Ssrview.AdaptorDb.Equivalence -> str " for apply//" + | None -> mt () + +let pr_ssrviewpos _ _ _ = pr_viewpos + +ARGUMENT EXTEND ssrviewpos PRINTED BY pr_ssrviewpos + | [ "for" "move" "/" ] -> [ Some Ssrview.AdaptorDb.Forward ] + | [ "for" "apply" "/" ] -> [ Some Ssrview.AdaptorDb.Backward ] + | [ "for" "apply" "/" "/" ] -> [ Some Ssrview.AdaptorDb.Equivalence ] + | [ "for" "apply" "//" ] -> [ Some Ssrview.AdaptorDb.Equivalence ] + | [ ] -> [ None ] +END + +let pr_ssrviewposspc _ _ _ i = pr_viewpos i ++ spc () + +ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY pr_ssrviewposspc + | [ ssrviewpos(i) ] -> [ i ] +END + +let print_view_hints kind l = + let pp_viewname = str "Hint View" ++ pr_viewpos (Some kind) ++ str " " in + let pp_hints = pr_list spc pr_rawhintref l in + Feedback.msg_info (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) + +VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY +| [ "Print" "Hint" "View" ssrviewpos(i) ] -> + [ match i with + | Some k -> print_view_hints k (Ssrview.AdaptorDb.get k) + | None -> + List.iter (fun k -> print_view_hints k (Ssrview.AdaptorDb.get k)) + [ Ssrview.AdaptorDb.Forward; + Ssrview.AdaptorDb.Backward; + Ssrview.AdaptorDb.Equivalence ] + ] +END + +let glob_view_hints lvh = + List.map (Constrintern.intern_constr (Global.env ()) (Evd.from_env (Global.env ()))) lvh + +VERNAC COMMAND EXTEND HintView CLASSIFIED AS SIDEFF + | [ "Hint" "View" ssrviewposspc(n) ne_ssrhintref_list(lvh) ] -> + [ let hints = glob_view_hints lvh in + match n with + | None -> + Ssrview.AdaptorDb.declare Ssrview.AdaptorDb.Forward hints; + Ssrview.AdaptorDb.declare Ssrview.AdaptorDb.Backward hints + | Some k -> + Ssrview.AdaptorDb.declare k hints ] +END + +(* }}} *) + +(** Canonical Structure alias *) + +GEXTEND Gram + GLOBAL: gallina_ext; + + gallina_ext: + (* Canonical structure *) + [[ IDENT "Canonical"; qid = Constr.global -> + Vernacexpr.VernacCanonical (CAst.make @@ AN qid) + | IDENT "Canonical"; ntn = Prim.by_notation -> + Vernacexpr.VernacCanonical (CAst.make @@ ByNotation ntn) + | IDENT "Canonical"; qid = Constr.global; + d = G_vernac.def_body -> + let s = coerce_reference_to_id qid in + Vernacexpr.VernacDefinition + ((Decl_kinds.NoDischarge,Decl_kinds.CanonicalStructure), + ((CAst.make (Name s)),None), d) + ]]; +END + +(** Keyword compatibility fixes. *) + +(* Coq v8.1 notation uses "by" and "of" quasi-keywords, i.e., reserved *) +(* identifiers used as keywords. This is incompatible with ssreflect.v *) +(* which makes "by" and "of" true keywords, because of technicalities *) +(* in the internal lexer-parser API of Coq. We patch this here by *) +(* adding new parsing rules that recognize the new keywords. *) +(* To make matters worse, the Coq grammar for tactics fails to *) +(* export the non-terminals we need to patch. Fortunately, the CamlP5 *) +(* API provides a backdoor access (with loads of Obj.magic trickery). *) + +(* Coq v8.3 defines "by" as a keyword, some hacks are not needed any *) +(* longer and thus comment out. Such comments are marked with v8.3 *) + +open Pltac + +GEXTEND Gram + GLOBAL: hypident; + hypident: [ + [ "("; IDENT "type"; "of"; id = Prim.identref; ")" -> id, Locus.InHypTypeOnly + | "("; IDENT "value"; "of"; id = Prim.identref; ")" -> id, Locus.InHypValueOnly + ] ]; +END + +GEXTEND Gram + GLOBAL: hloc; +hloc: [ + [ "in"; "("; "Type"; "of"; id = ident; ")" -> + Tacexpr.HypLocation (CAst.make id, Locus.InHypTypeOnly) + | "in"; "("; IDENT "Value"; "of"; id = ident; ")" -> + Tacexpr.HypLocation (CAst.make id, Locus.InHypValueOnly) + ] ]; +END + +GEXTEND Gram + GLOBAL: constr_eval; + constr_eval: [ + [ IDENT "type"; "of"; c = Constr.constr -> Genredexpr.ConstrTypeOf c ] + ]; +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/ssr/ssrvernac.mli b/plugins/ssr/ssrvernac.mli new file mode 100644 index 00000000..aa6e02d3 --- /dev/null +++ b/plugins/ssr/ssrvernac.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml new file mode 100644 index 00000000..aa614fbc --- /dev/null +++ b/plugins/ssr/ssrview.ml @@ -0,0 +1,332 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names + +open Ltac_plugin + +open Proofview +open Notations + +open Ssrcommon +open Ssrast + +module AdaptorDb = struct + + type kind = Forward | Backward | Equivalence + + module AdaptorKind = struct + type t = kind + let compare = Pervasives.compare + end + module AdaptorMap = Map.Make(AdaptorKind) + + let term_view_adaptor_db = + Summary.ref ~name:"view_adaptor_db" AdaptorMap.empty + + let get k = + try AdaptorMap.find k !term_view_adaptor_db + with Not_found -> [] + + let cache_adaptor (_, (k, t)) = + let lk = get k in + if not (List.exists (Glob_ops.glob_constr_eq t) lk) then + term_view_adaptor_db := AdaptorMap.add k (t :: lk) !term_view_adaptor_db + + let subst_adaptor ( subst, (k, t as a)) = + let t' = Detyping.subst_glob_constr subst t in + if t' == t then a else k, t' + + let classify_adaptor x = Libobject.Substitute x + + let in_db = + Libobject.declare_object { + (Libobject.default_object "VIEW_ADAPTOR_DB") + with + Libobject.open_function = (fun i o -> if i = 1 then cache_adaptor o); + Libobject.cache_function = cache_adaptor; + Libobject.subst_function = subst_adaptor; + Libobject.classify_function = classify_adaptor } + + let declare kind terms = + List.iter (fun term -> Lib.add_anonymous_leaf (in_db (kind,term))) + (List.rev terms) + +end + +(* Forward View application code *****************************************) + +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 vsASSERT_EMPTY : unit tactic + +end = struct (* {{{ *) + +type vstate = { + subject_name : Id.t option; (* top *) + (* None if views are being applied to a term *) + view : EConstr.t; (* v2 (v1 top) *) +} + +include Ssrcommon.MakeState(struct + type state = vstate option + let init = None +end) + +let vsINIT view = tclSET (Some { subject_name = None; view }) + +let vsPUSH k = + tacUPDATE (fun s -> match s with + | Some { subject_name; view } -> + k view >>= fun view -> + tclUNIT (Some { subject_name; view }) + | None -> + Goal.enter_one ~__LOC__ begin fun gl -> + let concl = Goal.concl gl in + let id = (* We keep the orig name for checks in "in" tcl *) + match EConstr.kind_of_type (Goal.sigma gl) concl with + | Term.ProdType(Name.Name id, _, _) + when Ssrcommon.is_discharged_id id -> id + | _ -> 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 }) + end) + +let vsCONSUME k = + tclGET (fun s -> match s with + | Some { subject_name; view } -> + tclSET None <*> + k subject_name view + | None -> anomaly "vsCONSUME: empty storage") + +let vsASSERT_EMPTY = + tclGET (function + | Some _ -> anomaly ("vsASSERT_EMPTY: not empty") + | _ -> tclUNIT ()) + +end (* }}} *) + +let intern_constr_expr { Genintern.genv; ltacvars = vars } sigma ce = + let ltacvars = { + Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in + Constrintern.intern_gen Pretyping.WithoutTypeConstraint ~ltacvars genv sigma ce + +(* Disambiguation of /t + - t is ltac:(tactic args) + - t is a term + To allow for t being a notation, like "Notation foo x := ltac:(foo x)", we + need to internalize t. +*) +let is_tac_in_term { body; glob_env; interp_env } = + Goal.(enter_one ~__LOC__ begin fun goal -> + let genv = env goal in + let sigma = sigma goal in + let ist = Ssrcommon.option_assert_get glob_env (Pp.str"not a term") in + (* We use the env of the goal, not the global one *) + let ist = { ist with Genintern.genv } in + (* We unravel notations *) + let g = intern_constr_expr ist sigma body in + match DAst.get g with + | Glob_term.GHole (_,_, Some x) + when Genarg.has_type x (Genarg.glbwit Tacarg.wit_tactic) + -> tclUNIT (`Tac (Genarg.out_gen (Genarg.glbwit Tacarg.wit_tactic) x)) + | _ -> tclUNIT (`Term (interp_env, g)) +end) + +(* To inject a constr into a glob_constr we use an Ltac variable *) +let tclINJ_CONSTR_IST ist p = + let fresh_id = Ssrcommon.mk_internal_id "ssr_inj_constr_in_glob" in + let ist = { + ist with Geninterp.lfun = + Id.Map.add fresh_id (Taccoerce.Value.of_constr p) ist.Geninterp.lfun} in + tclUNIT (ist,Glob_term.GVar fresh_id) + +let mkGHole = + DAst.make + (Glob_term.GHole(Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)) +let rec mkGHoles n = if n > 0 then mkGHole :: mkGHoles (n - 1) else [] +let mkGApp f args = + if args = [] then f + else DAst.make (Glob_term.GApp (f, args)) + +(* From glob_constr to open_constr === (env,sigma,constr) *) +let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> + let env = Goal.env goal in + let sigma = Goal.sigma goal in + Ssrprinters.ppdebug (lazy + Pp.(str"interp-in: " ++ Printer.pr_glob_constr_env env glob)); + try + let sigma,term = Tacinterp.interp_open_constr ist env sigma (glob,None) in + Ssrprinters.ppdebug (lazy + Pp.(str"interp-out: " ++ Printer.pr_econstr_env env sigma term)); + tclUNIT (env,sigma,term) + with e -> + Ssrprinters.ppdebug (lazy + Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env glob)); + tclZERO e +end + +(* Commits the term to the monad *) +(* I think we should make the API safe by storing here the original evar map, + * so that one cannot commit it wrongly. + * We could also commit the term automatically, but this makes the code less + * modular, see the 2 functions below that would need to "uncommit" *) +let tclKeepOpenConstr (_env, sigma, t) = Unsafe.tclEVARS sigma <*> tclUNIT t + +(* 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 *) +(* typecheck the partial application, so we use a minimum of 5. *) +(* Also, we don't handle delayed or iterated coercions to *) +(* FUNCLASS, which is probably just as well since these can *) +(* lead to infinite arities. *) +let guess_max_implicits ist glob = + Proofview.tclORELSE + (interp_glob ist (mkGApp glob (mkGHoles 6)) >>= fun (env,sigma,term) -> + let term_ty = Retyping.get_type_of env sigma term in + let ctx, _ = Reductionops.splay_prod env sigma term_ty in + tclUNIT (List.length ctx + 6)) + (fun _ -> tclUNIT 5) + +let pad_to_inductive ist glob = Goal.enter_one ~__LOC__ begin fun goal -> + interp_glob ist glob >>= fun (env, sigma, term) -> + 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") +end + +(* There are two ways of "applying" a view to term: *) +(* 1- using a view hint if the view is an instance of some *) +(* (reflection) inductive predicate. *) +(* 2- applying the view if it coerces to a function, adding *) +(* implicit arguments. *) +(* 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 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 *) + tclINJ_CONSTR_IST ist p >>= fun (ist, p_id) -> + let p_id = DAst.make p_id in + 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 + | _ -> + 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 -> + Ssrcommon.tclFIRSTa (List.map + (fun a -> interp_glob ist (mkGApp a [vpad; p_id])) adaptors)) + (fun _ -> + guess_max_implicits ist v >>= fun n -> + Ssrcommon.tclFIRSTi (fun n -> + interp_glob ist (mkGApp v (mkGHoles n @ [p_id]))) n) + >>= tclKeepOpenConstr + +(* we store in the state (v top), then (v1 (v2 top))... *) +let pile_up_view (ist, v) = + let ist = Ssrcommon.option_assert_get ist (Pp.str"not a term") in + State.vsPUSH (fun p -> interp_view 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 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 + 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) + else l + ) [] s in + let und0 = (* Unassigned evars in the initial goal *) + let sigma0 = Tacmach.project s0 in + let g0info = Evd.find sigma0 (Tacmach.sig_it s0) in + let g0 = Evd.evars_of_filtered_evar_info g0info in + List.filter (fun k -> Evar.Set.mem k g0) + (List.map fst (Evar.Map.bindings (Evd.undefined_map sigma0))) in + let rigid = rigid_of und0 in + let n, p, to_prune, _ucst = pf_abs_evars2 s0 rigid (sigma, p) in + let p = if simple_types then pf_abs_cterm s0 n p else p in + Ssrprinters.ppdebug (lazy Pp.(str"view@finalized: " ++ + Printer.pr_econstr_env env sigma p)); + let sigma = List.fold_left Evd.remove sigma to_prune in + Unsafe.tclEVARS sigma <*> + tclUNIT p +end + +let pose_proof subject_name p = + Tactics.generalize [p] <*> + Option.cata + (fun id -> Ssrcommon.tclRENAME_HD_PROD (Name.Name id)) (tclUNIT()) + subject_name + <*> + Tactics.New.reduce_after_refine + +let rec apply_all_views ending vs s0 = + match vs with + | [] -> ending s0 + | v :: vs -> + Ssrprinters.ppdebug (lazy Pp.(str"piling...")); + is_tac_in_term v >>= function + | `Tac tac -> + Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); + ending s0 <*> Tacinterp.eval_tactic tac <*> + Ssrcommon.tacSIGMA >>= apply_all_views ending vs + | `Term v -> + Ssrprinters.ppdebug (lazy Pp.(str"..a term")); + pile_up_view v <*> apply_all_views ending vs s0 + +(* Entry points *********************************************************) + +let tclIPAT_VIEWS ~views:vs ~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 + tclINDEPENDENT begin + State.vsASSERT_EMPTY <*> + Ssrcommon.tacSIGMA >>= apply_all_views 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 + tclINDEPENDENT begin + State.vsASSERT_EMPTY <*> + State.vsINIT subject <*> + Ssrcommon.tacSIGMA >>= apply_all_views ending_tac vs <*> + State.vsASSERT_EMPTY + end + +(* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrview.mli b/plugins/ssr/ssrview.mli new file mode 100644 index 00000000..be51fe7f --- /dev/null +++ b/plugins/ssr/ssrview.mli @@ -0,0 +1,39 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Ssrast + +(* Adaptor DB (Hint View) *) +module AdaptorDb : sig + + type kind = Forward | Backward | Equivalence + + val get : kind -> Glob_term.glob_constr list + val declare : kind -> Glob_term.glob_constr list -> unit + +end + +(* Apply views to the top of the stack (intro pattern) *) +val tclIPAT_VIEWS : + views:ast_closure_term list -> + conclusion:(to_clear:Names.Id.t list -> unit Proofview.tactic) -> + unit Proofview.tactic + +(* Apply views to a given subject (as if was the top of the stack), then + call conclusion on the obtained term (something like [v2 (v1 subject)]). + The term being passed to conclusion is abstracted over non-resolved evars: + if [simple_types] then all unnecessary dependencies among the abstracted + evars are pruned *) +val tclWITH_FWD_VIEWS : + simple_types:bool -> + subject:EConstr.t -> + views:ast_closure_term list -> + conclusion:(EConstr.t -> unit Proofview.tactic) -> + unit Proofview.tactic |