diff options
177 files changed, 3958 insertions, 2416 deletions
diff --git a/.gitattributes b/.gitattributes index 58b1a31d36..260e3f96b6 100644 --- a/.gitattributes +++ b/.gitattributes @@ -54,6 +54,7 @@ dune* whitespace=blank-at-eol,tab-in-indent .gitattributes whitespace=blank-at-eol,tab-in-indent _CoqProject whitespace=blank-at-eol,tab-in-indent Dockerfile whitespace=blank-at-eol,tab-in-indent +00000-title.rst -whitespace # tabs are allowed in Makefiles. Makefile* whitespace=blank-at-eol diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 73b61ee0d9..3bd3342329 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -16,4 +16,4 @@ Fixes / closes #???? <!-- If this is a feature pull request / breaks compatibility: --> <!-- (Otherwise, remove these lines.) --> - [ ] Corresponding documentation was added / updated (including any warning and error messages added / removed / modified). -- [ ] Entry added in CHANGES.md. +- [ ] Entry added in the changelog (see https://github.com/coq/coq/tree/master/doc/changelog#unreleased-changelog for details). diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fba68f633e..2bfb91f27f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -47,9 +47,6 @@ before_script: - opam list - opam config list -after_script: - - echo "The build completed normally (not a runner failure)." - ################ GITLAB CACHING ###################### # - use artifacts between jobs # ###################################################### @@ -660,5 +657,5 @@ plugin:plugin-tutorial: plugin:ci-quickchick: extends: .ci-template-flambda -plugin:ci-relation-algebra: +plugin:ci-relation_algebra: extends: .ci-template @@ -18,6 +18,7 @@ CJ Bell <cj@csail.mit.edu> CJ Bell <siegebell@gmail.com> Yves Bertot <yves.bertot@inria.fr> bertot <bertot@85f007b7-540e-0410-9357-904b9bb8a0f7> Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@inria.fr> Yves Bertot <yves.bertot@inria.fr> Yves Bertot <Yves.Bertot@inria.fr> +Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@nardis.inria.fr> Frédéric Besson <frederic.besson@inria.fr> fbesson <fbesson@85f007b7-540e-0410-9357-904b9bb8a0f7> Siddharth Bhat <siddu.druid@gmail.com> Siddharth <siddu.druid@gmail.com> Simon Boulier <simon.boulier@ens-rennes.fr> SimonBoulier <simon.boulier@ens-rennes.fr> @@ -33,6 +34,8 @@ Pierre Courtieu <Pierre.Courtieu@cnam.fr> courtieu <courtieu@85f007b7-5 David Delahaye <delahaye@gforge> delahaye <delahaye@85f007b7-540e-0410-9357-904b9bb8a0f7> Maxime Dénès <mail@maximedenes.fr> mdenes <mdenes@85f007b7-540e-0410-9357-904b9bb8a0f7> Maxime Dénès <mail@maximedenes.fr> Maxime Denes <maximedenes@gillespie.inria.fr> +Maxime Dénès <mail@maximedenes.fr> Maxime Dénès <maxime.denes@fondation-inria.fr> +Maxime Dénès <mail@maximedenes.fr> Maxime Dénès <maxime.denes@inria.fr> Olivier Desmettre <desmettr@gforge> desmettr <desmettr@85f007b7-540e-0410-9357-904b9bb8a0f7> Damien Doligez <doligez@gforge> doligez <doligez@85f007b7-540e-0410-9357-904b9bb8a0f7> Ä°smail Dönmez <ismail-s@users.noreply.github.com> Ismail <ismail-s@users.noreply.github.com> @@ -68,6 +71,7 @@ Florent Kirchner <fkirchne@gforge> kirchner <kirchner@85f007b7-5 Johannes Kloos <jkloos@mpi-sws.org> jkloos <jkloos@mpi-sws.org> Matej KoÅ¡Ãk <matej.kosik@inria.fr> Matej Kosik <m4tej.kosik@gmail.com> Matej KoÅ¡Ãk <matej.kosik@inria.fr> Matej Kosik <matej.kosik@inria.fr> +Matej KoÅ¡Ãk <matej.kosik@inria.fr> Matej KoÅ¡Ãk <mail@matej-kosik.net> Ambroise Lafont <chaster_killer@hotmail.fr> amblaf <you@example.com> Ambroise Lafont <chaster_killer@hotmail.fr> Ambroise <chaster_killer@hotmail.fr> Vincent Laporte <Vincent.Laporte@fondation-inria.fr> Vincent Laporte <Vincent.Laporte@gmail.com> @@ -87,6 +91,7 @@ Guillaume Melquiond <guillaume.melquiond@inria.fr> gmelquio <gmelquio@85f007b7-5 Guillaume Melquiond <guillaume.melquiond@inria.fr> Guillaume Melquiond <guillaume.melquiond@gmail.com> Alexandre Miquel <miquel@gforge> miquel <miquel@85f007b7-540e-0410-9357-904b9bb8a0f7> Benjamin Monate <monate@gforge> monate <monate@85f007b7-540e-0410-9357-904b9bb8a0f7> +Erik Martin-Dorel <erik.martin-dorel@irit.fr> Erik Martin-Dorel <erik@martin-dorel.org> Julien Narboux <jnarboux@gforge> jnarboux <jnarboux@85f007b7-540e-0410-9357-904b9bb8a0f7> Julien Narboux <jnarboux@gforge> narboux <narboux@85f007b7-540e-0410-9357-904b9bb8a0f7> Jean-Marc Notin <notin@gforge> notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty <notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -107,6 +112,7 @@ Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel De Rauglaudre <ddr@g Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> regisgia <regisgia@85f007b7-540e-0410-9357-904b9bb8a0f7> Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> Regis-Gianas <yrg@pps.univ-paris-diderot.fr> Clément Renard <clrenard@gforge> clrenard <clrenard@85f007b7-540e-0410-9357-904b9bb8a0f7> +Pierre Roux <pierre@roux01.fr> Pierre Roux <pierre.roux@onera.fr> Matthew Ryan <mr_1993@hotmail.co.uk> mrmr1993 <mr_1993@hotmail.co.uk> Claudio Sacerdoti Coen <sacerdot@gforge> sacerdot <sacerdot@85f007b7-540e-0410-9357-904b9bb8a0f7> Kazuhiko Sakaguchi <pi8027@gmail.com> Kazuhiko Sakaguchi <sakaguchi@coins.tsukuba.ac.jp> @@ -126,8 +132,12 @@ Enrico Tassi <Enrico.Tassi@inria.fr> Enrico <gares@fettunta.org> Laurent Théry <laurent.thery@inria.fr> thery <thery@85f007b7-540e-0410-9357-904b9bb8a0f7> Laurent Théry <laurent.thery@inria.fr> thery <thery@sophia.inria.fr> Laurent Théry <laurent.thery@inria.fr> Laurent Théry <thery@sophia.inria.fr> +Laurent Théry <laurent.thery@inria.fr> thery <Laurent.Thery@inria.fr> Anton Trunov <anton.a.trunov@gmail.com> Anton Trunov <anton.trunov@imdea.org> Benjamin Werner <werner@gforge> werner <werner@85f007b7-540e-0410-9357-904b9bb8a0f7> +Wang Zhuyang <hawnzug@gmail.com> hawnzug <hawnzug@gmail.com> +Beta Ziliani <beta@mpi-sws.org> Beta Ziliani <bziliani@famaf.unc.edu.ar> +Beta Ziliani <beta@mpi-sws.org> beta <beta@mpi-sws.org> Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Theo Zimmermann <theo.zimmermann@ens.fr> Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Théo Zimmermann <theo.zimmi@gmail.com> diff --git a/CHANGES.md b/CHANGES.md deleted file mode 100644 index fc7272da65..0000000000 --- a/CHANGES.md +++ /dev/null @@ -1,315 +0,0 @@ -Unreleased changes -================== - -OCaml and dependencies - -- Coq 8.10 requires OCaml >= 4.05.0, bumped from 4.02.3 See the - INSTALL file for more information on dependencies. - -- Coq 8.10 doesn't need Camlp5 to build anymore. It now includes a - fork of the core parsing library that Coq uses, which is a small - subset of the whole Camlp5 distribution. In particular, this subset - doesn't depend on the OCaml AST, allowing easier compilation and - testing on experimental OCaml versions. - - The Coq developers would like to thank Daniel de Rauglaudre for many - years of continued support. - -Coqide - -- CoqIDE now depends on gtk+3 and lablgtk3, rather than gtk+2 and lablgtk2. - -- CoqIDE now properly sets the module name for a given file based on - its path, see -topfile change entry for more details. - -Coqtop - -- the use of `coqtop` as a compiler has been deprecated, in favor of - `coqc`. Consequently option `-compile` will stop to be accepted in - the next release. `coqtop` is now reserved to interactive - use. (@ejgallego #9095) - -- new option -topfile filename, which will set the current module name - (à la -top) based on the filename passed, taking into account the - proper -R/-Q options. For example, given -R Foo foolib using - -topfile foolib/bar.v will set the module name to Foo.Bar. - -Specification language, type inference - -- Fixing a missing check in interpreting instances of existential - variables that are bound to local definitions might exceptionally - induce an overhead if the cost of checking the conversion of the - corresponding definitions is additionally high (PR #8215). - -- A few improvements in inference of the return clause of `match` can - exceptionally introduce incompatibilities (PR #262). This can be - solved by writing an explicit `return` clause, sometimes even simply - an explicit `return _` clause. - -- Using non-projection values with the projection syntax is not - allowed. For instance "0.(S)" is not a valid way to write "S 0". - Projections from non-primitive (emulated) records are allowed with - warning "nonprimitive-projection-syntax". - -Kernel - -- Added primitive integers - -- Unfolding heuristic in termination checking made more complete. - In particular Coq is now more aggressive in unfolding constants - when it looks for a iota redex. Performance regression may occur - in Fixpoint declarations without an explicit {struct} annotation, - since guessing the decreasing argument can now be more expensive. - (PR #9602) - -Notations - -- New command `Declare Scope` to explicitly declare a scope name - before any use of it. Implicit declaration of a scope at the time of - `Bind Scope`, `Delimit Scope`, `Undelimit Scope`, or `Notation` is - deprecated. - -- New command `String Notation` to register string syntax for custom - inductive types. - -- Numeral notations now parse decimal constants such as 1.02e+01 or - 10.2. Parsers added for Q and R. This should be considered as an - experimental feature currently. - Note: in -- the rare -- case when such numeral notations were used - in a development along with Q or R, they may have to be removed or - deconflicted through explicit scope annotations (1.23%Q, - 45.6%R,...). - -- Various bugs have been fixed (e.g. PR #9214 on removing spurious - parentheses on abbreviations shortening a strict prefix of an application). - -- Numeral Notations now support inductive types in the input to - printing functions (e.g., numeral notations can be defined for terms - containing things like `@cons nat O O`), and parsing functions now - fully normalize terms including parameters of constructors (so that, - e.g., a numeral notation whose parsing function outputs a proof of - `Nat.gcd x y = 1` will no longer fail to parse due to containing the - constant `Nat.gcd` in the parameter-argument of `eq_refl`). See - #9840 for more details. - -- Deprecated compatibility notations have actually been removed. Uses - of these notations are generally easy to fix thanks to the hint - contained in the deprecation warnings. For projects that require - more than a handful of such fixes, there is [a - script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) - that will do it automatically, using the output of coqc. The script - contains documentation on its usage in a comment at the top. - -Plugins - -- The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) - was removed. If some users are interested in maintaining this plugin - externally, the Coq development team can provide assistance for extracting - the plugin and setting up a new repository. - -Tactics - -- Removed the deprecated `romega` tactics. -- Tactic names are no longer allowed to clash, even if they are not defined in - the same section. For example, the following is no longer accepted: - `Ltac foo := idtac. Section S. Ltac foo := fail. End S.` - -- The tactics 'lia','nia','lra','nra' are now using a novel - Simplex-based proof engine. In case of regression, 'Unset Simplex' - to get the venerable Fourier-based engine. - -- Names of existential variables occurring in Ltac functions - (e.g. `?[n]` or `?n` in terms - not in patterns) are now interpreted - the same way as other variable names occurring in Ltac functions. - -- Hint declaration and removal should now specify a database (e.g. `Hint Resolve - foo : database`). When the database name is omitted, the hint is added to the - core database (as previously), but a deprecation warning is emitted. - -- There are now tactics in `PreOmega.v` called - `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and - `Z.to_euclidean_division_equations` (which combines the `div_mod` - and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to - support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), - by posing the specifying equation for `Z.div` and `Z.modulo` before - replacing them with atoms. - -- Ltac backtraces can be turned on using the "Ltac Backtrace" option. - -- The syntax of the `autoapply` tactic was fixed to conform with preexisting - documentation: it now takes a `with` clause instead of a `using` clause. - - - -Vernacular commands - -- `Combined Scheme` can now work when inductive schemes are generated in sort - `Type`. It used to be limited to sort `Prop`. - -- Binders for an `Instance` now act more like binders for a `Theorem`. - Names may not be repeated, and may not overlap with section variable names. - -- Removed the deprecated `Implicit Tactic` family of commands. - -- The `Automatic Introduction` option has been removed and is now the - default. - -- `Arguments` now accepts names for arguments provided with `extra_scopes`. - -- The naming scheme for anonymous binders in a `Theorem` has changed to - avoid conflicts with explicitly named binders. - -- Computation of implicit arguments now properly handles local definitions in the - binders for an `Instance`, and can be mixed with implicit binders `{x : T}`. - -- `Declare Instance` now requires an instance name. - -- Option `Refine Instance Mode` has been turned off by default, meaning that - `Instance` no longer opens a proof when a body is provided. - -- `Instance`, when no body is provided, now always opens a proof. This is a - breaking change, as instance of `Instance foo : C.` where `C` is a trivial - class will have to be changed into `Instance foo : C := {}.` or - `Instance foo : C. Proof. Qed.`. - -- Option `Program Mode` now means that the `Program` attribute is enabled - for all commands that support it. In particular, it does not have any effect - on tactics anymore. May cause some incompatibilities. - -- The algorithm computing implicit arguments now behaves uniformly for primitive - projection and application nodes (bug #9508). - -- `Hypotheses` and `Variables` can now take implicit binders inside sections. - -- Removed deprecated option `Automatic Coercions Import`. - -- The `Show Script` command has been deprecated. - -- Option `Refine Instance Mode` has been deprecated and will be removed in - the next version. - -- `Coercion` does not warn ambiguous paths which are obviously convertible with - existing ones. - -- A new flag `Fast Name Printing` has been introduced. It changes the - algorithm used for allocating bound variable names for a faster but less - clever one. - -Tools - -- The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: - - `no` disables native_compute - - `yes` enables native_compute and precompiles `.v` files to native code - - `ondemand` enables native_compute but compiles code only when `native_compute` is called - - The default value is `ondemand`. - - Note that this flag now has priority over the configure flag of the same name. - -- A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls whether - conversion can use the VM. The default value is `yes`. - -- CoqIDE now supports input for Unicode characters. For example, typing - "\alpha" then the "Shift+Space" will insert the greek letter alpha. - In fact, typing the prefix string "\a" is sufficient. - A larger number of default bindings are provided, following the latex - naming convention. Bindings can be customized, either globally, or on a - per-project basis, with the requirement is that keys must begin with a - backslash and contain no space character. Bindings may be assigned custom - priorities, so that prefixes resolve to the most convenient bindings. - The documentation pages for CoqIDE provides further details. - -- The pretty timing diff scripts (flag `TIMING=1` to a - `coq_makefile`-made `Makefile`, also - `tools/make-both-single-timing-files.py`, - `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) - now correctly support non-UTF-8 characters in the output of - `coqc`/`make` as well as printing to stdout, on both python2 and - python3. - -- Coq options can be set on the command line, eg `-set "Universe Polymorphism=true"` - -- coq_makefile's install target now errors if any file to install is missing. - -Standard Library - -- Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about - the upper bound of number represented by a vector. - Allowed implicit vector length argument in `Ndigits.Bv2N`. - -- Added `Bvector.BVeq` that decides whether two `Bvector`s are equal. - -- Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg`. - -- Added `ByteVector` type that can convert to and from [string]. - -- The prelude used to be automatically Exported and is now only - Imported. This should be relevant only when importing files which - don't use -noinit into files which do. - -- Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an - ordered type (using lexical order). - -- The `Coq.Numbers.Cyclic.Int31` library is deprecated. - -- Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. - -- Moved the `auto` hints of the `FSet` library into a new - `fset` database. - -Universes - -- Added `Print Universes Subgraph` variant of `Print Universes`. - Try for instance `Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1 eq_sigT2_rect.u1).` - -- Added private universes for opaque polymorphic constants, see doc - for the "Private Polymorphic Universes" option (and Unset it to get - the previous behaviour). - -SProp - -- Added a universe "SProp" for definitionally proof irrelevant - propositions. Use with -allow-sprop. See manual for details. - -Inductives - -- An option and attributes to control the automatic decision to - declare an inductive type as template polymorphic were added. - Warning "auto-template" will trigger when an inductive is - automatically declared template polymorphic without the attribute. - -Funind - -- Inductive types declared by Funind will never be template polymorphic. - -Misc - -- Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. - -- Removed option "Printing Primitive Projection Compatibility" - -SSReflect - -- New intro patterns: - - temporary introduction: `=> +` - - block introduction: `=> [^ prefix ] [^~ suffix ]` - - fast introduction: `=> >` - - tactics as views: `=> /ltac:mytac` - - replace hypothesis: `=> {}H` - See the reference manual for the actual documentation. - -- Clear discipline made consistent across the entire proof language. - Whenever a clear switch `{x..}` comes immediately before an existing proof - context entry (used as a view, as a rewrite rule or as name for a new - context entry) then such entry is cleared too. - - E.g. The following sentences are elaborated as follows (when H is an existing - proof context entry): - - `=> {x..} H` -> `=> {x..H} H` - - `=> {x..} /H` -> `=> /v {x..H}` - - `rewrite {x..} H` -> `rewrite E {x..H}` - -Diffs - -- Some error messages that show problems with a pair of non-matching values will now - highlight the differences. @@ -59,10 +59,10 @@ plugins/setoid_ring Assia Mahboubi, Laurent Théry (INRIA-Marelle, 2006) and Bruno Barras (INRIA LogiCal, 2005-2006), plugins/ssreflect - developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011), + developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2013, Inria, 2013-now), Assia Mahboubi and Enrico Tassi (Inria, 2011-now). plugins/ssrmatching - developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011), + developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011, Inria, 2013-now), and Enrico Tassi (Inria-Marelle, 2011-now) plugins/subtac developed by Matthieu Sozeau (LRI, 2005-2008) diff --git a/META.coq.in b/META.coq.in index ab142ccc43..ef5de8da2b 100644 --- a/META.coq.in +++ b/META.coq.in @@ -315,7 +315,7 @@ package "plugins" ( archive(native) = "micromega_plugin.cmx" ) - package "newring" ( + package "setoid_ring" ( description = "Coq newring plugin" version = "8.10" @@ -351,7 +351,7 @@ package "plugins" ( archive(native) = "cc_plugin.cmx" ) - package "ground" ( + package "firstorder" ( description = "Coq ground plugin" version = "8.10" @@ -387,7 +387,7 @@ package "plugins" ( archive(native) = "btauto_plugin.cmx" ) - package "recdef" ( + package "funind" ( description = "Coq recdef plugin" version = "8.10" diff --git a/Makefile.ci b/Makefile.ci index 000725b6b1..a244c17ef3 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -38,7 +38,7 @@ CI_TARGETS= \ ci-mtac2 \ ci-paramcoq \ ci-quickchick \ - ci-relation-algebra \ + ci-relation_algebra \ ci-sf \ ci-simple-io \ ci-stdlib2 \ diff --git a/Makefile.doc b/Makefile.doc index e89a20393c..25d146000b 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -31,8 +31,8 @@ DVIPS:=dvips HTMLSTYLE:=coqremote # Sphinx-related variables -OSNAME:=$(shell uname -o) -ifeq ($(OSNAME),Cygwin) +OSNAME:=$(shell uname -s) +ifeq ($(findstring CYGWIN,$(OSNAME)),CYGWIN) WIN_CURDIR:=$(shell cygpath -w $(CURDIR)) SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(WIN_CURDIR)" else @@ -66,7 +66,7 @@ SPHINX_DEPS := coq endif # refman-html and refman-latex -refman-%: $(SPHINX_DEPS) +refman-%: $(SPHINX_DEPS) doc/unreleased.rst $(SHOW)'SPHINXBUILD doc/sphinx ($*)' $(HIDE)$(SPHINXENV) $(SPHINXBUILD) -b $* \ $(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/$* @@ -116,6 +116,12 @@ plugin-tutorial: states tools doc/common/version.tex: config/Makefile printf '\\newcommand{\\coqversion}{$(VERSION)}' > doc/common/version.tex +### Changelog + +doc/unreleased.rst: $(wildcard doc/changelog/00-title.rst doc/changelog/*/*.rst) + $(SHOW)'AGGREGATE $@' + $(HIDE)cat doc/changelog/00-title.rst doc/changelog/*/*.rst > $@ + ###################################################################### # Standard library ###################################################################### diff --git a/Makefile.ide b/Makefile.ide index 8f9088a04a..4cec7aa443 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -68,6 +68,7 @@ GTKBIN=$(shell pkg-config --variable=prefix gtk+-3.0)/bin GTKLIBS=$(shell pkg-config --variable=libdir gtk+-3.0) PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-2.0)/bin SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-3.0)/share +ADWAITASHARE=$(shell ls -d /usr/local/Cellar/adwaita-icon-theme/*)/share ########################################################################### # CoqIde special targets @@ -255,6 +256,9 @@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-3.0/styles/{styles.rng,classic.xml} $@/gtksourceview-3.0/styles/ cp -R "$(GTKSHARE)/"locale $@ cp -R "$(GTKSHARE)/"themes $@ + $(MKDIR) $@/glib-2.0/schemas + glib-compile-schemas --targetdir=$@/glib-2.0/schemas "$(GTKSHARE)/"glib-2.0/schemas/ + cp -R "$(ADWAITASHARE)/"icons $@ $(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents $(MKDIR) $@ @@ -69,9 +69,12 @@ for additional user-contributed documentation. ## Changes -There is a file named [`CHANGES.md`](CHANGES.md) that explains the differences and the -incompatibilities since last versions. If you upgrade Coq, please read -it carefully. +The [Recent +changes](https://coq.github.io/doc/master/refman/changes.html) chapter +of the reference manual explains the differences and the +incompatibilities of each new version of Coq. If you upgrade Coq, +please read it carefully as it contains important advice on how to +approach some problems you may encounter. ## Questions and discussion diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 6fcc64f77e..f2cec1eb19 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -52,15 +52,15 @@ jobs: - script: | set -e brew update - brew install gnu-time opam pkg-config gtksourceview3 + brew install gnu-time opam pkg-config gtksourceview3 adwaita-icon-theme pip3 install macpack displayName: 'Install system dependencies' - script: | set -e export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig - opam init -a -j "$NJOBS" --compiler=$COMPILER - opam switch set $COMPILER + opam init -a -j "$NJOBS" --compiler=ocaml-base-compiler.$COMPILER + opam switch set ocaml-base-compiler.$COMPILER eval $(opam env) opam update opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index b86d491d72..1dd16f1630 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -33,7 +33,8 @@ let check_constant_declaration env kn cb = match Environ.body_of_constant_body env cb with | Some bd -> let j = infer env' (fst bd) in - conv_leq env' j.uj_type ty + (try conv_leq env' j.uj_type ty + with NotConvertible -> Type_errors.error_actual_type env j ty) | None -> () in let env = diff --git a/clib/cSig.mli b/clib/cSig.mli index 859018ca4b..0012bcef17 100644 --- a/clib/cSig.mli +++ b/clib/cSig.mli @@ -68,6 +68,8 @@ sig val remove: key -> 'a t -> 'a t val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val union: + (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit diff --git a/clib/hMap.ml b/clib/hMap.ml index 09ffb39c21..db59ef47b0 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -290,6 +290,14 @@ struct in Int.Map.merge fm s1 s2 + let union f s1 s2 = + let fm h m1 m2 = + let m = Map.union f m1 m2 in + if Map.is_empty m then None + else Some m + in + Int.Map.union fm s1 s2 + let compare f s1 s2 = let fc m1 m2 = Map.compare f m1 m2 in Int.Map.compare fc s1 s2 diff --git a/coq-refman.opam b/coq-refman.opam index b9500243a3..16be422c27 100644 --- a/coq-refman.opam +++ b/coq-refman.opam @@ -17,7 +17,7 @@ license: "Open Publication License" depends: [ "dune" { build } - "coq" { build } + "coq" { build & = version } ] build-env: [ @@ -20,16 +20,13 @@ license: "LGPL-2.1" depends: [ "ocaml" { >= "4.05.0" } - "dune" { build & >= "1.4.0" } + "dune" { build & >= "1.6.0" } "ocamlfind" { build } "num" ] -build-env: [ - [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] -] - build: [ + [ "./configure" "-prefix" prefix "-native-compiler" "no" ] [ "dune" "build" "@vodeps" ] [ "dune" "exec" "coq_dune" "_build/default/.vfiles.d" ] [ "dune" "build" "-p" name "-j" jobs ] diff --git a/coqide-server.opam b/coqide-server.opam index ed6f3d98d8..0325d2549c 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -19,8 +19,8 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.4.0" } - "coq" + "dune" { build & >= "1.6.0" } + "coq" { = version } ] build: [ [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/coqide.opam b/coqide.opam index c82fa72564..2507acbb26 100644 --- a/coqide.opam +++ b/coqide.opam @@ -17,8 +17,8 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.4.0" } - "coqide-server" + "dune" { build & >= "1.6.0" } + "coqide-server" { = version } "lablgtk3" { >= "3.0.beta5" } "lablgtk3-sourceview3" { >= "3.0.beta5" } ] diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 4c5bd29236..ea9af60330 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1316,7 +1316,6 @@ function copy_coq_license { # FIXME: this is not the micromega license # It only applies to code that was copied into one single file! install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" - install -D CHANGES.md "$PREFIXCOQ/license_readme/coq/Changes.md" install -D INSTALL "$PREFIXCOQ/license_readme/coq/Install.txt" install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true fi diff --git a/dev/ci/README-users.md b/dev/ci/README-users.md index 01769aeddb..06b617d4c1 100644 --- a/dev/ci/README-users.md +++ b/dev/ci/README-users.md @@ -45,6 +45,26 @@ using [coqbot](https://github.com/coq/bot); meanwhile, a workaround is to give merge permissions to someone from the Coq team as to help with these kind of merges. +### OCaml and plugin-specific considerations + +Developments that link against Coq's OCaml API [most of them are known +as "plugins"] do have some special requirements: + +- Coq's OCaml API is not stable. We hope to improve this in the future + but as of today you should expect to have to merge a fair amount of + "overlays", usually in the form of Pull Requests from Coq developers + in order to keep your plugin compatible with Coq master. + + In order to alleviate the load, you can delegate the merging of such + compatibility pull requests to Coq developers themselves, by + granting access to the plugin repository or by using `bots` such as + [Bors](https://github.com/apps/bors) that allow for automatic + management of Pull Requests. + +- Plugins in the CI should compile with the OCaml flags that Coq + uses. In particular, warnings that are considered fatal by the Coq + developers _must_ be also fatal for plugin CI code. + ### Add your development by submitting a pull request Add a new `ci-mydev.sh` script to [`dev/ci`](.); set the corresponding diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 0c89809ee9..4f5988c59c 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -254,7 +254,7 @@ : "${paramcoq_CI_ARCHIVEURL:=${paramcoq_CI_GITURL}/archive}" ######################################################################## -# relation-algebra +# relation_algebra ######################################################################## : "${relation_algebra_CI_REF:=master}" : "${relation_algebra_CI_GITURL:=https://github.com/damien-pous/relation-algebra}" diff --git a/dev/ci/ci-relation-algebra.sh b/dev/ci/ci-relation_algebra.sh index 84bed5bdfe..84bed5bdfe 100755 --- a/dev/ci/ci-relation-algebra.sh +++ b/dev/ci/ci-relation_algebra.sh diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index 3f1b470878..c9eceb1270 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -71,8 +71,9 @@ those external projects should have been prepared (cf. the relevant sub-section in the [CI README](../ci/README.md#Breaking-changes) and the PR can be tested with these fixes thanks to ["overlays"](../ci/user-overlays/README.md). -Moreover the PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) or -the [`dev/doc/changes.md`](changes.md) file. +Moreover the PR author *must* add an entry to the [unreleased +changelog](../../doc/changelog/README.md) or to the +[`dev/doc/changes.md`](changes.md) file. If overlays are missing, ask the author to prepare them and label the PR with the [needs: overlay](https://github.com/coq/coq/labels/needs%3A%20overlay) label. diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 40c3c32e4f..9e0d47651e 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -20,6 +20,15 @@ General deprecation removed. Please, make sure your plugin is warning-free in 8.8 before trying to port it over 8.9. +Warnings + +- Coq now builds plugins with `-warn-error` enabled by default. The + amount of dangerous warnings in plugin code was very high, so we now + require plugins in the CI to adhere to the Coq warning policy. We + _strongly_ recommend against disabling the default set of warnings. + If you have special needs, see the documentation of your build + system and/or OCaml for further help. + Names - Kernel names no longer contain a section path. They now have only two @@ -194,12 +203,6 @@ Termops - Internal printing functions have been placed under the `Termops.Internal` namespace. -Notations: - -- Notation.availability_of_notation is not anymore needed: if a - delimiter is needed, it is provided by Notation.uninterp_notation - which fails in case the notation is not available. - ### Unit testing The test suite now allows writing unit tests against OCaml code in the Coq diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index f532e1b68f..01c2b574a2 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -195,6 +195,18 @@ Conversion machines GH issue number: ? risk: + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: primitive integer emulation layer on 32 bits not robust to garbage collection + introduced: master (before v8.10 in GH pull request #6914) + impacted released versions: none + impacted development branches: + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: + found by: Roux, Melquiond + exploit: + GH issue number: #9925 + risk: + component: "native" conversion machine (translation to OCaml which compiles to native code) summary: translation of identifier from Coq to OCaml was not bijective, leading to identify True and False introduced: V8.5 diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 74be300134..816316487c 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -65,6 +65,7 @@ let get_current_context () = with Vernacstate.Proof_global.NoCurrentProof -> let env = Global.env() in Evd.from_env env, env + [@@ocaml.warning "-3"] (* term printers *) let envpp pp = let sigma,env = get_current_context () in pp env sigma diff --git a/doc/changelog/00-title.rst b/doc/changelog/00-title.rst new file mode 100644 index 0000000000..628d9c8578 --- /dev/null +++ b/doc/changelog/00-title.rst @@ -0,0 +1,2 @@ +Unreleased changes +------------------ diff --git a/doc/changelog/01-kernel/00000-title.rst b/doc/changelog/01-kernel/00000-title.rst new file mode 100644 index 0000000000..f680628a05 --- /dev/null +++ b/doc/changelog/01-kernel/00000-title.rst @@ -0,0 +1,3 @@ + +**Kernel** + diff --git a/doc/changelog/02-specification-language/00000-title.rst b/doc/changelog/02-specification-language/00000-title.rst new file mode 100644 index 0000000000..99bd2c5b44 --- /dev/null +++ b/doc/changelog/02-specification-language/00000-title.rst @@ -0,0 +1,3 @@ + +**Specification language, type inference** + diff --git a/doc/changelog/03-notations/00000-title.rst b/doc/changelog/03-notations/00000-title.rst new file mode 100644 index 0000000000..abc532df11 --- /dev/null +++ b/doc/changelog/03-notations/00000-title.rst @@ -0,0 +1,3 @@ + +**Notations** + diff --git a/doc/changelog/04-tactics/00000-title.rst b/doc/changelog/04-tactics/00000-title.rst new file mode 100644 index 0000000000..3c7802d632 --- /dev/null +++ b/doc/changelog/04-tactics/00000-title.rst @@ -0,0 +1,3 @@ + +**Tactics** + diff --git a/doc/changelog/04-tactics/09996-hint-mode.rst b/doc/changelog/04-tactics/09996-hint-mode.rst new file mode 100644 index 0000000000..06e9059b45 --- /dev/null +++ b/doc/changelog/04-tactics/09996-hint-mode.rst @@ -0,0 +1,5 @@ +- Modes are now taken into account by :tacn:`typeclasses eauto` for + local hypotheses + (`#9996 <https://github.com/coq/coq/pull/9996>`_, + fixes `#5752 <https://github.com/coq/coq/issues/5752>`_, + by Maxime Dénès, review by Pierre-Marie Pédrot). diff --git a/doc/changelog/04-tactics/10059-change-no-check.rst b/doc/changelog/04-tactics/10059-change-no-check.rst new file mode 100644 index 0000000000..987b2a8ccd --- /dev/null +++ b/doc/changelog/04-tactics/10059-change-no-check.rst @@ -0,0 +1,7 @@ +- New variant :tacn:`change_no_check` of :tacn:`change`, usable as a + documented replacement of :tacn:`convert_concl_no_check` + (`#10012 <https://github.com/coq/coq/pull/10012>`_, + `#10017 <https://github.com/coq/coq/pull/10017>`_, + `#10053 <https://github.com/coq/coq/pull/10053>`_, and + `#10059 <https://github.com/coq/coq/pull/10059>`_, + by Hugo Herbelin and Paolo G. Giarrusso). diff --git a/doc/changelog/05-tactic-language/00000-title.rst b/doc/changelog/05-tactic-language/00000-title.rst new file mode 100644 index 0000000000..b34d190298 --- /dev/null +++ b/doc/changelog/05-tactic-language/00000-title.rst @@ -0,0 +1,3 @@ + +**Tactic language** + diff --git a/doc/changelog/06-ssreflect/00000-title.rst b/doc/changelog/06-ssreflect/00000-title.rst new file mode 100644 index 0000000000..2e724627ec --- /dev/null +++ b/doc/changelog/06-ssreflect/00000-title.rst @@ -0,0 +1,3 @@ + +**SSReflect** + diff --git a/doc/changelog/06-ssreflect/09995-notations.rst b/doc/changelog/06-ssreflect/09995-notations.rst new file mode 100644 index 0000000000..3dfc45242d --- /dev/null +++ b/doc/changelog/06-ssreflect/09995-notations.rst @@ -0,0 +1,8 @@ +- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. + New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion + class, simplified `predType` interface: `pred_class` and `mkPredType` + deprecated, `{pred T}` and `PredType` should be used instead. + `if c return t then ...` now expects `c` to be a variable bound in `t`. + New `nonPropType` interface matching types that do _not_ have sort `Prop`. + New `relpre R f` definition for the preimage of a relation R under f + (`#9995 <https://github.com/coq/coq/pull/9995>`_, by Georges Gonthier). diff --git a/doc/changelog/07-commands-and-options/00000-title.rst b/doc/changelog/07-commands-and-options/00000-title.rst new file mode 100644 index 0000000000..1a0272983e --- /dev/null +++ b/doc/changelog/07-commands-and-options/00000-title.rst @@ -0,0 +1,3 @@ + +**Commands and options** + diff --git a/doc/changelog/08-tools/00000-title.rst b/doc/changelog/08-tools/00000-title.rst new file mode 100644 index 0000000000..bf462744fb --- /dev/null +++ b/doc/changelog/08-tools/00000-title.rst @@ -0,0 +1,3 @@ + +**Tools** + diff --git a/doc/changelog/09-coqide/00000-title.rst b/doc/changelog/09-coqide/00000-title.rst new file mode 100644 index 0000000000..0fc27cf380 --- /dev/null +++ b/doc/changelog/09-coqide/00000-title.rst @@ -0,0 +1,3 @@ + +**CoqIDE** + diff --git a/doc/changelog/10-standard-library/00000-title.rst b/doc/changelog/10-standard-library/00000-title.rst new file mode 100644 index 0000000000..d517a0e709 --- /dev/null +++ b/doc/changelog/10-standard-library/00000-title.rst @@ -0,0 +1,3 @@ + +**Standard library** + diff --git a/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst b/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst new file mode 100644 index 0000000000..732c088f45 --- /dev/null +++ b/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst @@ -0,0 +1,3 @@ +- Added :g:`Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull` + (`#9984 <https://github.com/coq/coq/pull/9984>`_, + by Jean-Christophe Léchenet and Oliver Nash). diff --git a/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst b/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst new file mode 100644 index 0000000000..6b301f59d3 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst @@ -0,0 +1,3 @@ + +**Infrastructure and dependencies** + diff --git a/doc/changelog/12-misc/00000-title.rst b/doc/changelog/12-misc/00000-title.rst new file mode 100644 index 0000000000..5e709e2b27 --- /dev/null +++ b/doc/changelog/12-misc/00000-title.rst @@ -0,0 +1,3 @@ + +**Miscellaneous** + diff --git a/doc/changelog/12-misc/09964-changes.rst b/doc/changelog/12-misc/09964-changes.rst new file mode 100644 index 0000000000..1113782180 --- /dev/null +++ b/doc/changelog/12-misc/09964-changes.rst @@ -0,0 +1,13 @@ +- Changelog has been moved from a specific file `CHANGES.md` to the + reference manual; former Credits chapter of the reference manual has + been split in two parts: a History chapter which was enriched with + additional historical information about Coq versions 1 to 5, and a + Changes chapter which was enriched with the content formerly in + `CHANGES.md` and `COMPATIBILITY` + (`#9133 <https://github.com/coq/coq/pull/9133>`_, + `#9668 <https://github.com/coq/coq/pull/9668>`_, + `#9939 <https://github.com/coq/coq/pull/9939>`_, + `#9964 <https://github.com/coq/coq/pull/9964>`_, + by Théo Zimmermann, + with help and ideas from Emilio Jesús Gallego Arias, + Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). diff --git a/doc/changelog/README.md b/doc/changelog/README.md new file mode 100644 index 0000000000..2891eb207e --- /dev/null +++ b/doc/changelog/README.md @@ -0,0 +1,41 @@ +# Unreleased changelog # + +## When to add an entry? ## + +All new features, user-visible changes to features, user-visible or +otherwise important infrastructure changes, and important bug fixes +should get a changelog entry. + +Compatibility-breaking changes should always get a changelog entry, +which should explain what compatibility-breakage is to expect. + +Pull requests changing the ML API in significant ways should add an +entry in [`dev/doc/changes.md`](../../dev/doc/changes.md). + +## How to add an entry? ## + +You should create a file in one of the sub-directories. The name of +the file should be `NNNNN-identifier.rst` where `NNNNN` is the number +of the pull request on five digits and `identifier` is whatever you +want. + +This file should use the same format as the reference manual (as it +will be copied in there). You may reference the documentation you just +added with `:ref:`, `:tacn:`, `:cmd:`, `:opt:`, `:token:`, etc. See +the [documentation of the Sphinx format](../sphinx/README.rst) of the +manual for details. + +The entry should be written using the following structure: + +``` rst +- Description of the changes, with possible link to + :ref:`relevant-section` of the updated documentation + (`#PRNUM <https://github.com/coq/coq/pull/PRNUM>`_, + [fixes `#ISSUE1 <https://github.com/coq/coq/issues/ISSUE1>`_ + [ and `#ISSUE2 <https://github.com/coq/coq/issues/ISSUE2>`_],] + by Full Name[, with help / review of Full Name]). +``` + +The description should be kept rather short and the only additional +required meta-information are the link to the pull request and the +full name of the author. @@ -11,6 +11,7 @@ (package coq) (source_tree sphinx) (source_tree tools) + unreleased.rst (env_var SPHINXWARNOPT)) (action (run env COQLIB=%{project_root} sphinx-build -j4 %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) @@ -19,6 +20,11 @@ (name refman-html) (deps sphinx_build)) +(rule + (targets unreleased.rst) + (deps (source_tree changelog)) + (action (with-stdout-to %{targets} (bash "cat changelog/00-title.rst changelog/*/*.rst")))) + ; The install target still needs more work. ; (install ; (section doc) diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 23f8fbe888..3c0355c92d 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,17 +1,8 @@ -(* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *) let edeclare ?hook ~ontop ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = - let sigma = Evd.minimize_universes sigma in - let body = EConstr.to_constr sigma body in - let tyopt = Option.map (EConstr.to_constr sigma) tyopt in - let uvars_fold uvars c = - Univ.LSet.union uvars (Vars.universes_of_constr c) in - let uvars = List.fold_left uvars_fold Univ.LSet.empty - (Option.List.cons tyopt [body]) in - let sigma = Evd.restrict_universe_context sigma uvars in - let univs = Evd.check_univ_decl ~poly sigma udecl in + let sigma, ce = DeclareDef.prepare_definition ~allow_evars:false + ~opaque ~poly sigma udecl ~types:tyopt ~body in let uctx = Evd.evar_universe_context sigma in let ubinders = Evd.universe_binders sigma in - let ce = Declare.definition_entry ?types:tyopt ~univs body in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in DeclareDef.declare_definition ~ontop ident k ce ubinders imps ?hook_data diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index c0c8c2d79c..8935ba27e3 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -10,9 +10,9 @@ SProp (proof irrelevant propositions) This section describes the extension of |Coq| with definitionally proof irrelevant propositions (types in the sort :math:`\SProp`, also known as strict propositions). To use :math:`\SProp` you must pass -``-allow-sprop`` to the |Coq| program or use :opt:`Allow StrictProp`. +``-allow-sprop`` to the |Coq| program or use :flag:`Allow StrictProp`. -.. opt:: Allow StrictProp +.. flag:: Allow StrictProp :name: Allow StrictProp Allows using :math:`\SProp` when set and forbids it when unset. The @@ -201,10 +201,10 @@ This means that some errors will be delayed until ``Qed``: Abort. -.. opt:: Elaboration StrictProp Cumulativity +.. flag:: Elaboration StrictProp Cumulativity :name: Elaboration StrictProp Cumulativity - Unset this option (it's on by default) to be strict with regard to + Unset this flag (it is on by default) to be strict with regard to :math:`\SProp` cumulativity during elaboration. The implementation of proof irrelevance uses inferred "relevance" diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index b069cf27f4..77a6ee79cc 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -405,6 +405,8 @@ few other commands related to typeclasses. resolution with the local hypotheses use full conversion during unification. + + When considering local hypotheses, we use the union of all the modes + declared in the given databases. .. cmdv:: typeclasses eauto @num @@ -433,22 +435,26 @@ few other commands related to typeclasses. .. _TypeclassesTransparent: -Typeclasses Transparent, Typclasses Opaque -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Typeclasses Transparent, Typeclasses Opaque +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. cmd:: Typeclasses Transparent {+ @ident} This command makes the identifiers transparent during typeclass resolution. + Shortcut for :n:`Hint Transparent {+ @ident } : typeclass_instances`. .. cmd:: Typeclasses Opaque {+ @ident} - Make the identifiers opaque for typeclass search. It is useful when some - constants prevent some unifications and make resolution fail. It is also - useful to declare constants which should never be unfolded during - proof-search, like fixpoints or anything which does not look like an - abbreviation. This can additionally speed up proof search as the typeclass - map can be indexed by such rigid constants (see + Make the identifiers opaque for typeclass search. + Shortcut for :n:`Hint Opaque {+ @ident } : typeclass_instances`. + + It is useful when some constants prevent some unifications and make + resolution fail. It is also useful to declare constants which + should never be unfolded during proof-search, like fixpoints or + anything which does not look like an abbreviation. This can + additionally speed up proof search as the typeclass map can be + indexed by such rigid constants (see :ref:`thehintsdatabasesforautoandeauto`). By default, all constants and local variables are considered transparent. One @@ -458,8 +464,6 @@ type, like: .. coqdoc:: Definition relation A := A -> A -> Prop. -This is equivalent to ``Hint Transparent, Opaque ident : typeclass_instances``. - Settings ~~~~~~~~ diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 57b9e45342..5704587ae0 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -2,6 +2,542 @@ Recent changes -------------- +.. include:: ../unreleased.rst + +Version 8.10 +------------ + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +|Coq| version 8.10 contains two major new features: support for a native +fixed-precision integer type and a new sort :math:`\SProp` of strict +propositions. It is also the result of refinements and stabilization of +previous features, deprecations or removals of deprecated features, +cleanups of the internals of the system and API, and many documentation improvements. +This release includes many user-visible changes, including deprecations that are +documented in the next subsection, and new features that are documented in the +reference manual. Here are the most important user-visible changes: + +- Kernel: + + - A notion of primitive object was added to the calculus. Its first + instance is primitive cyclic unsigned integers, axiomatized in + module :g:`UInt63`. See Section :ref:`primitive-integers`. + The `Coq.Numbers.Cyclic.Int31` library is deprecated + (`#6914 <https://github.com/coq/coq/pull/6914>`_, by Maxime Dénès, + Benjamin Grégoire and Vincent Laporte, + with help and reviews from many others). + + - The :math:`\SProp` sort of definitionally proof-irrelevant propositions was + introduced. :math:`\SProp` allows to mark proof + terms as irrelevant for conversion, and is treated like :math:`\Prop` + during extraction. It is enabled using the `-allow-sprop` + command-line flag or the :flag:`Allow StrictProp` flag. + See Chapter :ref:`sprop` + (`#8817 <https://github.com/coq/coq/pull/8817>`_, by Gaëtan Gilbert). + + - The unfolding heuristic in termination checking was made more + complete, allowing more constants to be unfolded to discover valid + recursive calls. Performance regression may occur in Fixpoint + declarations without an explicit ``{struct}`` annotation, since + guessing the decreasing argument can now be more expensive + (`#9602 <https://github.com/coq/coq/pull/9602>`_, by Enrico Tassi). + +- Universes: + + - Added :cmd:`Print Universes Subgraph` variant of :cmd:`Print Universes`. + Try for instance + :g:`Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1).` + (`#8451 <https://github.com/coq/coq/pull/8451>`_, by Gaëtan Gilbert). + + - Added private universes for opaque polymorphic constants, see the + documentation for the :flag:`Private Polymorphic Universes` flag, + and unset it to get the previous behaviour + (`#8850 <https://github.com/coq/coq/pull/8850>`_, by Gaëtan Gilbert). + +- Notations: + + - New command :cmd:`String Notation` to register string syntax for custom + inductive types + (`#8965 <https://github.com/coq/coq/pull/8965>`_, by Jason Gross). + + - Experimental: :ref:`Numeral Notations <numeral-notations>` now parse decimal + constants such as ``1.02e+01`` or ``10.2``. Parsers added for :g:`Q` and :g:`R`. + In the rare case when such numeral notations were used + in a development along with :g:`Q` or :g:`R`, they may have to be removed or + disambiguated through explicit scope annotations + (`#8764 <https://github.com/coq/coq/pull/8764>`_, by Pierre Roux). + +- Ltac backtraces can be turned on using the :flag:`Ltac Backtrace` + flag, which is off by default + (`#9142 <https://github.com/coq/coq/pull/9142>`_, + fixes `#7769 <https://github.com/coq/coq/issues/7769>`_ + and `#7385 <https://github.com/coq/coq/issues/7385>`_, + by Pierre-Marie Pédrot). + +- The tactics :tacn:`lia`, :tacn:`nia`, :tacn:`lra`, :tacn:`nra` are now using a novel + Simplex-based proof engine. In case of regression, unset :flag:`Simplex` + to get the venerable Fourier-based engine + (`#8457 <https://github.com/coq/coq/pull/8457>`_, by Fréderic Besson). + +- SSReflect: + + - New intro patterns: + + - temporary introduction: `=> +` + - block introduction: `=> [^ prefix ] [^~ suffix ]` + - fast introduction: `=> >` + - tactics as views: `=> /ltac:mytac` + - replace hypothesis: `=> {}H` + + See Section :ref:`introduction_ssr` + (`#6705 <https://github.com/coq/coq/pull/6705>`_, by Enrico Tassi, + with help from Maxime Dénès, + ideas coming from various users). + + - New tactic :tacn:`under` to rewrite under binders, given an + extensionality lemma: + + - interactive mode: :n:`under @term`, associated terminator: :tacn:`over` + - one-liner mode: `under @term do [@tactic | ...]` + + It can take occurrence switches, contextual patterns, and intro patterns: + :g:`under {2}[in RHS]eq_big => [i|i ?] do ...` + (`#9651 <https://github.com/coq/coq/pull/9651>`_, + by Erik Martin-Dorel and Enrico Tassi). + +- :cmd:`Combined Scheme` now works when inductive schemes are generated in sort + :math:`\Type`. It used to be limited to sort `Prop` + (`#7634 <https://github.com/coq/coq/pull/7634>`_, by Théo Winterhalter). + +- A new registration mechanism for reference from ML code to Coq + constructs has been added + (`#186 <https://github.com/coq/coq/pull/186>`_, + by Emilio Jesús Gallego Arias, Maxime Dénès and Vincent Laporte). + +- CoqIDE: + + - CoqIDE now depends on gtk+3 and lablgtk3 instead of gtk+2 and lablgtk2 + (`#9279 <https://github.com/coq/coq/pull/9279>`_, + by Hugo Herbelin, with help from Jacques Garrigue, + Emilio Jesús Gallego Arias, Michael Sogetrop and Vincent Laporte). + + - Smart input for Unicode characters. For example, typing + ``\alpha`` then ``Shift+Space`` will insert the greek letter alpha. + A larger number of default bindings are provided, following the latex + naming convention. Bindings can be customized, either globally, or on a + per-project basis. See Section :ref:`coqide-unicode` for details + (`#8560 <https://github.com/coq/coq/pull/8560>`_, by Arthur Charguéraud). + +- Infrastructure and dependencies: + + - Coq 8.10 requires OCaml >= 4.05.0, bumped from 4.02.3 See the + `INSTALL` file for more information on dependencies + (`#7522 <https://github.com/coq/coq/pull/7522>`_, by Emilio Jesús Gallego ArÃas). + + - Coq 8.10 doesn't need Camlp5 to build anymore. It now includes a + fork of the core parsing library that Coq uses, which is a small + subset of the whole Camlp5 distribution. In particular, this subset + doesn't depend on the OCaml AST, allowing easier compilation and + testing on experimental OCaml versions. Coq also ships a new parser + `coqpp` that plugin authors must switch to + (`#7902 <https://github.com/coq/coq/pull/7902>`_, + `#7979 <https://github.com/coq/coq/pull/7979>`_, + `#8161 <https://github.com/coq/coq/pull/8161>`_, + `#8667 <https://github.com/coq/coq/pull/8667>`_, + and `#8945 <https://github.com/coq/coq/pull/8945>`_, + by Pierre-Marie Pédrot and Emilio Jesús Gallego Arias). + + The Coq developers would like to thank Daniel de Rauglaudre for many + years of continued support. + + - Coq now supports building with Dune, in addition to the traditional + Makefile which is scheduled for deprecation + (`#6857 <https://github.com/coq/coq/pull/6857>`_, + by Emilio Jesús Gallego Arias, with help from Rudi Grinberg). + + Experimental support for building Coq projects has been integrated + in Dune at the same time, providing an `improved experience + <https://coq.discourse.group/t/a-guide-to-building-your-coq-libraries-and-plugins-with-dune/>`_ + for plugin developers. We thank the Dune team for their work + supporting Coq. + +Version 8.10 also comes with a bunch of smaller-scale changes and +improvements regarding the different components of the system, including +many additions to the standard library (see the next subsection for details). + +On the implementation side, the ``dev/doc/changes.md`` file documents +the numerous changes to the implementation and improvements of +interfaces. The file provides guidelines on porting a plugin to the new +version and a plugin development tutorial originally made by Yves Bertot +is now in `doc/plugin_tutorial`. The ``dev/doc/critical-bugs`` file +documents the known critical bugs of |Coq| and affected releases. + +The efficiency of the whole system has seen improvements thanks to +contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. + +Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael +Soegtrop, Théo Zimmermann worked on maintaining and improving the +continuous integration system and package building infrastructure. +Coq is now continuously tested against OCaml trunk, in addition to the +oldest supported and latest OCaml releases. + +Coq's documentation for the development branch is now deployed +continously at https://coq.github.io/doc/master/api (documentation of +the ML API), https://coq.github.io/doc/master/refman (reference +manual), and https://coq.github.io/doc/master/stdlib (documentation of +the standard library). Similar links exist for the `v8.10` branch. + +The OPAM repository for |Coq| packages has been maintained by Guillaume +Melquiond, Matthieu Sozeau, Enrico Tassi (who migrated it to opam 2) +with contributions from many users. A list of packages is available at +https://coq.inria.fr/opam/www/. + +The 61 contributors to this version are David A. Dalrymple, Tanaka +Akira, Benjamin Barenblat, Yves Bertot, Frédéric Besson, Lasse +Blaauwbroek, Martin Bodin, Joachim Breitner, Tej Chajed, Frédéric +Chapoton, Arthur Charguéraud, Cyril Cohen, Lukasz Czajka, Christian +Doczkal, Maxime Dénès, Andres Erbsen, Jim Fehrle, Gaëtan Gilbert, MatÄ›j +Grabovský, Simon Gregersen, Jason Gross, Samuel Gruetter, Hugo Herbelin, +Jasper Hugunin, Mirai Ikebuchi, Emilio Jesus Gallego Arias, Chantal +Keller, Matej KoÅ¡Ãk, Vincent Laporte, Olivier Laurent, Larry Darryl Lee +Jr, Pierre Letouzey, Nick Lewycky, Yao Li, Yishuai Li, Xia Li-yao, Assia +Mahboubi, Simon Marechal, Erik Martin-Dorel, Thierry Martinez, Guillaume +Melquiond, Kayla Ngan, Sam Pablo Kuper, Karl Palmskog, Clément +Pit-Claudel, Pierre-Marie Pédrot, Pierre Roux, Kazuhiko Sakaguchi, Ryan +Scott, Vincent Semeria, Gan Shen, Michael Soegtrop, Matthieu Sozeau, +Enrico Tassi, Laurent Théry, Kamil TrzciÅ„ski, whitequark, Théo +Winterhalter, Beta Ziliani and Théo Zimmermann. + +Many power users helped to improve the design of the new features via +the issue and pull request system, the |Coq| development mailing list, +the coq-club@inria.fr mailing list or the new Discourse forum. It would +be impossible to mention exhaustively the names of everybody who to some +extent influenced the development. + +Version 8.10 is the fifth release of |Coq| developed on a time-based +development cycle. Its development spanned 6 months from the release of +|Coq| 8.9. Vincent Laporte is the release manager and maintainer of this +release. This release is the result of ~2500 commits and ~650 PRs merged, +closing 150+ issues. + +| Santiago de Chile, April 2019, +| Matthieu Sozeau for the |Coq| development team +| + +Other changes in 8.10+beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +- Command-line tools and options: + + - The use of `coqtop` as a compiler has been deprecated, in favor of + `coqc`. Consequently option `-compile` will stop to be accepted in + the next release. `coqtop` is now reserved to interactive + use + (`#9095 <https://github.com/coq/coq/pull/9095>`_, + by Emilio Jesús Gallego Arias). + + - New option ``-topfile filename``, which will set the current module name + (*à la* ``-top``) based on the filename passed, taking into account the + proper ``-R``/``-Q`` options. For example, given ``-R Foo foolib`` using + ``-topfile foolib/bar.v`` will set the module name to ``Foo.Bar``. + CoqIDE now properly sets the module name for a given file based on + its path + (`#8991 <https://github.com/coq/coq/pull/8991>`_, + closes `#8989 <https://github.com/coq/coq/issues/8989>`_, + by Gaëtan Gilbert). + + - Experimental: Coq flags and options can now be set on the + command-line, e.g. ``-set "Universe Polymorphism=true"`` + (`#9876 <https://github.com/coq/coq/pull/9876>`_, by Gaëtan Gilbert). + + - The `-native-compiler` flag of `coqc` and `coqtop` now takes an + argument which can have three values: + + - `no` disables native_compute + - `yes` enables native_compute and precompiles `.v` files to + native code + - `ondemand` enables native_compute but compiles code only when + `native_compute` is called + + The default value is `ondemand`. Note that this flag now has + priority over the configure flag of the same name. + + A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls + whether conversion can use the VM. The default value is `yes`. + + (`#8870 <https://github.com/coq/coq/pull/8870>`_, by Maxime Dénès) + + - The pretty timing diff scripts (flag `TIMING=1` to a + `coq_makefile`\-made `Makefile`, also + `tools/make-both-single-timing-files.py`, + `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) + now correctly support non-UTF-8 characters in the output of + `coqc` / `make` as well as printing to stdout, on both python2 and + python3 + (`#9872 <https://github.com/coq/coq/pull/9872>`_, + closes `#9767 <https://github.com/coq/coq/issues/9767>`_ + and `#9705 <https://github.com/coq/coq/issues/9705>`_, + by Jason Gross) + + - coq_makefile's install target now errors if any file to install is missing + (`#9906 <https://github.com/coq/coq/pull/9906>`_, by Gaëtan Gilbert). + + - Preferences from ``coqide.keys`` are no longer overridden by + modifiers preferences in ``coqiderc`` + (`#10014 <https://github.com/coq/coq/pull/10014>`_, by Hugo Herbelin). + +- Specification language, type inference: + + - Fixing a missing check in interpreting instances of existential + variables that are bound to local definitions. Might exceptionally + induce an overhead if the cost of checking the conversion of the + corresponding definitions is additionally high + (`#8217 <https://github.com/coq/coq/pull/8217>`_, + closes `#8215 <https://github.com/coq/coq/issues/8215>`_, + by Hugo Herbelin). + + - A few improvements in inference of the return clause of `match` that + can exceptionally introduce incompatibilities. This can be + solved by writing an explicit `return` clause, sometimes even simply + an explicit `return _` clause + (`#262 <https://github.com/coq/coq/pull/262>`_, by Hugo Herbelin). + + - Using non-projection values with the projection syntax is not + allowed. For instance :g:`0.(S)` is not a valid way to write :g:`S 0`. + Projections from non-primitive (emulated) records are allowed with + warning "nonprimitive-projection-syntax" + (`#8829 <https://github.com/coq/coq/pull/8829>`_, by Gaëtan Gilbert). + + - An option and attributes to control the automatic decision to declare + an inductive type as template polymorphic were added. Warning + "auto-template" (off by default) can trigger when an inductive is + automatically declared template polymorphic without the attribute. + + Inductive types declared by Funind will never be template polymorphic. + + (`#8488 <https://github.com/coq/coq/pull/8488>`_, by Gaëtan Gilbert) + +- Notations: + + - New command :cmd:`Declare Scope` to explicitly declare a scope name + before any use of it. Implicit declaration of a scope at the time of + :cmd:`Bind Scope`, :cmd:`Delimit Scope`, :cmd:`Undelimit Scope`, + or :cmd:`Notation` is deprecated + (`#7135 <https://github.com/coq/coq/pull/7135>`_, by Hugo Herbelin). + + - Various bugs have been fixed (e.g. `#9214 + <https://github.com/coq/coq/pull/9214>`_ on removing spurious + parentheses on abbreviations shortening a strict prefix of an + application, by Hugo Herbelin). + + - :cmd:`Numeral Notation` now support inductive types in the input to + printing functions (e.g., numeral notations can be defined for terms + containing things like :g:`@cons nat O O`), and parsing functions now + fully normalize terms including parameters of constructors (so that, + e.g., a numeral notation whose parsing function outputs a proof of + :g:`Nat.gcd x y = 1` will no longer fail to parse due to containing the + constant :g:`Nat.gcd` in the parameter-argument of :g:`eq_refl`) + (`#9874 <https://github.com/coq/coq/pull/9840>`_, + closes `#9840 <https://github.com/coq/coq/issues/9840>`_ + and `#9844 <https://github.com/coq/coq/issues/9844>`_, + by Jason Gross). + + - Deprecated compatibility notations have actually been + removed. Uses of these notations are generally easy to fix thanks + to the hint contained in the deprecation warning emitted by Coq + 8.8 and 8.9. For projects that require more than a handful of + such fixes, there is `a script + <https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py>`_ + that will do it automatically, using the output of ``coqc`` + (`#8638 <https://github.com/coq/coq/pull/8638>`_, by Jason Gross). + +- The `quote plugin + <https://coq.inria.fr/distrib/V8.9.0/refman/proof-engine/detailed-tactic-examples.html#quote>`_ + was removed. If some users are interested in maintaining this plugin + externally, the Coq development team can provide assistance for + extracting the plugin and setting up a new repository + (`#7894 <https://github.com/coq/coq/pull/7894>`_, by Maxime Dénès). + +- Ltac: + + - Tactic names are no longer allowed to clash, even if they are not defined in + the same section. For example, the following is no longer accepted: + :g:`Ltac foo := idtac. Section S. Ltac foo := fail. End S.` + (`#8555 <https://github.com/coq/coq/pull/8555>`_, by Maxime Dénès). + + - Names of existential variables occurring in Ltac functions + (e.g. :g:`?[n]` or :g:`?n` in terms - not in patterns) are now interpreted + the same way as other variable names occurring in Ltac functions + (`#7309 <https://github.com/coq/coq/pull/7309>`_, by Hugo Herbelin). + +- Tactics: + + - Removed the deprecated `romega` tactic + (`#8419 <https://github.com/coq/coq/pull/8419>`_, + by Maxime Dénès and Vincent Laporte). + + - Hint declaration and removal should now specify a database (e.g. `Hint Resolve + foo : database`). When the database name is omitted, the hint is added to the + `core` database (as previously), but a deprecation warning is emitted + (`#8987 <https://github.com/coq/coq/pull/8987>`_, by Maxime Dénès). + + - There are now tactics in `PreOmega.v` called + `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and + `Z.to_euclidean_division_equations` (which combines the `div_mod` + and `quot_rem` variants) which allow :tacn:`lia`, :tacn:`nia`, etc to + support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), + by posing the specifying equation for `Z.div` and `Z.modulo` before + replacing them with atoms + (`#8062 <https://github.com/coq/coq/pull/8062>`_, by Jason Gross). + + - The syntax of the :tacn:`autoapply` tactic was fixed to conform with preexisting + documentation: it now takes a `with` clause instead of a `using` clause + (`#9524 <https://github.com/coq/coq/pull/9524>`_, + closes `#7632 <https://github.com/coq/coq/issues/7632>`_, + by Théo Zimmermann). + + - SSReflect clear discipline made consistent across the entire proof language. + Whenever a clear switch `{x..}` comes immediately before an existing proof + context entry (used as a view, as a rewrite rule or as name for a new + context entry) then such entry is cleared too. + + E.g. The following sentences are elaborated as follows (when H is an existing + proof context entry): + + - `=> {x..} H` -> `=> {x..H} H` + - `=> {x..} /H` -> `=> /v {x..H}` + - `rewrite {x..} H` -> `rewrite E {x..H}` + + (`#9341 <https://github.com/coq/coq/pull/9341>`_, by Enrico Tassi). + +- Vernacular commands: + + - Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. + Names may not be repeated, and may not overlap with section variable names + (`#8820 <https://github.com/coq/coq/pull/8820>`_, + closes `#8791 <https://github.com/coq/coq/issues/8791>`_, + by Jasper Hugunin). + + - Removed the deprecated `Implicit Tactic` family of commands + (`#8779 <https://github.com/coq/coq/pull/8779>`_, by Pierre-Marie Pédrot). + + - The `Automatic Introduction` option has been removed and is now the + default + (`#9001 <https://github.com/coq/coq/pull/9001>`_, + by Emilio Jesús Gallego Arias). + + - `Arguments` now accepts names for arguments provided with `extra_scopes` + (`#9117 <https://github.com/coq/coq/pull/9117>`_, by Maxime Dénès). + + - The naming scheme for anonymous binders in a `Theorem` has changed to + avoid conflicts with explicitly named binders + (`#9160 <https://github.com/coq/coq/pull/9160>`_, + closes `#8819 <https://github.com/coq/coq/issues/8819>`_, + by Jasper Hugunin). + + - Computation of implicit arguments now properly handles local definitions in the + binders for an `Instance`, and can be mixed with implicit binders `{x : T}` + (`#9307 <https://github.com/coq/coq/pull/9307>`_, + closes `#9300 <https://github.com/coq/coq/issues/9300>`_, + by Jasper Hugunin). + + - :cmd:`Declare Instance` now requires an instance name. + + The flag :flag:`Refine Instance Mode` has been turned off by default, + meaning that :cmd:`Instance` no longer opens a proof when a body is + provided. The flag has been deprecated and will be removed in the next + version. + + (`#9270 <https://github.com/coq/coq/pull/9270>`_, + and `#9825 <https://github.com/coq/coq/pull/9825>`_, + by Maxime Dénès) + + - Command :cmd:`Instance`, when no body is provided, now always opens + a proof. This is a breaking change, as instance of :n:`Instance + @ident__1 : @ident__2.` where :n:`@ident__2` is a trivial class will + have to be changed into :n:`Instance @ident__1 : @ident__2 := {}.` + or :n:`Instance @ident__1 : @ident__2. Proof. Qed.` + (`#9274 <https://github.com/coq/coq/pull/9274>`_, by Maxime Dénès). + + - The flag :flag:`Program Mode` now means that the `Program` attribute is enabled + for all commands that support it. In particular, it does not have any effect + on tactics anymore. May cause some incompatibilities + (`#9410 <https://github.com/coq/coq/pull/9410>`_, by Maxime Dénès). + + - The algorithm computing implicit arguments now behaves uniformly for primitive + projection and application nodes + (`#9509 <https://github.com/coq/coq/pull/9509>`_, + closes `#9508 <https://github.com/coq/coq/issues/9508>`_, + by Pierre-Marie Pédrot). + + - :cmd:`Hypotheses` and :cmd:`Variables` can now take implicit + binders inside sections + (`#9364 <https://github.com/coq/coq/pull/9364>`_, + closes `#9363 <https://github.com/coq/coq/issues/9363>`_, + by Jasper Hugunin). + + - Removed deprecated option `Automatic Coercions Import` + (`#8094 <https://github.com/coq/coq/pull/8094>`_, by Maxime Dénès). + + - The ``Show Script`` command has been deprecated + (`#9829 <https://github.com/coq/coq/pull/9829>`_, by Vincent Laporte). + + - :cmd:`Coercion` does not warn ambiguous paths which are obviously + convertible with existing ones + (`#9743 <https://github.com/coq/coq/pull/9743>`_, + closes `#3219 <https://github.com/coq/coq/issues/3219>`_, + by Kazuhiko Sakaguchi). + + - A new flag :flag:`Fast Name Printing` has been introduced. It changes the + algorithm used for allocating bound variable names for a faster but less + clever one + (`#9078 <https://github.com/coq/coq/pull/9078>`_, by Pierre-Marie Pédrot). + + - Option ``Typeclasses Axioms Are Instances`` (compatibility option + introduced in the previous version) is deprecated. Use :cmd:`Declare + Instance` for axioms which should be instances + (`#8920 <https://github.com/coq/coq/pull/8920>`_, by Gaëtan Gilbert). + + - Removed option `Printing Primitive Projection Compatibility` + (`#9306 <https://github.com/coq/coq/pull/9306>`_, by Gaëtan Gilbert). + +- Standard Library: + + - Added `Bvector.BVeq` that decides whether two `Bvector`\s are equal. + Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg` + (`#8171 <https://github.com/coq/coq/pull/8171>`_, by Yishuai Li). + + - Added `ByteVector` type that can convert to and from `string` + (`#8365 <https://github.com/coq/coq/pull/8365>`_, by Yishuai Li). + + - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about + the upper bound of number represented by a vector. + Allowed implicit vector length argument in `Ndigits.Bv2N` + (`#8815 <https://github.com/coq/coq/pull/8815>`_, by Yishuai Li). + + - The prelude used to be automatically Exported and is now only + Imported. This should be relevant only when importing files which + don't use `-noinit` into files which do + (`#9013 <https://github.com/coq/coq/pull/9013>`_, by Gaëtan Gilert). + + - Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an + ordered type, using lexical order + (`#7221 <https://github.com/coq/coq/pull/7221>`_, by Li Yao). + + - Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo` + (`#9425 <https://github.com/coq/coq/pull/9425>`_, by Andres Erbsen). + + - Moved the `auto` hints of the `FSet` library into a new + `fset` database + (`#9725 <https://github.com/coq/coq/pull/9725>`_, by Frédéric Besson). + +- Some error messages that show problems with a pair of non-matching + values will now highlight the differences + (`#8669 <https://github.com/coq/coq/pull/8669>`_, by Jim Fehrle). + + Version 8.9 ----------- @@ -12,7 +548,7 @@ Summary of changes of features and deprecations or removals of deprecated features, cleanups of the internals of the system and API along with a few new features. This release includes many user-visible changes, including -deprecations that are documented in ``CHANGES.md`` and new features that +deprecations that are documented in the next subsection and new features that are documented in the reference manual. Here are the most important changes: @@ -26,7 +562,7 @@ changes: manual). - Deprecated notations of the standard library will be removed in the - next version of |Coq|, see the ``CHANGES.md`` file for a script to + next version of |Coq|, see the next subsection for a script to ease porting, by Jason Gross and Jean-Christophe Léchenet. - Added the :cmd:`Numeral Notation` command for registering decimal @@ -79,7 +615,7 @@ changes: - Library: additions and changes in the ``VectorDef``, ``Ascii``, and ``String`` libraries. Syntax notations are now available only when using ``Import`` of libraries and not merely ``Require``, by various - contributors (source of incompatibility, see ``CHANGES.md`` for details). + contributors (source of incompatibility, see the next subsection for details). - Toplevels: ``coqtop`` and ``coqide`` can now display diffs between proof steps in color, using the :opt:`Diffs` option, by Jim Fehrle. @@ -96,7 +632,7 @@ changes: Version 8.9 also comes with a bunch of smaller-scale changes and improvements regarding the different components of the system. Most -important ones are documented in the ``CHANGES.md`` file. +important ones are documented in the next subsection file. On the implementation side, the ``dev/doc/changes.md`` file documents the numerous changes to the implementation and improvements of @@ -152,8 +688,8 @@ engineer working with Maxime Dénès in the |Coq| consortium. | Matthieu Sozeau for the |Coq| development team | -Details of changes -~~~~~~~~~~~~~~~~~~ +Details of changes in 8.9+beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Kernel @@ -167,16 +703,12 @@ Notations - Deprecated compatibility notations will actually be removed in the next version of Coq. Uses of these notations are generally easy to fix thanks to the hint contained in the deprecation warnings. For - projects that require more than a handful of such fixes, there is [a - script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) - that will do it automatically, using the output of coqc. The script + projects that require more than a handful of such fixes, there is `a + script + <https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py>`_ + that will do it automatically, using the output of ``coqc``. The script contains documentation on its usage in a comment at the top. -- When several notations are available for the same expression, - priority is given to latest notations defined in the scopes being - opened, in order, rather than to the latest notations defined - independently of whether they are in an opened scope or not. - Tactics - Added toplevel goal selector `!` which expects a single focused goal. @@ -260,7 +792,7 @@ Standard Library `Require Import Coq.Compat.Coq88` will make these notations available. Users wishing to port their developments automatically may download `fix.py` from - <https://gist.github.com/JasonGross/5d4558edf8f5c2c548a3d96c17820169> + https://gist.github.com/JasonGross/5d4558edf8f5c2c548a3d96c17820169 and run a command like `while true; do make -Okj 2>&1 | /path/to/fix.py; done` and get a cup of coffee. (This command must be manually interrupted once the build finishes all the way though. @@ -284,8 +816,8 @@ Tools If you would like to maintain this tool externally, please contact us. - Removed the Emacs modes distributed with Coq. You are advised to - use [Proof-General](https://proofgeneral.github.io/) (and optionally - [Company-Coq](https://github.com/cpitclaudel/company-coq)) instead. + use `Proof-General <https://proofgeneral.github.io/>`_ (and optionally + `Company-Coq <https://github.com/cpitclaudel/company-coq>`_) instead. If your use case is not covered by these alternative Emacs modes, please open an issue. We can help set up external maintenance as part of Proof-General, or independently as part of coq-community. @@ -428,7 +960,7 @@ version. Version 8.8 also comes with a bunch of smaller-scale changes and improvements regarding the different components of the system. -Most important ones are documented in the ``CHANGES.md`` file. +Most important ones are documented in the next subsection file. The efficiency of the whole system has seen improvements thanks to contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, Maxime Dénès and @@ -788,7 +1320,7 @@ of integers and real constants are now represented using ``IZR`` (work by Guillaume Melquiond). Standard library additions and improvements by Jason Gross, Pierre Letouzey and -others, documented in the ``CHANGES.md`` file. +others, documented in the next subsection file. The mathematical proof language/declarative mode plugin was removed from the archive. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 695dea222f..5308330820 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -2244,6 +2244,7 @@ Printing universes unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. .. cmdv:: Print Universes Subgraph(@names) + :name: Print Universes Subgraph Prints the graph restricted to the requested names (adjusting constraints to preserve the implied transitive constraints between diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 97d86943fb..6cbd00f45d 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -252,6 +252,8 @@ use antialiased fonts or not, by setting the environment variable `GDK_USE_XFT` to 1 or 0 respectively. +.. _coqide-unicode: + Bindings for input of Unicode symbols ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 8346b72cb9..35231610fe 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -144,6 +144,10 @@ Here we describe only few of them. :CAMLFLAGS: can be used to specify additional flags to the |OCaml| compiler, like ``-bin-annot`` or ``-w``.... +:OCAMLWARN: + it contains a default of ``-warn-error +a-3``, useful to modify + this setting; beware this is not recommended for projects in + Coq's CI. :COQC, COQDEP, COQDOC: can be set in order to use alternative binaries (e.g. wrappers) diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index b240cef40c..4e40df6f94 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1737,9 +1737,8 @@ Intro patterns for each :token:`ident`. Its type has to be fixed later on by using the ``abstract`` tactic. Before then the type displayed is ``<hidden>``. - Note that |SSR| does not support the syntax ``(ipat, …, ipat)`` for -destructing intro-patterns. +destructing intro patterns. Clear switch ```````````` @@ -3626,7 +3625,7 @@ corresponding new goals will be generated. As in :ref:`apply_ssr`, the ``ssrautoprop`` tactic is used to try to solve the existential variable. - .. coqtop:: all + .. coqtop:: all abort Lemma test (x : 'I_2) y (H : y < 2) : Some x = insub 2 y. rewrite insubT. @@ -3637,6 +3636,272 @@ rewriting rule is stated using Leibniz equality (as opposed to setoid relations). It will be extended to other rewriting relations in the future. +.. _under_ssr: + +Rewriting under binders +~~~~~~~~~~~~~~~~~~~~~~~ + +Goals involving objects defined with higher-order functions often +require "rewriting under binders". While setoid rewriting is a +possible approach in this case, it is common to use regular rewriting +along with dedicated extensionality lemmas. This may cause some +practical issues during the development of the corresponding scripts, +notably as we might be forced to provide the rewrite tactic with +complete terms, as shown by the simple example below. + +.. example:: + + .. coqtop:: reset none + + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + + .. coqtop:: in + + Axiom subnn : forall n : nat, n - n = 0. + Parameter map : (nat -> nat) -> list nat -> list nat. + Parameter sumlist : list nat -> nat. + Axiom eq_map : + forall F1 F2 : nat -> nat, + (forall n : nat, F1 n = F2 n) -> + forall l : list nat, map F1 l = map F2 l. + + .. coqtop:: all + + Lemma example_map l : sumlist (map (fun m => m - m) l) = 0. + + In this context, one cannot directly use ``eq_map``: + + .. coqtop:: all fail + + rewrite eq_map. + + as we need to explicitly provide the non-inferable argument ``F2``, + which corresponds here to the term we want to obtain *after* the + rewriting step. In order to perform the rewrite step one has to + provide the term by hand as follows: + + .. coqtop:: all abort + + rewrite (@eq_map _ (fun _ : nat => 0)). + by move=> m; rewrite subnn. + + The :tacn:`under` tactic lets one perform the same operation in a more + convenient way: + + .. coqtop:: all abort + + Lemma example_map l : sumlist (map (fun m => m - m) l) = 0. + under eq_map => m do rewrite subnn. + + +The under tactic +```````````````` + +The convenience :tacn:`under` tactic supports the following syntax: + +.. tacn:: under {? @r_prefix } @term {? => {+ @i_item}} {? do ( @tactic | [ {*| @tactic } ] ) } + :name: under + + Operate under the context proved to be extensional by + lemma :token:`term`. + + .. exn:: Incorrect number of tactics (expected N tactics, was given M). + + This error can occur when using the version with a ``do`` clause. + + The multiplier part of :token:`r_prefix` is not supported. + +We distinguish two modes, +:ref:`interactive mode <under_interactive>` without a ``do`` clause, and +:ref:`one-liner mode <under_one_liner>` with a ``do`` clause, +which are explained in more detail below. + +.. _under_interactive: + +Interactive mode +```````````````` + +Let us redo the running example in interactive mode. + +.. example:: + + .. coqtop:: all abort + + Lemma example_map l : sumlist (map (fun m => m - m) l) = 0. + under eq_map => m. + rewrite subnn. + over. + +The execution of the Ltac expression: + +:n:`under @term => [ @i_item__1 | … | @i_item__n ].` + +involves the following steps: + +1. It performs a :n:`rewrite @term` + without failing like in the first example with ``rewrite eq_map.``, + but creating evars (see :tacn:`evar`). If :n:`term` is prefixed by + a pattern or an occurrence selector, then the modifiers are honoured. + +2. As a n-branches intro pattern is provided :tacn:`under` checks that + n+1 subgoals have been created. The last one is the main subgoal, + while the other ones correspond to premises of the rewrite rule (such as + ``forall n, F1 n = F2 n`` for ``eq_map``). + +3. If so :tacn:`under` puts these n goals in head normal form (using + the defective form of the tactic :tacn:`move`), then executes + the corresponding intro pattern :n:`@ipat__i` in each goal. + +4. Then :tacn:`under` checks that the first n subgoals + are (quantified) equalities or double implications between a + term and an evar (e.g. ``m - m = ?F2 m`` in the running example). + +5. If so :tacn:`under` protects these n goals against an + accidental instantiation of the evar. + These protected goals are displayed using the ``Under[ … ]`` + notation (e.g. ``Under[ m - m ]`` in the running example). + +6. The expression inside the ``Under[ … ]`` notation can be + proved equivalent to the desired expression + by using a regular :tacn:`rewrite` tactic. + +7. Interactive editing of the first n goals has to be signalled by + using the :tacn:`over` tactic or rewrite rule (see below). + +8. Finally, a post-processing step is performed in the main goal + to keep the name(s) for the bound variables chosen by the user in + the intro pattern for the first branch. + +.. _over_ssr: + +The over tactic ++++++++++++++++ + +Two equivalent facilities (a terminator and a lemma) are provided to +close intermediate subgoals generated by :tacn:`under` (i.e. goals +displayed as ``Under[ … ]``): + +.. tacn:: over + :name: over + + This terminator tactic allows one to close goals of the form + ``'Under[ … ]``. + +.. tacv:: by rewrite over + + This is a variant of :tacn:`over` in order to close ``Under[ … ]`` + goals, relying on the ``over`` rewrite rule. + +.. _under_one_liner: + +One-liner mode +`````````````` + +The Ltac expression: + +:n:`under @term => [ @i_item__1 | … | @i_item__n ] do [ @tac__1 | … | @tac__n ].` + +can be seen as a shorter form for the following expression: + +:n:`(under @term) => [ @i_item__1 | … | @i_item__n | ]; [ @tac__1; over | … | @tac__n; over | cbv beta iota ].` + +Notes: + ++ The ``beta-iota`` reduction here is useful to get rid of the beta + redexes that could be introduced after the substitution of the evars + by the :tacn:`under` tactic. + ++ Note that the provided tactics can as well + involve other :tacn:`under` tactics. See below for a typical example + involving the `bigop` theory from the Mathematical Components library. + ++ If there is only one tactic, the brackets can be omitted, e.g.: + :n:`under @term => i do @tac.` and that shorter form should be + preferred. + ++ If the ``do`` clause is provided and the intro pattern is omitted, + then the default :token:`i_item` ``*`` is applied to each branch. + E.g., the Ltac expression: + :n:`under @term do [ @tac__1 | … | @tac__n ]` is equivalent to: + :n:`under @term => [ * | … | * ] do [ @tac__1 | … | @tac__n ]` + (and it can be noted here that the :tacn:`under` tactic performs a + ``move.`` before processing the intro patterns ``=> [ * | … | * ]``). + +.. example:: + + .. coqtop:: reset none + + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + + Coercion is_true : bool >-> Sortclass. + + Reserved Notation "\big [ op / idx ]_ ( m <= i < n | P ) F" + (at level 36, F at level 36, op, idx at level 10, m, i, n at level 50, + format "'[' \big [ op / idx ]_ ( m <= i < n | P ) F ']'"). + Variant bigbody (R I : Type) : Type := + BigBody : forall (_ : I) (_ : forall (_ : R) (_ : R), R) (_ : bool) (_ : R), bigbody R I. + + Parameter bigop : + forall (R I : Type) (_ : R) (_ : list I) (_ : forall _ : I, bigbody R I), R. + + Axiom eq_bigr_ : + forall (R : Type) (idx : R) (op : forall (_ : R) (_ : R), R) (I : Type) + (r : list I) (P : I -> bool) (F1 F2 : I -> R), + (forall x : I, is_true (P x) -> F1 x = F2 x) -> + bigop idx r (fun i : I => BigBody i op (P i) (F1 i)) = + bigop idx r (fun i : I => BigBody i op (P i) (F2 i)). + + Axiom eq_big_ : + forall (R : Type) (idx : R) (op : R -> R -> R) (I : Type) (r : list I) + (P1 P2 : I -> bool) (F1 F2 : I -> R), + (forall x : I, P1 x = P2 x) -> + (forall i : I, is_true (P1 i) -> F1 i = F2 i) -> + bigop idx r (fun i : I => BigBody i op (P1 i) (F1 i)) = + bigop idx r (fun i : I => BigBody i op (P2 i) (F2 i)). + + Reserved Notation "\sum_ ( m <= i < n | P ) F" + (at level 41, F at level 41, i, m, n at level 50, + format "'[' \sum_ ( m <= i < n | P ) '/ ' F ']'"). + + Parameter index_iota : nat -> nat -> list nat. + + Notation "\big [ op / idx ]_ ( m <= i < n | P ) F" := + (bigop idx (index_iota m n) (fun i : nat => BigBody i op P%bool F)). + + Notation "\sum_ ( m <= i < n | P ) F" := + (\big[plus/O]_(m <= i < n | P%bool) F%nat). + + Notation eq_bigr := (fun n m => eq_bigr_ 0 plus (index_iota n m)). + Notation eq_big := (fun n m => eq_big_ 0 plus (index_iota n m)). + + Parameter odd : nat -> bool. + Parameter prime : nat -> bool. + + .. coqtop:: in + + Parameter addnC : forall m n : nat, m + n = n + m. + Parameter muln1 : forall n : nat, n * 1 = n. + + .. coqtop:: all + + Check eq_bigr. + Check eq_big. + + Lemma test_big_nested (m n : nat) : + \sum_(0 <= a < m | prime a) \sum_(0 <= j < n | odd (j * 1)) (a + j) = + \sum_(0 <= i < m | prime i) \sum_(0 <= j < n | odd j) (j + i). + under eq_bigr => i prime_i do + under eq_big => [ j | j odd_j ] do + [ rewrite (muln1 j) | rewrite (addnC i j) ]. + + Remark how the final goal uses the name ``i`` (the name given in the + intro pattern) rather than ``a`` in the binder of the first summation. .. _locking_ssr: @@ -5373,7 +5638,15 @@ respectively. .. tacn:: rewrite {+ @r_step } - rewrite (see :ref:`rewriting_ssr`) + rewrite (see :ref:`rewriting_ssr`) + +.. tacn:: under {? @r_prefix } @term {? => {+ @i_item}} {? do ( @tactic | [ {*| @tactic } ] )} + + under (see :ref:`under_ssr`) + +.. tacn:: over + + over (see :ref:`over_ssr`) .. tacn:: have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } {? : @term } := @term have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } : @term {? by @tactic } diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index afb0239be4..1f339e7761 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3830,25 +3830,25 @@ The general command to add a hint to some databases :n:`{+ @ident}` is check with :cmd:`Print HintDb` to verify the current cut expression: .. productionlist:: regexp - e : `ident` hint or instance identifier - : _ any hint - : `e` | `e` disjunction - : `e` `e` sequence - : `e` * Kleene star - : emp empty - : eps epsilon - : ( `e` ) + regexp : `ident` (hint or instance identifier) + : _ (any hint) + : `regexp` | `regexp` (disjunction) + : `regexp` `regexp` (sequence) + : `regexp` * (Kleene star) + : emp (empty) + : eps (epsilon) + : ( `regexp` ) The `emp` regexp does not match any search path while `eps` matches the empty path. During proof search, the path of successive successful hints on a search branch is recorded, as a - list of identifiers for the hints (note that Hint Extern’s do not have + list of identifiers for the hints (note that :cmd:`Hint Extern`\’s do not have an associated identifier). Before applying any hint :n:`@ident` the current path `p` extended with :n:`@ident` is matched against the current cut expression `c` associated to the hint database. If matching succeeds, the hint is *not* applied. The - semantics of ``Hint Cut e`` is to set the cut expression to ``c | e``, the - initial cut expression being `emp`. + semantics of :n:`Hint Cut @regexp` is to set the cut expression + to :n:`c | regexp`, the initial cut expression being `emp`. .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} : @ident :name: Hint Mode @@ -3875,7 +3875,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. note:: One can use an ``Extern`` hint with no pattern to do pattern matching on - hypotheses using ``match goal`` with inside the tactic. + hypotheses using ``match goal with`` inside the tactic. Hint databases defined in the Coq standard library @@ -4724,6 +4724,12 @@ Non-logical tactics from the shelf into focus, by appending them to the end of the current list of focused goals. +.. tacn:: unshelve @tactic + :name: unshelve + + Performs :n:`@tactic`, then unshelves existential variables added to the + shelf by the execution of :n:`@tactic`, prepending them to the current goal. + .. tacn:: give_up :name: give_up @@ -4805,3 +4811,83 @@ references to automatically generated names. :name: Mangle Names Prefix Specifies the prefix to use when generating names. + +Performance-oriented tactic variants +------------------------------------ + +.. tacn:: change_no_check @term + :name: change_no_check + + For advanced usage. Similar to :n:`change @term`, but as an optimization, + it skips checking that :n:`@term` is convertible to the goal. + + Recall that the Coq kernel typechecks proofs again when they are concluded to + ensure safety. Hence, using :tacn:`change` checks convertibility twice + overall, while :tacn:`change_no_check` can produce ill-typed terms, + but checks convertibility only once. + Hence, :tacn:`change_no_check` can be useful to speed up certain proof + scripts, especially if one knows by construction that the argument is + indeed convertible to the goal. + + In the following example, :tacn:`change_no_check` replaces :g:`False` by + :g:`True`, but :g:`Qed` then rejects the proof, ensuring consistency. + + .. example:: + + .. coqtop:: all abort + + Goal False. + change_no_check True. + exact I. + Fail Qed. + + .. tacv:: convert_concl_no_check @term + :name: convert_concl_no_check + + Deprecated old name for :tacn:`change_no_check`. Does not support any of its + variants. + +.. tacn:: exact_no_check @term + :name: exact_no_check + + For advanced usage. Similar to :n:`exact @term`, but as an optimization, + it skips checking that :n:`@term` has the goal's type, relying on the kernel + check instead. See :tacn:`change_no_check` for more explanations. + + .. example:: + + .. coqtop:: all abort + + Goal False. + exact_no_check I. + Fail Qed. + + .. tacv:: vm_cast_no_check @term + :name: vm_cast_no_check + + For advanced usage. Similar to :n:`exact_no_check @term`, but additionally + instructs the kernel to use :tacn:`vm_compute` to compare the + goal's type with the :n:`@term`'s type. + + .. example:: + + .. coqtop:: all abort + + Goal False. + vm_cast_no_check I. + Fail Qed. + + .. tacv:: native_cast_no_check @term + :name: native_cast_no_check + + for advanced usage. similar to :n:`exact_no_check @term`, but additionally + instructs the kernel to use :tacn:`native_compute` to compare the goal's + type with the :n:`@term`'s type. + + .. example:: + + .. coqtop:: all abort + + Goal False. + native_cast_no_check I. + Fail Qed. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 63df3d37bf..ac079ea7d5 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1040,8 +1040,6 @@ interpreted in the scope stack extended with the scope bound tokey. To remove a delimiting key of a scope, use the command :n:`Undelimit Scope @scope` -.. _ArgumentScopes: - Binding arguments of a constant to an interpretation scope +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -1311,65 +1309,6 @@ Displaying information about scopes It also displays the delimiting key if any and the class to which the scope is bound, if any. -Impact of scopes on printing -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When several notations are available for printing the same expression, -Coq will use the following rules for printing priorities: - -- If two notations are available in different scopes which are open, - the notation in the more recently opened scope takes precedence. - -- If two notations are available in the same scope, the more recently - defined (or imported) notation takes precedence. - -- Abbreviations and lonely notations, both of which have no scope, - take precedence over a notation in an open scope if and only if the - abbreviation or lonely notation was defined (or imported) more - recently than when the corresponding scope was open. They take - precedence over any notation not in an open scope, whether this scope - has a delimiter or not. - -- A scope is *active* for printing a term either because it was opened - with :cmd:`Open Scope`, or the term is the immediate argument of a - constant which temporarily opens a scope for this argument (see - :ref:`Arguments <ArgumentScopes>`) in which case this temporary - scope is the most recent open one. - -- In case no abbreviation, nor lonely notation, nor notation in an - explicitly open scope, nor notation in a temporarily open scope of - arguments, has been found, notations in those closed scopes which - have a delimiter are considered, giving priority to the most - recently defined (or imported) ones. The corresponding delimiter is - inserted, making the corresponding scope the most recent explicitly - open scope for all subterms of the current term. As an exception to - the insertion of the corresponding delimiter, when an expression is - statically known to be in a position expecting a type and the - notation is from scope ``type_scope``, and the latter is closed, the - delimiter is not inserted. This is because expressions statically - known to be in a position expecting a type are by default - interpreted with `type_scope` temporarily activated. Expressions - statically known to be in a position expecting a type typically - include being on the right-hand side of `:`, `<:`, `<<:` and after - the comma in a `forall` expression. - -- As a refinement of the previous rule, in the case of applied global - references, notations in a non-opened scope with delimiter - specifically defined for this applied global reference take priority - over notations in a non-opened scope with delimiter for generic - applications. For instance, in the presence of ``Notation "f ( x - )" := (f x) (at level 10, format "f ( x )") : app_scope`` and - ``Notation "x '.+1'" := (S x) (at level 10, format "x '.+1'") : - mynat_scope.`` and both of ``app_scope`` and ``mynat_scope`` being - bound to a delimiter *and* both not opened, the latter, more - specific notation will always take precedence over the first, more - generic one. - -- A scope can be closed by using :cmd:`Close Scope` and its delimiter - removed by using :cmd:`Undelimit Scope`. To remove automatic - temporary opening of scopes for arguments of a constant, use - :ref:`Arguments <ArgumentScopes>`. - .. _Abbreviations: Abbreviations @@ -1437,6 +1376,8 @@ Abbreviations denoted expression is performed at definition time. Type checking is done only at the time of use of the abbreviation. +.. _numeral-notations: + Numeral notations ----------------- diff --git a/engine/proofview.ml b/engine/proofview.ml index 316f02bc37..f278c83912 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -345,29 +345,19 @@ let tclBREAK = Proof.break exception NoSuchGoals of int -(* This hook returns a string to be appended to the usual message. - Primarily used to add a suggestion about the right bullet to use to - focus the next goal, if applicable. *) -let nosuchgoals_hook:(int -> Pp.t) ref = ref (fun n -> mt ()) -let set_nosuchgoals_hook f = nosuchgoals_hook := f - - - -(* This uses the hook above *) let _ = CErrors.register_handler begin function | NoSuchGoals n -> - let suffix = !nosuchgoals_hook n in - CErrors.user_err - (str "No such " ++ str (String.plural n "goal") ++ str "." ++ - pr_non_empty_arg (fun x -> x) suffix) - | _ -> raise CErrors.Unhandled + CErrors.user_err + (str "No such " ++ str (String.plural n "goal") ++ str ".") + | _ -> raise CErrors.Unhandled end -(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where +(** [tclFOCUS ?nosuchgoal i j t] applies [t] in a context where only the goals numbered [i] to [j] are focused (the rest of the goals is restored at the end of the tactic). If the range [i]-[j] is not valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *) -let tclFOCUS_gen nosuchgoal i j t = +let tclFOCUS ?nosuchgoal i j t = + let nosuchgoal = Option.default (tclZERO (NoSuchGoals (j+1-i))) nosuchgoal in let open Proof in Pv.get >>= fun initial -> try @@ -378,10 +368,9 @@ let tclFOCUS_gen nosuchgoal i j t = return result with CList.IndexOutOfRange -> nosuchgoal -let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t -let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t +let tclTRYFOCUS i j t = tclFOCUS ~nosuchgoal:(tclUNIT ()) i j t -let tclFOCUSLIST l t = +let tclFOCUSLIST ?(nosuchgoal=tclZERO (NoSuchGoals 0)) l t = let open Proof in Comb.get >>= fun comb -> let n = CList.length comb in @@ -395,7 +384,7 @@ let tclFOCUSLIST l t = in let l = CList.map_filter sanitize l in match l with - | [] -> tclZERO (NoSuchGoals 0) + | [] -> nosuchgoal | (mi, _) :: _ -> (* Get the left-most goal to focus. This goal won't move, and we will then place all the other goals to focus to the right. *) @@ -412,7 +401,7 @@ let tclFOCUSLIST l t = (** Like {!tclFOCUS} but selects a single goal by name. *) -let tclFOCUSID id t = +let tclFOCUSID ?(nosuchgoal=tclZERO (NoSuchGoals 1)) id t = let open Proof in Pv.get >>= fun initial -> try @@ -432,7 +421,7 @@ let tclFOCUSID id t = t >>= fun result -> Comb.set initial.comb >> return result - with Not_found -> tclZERO (NoSuchGoals 1) + with Not_found -> nosuchgoal (** {7 Dispatching on goals} *) diff --git a/engine/proofview.mli b/engine/proofview.mli index c772525c86..9455dae643 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -244,15 +244,12 @@ val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic (** [tclFOCUS i j t] applies [t] after focusing on the goals number [i] to [j] (see {!focus}). The rest of the goals is restored after the tactic action. If the specified range doesn't correspond to - existing goals, fails with [NoSuchGoals] (a user error). this - exception is caught at toplevel with a default message + a hook - message that can be customized by [set_nosuchgoals_hook] below. - This hook is used to add a suggestion about bullets when - applicable. *) + existing goals, fails with the [nosuchgoal] argument, by default + raising [NoSuchGoals] (a user error). This exception is caught at + toplevel with a default message. *) exception NoSuchGoals of int -val set_nosuchgoals_hook: (int -> Pp.t) -> unit -val tclFOCUS : int -> int -> 'a tactic -> 'a tactic +val tclFOCUS : ?nosuchgoal:'a tactic -> int -> int -> 'a tactic -> 'a tactic (** [tclFOCUSLIST li t] applies [t] on the list of focused goals described by [li]. Each element of [li] is a pair [(i, j)] denoting @@ -261,13 +258,14 @@ val tclFOCUS : int -> int -> 'a tactic -> 'a tactic intervals. If the set of such goals is not a single range, then it will move goals such that it is a single range. (So, for instance, [[1, 3-5]; idtac.] is not the identity.) - If the set of such goals is empty, it will fail. *) -val tclFOCUSLIST : (int * int) list -> 'a tactic -> 'a tactic + If the set of such goals is empty, it will fail with [nosuchgoal], + by default raising [NoSuchGoals 0]. *) +val tclFOCUSLIST : ?nosuchgoal:'a tactic -> (int * int) list -> 'a tactic -> 'a tactic (** [tclFOCUSID x t] applies [t] on a (single) focused goal like {!tclFOCUS}. The goal is found by its name rather than its - number.*) -val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic + number. Fails with [nosuchgoal], by default raising [NoSuchGoals 1]. *) +val tclFOCUSID : ?nosuchgoal:'a tactic -> Names.Id.t -> 'a tactic -> 'a tactic (** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the specified range doesn't correspond to existing goals, behaves like diff --git a/engine/uState.ml b/engine/uState.ml index 6f4f40e2c5..aa14f66df6 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -85,7 +85,7 @@ let union ctx ctx' = let declarenew g = LSet.fold (fun u g -> UGraph.add_universe u false g) newus g in - let names_rev = LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in + let names_rev = LMap.lunion (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; uctx_seff_univs = seff; diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 46ff6340b4..fcbf305f9d 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -203,7 +203,7 @@ let minimize_univ_variables ctx us algs left right cstrs = (acc, [], LMap.empty, LMap.empty) l in let left = CList.uniquize (List.filter (not_lower lower) left) in - (acc, left, LMap.union newlow lower) + (acc, left, LMap.lunion newlow lower) in let instantiate_lbound lbound = let alg = LSet.mem u algs in diff --git a/ide/.merlin.in b/ide/.merlin.in index 4dc6f45550..b8d7953833 100644 --- a/ide/.merlin.in +++ b/ide/.merlin.in @@ -1,4 +1,4 @@ -PKG unix laglgtk2 lablgtk2.sourceview2 +PKG unix laglgtk3 lablgtk3-sourceview3 S utils B utils diff --git a/ide/coq-ssreflect.lang b/ide/coq-ssreflect.lang index bd9cb4bfa2..fc7bc64a68 100644 --- a/ide/coq-ssreflect.lang +++ b/ide/coq-ssreflect.lang @@ -73,11 +73,13 @@ <keyword>suffices</keyword> <keyword>suff</keyword> <keyword>transitivity</keyword> + <keyword>under</keyword> <keyword>without loss</keyword> <keyword>wlog</keyword> </context> <context id="ssr-endtac" style-ref="endtactic"> <keyword>by</keyword> + <keyword>over</keyword> <keyword>exact</keyword> <keyword>reflexivity</keyword> </context> diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index d554bebdd3..82a5e9cdf6 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -10,11 +10,11 @@ let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0) let prime = Glib.Utf8.to_unichar "'" ~pos:(ref 0) - +let dot = Glib.Utf8.to_unichar "." ~pos:(ref 0) (* TODO: avoid num and prime at the head of a word *) let is_word_char c = - Glib.Unichar.isalnum c || c = underscore || c = prime + Glib.Unichar.isalnum c || c = underscore || c = prime || c = dot let starts_word (it:GText.iter) = diff --git a/ide/idetop.ml b/ide/idetop.ml index 543ff924bd..ce00ba6d8c 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -64,7 +64,7 @@ let is_known_option cmd = match Vernacprop.under_control cmd with (** Check whether a command is forbidden in the IDE *) -let ide_cmd_checks ~last_valid {CAst.loc;v=ast} = +let ide_cmd_checks ~last_valid ({ CAst.loc; _ } as cmd) = let user_error s = try CErrors.user_err ?loc ~hdr:"IDE" (str s) with e -> @@ -72,14 +72,14 @@ let ide_cmd_checks ~last_valid {CAst.loc;v=ast} = let info = Stateid.add info ~valid:last_valid Stateid.dummy in Exninfo.raise ~info e in - if is_debug ast then + if is_debug cmd then user_error "Debug mode not available in the IDE" -let ide_cmd_warns ~id {CAst.loc;v=ast} = +let ide_cmd_warns ~id ({ CAst.loc; _ } as cmd) = let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in - if is_known_option ast then + if is_known_option cmd then warn "Set this option from the IDE menu instead"; - if is_navigation_vernac ast || is_undo ast then + if is_navigation_vernac cmd || is_undo cmd then warn "Use IDE navigation instead" (** Interpretation (cf. [Ide_intf.interp]) *) @@ -137,7 +137,7 @@ let annotate phrase = | None -> Richpp.richpp_of_pp 78 (Pp.mt ()) | Some ast -> (* XXX: Width should be a parameter of annotate... *) - Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast.CAst.v) + Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast) (** Goal display *) @@ -238,7 +238,8 @@ let goals () = Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) end else Some (export_pre_goals Proof.(data newp) process_goal) - with Vernacstate.Proof_global.NoCurrentProof -> None;; + with Vernacstate.Proof_global.NoCurrentProof -> None + [@@ocaml.warning "-3"];; let evars () = try @@ -251,6 +252,7 @@ let evars () = let el = List.map map_evar exl in Some el with Vernacstate.Proof_global.NoCurrentProof -> None + [@@ocaml.warning "-3"] let hints () = try @@ -264,7 +266,7 @@ let hints () = let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in Some (hint_hyps, concl_next_tac) with Vernacstate.Proof_global.NoCurrentProof -> None - + [@@ocaml.warning "-3"] (** Other API calls *) @@ -297,6 +299,7 @@ let status force = Interface.status_allproofs = allproofs; Interface.status_proofnum = Stm.current_proof_depth ~doc:(get_doc ()); } + [@@ocaml.warning "-3"] let export_coq_object t = { Interface.coq_object_prefix = t.Search.coq_object_prefix; @@ -340,6 +343,7 @@ let search flags = List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) + [@@ocaml.warning "-3"] let export_option_value = function | Goptions.BoolValue b -> Interface.BoolValue b diff --git a/ide/preferences.ml b/ide/preferences.ml index 47cd4c58b6..3893d023bd 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -263,8 +263,6 @@ let get_unicode_bindings_default_file () = (** Hooks *) -(** New style preferences *) - let cmd_coqtop = new preference ~name:["cmd_coqtop"] ~init:None ~repr:Repr.(option string) @@ -645,8 +643,6 @@ let tag_button () = let box = GPack.hbox () in new tag_button (Gobject.unsafe_cast box#as_widget) -(** Old style preferences *) - let save_pref () = if not (Sys.file_exists (Minilib.coqide_config_home ())) then Unix.mkdir (Minilib.coqide_config_home ()) 0o700; @@ -658,15 +654,18 @@ let save_pref () = Config_lexer.print_file pref_file prefs let load_pref () = + (* Load main preference file *) + let () = + let m = Config_lexer.load_file loaded_pref_file in + let iter name v = + if Util.String.Map.mem name !preferences then + try (Util.String.Map.find name !preferences).set v with _ -> () + else unknown_preferences := Util.String.Map.add name v !unknown_preferences + in + Util.String.Map.iter iter m in + (* Load file for bindings *) let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in - - let m = Config_lexer.load_file loaded_pref_file in - let iter name v = - if Util.String.Map.mem name !preferences then - try (Util.String.Map.find name !preferences).set v with _ -> () - else unknown_preferences := Util.String.Map.add name v !unknown_preferences - in - Util.String.Map.iter iter m + () let pstring name p = string ~f:p#set name p#get let pbool name p = bool ~f:p#set name p#get diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 488c9a740f..e5bf52571c 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -67,7 +67,10 @@ let print_no_symbol = ref false (**********************************************************************) (* Turning notations and scopes on and off for printing *) -module IRuleSet = InterpRuleSet +module IRuleSet = Set.Make(struct + type t = interp_rule + let compare x y = Pervasives.compare x y + end) let inactive_notations_table = Summary.ref ~name:"inactive_notations_table" (IRuleSet.empty) @@ -107,13 +110,13 @@ let deactivate_notation nr = (* shouldn't we check wether it is well defined? *) inactive_notations_table := IRuleSet.add nr !inactive_notations_table | NotationRule (scopt, ntn) -> - if not (exists_notation_interpretation_in_scope scopt ntn) then - user_err ~hdr:"Notation" + match availability_of_notation (scopt, ntn) (scopt, []) with + | None -> user_err ~hdr:"Notation" (pr_notation ntn ++ spc () ++ str "does not exist" ++ (match scopt with | None -> spc () ++ str "in the empty scope." | Some _ -> show_scope scopt ++ str ".")) - else + | Some _ -> if IRuleSet.mem nr !inactive_notations_table then Feedback.msg_warning (str "Notation" ++ spc () ++ pr_notation ntn ++ spc () @@ -260,11 +263,6 @@ let rec insert_pat_coercion ?loc l c = match l with | [] -> c | ntn::l -> CAst.make ?loc @@ CPatNotation (ntn,([insert_pat_coercion ?loc l c],[]),[]) -let add_lonely keyrule seen = - match keyrule with - | NotationRule (None,ntn) -> ntn::seen - | SynDefRule _ | NotationRule (Some _,_) -> seen - (**********************************************************************) (* conversion of references *) @@ -388,8 +386,8 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = with No_match -> try if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation_pattern allscopes [] vars pat - (uninterp_cases_pattern_notations scopes pat) + extern_notation_pattern allscopes vars pat + (uninterp_cases_pattern_notations pat) with No_match -> let loc = pat.CAst.loc in match DAst.get pat with @@ -442,15 +440,18 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = insert_pat_coercion coercion pat and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) - (custom, (tmp_scope, scopes) as allscopes) lonely_seen vars = + (custom, (tmp_scope, scopes) as allscopes) vars = function - | NotationRule (sc,ntn),key,need_delim -> + | NotationRule (sc,ntn) -> begin match availability_of_entry_coercion custom (fst ntn) with | None -> raise No_match | Some coercion -> - let key = if need_delim || List.mem ntn lonely_seen then key else None in - let scopt = match key with Some _ -> sc | _ -> None in + match availability_of_notation (sc,ntn) (tmp_scope,scopes) with + (* Uninterpretation is not allowed in current context *) + | None -> raise No_match + (* Uninterpretation is allowed in current context *) + | Some (scopt,key) -> let scopes' = Option.List.cons scopt scopes in let l = List.map (fun (c,(subentry,(scopt,scl))) -> @@ -472,8 +473,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) (insert_pat_delimiters ?loc (make_pat_notation ?loc ntn (l,ll) l2') key) end - | SynDefRule kn,key,need_delim -> - assert (key = None && need_delim = false); + | SynDefRule kn -> match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match | Some coercion -> @@ -491,9 +491,9 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) in assert (List.is_empty substlist); insert_pat_coercion ?loc coercion (mkPat ?loc qid (List.rev_append l1 l2')) -and extern_notation_pattern allscopes lonely_seen vars t = function +and extern_notation_pattern allscopes vars t = function | [] -> raise No_match - | (keyrule,pat,n as _rule,key,need_delim)::rules -> + | (keyrule,pat,n as _rule)::rules -> try if is_inactive_rule keyrule then raise No_match; let loc = t.loc in @@ -501,27 +501,22 @@ and extern_notation_pattern allscopes lonely_seen vars t = function | PatCstr (cstr,args,na) -> let t = if na = Anonymous then t else DAst.make ?loc (PatCstr (cstr,args,Anonymous)) in let p = apply_notation_to_pattern ?loc (ConstructRef cstr) - (match_notation_constr_cases_pattern t pat) allscopes lonely_seen vars - (keyrule,key,need_delim) in + (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in insert_pat_alias ?loc p na | PatVar Anonymous -> CAst.make ?loc @@ CPatAtom None | PatVar (Name id) -> CAst.make ?loc @@ CPatAtom (Some (qualid_of_ident ?loc id)) with - No_match -> - let lonely_seen = add_lonely keyrule lonely_seen in - extern_notation_pattern allscopes lonely_seen vars t rules + No_match -> extern_notation_pattern allscopes vars t rules -let rec extern_notation_ind_pattern allscopes lonely_seen vars ind args = function +let rec extern_notation_ind_pattern allscopes vars ind args = function | [] -> raise No_match - | (keyrule,pat,n as _rule,key,need_delim)::rules -> + | (keyrule,pat,n as _rule)::rules -> try if is_inactive_rule keyrule then raise No_match; apply_notation_to_pattern (IndRef ind) - (match_notation_constr_ind_pattern ind args pat) allscopes lonely_seen vars (keyrule,key,need_delim) + (match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule with - No_match -> - let lonely_seen = add_lonely keyrule lonely_seen in - extern_notation_ind_pattern allscopes lonely_seen vars ind args rules + No_match -> extern_notation_ind_pattern allscopes vars ind args rules let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = (* pboutill: There are letins in pat which is incompatible with notations and @@ -533,8 +528,8 @@ let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = else try if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation_ind_pattern allscopes [] vars ind args - (uninterp_ind_pattern_notations scopes ind) + extern_notation_ind_pattern allscopes vars ind args + (uninterp_ind_pattern_notations ind) with No_match -> let c = extern_reference vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in @@ -778,32 +773,32 @@ let extern_ref vars ref us = let extern_var ?loc id = CRef (qualid_of_ident ?loc id,None) -let rec extern inctx (custom,scopes as allscopes) vars r = +let rec extern inctx scopes vars r = let r' = remove_coercions inctx r in try if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_optimal (extern_possible_prim_token allscopes) r r' + extern_optimal (extern_possible_prim_token scopes) r r' with No_match -> try let r'' = flatten_application r' in if !Flags.raw_print || !print_no_symbol then raise No_match; extern_optimal - (fun r -> extern_notation allscopes [] vars r (uninterp_notations scopes r)) + (fun r -> extern_notation scopes vars r (uninterp_notations r)) r r'' with No_match -> let loc = r'.CAst.loc in match DAst.get r' with - | GRef (ref,us) when entry_has_global custom -> CAst.make ?loc (extern_ref vars ref us) + | GRef (ref,us) when entry_has_global (fst scopes) -> CAst.make ?loc (extern_ref vars ref us) - | GVar id when entry_has_ident custom -> CAst.make ?loc (extern_var ?loc id) + | GVar id when entry_has_ident (fst scopes) -> CAst.make ?loc (extern_var ?loc id) | c -> - match availability_of_entry_coercion custom InConstrEntrySomeLevel with + match availability_of_entry_coercion (fst scopes) InConstrEntrySomeLevel with | None -> raise No_match | Some coercion -> - let scopes = (InConstrEntrySomeLevel, scopes) in + let scopes = (InConstrEntrySomeLevel, snd scopes) in let c = match c with (* The remaining cases are only for the constr entry *) @@ -815,7 +810,7 @@ let rec extern inctx (custom,scopes as allscopes) vars r = | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, IntroAnonymous, None) | GEvar (n,l) -> - extern_evar n (List.map (on_snd (extern false allscopes vars)) l) + extern_evar n (List.map (on_snd (extern false scopes vars)) l) | GPatVar kind -> if !print_meta_as_hole then CHole (None, IntroAnonymous, None) else @@ -1078,9 +1073,9 @@ and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in make ?loc (pll,extern inctx scopes vars c) -and extern_notation (custom,scopes as allscopes) lonely_seen vars t = function +and extern_notation (custom,scopes as allscopes) vars t = function | [] -> raise No_match - | (keyrule,pat,n as _rule,key,need_delim)::rules -> + | (keyrule,pat,n as _rule)::rules -> let loc = Glob_ops.loc_of_glob_constr t in try if is_inactive_rule keyrule then raise No_match; @@ -1128,8 +1123,11 @@ and extern_notation (custom,scopes as allscopes) lonely_seen vars t = function (match availability_of_entry_coercion custom (fst ntn) with | None -> raise No_match | Some coercion -> - let key = if need_delim || List.mem ntn lonely_seen then key else None in - let scopt = match key with Some _ -> sc | None -> None in + match availability_of_notation (sc,ntn) scopes with + (* Uninterpretation is not allowed in current context *) + | None -> raise No_match + (* Uninterpretation is allowed in current context *) + | Some (scopt,key) -> let scopes' = Option.List.cons scopt (snd scopes) in let l = List.map (fun (c,(subentry,(scopt,scl))) -> @@ -1165,9 +1163,7 @@ and extern_notation (custom,scopes as allscopes) lonely_seen vars t = function let args = extern_args (extern true) vars args in CAst.make ?loc @@ explicitize false argsimpls (None,e) args with - No_match -> - let lonely_seen = add_lonely keyrule lonely_seen in - extern_notation allscopes lonely_seen vars t rules + No_match -> extern_notation allscopes vars t rules let extern_glob_constr vars c = extern false (InConstrEntrySomeLevel,(None,[])) vars c diff --git a/interp/notation.ml b/interp/notation.ml index 56504db04e..a7bac96d31 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -21,7 +21,6 @@ open Notation_term open Glob_term open Glob_ops open Context.Named.Declaration -open Classops (*i*) @@ -50,25 +49,15 @@ let notation_entry_level_eq s1 s2 = match (s1,s2) with | InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> String.equal s1 s2 && n1 = n2 | (InConstrEntrySomeLevel | InCustomEntryLevel _), _ -> false -let notation_entry_level_compare s1 s2 = match (s1,s2) with -| InConstrEntrySomeLevel, InConstrEntrySomeLevel -> 0 -| InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> - pair_compare String.compare Int.compare (s1,n1) (s2,n2) -| InConstrEntrySomeLevel, _ -> -1 -| InCustomEntryLevel _, _ -> 1 - let notation_eq (from1,ntn1) (from2,ntn2) = notation_entry_level_eq from1 from2 && String.equal ntn1 ntn2 let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntrySomeLevel -> mt () | InCustomEntryLevel (s,n) -> str " in custom " ++ str s -let notation_compare = - pair_compare notation_entry_level_compare String.compare - module NotationOrd = struct type t = notation - let compare = notation_compare + let compare = Pervasives.compare end module NotationSet = Set.Make(NotationOrd) @@ -167,8 +156,6 @@ let scope_eq s1 s2 = match s1, s2 with | Scope _, SingleNotation _ | SingleNotation _, Scope _ -> false -(* Scopes for interpretation *) - let scope_stack = ref [] let current_scopes () = !scope_stack @@ -178,102 +165,14 @@ let scope_is_open_in_scopes sc l = let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack) -(* Uninterpretation tables *) - -type interp_rule = - | NotationRule of scope_name option * notation - | SynDefRule of KerName.t - -type scoped_notation_rule_core = scope_name * notation * interpretation * int option -type notation_rule_core = interp_rule * interpretation * int option -type notation_rule = notation_rule_core * delimiters option * bool - -let interp_rule_compare r1 r2 = match r1, r2 with - | NotationRule (sc1,ntn1), NotationRule (sc2,ntn2) -> - pair_compare (Option.compare String.compare) notation_compare (sc1,ntn1) (sc2,ntn2) - | SynDefRule kn1, SynDefRule kn2 -> KerName.compare kn1 kn2 - | (NotationRule _ | SynDefRule _), _ -> -1 - -module InterpRuleSet = Set.Make(struct - type t = interp_rule - let compare = interp_rule_compare - end) - -(* Scopes for uninterpretation: includes abbreviations (i.e. syntactic definitions) and *) - -type uninterp_scope_elem = - | UninterpScope of scope_name - | UninterpSingle of notation_rule_core - -let uninterp_scope_eq_weak s1 s2 = match s1, s2 with -| UninterpScope s1, UninterpScope s2 -> String.equal s1 s2 -| UninterpSingle s1, UninterpSingle s2 -> false -| (UninterpSingle _ | UninterpScope _), _ -> false - -module ScopeOrd = - struct - type t = scope_name option - let compare = Pervasives.compare - end - -module ScopeMap = CMap.Make(ScopeOrd) - -let uninterp_scope_stack = ref [] - -let push_uninterp_scope sc scopes = UninterpScope sc :: scopes - -let push_uninterp_scopes = List.fold_right push_uninterp_scope - -(**********************************************************************) -(* Mapping classes to scopes *) - -type scope_class = cl_typ - -let scope_class_compare : scope_class -> scope_class -> int = - cl_typ_ord - -let compute_scope_class sigma t = - let (cl,_,_) = find_class_type sigma t in - cl - -module ScopeClassOrd = -struct - type t = scope_class - let compare = scope_class_compare -end - -module ScopeClassMap = Map.Make(ScopeClassOrd) - -let initial_scope_class_map : scope_name ScopeClassMap.t = - ScopeClassMap.empty - -let scope_class_map = ref initial_scope_class_map - -let declare_scope_class sc cl = - scope_class_map := ScopeClassMap.add cl sc !scope_class_map - -let find_scope_class cl = - ScopeClassMap.find cl !scope_class_map - -let find_scope_class_opt = function - | None -> None - | Some cl -> try Some (find_scope_class cl) with Not_found -> None - -let current_type_scope_name () = - find_scope_class_opt (Some CL_SORT) - (* TODO: push nat_scope, z_scope, ... in scopes summary *) (* Exportation of scopes *) let open_scope i (_,(local,op,sc)) = - if Int.equal i 1 then begin + if Int.equal i 1 then scope_stack := - if op then Scope sc :: !scope_stack - else List.except scope_eq (Scope sc) !scope_stack; - uninterp_scope_stack := - if op then UninterpScope sc :: !uninterp_scope_stack - else List.except uninterp_scope_eq_weak (UninterpScope sc) !uninterp_scope_stack - end + if op then sc :: !scope_stack + else List.except scope_eq sc !scope_stack let cache_scope o = open_scope 1 o @@ -288,7 +187,7 @@ let discharge_scope (_,(local,_,_ as o)) = let classify_scope (local,_,_ as o) = if local then Dispose else Substitute o -let inScope : bool * bool * scope_name -> obj = +let inScope : bool * bool * scope_elem -> obj = declare_object {(default_object "SCOPE") with cache_function = cache_scope; open_function = open_scope; @@ -297,7 +196,7 @@ let inScope : bool * bool * scope_name -> obj = classify_function = classify_scope } let open_close_scope (local,opening,sc) = - Lib.add_anonymous_leaf (inScope (local,opening,normalize_scope sc)) + Lib.add_anonymous_leaf (inScope (local,opening,Scope (normalize_scope sc))) let empty_scope_stack = [] @@ -305,20 +204,9 @@ let push_scope sc scopes = Scope sc :: scopes let push_scopes = List.fold_right push_scope -let make_type_scope_soft tmp_scope = - if Option.equal String.equal tmp_scope (current_type_scope_name ()) then - true, None - else - false, tmp_scope - let make_current_scopes (tmp_scope,scopes) = Option.fold_right push_scope tmp_scope (push_scopes scopes !scope_stack) -let make_current_uninterp_scopes (tmp_scope,scopes) = - let istyp,tmp_scope = make_type_scope_soft tmp_scope in - istyp,Option.fold_right push_uninterp_scope tmp_scope - (push_uninterp_scopes scopes !uninterp_scope_stack) - (**********************************************************************) (* Delimiters *) @@ -362,80 +250,40 @@ let find_delimiters_scope ?loc key = user_err ?loc ~hdr:"find_delimiters" (str "Unknown scope delimiting key " ++ str key ++ str ".") +(* Uninterpretation tables *) + +type interp_rule = + | NotationRule of scope_name option * notation + | SynDefRule of KerName.t + (* We define keys for glob_constr and aconstr to split the syntax entries according to the key of the pattern (adapted from Chet Murthy by HH) *) type key = | RefKey of GlobRef.t - | LambdaKey - | ProdKey | Oth let key_compare k1 k2 = match k1, k2 with | RefKey gr1, RefKey gr2 -> GlobRef.Ordered.compare gr1 gr2 -| RefKey _, _ -> -1 -| _, RefKey _ -> 1 -| k1, k2 -> Pervasives.compare k1 k2 +| RefKey _, Oth -> -1 +| Oth, RefKey _ -> 1 +| Oth, Oth -> 0 module KeyOrd = struct type t = key let compare = key_compare end module KeyMap = Map.Make(KeyOrd) -let keymap_add key sc interp (scope_map,global_map) = - (* Adding to scope keymap for printing based on open scopes *) - let oldkeymap = try ScopeMap.find sc scope_map with Not_found -> KeyMap.empty in - let oldscmap = try KeyMap.find key oldkeymap with Not_found -> [] in - let newscmap = KeyMap.add key (interp :: oldscmap) oldkeymap in - let scope_map = ScopeMap.add sc newscmap scope_map in - (* Adding to global keymap of scoped notations in case the scope is not open *) - let global_map = match interp with - | NotationRule (Some sc,ntn), interp, c -> - let oldglobalkeymap = try KeyMap.find key global_map with Not_found -> [] in - KeyMap.add key ((sc,ntn,interp,c) :: oldglobalkeymap) global_map - | (NotationRule (None,_) | SynDefRule _), _, _ -> global_map in - (scope_map, global_map) - -let keymap_extract istype keys sc map = - let keymap = - try ScopeMap.find (Some sc) map - with Not_found -> KeyMap.empty in - let delim = - if istype && Option.equal String.equal (Some sc) (current_type_scope_name ()) then - (* A type is re-interpreted with type_scope on top, so never need a delimiter *) - None - else - (* Pass the delimiter so that it can be used if ever the notation is masked *) - (String.Map.find sc !scope_map).delimiters in - let add_scope rule = (rule,delim,false) in - List.map_append (fun key -> try List.map add_scope (KeyMap.find key keymap) with Not_found -> []) keys - -let find_with_delimiters istype = function - | None -> - None - | Some _ as scope when istype && Option.equal String.equal scope (current_type_scope_name ()) -> - (* This is in case type_scope (which by default is open in the - initial state) has been explicitly closed *) - Some None - | Some scope -> - match (String.Map.find scope !scope_map).delimiters with - | Some key -> Some (Some key) - | None -> None +type notation_rule = interp_rule * interpretation * int option -let rec keymap_extract_remainder istype scope_seen = function - | [] -> [] - | (sc,ntn,interp,c) :: l -> - if String.Set.mem sc scope_seen then keymap_extract_remainder istype scope_seen l - else - match find_with_delimiters istype (Some sc) with - | None -> keymap_extract_remainder istype scope_seen l - | Some delim -> - let rule = (NotationRule (Some sc, ntn), interp, c) in - (rule,delim,true) :: keymap_extract_remainder istype scope_seen l +let keymap_add key interp map = + let old = try KeyMap.find key map with Not_found -> [] in + KeyMap.add key (interp :: old) map + +let keymap_find key map = + try KeyMap.find key map + with Not_found -> [] (* Scopes table : interpretation -> scope_name *) -let notations_key_table = - ref ((ScopeMap.empty, KeyMap.empty) : - notation_rule_core list KeyMap.t ScopeMap.t * - scoped_notation_rule_core list KeyMap.t) +let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t) let glob_prim_constr_key c = match DAst.get c with | GRef (ref, _) -> Some (canonical_gr ref) @@ -447,14 +295,12 @@ let glob_prim_constr_key c = match DAst.get c with | _ -> None let glob_constr_keys c = match DAst.get c with - | GRef (ref,_) -> [RefKey (canonical_gr ref)] | GApp (c, _) -> begin match DAst.get c with | GRef (ref, _) -> [RefKey (canonical_gr ref); Oth] | _ -> [Oth] end - | GLambda _ -> [LambdaKey] - | GProd _ -> [ProdKey] + | GRef (ref,_) -> [RefKey (canonical_gr ref)] | _ -> [Oth] let cases_pattern_key c = match DAst.get c with @@ -468,8 +314,6 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) RefKey (canonical_gr ref), Some (List.length args) | NRef ref -> RefKey(canonical_gr ref), None | NApp (_,args) -> Oth, Some (List.length args) - | NLambda _ | NBinderList (_,_,NLambda _,_,_) | NList (_,_,NLambda _,_,_) -> LambdaKey, None - | NProd _ | NBinderList (_,_,NProd _,_,_) | NList (_,_,NProd _,_,_) -> ProdKey, None | _ -> Oth, None (**********************************************************************) @@ -1211,31 +1055,37 @@ let check_required_module ?loc sc (sp,d) = (* Look if some notation or numeral printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) -let rec find_without_delimiters find (istype,ntn_scope,ntn as ntndata) = function - | UninterpScope scope :: scopes -> +let find_with_delimiters = function + | None -> None + | Some scope -> + match (String.Map.find scope !scope_map).delimiters with + | Some key -> Some (Some scope, Some key) + | None -> None + +let rec find_without_delimiters find (ntn_scope,ntn) = function + | Scope scope :: scopes -> (* Is the expected ntn/numpr attached to the most recently open scope? *) begin match ntn_scope with | Some scope' when String.equal scope scope' -> - Some None + Some (None,None) | _ -> (* If the most recently open scope has a notation/numeral printer but not the expected one then we need delimiters *) if find scope then - find_with_delimiters istype ntn_scope + find_with_delimiters ntn_scope else - find_without_delimiters find ntndata scopes + find_without_delimiters find (ntn_scope,ntn) scopes end - | UninterpSingle (NotationRule (_,ntn'),_,_) :: scopes -> + | SingleNotation ntn' :: scopes -> begin match ntn_scope, ntn with | None, Some ntn when notation_eq ntn ntn' -> - Some None + Some (None, None) | _ -> - find_without_delimiters find ntndata scopes + find_without_delimiters find (ntn_scope,ntn) scopes end - | UninterpSingle (SynDefRule _,_,_) :: scopes -> find_without_delimiters find ntndata scopes | [] -> (* Can we switch to [scope]? Yes if it has defined delimiters *) - find_with_delimiters istype ntn_scope + find_with_delimiters ntn_scope (* The mapping between notations and their interpretation *) @@ -1268,19 +1118,9 @@ let declare_notation_interpretation ntn scopt pat df ~onlyprint = | Some _ -> () end -let scope_of_rule = function - | NotationRule (None,_) | SynDefRule _ -> None - | NotationRule (Some sc as sco,_) -> sco - -let uninterp_scope_to_add pat n = function - | NotationRule (None,_) | SynDefRule _ as rule -> Some (UninterpSingle (rule,pat,n)) - | NotationRule (Some sc,_) -> None - let declare_uninterpretation rule (metas,c as pat) = let (key,n) = notation_constr_key c in - let sc = scope_of_rule rule in - notations_key_table := keymap_add key sc (rule,pat,n) !notations_key_table; - uninterp_scope_stack := Option.List.cons (uninterp_scope_to_add pat n rule) !uninterp_scope_stack + notations_key_table := keymap_add key (rule,pat,n) !notations_key_table let rec find_interpretation ntn find = function | [] -> raise Not_found @@ -1359,29 +1199,20 @@ let interp_notation ?loc ntn local_scopes = user_err ?loc (str "Unknown interpretation for notation " ++ pr_notation ntn ++ str ".") -let extract_notations (istype,scopes) keys = - if keys == [] then [] (* shortcut *) else - let scope_map, global_map = !notations_key_table in - let rec aux scopes seen = - match scopes with - | UninterpScope sc :: scopes -> keymap_extract istype keys sc scope_map @ aux scopes (String.Set.add sc seen) - | UninterpSingle rule :: scopes -> (rule,None,false) :: aux scopes seen - | [] -> - let find key = try KeyMap.find key global_map with Not_found -> [] in - keymap_extract_remainder istype seen (List.flatten (List.map find keys)) - in aux scopes String.Set.empty +let uninterp_notations c = + List.map_append (fun key -> keymap_find key !notations_key_table) + (glob_constr_keys c) -let uninterp_notations scopes c = - let scopes = make_current_uninterp_scopes scopes in - extract_notations scopes (glob_constr_keys c) +let uninterp_cases_pattern_notations c = + keymap_find (cases_pattern_key c) !notations_key_table -let uninterp_cases_pattern_notations scopes c = - let scopes = make_current_uninterp_scopes scopes in - extract_notations scopes [cases_pattern_key c] +let uninterp_ind_pattern_notations ind = + keymap_find (RefKey (canonical_gr (IndRef ind))) !notations_key_table -let uninterp_ind_pattern_notations scopes ind = - let scopes = make_current_uninterp_scopes scopes in - extract_notations scopes [RefKey (canonical_gr (IndRef ind))] +let availability_of_notation (ntn_scope,ntn) scopes = + let f scope = + NotationMap.mem ntn (String.Map.find scope !scope_map).notations in + find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes) (* We support coercions from a custom entry at some level to an entry at some level (possibly the same), and from and to the constr entry. E.g.: @@ -1538,11 +1369,13 @@ let availability_of_prim_token n printer_scope local_scopes = | _ -> false with Not_found -> false in - let istype,scopes = make_current_uninterp_scopes local_scopes in - find_without_delimiters f (istype,Some printer_scope,None) scopes + let scopes = make_current_scopes local_scopes in + Option.map snd (find_without_delimiters f (Some printer_scope,None) scopes) (* Miscellaneous *) +let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 + let notation_binder_source_eq s1 s2 = match s1, s2 with | NtnParsedAsIdent, NtnParsedAsIdent -> true | NtnParsedAsPattern b1, NtnParsedAsPattern b2 -> b1 = b2 @@ -1556,10 +1389,9 @@ let ntpe_eq t1 t2 = match t1, t2 with | NtnTypeBinderList, NtnTypeBinderList -> true | (NtnTypeConstr | NtnTypeBinder _ | NtnTypeConstrList | NtnTypeBinderList), _ -> false -let var_attributes_eq (_, ((entry1, (tmpsc1, scl1)), tp1)) (_, ((entry2, (tmpsc2, scl2)), tp2)) = +let var_attributes_eq (_, ((entry1, sc1), tp1)) (_, ((entry2, sc2), tp2)) = notation_entry_level_eq entry1 entry2 && - Option.equal String.equal tmpsc1 tmpsc2 && - List.equal String.equal scl1 scl2 && + pair_eq (Option.equal String.equal) (List.equal String.equal) sc1 sc2 && ntpe_eq tp1 tp2 let interpretation_eq (vars1, t1) (vars2, t2) = @@ -1574,17 +1406,46 @@ let exists_notation_in_scope scopt ntn onlyprint r = interpretation_eq n.not_interp r with Not_found -> false -let exists_notation_interpretation_in_scope scopt ntn = - let scope = match scopt with Some s -> s | None -> default_scope in - try - let sc = String.Map.find scope !scope_map in - let _ = NotationMap.find ntn sc.notations in - true - with Not_found -> false - let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false (**********************************************************************) +(* Mapping classes to scopes *) + +open Classops + +type scope_class = cl_typ + +let scope_class_compare : scope_class -> scope_class -> int = + cl_typ_ord + +let compute_scope_class sigma t = + let (cl,_,_) = find_class_type sigma t in + cl + +module ScopeClassOrd = +struct + type t = scope_class + let compare = scope_class_compare +end + +module ScopeClassMap = Map.Make(ScopeClassOrd) + +let initial_scope_class_map : scope_name ScopeClassMap.t = + ScopeClassMap.empty + +let scope_class_map = ref initial_scope_class_map + +let declare_scope_class sc cl = + scope_class_map := ScopeClassMap.add cl sc !scope_class_map + +let find_scope_class cl = + ScopeClassMap.find cl !scope_class_map + +let find_scope_class_opt = function + | None -> None + | Some cl -> try Some (find_scope_class cl) with Not_found -> None + +(**********************************************************************) (* Special scopes associated to arguments of a global reference *) let rec compute_arguments_classes sigma t = @@ -1604,6 +1465,9 @@ let compute_arguments_scope sigma t = fst (compute_arguments_scope_full sigma t) let compute_type_scope sigma t = find_scope_class_opt (try Some (compute_scope_class sigma t) with Not_found -> None) +let current_type_scope_name () = + find_scope_class_opt (Some CL_SORT) + let scope_class_of_class (x : cl_typ) : scope_class = x @@ -1960,7 +1824,7 @@ let locate_notation prglob ntn scope = str "Notation" ++ fnl () ++ prlist_with_sep fnl (fun (ntn,l) -> let scope = find_default ntn scopes in - prlist_with_sep fnl + prlist (fun (sc,r,(_,df)) -> hov 0 ( pr_notation_info prglob df r ++ @@ -2023,18 +1887,17 @@ let pr_visibility prglob = function (* Synchronisation with reset *) let freeze ~marshallable = - (!scope_map, !scope_stack, !uninterp_scope_stack, !arguments_scope, + (!scope_map, !scope_stack, !arguments_scope, !delimiters_map, !notations_key_table, !scope_class_map, !prim_token_interp_infos, !prim_token_uninterp_infos, !entry_coercion_map, !entry_has_global_map, !entry_has_ident_map) -let unfreeze (scm,scs,uscs,asc,dlm,fkm,clsc,ptii,ptui,coe,globs,ids) = +let unfreeze (scm,scs,asc,dlm,fkm,clsc,ptii,ptui,coe,globs,ids) = scope_map := scm; scope_stack := scs; - uninterp_scope_stack := uscs; - arguments_scope := asc; delimiters_map := dlm; + arguments_scope := asc; notations_key_table := fkm; scope_class_map := clsc; prim_token_interp_infos := ptii; @@ -2045,9 +1908,8 @@ let unfreeze (scm,scs,uscs,asc,dlm,fkm,clsc,ptii,ptui,coe,globs,ids) = let init () = init_scope_map (); - uninterp_scope_stack := []; delimiters_map := String.Map.empty; - notations_key_table := (ScopeMap.empty,KeyMap.empty); + notations_key_table := KeyMap.empty; scope_class_map := initial_scope_class_map; prim_token_interp_infos := String.Map.empty; prim_token_uninterp_infos := GlobRef.Map.empty diff --git a/interp/notation.mli b/interp/notation.mli index 57e2be16b9..a67948a778 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -216,8 +216,6 @@ type interp_rule = | NotationRule of scope_name option * notation | SynDefRule of KerName.t -module InterpRuleSet : Set.S with type elt = interp_rule - val declare_notation_interpretation : notation -> scope_name option -> interpretation -> notation_location -> onlyprint:bool -> unit @@ -227,28 +225,18 @@ val declare_uninterpretation : interp_rule -> interpretation -> unit val interp_notation : ?loc:Loc.t -> notation -> subscopes -> interpretation * (notation_location * scope_name option) -type notation_rule_core = - interp_rule (* kind of notation *) - * interpretation (* pattern associated to the notation *) - * int option (* number of expected arguments *) - -type notation_rule = - notation_rule_core - * delimiters option (* delimiter to possibly add *) - * bool (* true if the delimiter is mandatory *) +type notation_rule = interp_rule * interpretation * int option (** Return the possible notations for a given term *) -val uninterp_notations : subscopes -> 'a glob_constr_g -> notation_rule list -val uninterp_cases_pattern_notations : subscopes -> 'a cases_pattern_g -> notation_rule list -val uninterp_ind_pattern_notations : subscopes -> inductive -> notation_rule list +val uninterp_notations : 'a glob_constr_g -> notation_rule list +val uninterp_cases_pattern_notations : 'a cases_pattern_g -> notation_rule list +val uninterp_ind_pattern_notations : inductive -> notation_rule list -(* (** Test if a notation is available in the scopes context [scopes]; if available, the result is not None; the first argument is itself not None if a delimiters is needed *) val availability_of_notation : scope_name option * notation -> subscopes -> (scope_name option * delimiters option) option - *) (** {6 Miscellaneous} *) @@ -259,9 +247,6 @@ val interp_notation_as_global_reference : ?loc:Loc.t -> (GlobRef.t -> bool) -> val exists_notation_in_scope : scope_name option -> notation -> bool -> interpretation -> bool -(** Checks for already existing notations *) -val exists_notation_interpretation_in_scope : scope_name option -> notation -> bool - (** Declares and looks for scopes associated to arguments of a global ref *) val declare_arguments_scope : bool (** true=local *) -> GlobRef.t -> scope_name option list -> unit diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index d2c88bffcc..2293ae9dfd 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -193,6 +193,12 @@ if (sp - num_args < coq_stack_threshold) { \ #define AllocCarry(cond) Alloc_small(accu, 1, (cond)? coq_tag_C1 : coq_tag_C0) #define AllocPair() Alloc_small(accu, 2, coq_tag_pair) +#define Swap_accu_sp do{ \ + value swap_accu_sp_tmp__ = accu; \ + accu = *sp; \ + *sp = swap_accu_sp_tmp__; \ + }while(0) + /* For signal handling, we hijack some code from the caml runtime */ extern intnat caml_signals_are_pending; @@ -1213,7 +1219,7 @@ value coq_interprete /* Adds the integer in the accumulator with the one ontop of the stack (which is poped)*/ print_instr("ADDINT63"); - accu = uint63_add(accu, *sp++); + Uint63_add(accu, *sp++); Next; } @@ -1221,10 +1227,12 @@ value coq_interprete print_instr("CHECKADDCINT63"); CheckInt2(); /* returns the sum with a carry */ - value s; - s = uint63_add(accu, *sp++); - AllocCarry(uint63_lt(s,accu)); - Field(accu, 0) = s; + int c; + Uint63_add(accu, *sp); + Uint63_lt(c, accu, *sp); + Swap_accu_sp; + AllocCarry(c); + Field(accu, 0) = *sp++; Next; } @@ -1232,10 +1240,12 @@ value coq_interprete print_instr("ADDCARRYCINT63"); CheckInt2(); /* returns the sum plus one with a carry */ - value s; - s = uint63_addcarry(accu, *sp++); - AllocCarry(uint63_leq(s, accu)); - Field(accu, 0) = s; + int c; + Uint63_addcarry(accu, *sp); + Uint63_leq(c, accu, *sp); + Swap_accu_sp; + AllocCarry(c); + Field(accu, 0) = *sp++; Next; } @@ -1246,7 +1256,7 @@ value coq_interprete Instruct (SUBINT63) { print_instr("SUBINT63"); /* returns the subtraction */ - accu = uint63_sub(accu, *sp++); + Uint63_sub(accu, *sp++); Next; } @@ -1254,12 +1264,12 @@ value coq_interprete print_instr("SUBCINT63"); CheckInt2(); /* returns the subtraction with a carry */ - value b; - value s; - b = *sp++; - s = uint63_sub(accu,b); - AllocCarry(uint63_lt(accu,b)); - Field(accu, 0) = s; + int c; + Uint63_lt(c, accu, *sp); + Uint63_sub(accu, *sp); + Swap_accu_sp; + AllocCarry(c); + Field(accu, 0) = *sp++; Next; } @@ -1267,12 +1277,12 @@ value coq_interprete print_instr("SUBCARRYCINT63"); CheckInt2(); /* returns the subtraction minus one with a carry */ - value b; - value s; - b = *sp++; - s = uint63_subcarry(accu,b); - AllocCarry(uint63_leq(accu,b)); - Field(accu, 0) = s; + int c; + Uint63_leq(c,accu,*sp); + Uint63_subcarry(accu,*sp); + Swap_accu_sp; + AllocCarry(c); + Field(accu, 0) = *sp++; Next; } @@ -1280,7 +1290,7 @@ value coq_interprete print_instr("MULINT63"); CheckInt2(); /* returns the multiplication */ - accu = uint63_mul(accu,*sp++); + Uint63_mul(accu,*sp++); Next; } @@ -1294,9 +1304,11 @@ value coq_interprete AllocPair(); */ /* Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; */ /*higher part*/ /* Field(accu, 1) = (value)(I64_to_int32(p)|1); */ /*lower part*/ - value x = accu; + Uint63_mulc(accu, *sp, sp); + *--sp = accu; AllocPair(); - Field(accu, 1) = uint63_mulc(x, *sp++, &Field(accu, 0)); + Field(accu, 1) = *sp++; + Field(accu, 0) = *sp++; Next; } @@ -1306,13 +1318,13 @@ value coq_interprete /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag since it probably only concerns negative number. needs to be checked at this point */ - value divisor; - divisor = *sp++; - if (uint63_eq0(divisor)) { - accu = divisor; + int b; + Uint63_eq0(b, *sp); + if (b) { + accu = *sp++; } else { - accu = uint63_div(accu, divisor); + Uint63_div(accu, *sp++); } Next; } @@ -1320,13 +1332,13 @@ value coq_interprete Instruct(CHECKMODINT63) { print_instr("CHEKMODINT63"); CheckInt2(); - value divisor; - divisor = *sp++; - if (uint63_eq0(divisor)) { - accu = divisor; + int b; + Uint63_eq0(b, *sp); + if (b) { + accu = *sp++; } else { - accu = uint63_mod(accu,divisor); + Uint63_mod(accu,*sp++); } Next; } @@ -1337,19 +1349,24 @@ value coq_interprete /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag since it probably only concerns negative number. needs to be checked at this point */ - value divisor; - divisor = *sp++; - if (uint63_eq0(divisor)) { - Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - Field(accu, 0) = divisor; - Field(accu, 1) = divisor; + int b; + Uint63_eq0(b, *sp); + if (b) { + AllocPair(); + Field(accu, 0) = *sp; + Field(accu, 1) = *sp++; } else { - value modulus; - modulus = accu; - Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - Field(accu, 0) = uint63_div(modulus,divisor); - Field(accu, 1) = uint63_mod(modulus,divisor); + *--sp = accu; + Uint63_div(sp[0],sp[1]); + Swap_accu_sp; + Uint63_mod(accu,sp[1]); + sp[1] = sp[0]; + Swap_accu_sp; + AllocPair(); + Field(accu, 0) = sp[1]; + Field(accu, 1) = sp[0]; + sp += 2; } Next; } @@ -1376,59 +1393,57 @@ value coq_interprete Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); } */ - value bigint; /* TODO: fix */ - bigint = *sp++; /* TODO: take accu into account */ - value divisor; - divisor = *sp++; - if (uint63_eq0(divisor)) { - Alloc_small(accu, 2, 1); - Field(accu, 0) = divisor; - Field(accu, 1) = divisor; + int b; + Uint63_eq0(b, sp[1]); + if (b) { + AllocPair(); + Field(accu, 0) = sp[1]; + Field(accu, 1) = sp[1]; } else { - value quo, mod; - mod = uint63_div21(accu, bigint, divisor, &quo); - Alloc_small(accu, 2, 1); - Field(accu, 0) = quo; - Field(accu, 1) = mod; + Uint63_div21(accu, sp[0], sp[1], sp); + sp[1] = sp[0]; + Swap_accu_sp; + AllocPair(); + Field(accu, 0) = sp[1]; + Field(accu, 1) = sp[0]; } + sp += 2; Next; } Instruct(CHECKLXORINT63) { print_instr("CHECKLXORINT63"); CheckInt2(); - accu = uint63_lxor(accu,*sp++); + Uint63_lxor(accu,*sp++); Next; } Instruct(CHECKLORINT63) { print_instr("CHECKLORINT63"); CheckInt2(); - accu = uint63_lor(accu,*sp++); + Uint63_lor(accu,*sp++); Next; } Instruct(CHECKLANDINT63) { print_instr("CHECKLANDINT63"); CheckInt2(); - accu = uint63_land(accu,*sp++); + Uint63_land(accu,*sp++); Next; } Instruct(CHECKLSLINT63) { print_instr("CHECKLSLINT63"); CheckInt2(); - value p = *sp++; - accu = uint63_lsl(accu,p); + Uint63_lsl(accu,*sp++); Next; } Instruct(CHECKLSRINT63) { print_instr("CHECKLSRINT63"); CheckInt2(); - value p = *sp++; - accu = uint63_lsr(accu,p); + Uint63_lsr(accu,*sp++); Next; } @@ -1436,7 +1451,7 @@ value coq_interprete print_instr("CHECKLSLINT63CONST1"); if (Is_uint63(accu)) { pc++; - accu = uint63_lsl1(accu); + Uint63_lsl1(accu); Next; } else { *--sp = uint63_one(); @@ -1450,7 +1465,7 @@ value coq_interprete print_instr("CHECKLSRINT63CONST1"); if (Is_uint63(accu)) { pc++; - accu = uint63_lsr1(accu); + Uint63_lsr1(accu); Next; } else { *--sp = uint63_one(); @@ -1463,18 +1478,17 @@ value coq_interprete Instruct (CHECKADDMULDIVINT63) { print_instr("CHECKADDMULDIVINT63"); CheckInt3(); - value x; - value y; - x = *sp++; - y = *sp++; - accu = uint63_addmuldiv(accu,x,y); + Uint63_addmuldiv(accu,sp[0],sp[1]); + sp += 2; Next; } Instruct (CHECKEQINT63) { print_instr("CHECKEQINT63"); CheckInt2(); - accu = uint63_eq(accu,*sp++) ? coq_true : coq_false; + int b; + Uint63_eq(b, accu, *sp++); + accu = b ? coq_true : coq_false; Next; } @@ -1484,7 +1498,9 @@ value coq_interprete } Instruct (LTINT63) { print_instr("LTINT63"); - accu = uint63_lt(accu,*sp++) ? coq_true : coq_false; + int b; + Uint63_lt(b,accu,*sp++); + accu = b ? coq_true : coq_false; Next; } @@ -1494,7 +1510,9 @@ value coq_interprete } Instruct (LEINT63) { print_instr("LEINT63"); - accu = uint63_leq(accu,*sp++) ? coq_true : coq_false; + int b; + Uint63_leq(b,accu,*sp++); + accu = b ? coq_true : coq_false; Next; } @@ -1503,25 +1521,30 @@ value coq_interprete /* assumes Inductive _ : _ := Eq | Lt | Gt */ print_instr("CHECKCOMPAREINT63"); CheckInt2(); - if (uint63_eq(accu,*sp)) { + int b; + Uint63_eq(b, accu, *sp); + if (b) { accu = coq_Eq; sp++; } - else accu = uint63_lt(accu,*sp++) ? coq_Lt : coq_Gt; + else { + Uint63_lt(b, accu, *sp++); + accu = b ? coq_Lt : coq_Gt; + } Next; } Instruct (CHECKHEAD0INT63) { print_instr("CHECKHEAD0INT63"); CheckInt1(); - accu = uint63_head0(accu); + Uint63_head0(accu); Next; } Instruct (CHECKTAIL0INT63) { print_instr("CHECKTAIL0INT63"); CheckInt1(); - accu = uint63_tail0(accu); + Uint63_tail0(accu); Next; } diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h index 9375b15de2..1ea461c5e5 100644 --- a/kernel/byterun/coq_memory.h +++ b/kernel/byterun/coq_memory.h @@ -19,7 +19,7 @@ #define Coq_stack_size (4096 * sizeof(value)) -#define Coq_stack_threshold (256 * sizeof(value)) +#define Coq_stack_threshold (256 * sizeof(value)) /* see kernel/cbytegen.ml */ #define Coq_max_stack_size (256 * 1024) #define TRANSP 0 diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index 5499f124a2..d982f67566 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -15,83 +15,142 @@ value uint63_##name() { \ } # define DECLARE_UNOP(name) \ -value uint63_##name(value x) { \ +value uint63_##name##_ml(value x) { \ static value* cb = 0; \ CAMLparam1(x); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(caml_callback(*cb, x)); \ } -# define DECLARE_PREDICATE(name) \ -value uint63_##name(value x) { \ - static value* cb = 0; \ - CAMLparam1(x); \ - if (!cb) cb = caml_named_value("uint63 " #name); \ - CAMLreturn(Int_val(caml_callback(*cb, x))); \ - } +# define CALL_UNOP_NOASSIGN(name, x) \ + value uint63_return_value__; \ + value uint63_arg_x__ = (x); \ + Setup_for_gc; \ + uint63_return_value__ = uint63_##name##_ml(uint63_arg_x__); \ + Restore_after_gc + +# define CALL_UNOP(name, x) do{ \ + CALL_UNOP_NOASSIGN(name, x); \ + accu = uint63_return_value__; \ + }while(0) + +# define CALL_PREDICATE(r, name, x) do{ \ + CALL_UNOP_NOASSIGN(name, x); \ + (r) = Int_val(uint63_return_value__); \ + }while(0) # define DECLARE_BINOP(name) \ -value uint63_##name(value x, value y) { \ +value uint63_##name##_ml(value x, value y) { \ static value* cb = 0; \ CAMLparam2(x, y); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(caml_callback2(*cb, x, y)); \ } -# define DECLARE_RELATION(name) \ -value uint63_##name(value x, value y) { \ - static value* cb = 0; \ - CAMLparam2(x, y); \ - if (!cb) cb = caml_named_value("uint63 " #name); \ - CAMLreturn(Int_val(caml_callback2(*cb, x, y))); \ - } +# define CALL_BINOP_NOASSIGN(name, x, y) \ + value uint63_return_value__; \ + value uint63_arg_x__ = (x); \ + value uint63_arg_y__ = (y); \ + Setup_for_gc; \ + uint63_return_value__ = uint63_##name##_ml(uint63_arg_x__, uint63_arg_y__); \ + Restore_after_gc + +# define CALL_BINOP(name, x, y) do{ \ + CALL_BINOP_NOASSIGN(name, x, y); \ + accu = uint63_return_value__; \ + }while(0) + +# define CALL_RELATION(r, name, x, y) do{ \ + CALL_BINOP_NOASSIGN(name, x, y); \ + (r) = Int_val(uint63_return_value__); \ + }while(0) # define DECLARE_TEROP(name) \ -value uint63_##name(value x, value y, value z) { \ +value uint63_##name##_ml(value x, value y, value z) { \ static value* cb = 0; \ CAMLparam3(x, y, z); \ if (!cb) cb = caml_named_value("uint63 " #name); \ CAMLreturn(caml_callback3(*cb, x, y, z)); \ } +# define CALL_TEROP(name, x, y, z) do{ \ + value uint63_return_value__; \ + value uint63_arg_x__ = (x); \ + value uint63_arg_y__ = (y); \ + value uint63_arg_z__ = (z); \ + Setup_for_gc; \ + uint63_return_value__ = uint63_##name##_ml(uint63_arg_x__, uint63_arg_y__, uint63_arg_z__); \ + Restore_after_gc; \ + accu = uint63_return_value__; \ + }while(0) DECLARE_NULLOP(one) DECLARE_BINOP(add) +#define Uint63_add(x, y) CALL_BINOP(add, x, y) DECLARE_BINOP(addcarry) +#define Uint63_addcarry(x, y) CALL_BINOP(addcarry, x, y) DECLARE_TEROP(addmuldiv) +#define Uint63_addmuldiv(x, y, z) CALL_TEROP(addmuldiv, x, y, z) DECLARE_BINOP(div) -DECLARE_TEROP(div21_ml) -DECLARE_RELATION(eq) -DECLARE_PREDICATE(eq0) +#define Uint63_div(x, y) CALL_BINOP(div, x, y) +DECLARE_BINOP(eq) +#define Uint63_eq(r, x, y) CALL_RELATION(r, eq, x, y) +DECLARE_UNOP(eq0) +#define Uint63_eq0(r, x) CALL_PREDICATE(r, eq0, x) DECLARE_UNOP(head0) +#define Uint63_head0(x) CALL_UNOP(head0, x) DECLARE_BINOP(land) -DECLARE_RELATION(leq) +#define Uint63_land(x, y) CALL_BINOP(land, x, y) +DECLARE_BINOP(leq) +#define Uint63_leq(r, x, y) CALL_RELATION(r, leq, x, y) DECLARE_BINOP(lor) +#define Uint63_lor(x, y) CALL_BINOP(lor, x, y) DECLARE_BINOP(lsl) +#define Uint63_lsl(x, y) CALL_BINOP(lsl, x, y) DECLARE_UNOP(lsl1) +#define Uint63_lsl1(x) CALL_UNOP(lsl1, x) DECLARE_BINOP(lsr) +#define Uint63_lsr(x, y) CALL_BINOP(lsr, x, y) DECLARE_UNOP(lsr1) -DECLARE_RELATION(lt) +#define Uint63_lsr1(x) CALL_UNOP(lsr1, x) +DECLARE_BINOP(lt) +#define Uint63_lt(r, x, y) CALL_RELATION(r, lt, x, y) DECLARE_BINOP(lxor) +#define Uint63_lxor(x, y) CALL_BINOP(lxor, x, y) DECLARE_BINOP(mod) +#define Uint63_mod(x, y) CALL_BINOP(mod, x, y) DECLARE_BINOP(mul) -DECLARE_BINOP(mulc_ml) +#define Uint63_mul(x, y) CALL_BINOP(mul, x, y) DECLARE_BINOP(sub) +#define Uint63_sub(x, y) CALL_BINOP(sub, x, y) DECLARE_BINOP(subcarry) +#define Uint63_subcarry(x, y) CALL_BINOP(subcarry, x, y) DECLARE_UNOP(tail0) +#define Uint63_tail0(x) CALL_UNOP(tail0, x) + +DECLARE_TEROP(div21_ml) +# define Uint63_div21(x, y, z, q) do{ \ + value uint63_return_value__; \ + value uint63_arg_x__ = (x); \ + value uint63_arg_y__ = (y); \ + value uint63_arg_z__ = (z); \ + Setup_for_gc; \ + uint63_return_value__ = \ + uint63_div21_ml_ml(uint63_arg_x__, uint63_arg_y__, uint63_arg_z__); \ + Restore_after_gc; \ + *q = Field(uint63_return_value__, 0); \ + accu = Field(uint63_return_value__, 1); \ + }while(0) -value uint63_div21(value x, value y, value z, value* q) { - CAMLparam3(x, y, z); - CAMLlocal1(qr); - qr = uint63_div21_ml(x, y, z); - *q = Field(qr, 0); - CAMLreturn(Field(qr, 1)); -} - -value uint63_mulc(value x, value y, value* h) { - CAMLparam2(x, y); - CAMLlocal1(hl); - hl = uint63_mulc_ml(x, y); - *h = Field(hl, 0); - CAMLreturn(Field(hl, 1)); -} +DECLARE_BINOP(mulc_ml) +# define Uint63_mulc(x, y, h) do{ \ + value uint63_return_value__; \ + value uint63_arg_x__ = (x); \ + value uint63_arg_y__ = (y); \ + Setup_for_gc; \ + uint63_return_value__ = \ + uint63_mulc_ml_ml(uint63_arg_x__, uint63_arg_y__); \ + Restore_after_gc; \ + *(h) = Field(uint63_return_value__, 0); \ + accu = Field(uint63_return_value__, 1); \ + }while(0) diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 92f4dc79bc..d431dc1e5c 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -9,28 +9,43 @@ #define uint63_one() ((value) 3) /* 2*1 + 1 */ #define uint63_eq(x,y) ((x) == (y)) -#define uint63_eq0(x) ((x) == (uint64_t)1) +#define Uint63_eq(r,x,y) ((r) = uint63_eq(x,y)) +#define Uint63_eq0(r,x) ((r) = ((x) == (uint64_t)1)) #define uint63_lt(x,y) ((uint64_t) (x) < (uint64_t) (y)) +#define Uint63_lt(r,x,y) ((r) = uint63_lt(x,y)) #define uint63_leq(x,y) ((uint64_t) (x) <= (uint64_t) (y)) +#define Uint63_leq(r,x,y) ((r) = uint63_leq(x,y)) -#define uint63_add(x,y) ((value)((uint64_t) (x) + (uint64_t) (y) - 1)) -#define uint63_addcarry(x,y) ((value)((uint64_t) (x) + (uint64_t) (y) + 1)) -#define uint63_sub(x,y) ((value)((uint64_t) (x) - (uint64_t) (y) + 1)) -#define uint63_subcarry(x,y) ((value)((uint64_t) (x) - (uint64_t) (y) - 1)) -#define uint63_mul(x,y) (Val_long(uint63_of_value(x) * uint63_of_value(y))) -#define uint63_div(x,y) (Val_long(uint63_of_value(x) / uint63_of_value(y))) -#define uint63_mod(x,y) (Val_long(uint63_of_value(x) % uint63_of_value(y))) +#define Uint63_add(x,y) (accu = (value)((uint64_t) (x) + (uint64_t) (y) - 1)) +#define Uint63_addcarry(x,y) (accu = (value)((uint64_t) (x) + (uint64_t) (y) + 1)) +#define Uint63_sub(x,y) (accu = (value)((uint64_t) (x) - (uint64_t) (y) + 1)) +#define Uint63_subcarry(x,y) (accu = (value)((uint64_t) (x) - (uint64_t) (y) - 1)) +#define Uint63_mul(x,y) (accu = Val_long(uint63_of_value(x) * uint63_of_value(y))) +#define Uint63_div(x,y) (accu = Val_long(uint63_of_value(x) / uint63_of_value(y))) +#define Uint63_mod(x,y) (accu = Val_long(uint63_of_value(x) % uint63_of_value(y))) -#define uint63_lxor(x,y) ((value)(((uint64_t)(x) ^ (uint64_t)(y)) | 1)) -#define uint63_lor(x,y) ((value)((uint64_t)(x) | (uint64_t)(y))) -#define uint63_land(x,y) ((value)((uint64_t)(x) & (uint64_t)(y))) +#define Uint63_lxor(x,y) (accu = (value)(((uint64_t)(x) ^ (uint64_t)(y)) | 1)) +#define Uint63_lor(x,y) (accu = (value)((uint64_t)(x) | (uint64_t)(y))) +#define Uint63_land(x,y) (accu = (value)((uint64_t)(x) & (uint64_t)(y))) /* TODO: is + or | better? OCAML uses + */ /* TODO: is - or ^ better? */ -#define uint63_lsl(x,y) ((y) < (uint64_t) 127 ? ((value)((((uint64_t)(x)-1) << (uint63_of_value(y))) | 1)) : uint63_zero) -#define uint63_lsr(x,y) ((y) < (uint64_t) 127 ? ((value)(((uint64_t)(x) >> (uint63_of_value(y))) | 1)) : uint63_zero) -#define uint63_lsl1(x) ((value)((((uint64_t)(x)-1) << 1) +1)) -#define uint63_lsr1(x) ((value)(((uint64_t)(x) >> 1) |1)) +#define Uint63_lsl(x,y) do{ \ + value uint63_lsl_y__ = (y); \ + if (uint63_lsl_y__ < (uint64_t) 127) \ + accu = (value)((((uint64_t)(x)-1) << uint63_of_value(uint63_lsl_y__)) | 1); \ + else \ + accu = uint63_zero; \ + }while(0) +#define Uint63_lsr(x,y) do{ \ + value uint63_lsl_y__ = (y); \ + if (uint63_lsl_y__ < (uint64_t) 127) \ + accu = (value)(((uint64_t)(x) >> uint63_of_value(uint63_lsl_y__)) | 1); \ + else \ + accu = uint63_zero; \ + }while(0) +#define Uint63_lsl1(x) (accu = (value)((((uint64_t)(x)-1) << 1) +1)) +#define Uint63_lsr1(x) (accu = (value)(((uint64_t)(x) >> 1) |1)) /* addmuldiv(p,x,y) = x * 2^p + y / 2 ^ (63 - p) */ /* (modulo 2^63) for p <= 63 */ @@ -40,6 +55,7 @@ value uint63_addmuldiv(uint64_t p, uint64_t x, uint64_t y) { r |= ((uint64_t)y >> (63-shiftby)) | 1; return r; } +#define Uint63_addmuldiv(p, x, y) (accu = uint63_addmuldiv(p, x, y)) value uint63_head0(uint64_t x) { int r = 0; @@ -51,6 +67,7 @@ value uint63_head0(uint64_t x) { if (!(x & 0x8000000000000000)) { x <<=1; r += 1; } return Val_int(r); } +#define Uint63_head0(x) (accu = uint63_head0(x)) value uint63_tail0(value x) { int r = 0; @@ -63,6 +80,7 @@ value uint63_tail0(value x) { if (!(x & 0x00000001)) { x >>=1; r += 1; } return Val_int(r); } +#define Uint63_tail0(x) (accu = uint63_tail0(x)) value uint63_mulc(value x, value y, value* h) { x = (uint64_t)x >> 1; @@ -86,6 +104,7 @@ value uint63_mulc(value x, value y, value* h) { *h = Val_int(hr); return Val_int(lr); } +#define Uint63_mulc(x, y, h) (accu = uint63_mulc(x, y, h)) #define lt128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_lt(xl,yl))) #define le128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_leq(xl,yl))) @@ -123,3 +142,4 @@ value uint63_div21(value xh, value xl, value y, value* q) { *q = Val_int(quotient); return Val_int(reml); } +#define Uint63_div21(xh, xl, y, q) (accu = uint63_div21(xh, xl, y, q)) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 12ffbf4357..af710e7822 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -462,28 +462,6 @@ let type_of_global_in_context env r = let inst = Univ.make_abstract_instance univs in Inductive.type_of_constructor (cstr,inst) specif, univs -(* Build a fresh instance for a given context, its associated substitution and - the instantiated constraints. *) - -let constr_of_global_in_context env r = - let open GlobRef in - match r with - | VarRef id -> mkVar id, Univ.AUContext.empty - | ConstRef c -> - let cb = lookup_constant c env in - let univs = Declareops.constant_polymorphic_context cb in - mkConstU (c, Univ.make_abstract_instance univs), univs - | IndRef ind -> - let (mib,_) = Inductive.lookup_mind_specif env ind in - let univs = Declareops.inductive_polymorphic_context mib in - mkIndU (ind, Univ.make_abstract_instance univs), univs - | ConstructRef cstr -> - let (mib,_) = - Inductive.lookup_mind_specif env (inductive_of_constructor cstr) - in - let univs = Declareops.inductive_polymorphic_context mib in - mkConstructU (cstr, Univ.make_abstract_instance univs), univs - (************************************************************************) (************************************************************************) diff --git a/kernel/typeops.mli b/kernel/typeops.mli index cc1885f42d..c8f3e506e6 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -107,14 +107,6 @@ val type_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t usage. For non-universe-polymorphic constants, it does not matter. *) -(** {6 Building a term from a global reference *) - -(** Map a global reference to a term in its local universe - context. The term should not be used without pushing it's universe - context in the environmnent of usage. For non-universe-polymorphic - constants, it does not matter. *) -val constr_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t - (** {6 Miscellaneous. } *) (** Check that hyps are included in env and fails with error otherwise *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 8263c68bf5..b1bbc25fe6 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -231,18 +231,15 @@ module LMap = struct module M = HMap.Make (Level) include M - let union l r = - merge (fun _k l r -> - match l, r with - | Some _, _ -> l - | _, _ -> r) l r + let lunion l r = + union (fun _k l _r -> Some l) l r - let subst_union l r = - merge (fun _k l r -> + let subst_union l r = + union (fun _k l r -> match l, r with - | Some (Some _), _ -> l - | Some None, None -> l - | _, _ -> r) l r + | Some _, _ -> Some l + | None, None -> Some l + | _, _ -> Some r) l r let diff ext orig = fold (fun u v acc -> diff --git a/kernel/univ.mli b/kernel/univ.mli index 5543c35741..db178c4bb0 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -223,8 +223,8 @@ module LMap : sig include CMap.ExtS with type key = Level.t and module Set := LSet - val union : 'a t -> 'a t -> 'a t - (** [union x y] favors the bindings in the first map. *) + val lunion : 'a t -> 'a t -> 'a t + (** [lunion x y] favors the bindings in the first map. *) val diff : 'a t -> 'a t -> 'a t (** [diff x y] removes bindings from x that appear in y (whatever the value). *) diff --git a/lib/envars.ml b/lib/envars.ml index 0f4670688b..af8e45b137 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -178,6 +178,7 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = fprintf f "%sDOCDIR=%s/\n" prefix_var_name (docdir ()); fprintf f "%sOCAMLFIND=%s\n" prefix_var_name (ocamlfind ()); fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; + fprintf f "%sWARN=%s\n" prefix_var_name "-warn-error +a-3"; fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name (if Coq_config.has_natdynlink then "true" else "false"); fprintf f "%sCOQ_SRC_SUBDIRS=%s\n" prefix_var_name (String.concat " " coq_src_subdirs) diff --git a/lib/util.ml b/lib/util.ml index 0389336258..38d73d3453 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -20,12 +20,6 @@ let on_pi1 f (a,b,c) = (f a,b,c) let on_pi2 f (a,b,c) = (a,f b,c) let on_pi3 f (a,b,c) = (a,b,f c) -(* Comparing pairs *) - -let pair_compare cmpx cmpy (x1,y1 as p1) (x2,y2 as p2) = - if p1 == p2 then 0 else - let c = cmpx x1 x2 in if c == 0 then cmpy y1 y2 else c - (* Projections from triplets *) let pi1 (a,_,_) = a diff --git a/lib/util.mli b/lib/util.mli index fa3b622621..1eb60f509a 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -17,10 +17,6 @@ val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b val map_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b -(** Comparing pairs *) - -val pair_compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a * 'b -> 'a * 'b -> int) - (** Mapping under triple *) val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd diff --git a/library/global.ml b/library/global.ml index d9f8a6ffa3..55aed1c56e 100644 --- a/library/global.ml +++ b/library/global.ml @@ -157,7 +157,6 @@ let import c u d = globalize (Safe_typing.import c u d) let env_of_context hyps = reset_with_named_context hyps (env()) -let constr_of_global_in_context = Typeops.constr_of_global_in_context let type_of_global_in_context = Typeops.type_of_global_in_context let universes_of_global gr = diff --git a/library/global.mli b/library/global.mli index ca88d2dafd..76ac3f6279 100644 --- a/library/global.mli +++ b/library/global.mli @@ -131,10 +131,6 @@ val is_polymorphic : GlobRef.t -> bool val is_template_polymorphic : GlobRef.t -> bool val is_type_in_type : GlobRef.t -> bool -val constr_of_global_in_context : Environ.env -> - GlobRef.t -> Constr.types * Univ.AUContext.t - [@@ocaml.deprecated "alias of [Typeops.constr_of_global_in_context]"] - val type_of_global_in_context : Environ.env -> GlobRef.t -> Constr.types * Univ.AUContext.t [@@ocaml.deprecated "alias of [Typeops.type_of_global_in_context]"] diff --git a/library/goptions.ml b/library/goptions.ml index b9c1802a72..f4b8ce9465 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -42,13 +42,12 @@ let error_undeclared_key key = (****************************************************************************) (* 1- Tables *) -class type ['a] table_of_A = -object - method add : 'a -> unit - method remove : 'a -> unit - method mem : 'a -> unit - method print : unit -end +type 'a table_of_A = { + add : Environ.env -> 'a -> unit; + remove : Environ.env -> 'a -> unit; + mem : Environ.env -> 'a -> unit; + print : unit -> unit; +} module MakeTable = functor @@ -109,18 +108,17 @@ module MakeTable = (fun a b -> spc () ++ printer a ++ b) table (mt ()) ++ str "." ++ fnl ()))) - class table_of_A () = - object - method add x = add_option (A.encode (Global.env()) x) - method remove x = remove_option (A.encode (Global.env()) x) - method mem x = - let y = A.encode (Global.env()) x in + let table_of_A = { + add = (fun env x -> add_option (A.encode env x)); + remove = (fun env x -> remove_option (A.encode env x)); + mem = (fun env x -> + let y = A.encode env x in let answer = MySet.mem y !t in - Feedback.msg_info (A.member_message y answer) - method print = print_table A.title A.printer !t - end + Feedback.msg_info (A.member_message y answer)); + print = (fun () -> print_table A.title A.printer !t); + } - let _ = A.table := (nick,new table_of_A ())::!A.table + let _ = A.table := (nick, table_of_A)::!A.table let active c = MySet.mem c !t let elements () = MySet.elements !t end diff --git a/library/goptions.mli b/library/goptions.mli index 2e593e9d9e..381ba4d34a 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -76,7 +76,7 @@ end (** The functor [MakeRefTable] declares a new table of objects of type [A.t] practically denoted by [reference]; the encoding function - [encode : reference -> A.t] is typically a globalization function, + [encode : env -> reference -> A.t] is typically a globalization function, possibly with some restriction checks; the function [member_message] say what to print when invoking the "Test Toto Titi foo." command; at the end [title] is the table name printed @@ -139,19 +139,17 @@ val declare_bool_option_and_ref : depr:bool -> name:string -> key:option_name -> module OptionMap : CSig.MapS with type key = option_name -val get_string_table : - option_name -> - < add : string -> unit; - remove : string -> unit; - mem : string -> unit; - print : unit > +type 'a table_of_A = { + add : Environ.env -> 'a -> unit; + remove : Environ.env -> 'a -> unit; + mem : Environ.env -> 'a -> unit; + print : unit -> unit; +} +val get_string_table : + option_name -> string table_of_A val get_ref_table : - option_name -> - < add : qualid -> unit; - remove : qualid -> unit; - mem : qualid -> unit; - print : unit > + option_name -> qualid table_of_A (** The first argument is a locality flag. *) val set_int_option_value_gen : ?locality:option_locality -> option_name -> int option -> unit diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index a3973732ad..dbfc0fc91d 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -185,7 +185,7 @@ VERNAC COMMAND EXTEND Function | _,((_,None,_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac - (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) + (Vernacexpr.(CAst.make @@ VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with | Vernacextend.VtSideff ids, _ when hard -> Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 45a4e61846..e15e167ff3 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1518,7 +1518,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ msg in @@ -1533,7 +1533,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/plugin_base.dune b/plugins/funind/plugin_base.dune index 002eb28eea..6ccf15df29 100644 --- a/plugins/funind/plugin_base.dune +++ b/plugins/funind/plugin_base.dune @@ -1,5 +1,5 @@ (library (name recdef_plugin) - (public_name coq.plugins.recdef) + (public_name coq.plugins.funind) (synopsis "Coq's functional induction plugin") (libraries coq.plugins.extraction)) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 523c7c8305..e59076bd63 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -182,9 +182,18 @@ TACTIC EXTEND unify } END +{ +let deprecated_convert_concl_no_check = + CWarnings.create + ~name:"convert_concl_no_check" ~category:"deprecated" + (fun () -> Pp.str "The syntax [convert_concl_no_check] is deprecated. Use [change_no_check] instead.") +} TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> { Tactics.convert_concl_no_check x DEFAULTcast } +| ["convert_concl_no_check" constr(x) ] -> { + deprecated_convert_concl_no_check (); + Tactics.convert_concl ~check:false x DEFAULTcast + } END { diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index a2dd51643b..c23240b782 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -703,7 +703,11 @@ GRAMMAR EXTEND Gram | IDENT "change"; c = conversion; cl = clause_dft_concl -> { let (oc, c) = c in let p,cl = merge_occurrences loc cl oc in - TacAtom (CAst.make ~loc @@ TacChange (p,c,cl)) } + TacAtom (CAst.make ~loc @@ TacChange (true,p,c,cl)) } + | IDENT "change_no_check"; c = conversion; cl = clause_dft_concl -> + { let (oc, c) = c in + let p,cl = merge_occurrences loc cl oc in + TacAtom (CAst.make ~loc @@ TacChange (false,p,c,cl)) } ] ] ; END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 80070a7493..79f0f521cc 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -833,9 +833,10 @@ let pr_goal_selector ~toplevel s = pr_red_expr r ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) - | TacChange (op,c,h) -> + | TacChange (check,op,c,h) -> + let name = if check then "change_no_check" else "change" in hov 1 ( - primitive "change" ++ brk (1,1) + primitive name ++ brk (1,1) ++ ( match op with None -> diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 2d40ba6562..99a9c1ab9a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1596,7 +1596,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> + convert_hyp ~check:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> @@ -1610,7 +1610,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = end | None, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_concl_no_check newt DEFAULTcast + convert_concl ~check:false newt DEFAULTcast in Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 30e316b36d..0eb7726a18 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -34,6 +34,7 @@ type rec_flag = bool (* true = recursive false = not recursive *) type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) +type check_flag = bool (* true = check false = do not check *) type ('c,'d,'id) inversion_strength = | NonDepInversion of @@ -125,7 +126,7 @@ type 'a gen_atomic_tactic_expr = (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr + | TacChange of check_flag * 'pat option * 'dtrm * 'nam clause_expr (* Equality and inversion *) | TacRewrite of evars_flag * diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 8b6b14322b..fd303f5d94 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -34,6 +34,7 @@ type rec_flag = bool (* true = recursive false = not recursive *) type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) +type check_flag = bool (* true = check false = do not check *) type ('c,'d,'id) inversion_strength = | NonDepInversion of @@ -124,7 +125,7 @@ type 'a gen_atomic_tactic_expr = (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr + | TacChange of check_flag * 'pat option * 'dtrm * 'nam clause_expr (* Equality and inversion *) | TacRewrite of evars_flag * diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 543d4de0fe..c1f7fab123 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -551,7 +551,7 @@ let rec intern_atomic lf ist x = | TacReduce (r,cl) -> dump_glob_red_expr r; TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) - | TacChange (None,c,cl) -> + | TacChange (check,None,c,cl) -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false @@ -560,17 +560,17 @@ let rec intern_atomic lf ist x = | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in - TacChange (None, + TacChange (check,None, (if is_onhyps && is_onconcl then intern_type ist c else intern_constr ist c), clause_app (intern_hyp_location ist) cl) - | TacChange (Some p,c,cl) -> + | TacChange (check,Some p,c,cl) -> let { ltacvars } = ist in let metas,pat = intern_typed_pattern ist ~as_type:false ~ltacvars p in let fold accu x = Id.Set.add x accu in let ltacvars = List.fold_left fold ltacvars metas in let ist' = { ist with ltacvars } in - TacChange (Some pat,intern_constr ist' c, + TacChange (check,Some pat,intern_constr ist' c, clause_app (intern_hyp_location ist) cl) (* Equality and inversion *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 4398fb14ab..800be2565d 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1770,7 +1770,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) end - | TacChange (None,c,cl) -> + | TacChange (check,None,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> @@ -1792,10 +1792,10 @@ and interp_atomic ist tac : unit Proofview.tactic = then interp_type ist env sigma c else interp_constr ist env sigma c in - Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) + Tactics.change ~check None c_interp (interp_clause ist (pf_env gl) (project gl) cl) end end - | TacChange (Some op,c,cl) -> + | TacChange (check,Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> @@ -1815,7 +1815,7 @@ and interp_atomic ist tac : unit Proofview.tactic = with e when to_catch e (* Hack *) -> user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") in - Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) + Tactics.change ~check (Some op) c_interp (interp_clause ist env sigma cl) end end diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index e617f3d45e..a3eeca2267 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -158,8 +158,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) - | TacChange (op,c,cl) -> - TacChange (Option.map (subst_glob_constr_or_pattern subst) op, + | TacChange (check,op,c,cl) -> + TacChange (check,Option.map (subst_glob_constr_or_pattern subst) op, subst_glob_constr subst c, cl) (* Equality and inversion *) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 4802608fda..f3bc791b8d 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -535,7 +535,7 @@ let focused_simpl path = let open Tacmach.New in Proofview.Goal.enter begin fun gl -> let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in - convert_concl_no_check newc DEFAULTcast + convert_concl ~check:false newc DEFAULTcast end let focused_simpl path = focused_simpl path @@ -687,7 +687,7 @@ let simpl_coeffs path_init path_k = let n = Pervasives.(-) (List.length path_k) (List.length path_init) in let newc = context sigma (fun _ t -> loop n t) (List.rev path_init) (pf_concl gl) in - convert_concl_no_check newc DEFAULTcast + convert_concl ~check:false newc DEFAULTcast end let rec shuffle p (t1,t2) = @@ -1849,12 +1849,12 @@ let destructure_hyps = match destructurate_type env sigma typ with | Kapp(Nat,_) -> (tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) (loop lit)) | Kapp(Z,_) -> (tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) (loop lit)) | _ -> loop lit diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index d6b7371647..49d729bd6c 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -94,20 +94,31 @@ Require Import ssreflect ssrfun. 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. + simpl_pred T == the type of simplifying bool predicates, based on + the simpl_fun type from ssrfun.v. + mem_pred T == a specialized form of simpl_pred for "collective" + predicates (see below). rel T == the type of bool relations. := T -> pred T or T -> T -> bool. simpl_rel T == type of simplifying relations. + := T -> simpl_pred T 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. + pred_sort == the predType >-> Type projection; pred_sort is + itself a Coercion target class. Declaring a + coercion to pred_sort is an alternative way of + equiping 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. + {pred T} == a type convertible to pred T, but whose head + constant is pred_sort. This type should be used + for parameters that can be used as collective + predicates (see below), as this will allow passing + in directly collections that implement predType + by coercion as described above, e.g., finite sets. + := pred_sort (predPredType T) 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 @@ -119,8 +130,14 @@ Require Import ssreflect ssrfun. 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. + mem A == an applicative equivalent of collective predicate A: + mem A x simplifies to x \in A, as mem A has in + fact type mem_pred T. + --> In user notation collective predicates _only_ occur as arguments to mem: + A only appears as (mem A). This is hidden by notation, e.g., + x \in A := in_mem x (mem A) here, enum A := enum_mem (mem A) in fintype. + This makes it possible to unify the various ways in which A can be + interpreted as a predicate, for both pattern matching and display. 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. @@ -135,11 +152,11 @@ Require Import ssreflect ssrfun. #[#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}) + predU P Q, ..., preim f P == 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. @@ -147,7 +164,9 @@ Require Import ssreflect ssrfun. #[#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. + relU R S == union of relations R and S. + relpre f R == preimage of relation R under f. + xpredU, ..., xrelpre == lambda terms implementing predU, ..., etc. 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 @@ -177,7 +196,7 @@ Require Import ssreflect ssrfun. 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 + coerces to pred_sort 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, @@ -189,11 +208,11 @@ Require Import ssreflect ssrfun. 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 + to be attached to p : {pred _}; 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. + coercion to pred_sort. 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 @@ -235,17 +254,20 @@ Require Import ssreflect ssrfun. {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. + {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, e.g., + {on C, involutive f}. {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy - when P2 is also convertible to Pf f. + when P2 is also convertible to Pf f, e.g., + {on C &, injective 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. + and P1' g is convertible to forall x, Qx, e.g., + {on C, cancel f & g}. {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. @@ -282,13 +304,119 @@ 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). +Reserved Notation "b1 (+) b2" (at level 50, left associativity). + +Reserved Notation "x \in A" (at level 70, no associativity, + format "'[hv' x '/ ' \in A ']'"). +Reserved Notation "x \notin A" (at level 70, no associativity, + format "'[hv' x '/ ' \notin A ']'"). +Reserved Notation "x \is A" (at level 70, no associativity, + format "'[hv' x '/ ' \is A ']'"). +Reserved Notation "x \isn't A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't A ']'"). +Reserved Notation "x \is 'a' A" (at level 70, no associativity, + format "'[hv' x '/ ' \is 'a' A ']'"). +Reserved Notation "x \isn't 'a' A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'a' A ']'"). +Reserved Notation "x \is 'an' A" (at level 70, no associativity, + format "'[hv' x '/ ' \is 'an' A ']'"). +Reserved Notation "x \isn't 'an' A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'an' A ']'"). +Reserved Notation "p1 =i p2" (at level 70, no associativity, + format "'[hv' p1 '/ ' =i p2 ']'"). +Reserved Notation "{ 'subset' A <= B }" (at level 0, A, B at level 69, + format "'[hv' { 'subset' A '/ ' <= B } ']'"). + +Reserved Notation "{ : T }" (at level 0, format "{ : T }"). +Reserved Notation "{ 'pred' T }" (at level 0, format "{ 'pred' T }"). +Reserved Notation "[ 'predType' 'of' T ]" (at level 0, + format "[ 'predType' 'of' T ]"). + +Reserved Notation "[ 'pred' : T | E ]" (at level 0, + format "'[hv' [ 'pred' : T | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x : T | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x : T | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x | '/ ' E1 & '/ ' E2 ] ']'"). +Reserved Notation "[ 'pred' x : T | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x : T | '/ ' E1 & E2 ] ']'"). +Reserved Notation "[ 'pred' x 'in' A ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A ] ']'"). +Reserved Notation "[ 'pred' x 'in' A | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x 'in' A | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A | '/ ' E1 & '/ ' E2 ] ']'"). + +Reserved Notation "[ 'qualify' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' x : T | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'a' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'a' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x : T | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'an' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'an' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x : T | '/ ' P ] ']'"). + +Reserved Notation "[ 'rel' x y | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y : T | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y : T | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A & B | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A & B | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A & B ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A & B ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A ] ']'"). + +Reserved Notation "[ 'mem' A ]" (at level 0, format "[ 'mem' A ]"). +Reserved Notation "[ 'predI' A & B ]" (at level 0, + format "[ 'predI' A & B ]"). +Reserved Notation "[ 'predU' A & B ]" (at level 0, + format "[ 'predU' A & B ]"). +Reserved Notation "[ 'predD' A & B ]" (at level 0, + format "[ 'predD' A & B ]"). +Reserved Notation "[ 'predC' A ]" (at level 0, + format "[ 'predC' A ]"). +Reserved Notation "[ 'preim' f 'of' A ]" (at level 0, + format "[ 'preim' f 'of' A ]"). + +Reserved Notation "\unless C , P" (at level 200, C at level 100, + format "'[hv' \unless C , '/ ' P ']'"). + +Reserved Notation "{ 'for' x , P }" (at level 0, + format "'[hv' { 'for' x , '/ ' P } ']'"). +Reserved Notation "{ 'in' d , P }" (at level 0, + format "'[hv' { 'in' d , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d & , P }" (at level 0, + format "'[hv' { 'in' d & , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 & d3 , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 & d3 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & & d3 , P }" (at level 0, + format "'[hv' { 'in' d1 & & d3 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 & , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 & , '/ ' P } ']'"). +Reserved Notation "{ 'in' d & & , P }" (at level 0, + format "'[hv' { 'in' d & & , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd , P }" (at level 0, + format "'[hv' { 'on' cd , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd & , P }" (at level 0, + format "'[hv' { 'on' cd & , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd , P & g }" (at level 0, g at level 8, + format "'[hv' { 'on' cd , '/ ' P & g } ']'"). +Reserved Notation "{ 'in' d , 'bijective' f }" (at level 0, f at level 8, + format "'[hv' { 'in' d , '/ ' 'bijective' f } ']'"). +Reserved Notation "{ 'on' cd , 'bijective' f }" (at level 0, f at level 8, + format "'[hv' { 'on' cd , '/ ' 'bijective' f } ']'"). + (** We introduce a number of n-ary "list-style" notations that share a common @@ -335,18 +463,6 @@ 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. @@ -622,9 +738,7 @@ Hint View for apply/ impliesPn|2 impliesP|2. 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. +Notation "\unless C , P" := (unless C P) : type_scope. Lemma unlessL C P : implies C (\unless C, P). Proof. by split=> hC G /(_ hC). Qed. @@ -1002,8 +1116,7 @@ Ltac bool_congr := 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. + used applicatively, because of restrictions 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 @@ -1019,319 +1132,391 @@ Ltac bool_congr := 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). + In detail, we ensure that the head normal form of mem A is always of the + eta-long MemPred (fun x => pA x) form, where pA is the pred interpretation of + A following its predType pT, i.e., the _expansion_ of topred A. For a pred T + evar ?P, (mem ?P) converts MemPred (fun x => ?P x), whose argument is a Miller + pattern and therefore always unify: unifying (mem A) with (mem ?P) always + yields ?P = pA, because the rigid constant MemPred aligns the unification. + Furthermore, we ensure pA is always either A or toP .... A where toP ... is + the expansion of @topred T pT, and toP is declared as a Coercion, so pA will + _display_ as A in either case, and the instances of @mem T (predPredType T) pA + appearing in the premises or right-hand side of a generic lemma parametrized + by ?P will be indistinguishable from @mem T pT A. + Users should take care not to inadvertently "strip" (mem A) down to the + coerced A, since this will expose the internal toP coercion: Coq could then + display terms A x that cannot be typed as such. The topredE lemma can be used + to restore the x \in A syntax in this case. While -topredE can conversely be + used to change x \in P into P x for an applicative P, it is safer to use the + inE, unfold_in or 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 predicate 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. **) - + coercion to the sort of the predPredType structure, conveniently denoted + {pred T}. 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, or of any lemma that expects a generic collective predicates with + type {pred T} := pred_sort (predPredType T) = pred T; thus {pred T} should be + the preferred type for generic collective predicate parameters. + This device 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. + **) + +(** Boolean predicates. *) Definition pred T := T -> bool. - Identity Coercion fun_of_pred : pred >-> Funclass. -Definition rel T := T -> pred T. +Definition subpred T (p1 p2 : pred T) := forall x : T, p1 x -> p2 x. -Identity Coercion fun_of_rel : rel >-> Funclass. +(* Notation for some manifest predicates. *) -Notation xpred0 := (fun _ => false). -Notation xpredT := (fun _ => true). +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. +(** The packed class interface for pred-like types. **) -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. +#[universes(template)] +Structure predType T := + PredType {pred_sort :> Type; topred : pred_sort -> pred T}. + +Definition clone_pred T U := + fun pT & @pred_sort T pT -> U => + fun toP (pT' := @PredType T U toP) & phant_id pT' pT => pT'. +Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ id) : form_scope. + +Canonical predPredType T := PredType (@id (pred T)). +Canonical boolfunPredType T := PredType (@id (T -> bool)). + +(** The type of abstract collective predicates. + While {pred T} is contertible to pred T, it presents the pred_sort coercion + class, which crucially does _not_ coerce to Funclass. Term whose type P coerces + to {pred T} cannot be applied to arguments, but they _can_ be used as if P + had a canonical predType instance, as the coercion will be inserted if the + unification P =~= pred_sort ?pT fails, changing the problem into the trivial + {pred T} =~= pred_sort ?pT (solution ?pT := predPredType P). + Additional benefits of this approach are that any type coercing to P will + also inherit this behaviour, and that the coercion will be apparent in the + elaborated expression. The latter may be important if the coercion is also + a canonical structure projector - see mathcomp/fingroup/fingroup.v. The + main drawback of implementing predType by coercion in this way is that the + type of the value must be known when the unification constraint is imposed: + if we only register the constraint and then later discover later that the + expression had type P it will be too late of insert a coercion, whereas a + canonical instance of predType fo P would have solved the deferred constraint. + Finally, definitions, lemmas and sections should use type {pred T} for + their generic collective type parameters, as this will make it possible to + apply such definitions and lemmas directly to values of types that implement + predType by coercion to {pred T} (values of types that implement predType + without coercing to {pred T} will have to be coerced explicitly using topred). +**) +Notation "{ 'pred' T }" := (pred_sort (predPredType T)) : type_scope. + +(** The type of self-simplifying collective predicates. **) +Definition simpl_pred T := simpl_fun T bool. +Definition SimplPred {T} (p : pred T) : simpl_pred T := SimplFun p. + +(** Some simpl_pred constructors. **) + +Definition pred0 {T} := @SimplPred T xpred0. +Definition predT {T} := @SimplPred T xpredT. +Definition predI {T} (p1 p2 : pred T) := SimplPred (xpredI p1 p2). +Definition predU {T} (p1 p2 : pred T) := SimplPred (xpredU p1 p2). +Definition predC {T} (p : pred T) := SimplPred (xpredC p). +Definition predD {T} (p1 p2 : pred T) := SimplPred (xpredD p1 p2). +Definition preim {aT rT} (f : aT -> rT) (d : pred rT) := SimplPred (xpreim f d). + +Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) : fun_scope. +Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) : fun_scope. +Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] : fun_scope. +Notation "[ 'pred' x : T | E ]" := + (SimplPred (fun x : T => E%B)) (only parsing) : fun_scope. +Notation "[ 'pred' x : T | E1 & E2 ]" := + [pred x : T | E1 && E2 ] (only parsing) : fun_scope. + +(** Coercions for simpl_pred. + As simpl_pred T values are used both applicatively and collectively we + need simpl_pred to coerce to both pred T _and_ {pred T}. However it is + undesireable to have two distinct constants for what are essentially identical + coercion functions, as this confuses the SSReflect keyed matching algorithm. + While the Coq Coercion declarations appear to disallow such Coercion aliasing, + it is possible to work around this limitation with a combination of modules + and functors, which we do below. + In addition we also give a predType instance for simpl_pred, which will + be preferred to the {pred T} coercion to solve simpl_pred T =~= pred_sort ?pT + constraints; not however that the pred_of_simpl coercion _will_ be used + when a simpl_pred T is passed as a {pred T}, since the simplPredType T + structure for simpl_pred T is _not_ convertible to predPredType T. **) + +Module PredOfSimpl. +Definition coerce T (sp : simpl_pred T) : pred T := fun_of_simpl sp. +End PredOfSimpl. +Notation pred_of_simpl := PredOfSimpl.coerce. +Coercion pred_of_simpl : simpl_pred >-> pred. +Canonical simplPredType T := PredType (@pred_of_simpl T). + +Module Type PredSortOfSimplSignature. +Parameter coerce : forall T, simpl_pred T -> {pred T}. +End PredSortOfSimplSignature. +Module DeclarePredSortOfSimpl (PredSortOfSimpl : PredSortOfSimplSignature). +Coercion PredSortOfSimpl.coerce : simpl_pred >-> pred_sort. +End DeclarePredSortOfSimpl. +Module Export PredSortOfSimplCoercion := DeclarePredSortOfSimpl PredOfSimpl. + +(** Type to pred coercion. + This lets us use types of sort predArgType as a synonym for their universal + predicate. We define this predicate as a simpl_pred T rather than a pred T or + a {pred T} so that /= and inE reduce (T x) and x \in T to true, respectively. + Unfortunately, this can't be used for existing types like bool whose sort + is already fixed (at least, not without redefining bool, true, false and + all bool operations and lemmas); we provide syntax to recast a given type + in predArgType as a workaround. **) +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) : type_scope. -Definition SimplPred (p : pred T) : simpl_pred := SimplFun p. +(** Boolean relations. + Simplifying relations follow the coding pattern of 2-argument simplifying + functions: the simplifying type constructor is applied to the _last_ + argument. This design choice will let the in_simpl componenent of inE expand + membership in simpl_rel as well. We provide an explicit coercion to rel T + to avoid eta-expansion during coercion; this coercion self-simplifies so it + should be invisible. + **) -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 rel T := T -> pred T. +Identity Coercion fun_of_rel : rel >-> Funclass. -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 subrel T (r1 r2 : rel T) := forall x y : T, r1 x y -> r2 x y. -Definition simpl_rel := simpl_fun T (pred T). +Definition simpl_rel T := T -> simpl_pred T. -Definition SimplRel (r : rel T) : simpl_rel := [fun x => r x]. +Coercion rel_of_simpl T (sr : simpl_rel T) : rel T := fun x : T => sr x. +Arguments rel_of_simpl {T} sr x /. -Coercion rel_of_simpl_rel (r : simpl_rel) : rel T := fun x y => r x y. +Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). +Notation xrelpre := (fun f (r : rel _) x y => r (f x) (f y)). -Definition relU r1 r2 := SimplRel (xrelU r1 r2). +Definition SimplRel {T} (r : rel T) : simpl_rel T := fun x => SimplPred (r x). +Definition relU {T} (r1 r2 : rel T) := SimplRel (xrelU r1 r2). +Definition relpre {aT rT} (f : aT -> rT) (r : rel rT) := SimplRel (xrelpre f r). -Lemma subrelUl r1 r2 : subrel r1 (relU r1 r2). -Proof. by move=> *; apply/orP; left. Qed. +Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) : fun_scope. +Notation "[ 'rel' x y : T | E ]" := + (SimplRel (fun x y : T => E%B)) (only parsing) : fun_scope. -Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). -Proof. by move=> *; apply/orP; right. Qed. +Lemma subrelUl T (r1 r2 : rel T) : subrel r1 (relU r1 r2). +Proof. by move=> x y r1xy; apply/orP; left. Qed. -#[universes(template)] -Variant mem_pred := Mem of pred T. +Lemma subrelUr T (r1 r2 : rel T) : subrel r2 (relU r1 r2). +Proof. by move=> x y r2xy; apply/orP; right. Qed. -Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). +(** Variant of simpl_pred specialised to the membership operator. **) #[universes(template)] -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. +Variant mem_pred T := Mem of pred T. (** - 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. + We mainly declare pred_of_mem as a coercion so that it is not displayed. + Similarly to pred_of_simpl, it will usually not be inserted by type + inference, as all mem_pred mp =~= pred_sort ?pT unification problems will + be solve by the memPredType instance below; pred_of_mem will however + be used if a mem_pred T is used as a {pred T}, which is desireable as it + will avoid a redundant mem in a collective, e.g., passing (mem A) to a lemma + expection a generic collective predicate p : {pred T} and premise x \in P + will display a subgoal x \in A rathere than x \in mem A. + Conversely, pred_of_mem will _not_ if it is used id (mem A) is used + applicatively or as a pred T; there the simpl_of_mem coercion defined below + will be used, resulting in a subgoal that displays as mem A x by simplifies + to x \in A. + **) +Coercion pred_of_mem {T} mp : {pred T} := let: Mem p := mp in [eta p]. +Canonical memPredType T := PredType (@pred_of_mem T). + +Definition in_mem {T} (x : T) mp := pred_of_mem mp x. +Definition eq_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 = in_mem x mp2. +Definition sub_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 -> in_mem x mp2. + +Arguments in_mem {T} x mp : simpl never. +Typeclasses Opaque eq_mem. +Typeclasses Opaque sub_mem. -(** - 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. +(** The [simpl_of_mem; pred_of_simpl] path provides a new mem_pred >-> pred + coercion, but does _not_ override the pred_of_mem : mem_pred >-> pred_sort + explicit coercion declaration above. + **) +Coercion simpl_of_mem {T} mp := SimplPred (fun x : T => in_mem x mp). -Notation "{ : T }" := (T%type : predArgType) - (at level 0, format "{ : T }") : type_scope. +Lemma sub_refl T (mp : mem_pred T) : sub_mem mp mp. Proof. by []. Qed. +Arguments sub_refl {T mp} [x] mp_x. (** - These must be defined outside a Section because "cooking" kills the - nosimpl tag. **) - + It is essential to interlock the production of the Mem constructor inside + the branch of the predType match, to ensure that unifying mem A with + Mem [eta ?p] sets ?p := toP A (or ?p := P if toP = id and A = [eta P]), + rather than topred pT A, had we put mem A := Mem (topred A). +**) 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}. + let: PredType toP := pT in fun A => Mem [eta toP A]. +Arguments mem {T pT} A : rename, simpl never. 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 "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) : type_scope. + +Notation "[ 'mem' A ]" := + (pred_of_simpl (simpl_of_mem (mem A))) (only parsing) : fun_scope. + +Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) : fun_scope. +Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) : fun_scope. +Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) : fun_scope. +Notation "[ 'predC' A ]" := (predC [mem A]) : fun_scope. +Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) : fun_scope. +Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] : fun_scope. +Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] : fun_scope. +Notation "[ 'pred' x 'in' A | E1 & E2 ]" := + [pred x | 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). + [rel x y | (x \in A) && (y \in B) && E] : fun_scope. +Notation "[ 'rel' x y 'in' A & B ]" := + [rel x y | (x \in A) && (y \in B)] : fun_scope. +Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] : fun_scope. +Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] : fun_scope. + +(** Aliases of pred T that let us tag intances of simpl_pred as applicative + or collective, via bespoke coercions. This tagging will give control over + the simplification behaviour of inE and othe rewriting lemmas below. + For this control to work it is crucial that collective_of_simpl _not_ + be convertible to either applicative_of_simpl or pred_of_simpl. Indeed + they differ here by a commutattive conversion (of the match and lambda). + **) +Definition applicative_pred T := pred T. +Definition collective_pred T := pred T. +Coercion applicative_pred_of_simpl T (sp : simpl_pred T) : applicative_pred T := + fun_of_simpl sp. +Coercion collective_pred_of_simpl T (sp : simpl_pred T) : collective_pred T := + let: SimplFun p := sp in p. + +(** Explicit simplification rules for predicate application and membership. **) +Section PredicateSimplification. + +Variables T : Type. + +Implicit Types (p : pred T) (pT : predType T) (sp : simpl_pred T). +Implicit Types (mp : mem_pred T). (** - 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). **) + The following four bespoke structures provide fine-grained control over + matching the various predicate forms. While all four follow a common pattern + of using a canonical projection to match a particular form of predicate + (in pred T, simpl_pred, mem_pred and mem_pred, respectively), and display + the matched predicate in the structure type, each is in fact used for a + different, specific purpose: + - registered_applicative_pred: this user-facing structure is used to + declare values of type pred T meant to be used applicatively. The + structure parameter merely displays this same value, and is used to avoid + undesireable, visible occurrence of the structure in the right hand side + of rewrite rules such as app_predE. + There is a canonical instance of registered_applicative_pred for values + of the applicative_of_simpl coercion, which handles the + Definition Apred : applicative_pred T := [pred x | ...] idiom. + This instance is mainly intended for the in_applicative component of inE, + in conjunction with manifest_mem_pred and applicative_mem_pred. + - manifest_simpl_pred: the only instance of this structure matches manifest + simpl_pred values of the form SimplPred p, displaying p in the structure + type. This structure is used in in_simpl to detect and selectively expand + collective predicates of this form. An explicit SimplPred p pattern would + _NOT_ work for this purpose, as then the left-hand side of in_simpl would + reduce to in_mem ?x (Mem [eta ?p]) and would thus match _any_ instance + of \in, not just those arising from a manifest simpl_pred. + - manifest_mem_pred: similar to manifest_simpl_pred, the one instance of this + structure matches manifest mem_pred values of the form Mem [eta ?p]. The + purpose is different however: to match and display in ?p the actual + predicate appearing in an ... \in ... expression matched by the left hand + side of the in_applicative component of inE; then + - applicative_mem_pred is a telescope refinement of manifest_mem_pred p with + a default constructor that checks that the predicate p is the value of a + registered_applicative_pred; any unfolding occurring during this check + does _not_ affect the value of p passed to in_applicative, since that + has been fixed earlier by the manifest_mem_pred match. In particular the + definition of a predicate using the applicative_pred_of_simpl idiom above + will not be expanded - this very case is the reason in_applicative uses + a mem_pred telescope in its left hand side. The more straighforward + ?x \in applicative_pred_value ?ap (equivalent to in_mem ?x (Mem ?ap)) + with ?ap : registered_applicative_pred ?p would set ?p := [pred x | ...] + rather than ?p := Apred in the example above. + Also note that the in_applicative component of inE must be come before the + in_simpl one, as the latter also matches terms of the form x \in Apred. + Finally, no component of inE matches x \in Acoll, when + Definition Acoll : collective_pred T := [pred x | ...]. + as the collective_pred_of_simpl is _not_ convertible to pred_of_simpl. **) + #[universes(template)] -Structure manifest_applicative_pred p := ManifestApplicativePred { - manifest_applicative_pred_value :> pred T; - _ : manifest_applicative_pred_value = p +Structure registered_applicative_pred p := RegisteredApplicativePred { + applicative_pred_value :> pred T; + _ : applicative_pred_value = p }. -Definition ApplicativePred p := ManifestApplicativePred (erefl p). +Definition ApplicativePred p := RegisteredApplicativePred (erefl p). Canonical applicative_pred_applicative sp := ApplicativePred (applicative_pred_of_simpl sp). #[universes(template)] Structure manifest_simpl_pred p := ManifestSimplPred { - manifest_simpl_pred_value :> simpl_pred T; - _ : manifest_simpl_pred_value = SimplPred p + simpl_pred_value :> simpl_pred T; + _ : simpl_pred_value = SimplPred p }. Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). #[universes(template)] Structure manifest_mem_pred p := ManifestMemPred { - manifest_mem_pred_value :> mem_pred T; - _ : manifest_mem_pred_value= Mem [eta p] + mem_pred_value :> mem_pred T; + _ : mem_pred_value = Mem [eta p] }. -Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). +Canonical expose_mem_pred p := ManifestMemPred (erefl (Mem [eta p])). #[universes(template)] 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. +Canonical check_applicative_mem_pred p (ap : registered_applicative_pred p) := + [eta @ApplicativeMemPred ap]. -Lemma mem_topred (pp : pT) : mem (topred pp) = mem pp. -Proof. by rewrite /mem; case: pT pp => T1 app1 [mem1 /= ->]. Qed. +Lemma mem_topred pT (pp : pT) : mem (topred pp) = mem pp. +Proof. by case: pT pp. Qed. -Lemma topredE x (pp : pT) : topred pp x = (x \in pp). +Lemma topredE pT 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). +Lemma app_predE x p (ap : registered_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. +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. + in_mem x (Mem [eta pred_of_simpl msp]) = 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. **) + should only be used in the left-to-right direction. + **) Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. Proof. by []. Qed. @@ -1345,55 +1530,39 @@ 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. +Lemma mem_mem mp : + (mem mp = mp) * (mem (mp : simpl_pred T) = mp) * (mem (mp : pred T) = mp). +Proof. by case: mp. Qed. -End simpl_mem. +End PredicateSimplification. (** Qualifiers and keyed predicates. **) #[universes(template)] -Variant qualifier (q : nat) T := Qualifier of predPredType T. +Variant qualifier (q : nat) T := Qualifier of {pred T}. -Coercion has_quality n T (q : qualifier n T) : pred_class := +Coercion has_quality n T (q : qualifier n T) : {pred T} := 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. +Notation "x \is A" := (x \in has_quality 0 A) : bool_scope. +Notation "x \is 'a' A" := (x \in has_quality 1 A) : bool_scope. +Notation "x \is 'an' A" := (x \in has_quality 2 A) : bool_scope. +Notation "x \isn't A" := (x \notin has_quality 0 A) : bool_scope. +Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) : bool_scope. +Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) : bool_scope. +Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' x : T | P ]" := + (Qualifier 0 (fun x : T => P%B)) (only parsing) : form_scope. +Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' 'a' x : T | P ]" := + (Qualifier 1 (fun x : T => P%B)) (only parsing) : form_scope. +Notation "[ 'qualify' 'an' x | P ]" := + (Qualifier 2 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' 'an' x : T | P ]" := + (Qualifier 2 (fun x : T => P%B)) (only parsing) : form_scope. (** Keyed predicates: support for property-bearing predicate interfaces. **) @@ -1401,12 +1570,12 @@ Section KeyPred. Variable T : Type. #[universes(template)] -Variant pred_key (p : predPredType T) := DefaultPredKey. +Variant pred_key (p : {pred T}) := DefaultPredKey. -Variable p : predPredType T. +Variable p : {pred T}. #[universes(template)] Structure keyed_pred (k : pred_key p) := - PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. + PackKeyedPred {unkey_pred :> {pred T}; _ : unkey_pred =i p}. Variable k : pred_key p. Definition KeyedPred := @PackKeyedPred k p (frefl _). @@ -1418,10 +1587,10 @@ 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 + Note: pred_of_mem is the registered mem >-> pred_sort 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 !! **) + computation does not strip casts. **) Canonical keyed_mem := @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. Canonical keyed_mem_simpl := @@ -1429,8 +1598,8 @@ Canonical keyed_mem_simpl := End KeyPred. -Notation "x \i 'n' S" := (x \in @unkey_pred _ S _ _) - (at level 70, format "'[hv' x '/ ' \i 'n' S ']'") : bool_scope. +Local Notation in_unkey x S := (x \in @unkey_pred _ S _ _) (only parsing). +Notation "x \in S" := (in_unkey x S) (only printing) : bool_scope. Section KeyedQualifier. @@ -1447,12 +1616,12 @@ 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. +Notation "x \is A" := + (in_unkey x (has_quality 0 A)) (only printing) : bool_scope. +Notation "x \is 'a' A" := + (in_unkey x (has_quality 1 A)) (only printing) : bool_scope. +Notation "x \is 'an' A" := + (in_unkey x (has_quality 2 A)) (only printing) : bool_scope. Module DefaultKeying. @@ -1592,7 +1761,7 @@ Definition prop_on2 Pf P & phantom T3 (Pf f) & ph {all2 P} := End LocalProperties. Definition inPhantom := Phantom Prop. -Definition onPhantom T P (x : T) := Phantom Prop (P x). +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)) @@ -1602,59 +1771,30 @@ 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 "{ 'for' x , P }" := (prop_for x (inPhantom P)) : type_scope. +Notation "{ 'in' d , P }" := (prop_in1 (mem d) (inPhantom 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. - + (prop_in11 (mem d1) (mem d2) (inPhantom P)) : type_scope. +Notation "{ 'in' d & , P }" := (prop_in2 (mem d) (inPhantom 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. - + (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom 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. - + (prop_in21 (mem d1) (mem d3) (inPhantom 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. - + (prop_in12 (mem d1) (mem d2) (inPhantom P)) : type_scope. +Notation "{ 'in' d & & , P }" := (prop_in3 (mem d) (inPhantom P)) : type_scope. Notation "{ 'on' cd , P }" := - (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) - (at level 0, format "{ 'on' cd , P }") : type_scope. + (prop_on1 (mem cd) (inPhantom P) (inPhantom 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} _ _. + (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) : type_scope. +Local Arguments onPhantom : clear scopes. 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. + (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) : type_scope. +Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) : type_scope. +Notation "{ 'on' cd , 'bijective' f }" := + (bijective_on (mem cd) f) : type_scope. (** Weakening and monotonicity lemmas for localized predicates. @@ -1666,7 +1806,7 @@ Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) Section LocalGlobal. Variables T1 T2 T3 : predArgType. -Variables (D1 : pred T1) (D2 : pred T2) (D3 : pred T3). +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). @@ -1850,7 +1990,7 @@ End MonoHomoMorphismTheory. Section MonoHomoMorphismTheory_in. Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). -Variable (aD : pred 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]. diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 2a84469af0..a4caeb403c 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -426,7 +426,7 @@ let mk_anon_id t gl_ids = (set s i (Char.chr (Char.code (get s i) + 1)); s) in Id.of_string_soft (Bytes.to_string (loop (n - 1))) -let convert_concl_no_check t = Tactics.convert_concl_no_check t DEFAULTcast +let convert_concl_no_check t = Tactics.convert_concl ~check:false t DEFAULTcast let convert_concl t = Tactics.convert_concl t DEFAULTcast let rename_hd_prod orig_name_ref gl = @@ -828,10 +828,12 @@ let view_error s gv = open Locus (****************************** tactics ***********************************) -let rewritetac dir c = +let rewritetac ?(under=false) dir c = (* Due to the new optional arg ?tac, application shouldn't be too partial *) + let open Proofview.Notations in Proofview.V82.of_tactic begin - Equality.general_rewrite (dir = L2R) AllOccurrences true false c + Equality.general_rewrite (dir = L2R) AllOccurrences true false c <*> + if under then Proofview.cycle 1 else Proofview.tclUNIT () end (**********************`:********* hooks ************************************) @@ -973,7 +975,7 @@ let dependent_apply_error = * * 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 = +let applyn ~with_evars ?beta ?(with_shelve=false) ?(first_goes_last=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 @@ -985,8 +987,11 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = pf_partial_solution gl t gs in Proofview.(V82.of_tactic - (tclTHEN (V82.tactic refine) - (if with_shelve then shelve_unifiable else tclUNIT ()))) gl + (Tacticals.New.tclTHENLIST [ + V82.tactic refine; + (if with_shelve then shelve_unifiable else tclUNIT ()); + (if first_goes_last then cycle 1 else tclUNIT ()) + ])) gl else let t, gl = if n = 0 then t, gl else let sigma, si = project gl, sig_it gl in @@ -1001,21 +1006,17 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = | _ -> assert false in loop sigma t [] n in pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); - Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t) gl + Proofview.(V82.of_tactic + (Tacticals.New.tclTHENLIST [ + V82.tactic (Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t)); + (if first_goes_last then cycle 1 else tclUNIT ()) + ])) 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 n, oc = pf_abs_evars_pirrel gl (fst oc, EConstr.to_constr ~abort_on_undefined_evars:false (fst oc) (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 + try applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc) gl with e when CErrors.noncritical e -> raise dependent_apply_error (* We wipe out all the keywords generated by the grammar rules we defined. *) @@ -1408,8 +1409,6 @@ let tclINTRO_ANON ?seed () = | Some seed -> tclINTRO ~id:(Seed seed) ~conclusion:return let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> - let convert_concl_no_check t = - Tactics.convert_concl_no_check t DEFAULTcast in let concl = Goal.concl gl in let sigma = Goal.sigma gl in match EConstr.kind sigma concl with @@ -1540,5 +1539,10 @@ let get g = end +let is_construct_ref sigma c r = + EConstr.isConstruct sigma c && GlobRef.equal (ConstructRef (fst(EConstr.destConstruct sigma c))) r +let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (IndRef (fst(EConstr.destInd sigma c))) r +let is_const_ref sigma c r = + EConstr.isConst sigma c && GlobRef.equal (ConstRef (fst(EConstr.destConst sigma c))) r (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 9662daa7c7..58ce84ecb3 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -312,6 +312,7 @@ val applyn : with_evars:bool -> ?beta:bool -> ?with_shelve:bool -> + ?first_goes_last:bool -> int -> EConstr.t -> v82tac exception NotEnoughProducts @@ -348,7 +349,7 @@ val resolve_typeclasses : (*********************** Wrapped Coq tactics *****************************) -val rewritetac : ssrdir -> EConstr.t -> tactic +val rewritetac : ?under:bool -> ssrdir -> EConstr.t -> tactic type name_hint = (int * EConstr.types array) option ref @@ -482,3 +483,7 @@ module MakeState(S : StateType) : sig val get : Proofview.Goal.t -> S.state end + +val is_ind_ref : Evd.evar_map -> EConstr.t -> Names.GlobRef.t -> bool +val is_construct_ref : Evd.evar_map -> EConstr.t -> Names.GlobRef.t -> bool +val is_const_ref : Evd.evar_map -> EConstr.t -> Names.GlobRef.t -> bool diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 4721e19a8b..5e3e8ce5fb 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -28,6 +28,11 @@ Declare ML Module "ssreflect_plugin". 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. + nonPropType == an interface for non-Prop Types: a nonPropType coerces + to a Type, and only types that do _not_ have sort + Prop are canonical nonPropType instances. This is + useful for applied views (see mid-file comment). + notProp T == the nonPropType instance for type T. 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 @@ -57,8 +62,6 @@ Declare ML Module "ssreflect_plugin". 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. @@ -77,7 +80,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 "<hidden n >" (at level 0, n at level 0, + format "<hidden n >"). Reserved Notation "T (* n *)" (at level 200, format "T (* n *)"). End SsrSyntax. @@ -85,6 +89,39 @@ End SsrSyntax. Export SsrMatchingSyntax. Export SsrSyntax. +(** Save primitive notation that will be overloaded. **) +Local Notation CoqGenericIf c vT vF := (if c then vT else vF) (only parsing). +Local Notation CoqGenericDependentIf c x R vT vF := + (if c as x return R then vT else vF) (only parsing). +Local Notation CoqCast x T := (x : T) (only parsing). + +(** Reserve notation that introduced in this file. **) +Reserved Notation "'if' c 'then' vT 'else' vF" (at level 200, + c, vT, vF at level 200, only parsing). +Reserved Notation "'if' c 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200, only parsing). +Reserved Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200, x ident, only parsing). + +Reserved Notation "x : T" (at level 100, right associativity, + format "'[hv' x '/ ' : T ']'"). +Reserved Notation "T : 'Type'" (at level 100, format "T : 'Type'"). +Reserved Notation "P : 'Prop'" (at level 100, format "P : 'Prop'"). + +Reserved Notation "[ 'the' sT 'of' v 'by' f ]" (at level 0, + format "[ 'the' sT 'of' v 'by' f ]"). +Reserved Notation "[ 'the' sT 'of' v ]" (at level 0, + format "[ 'the' sT 'of' v ]"). +Reserved Notation "{ 'type' 'of' c 'for' s }" (at level 0, + format "{ 'type' 'of' c 'for' s }"). + +Reserved Notation "=^~ r" (at level 100, format "=^~ r"). + +Reserved Notation "[ 'unlockable' 'of' C ]" (at level 0, + format "[ 'unlockable' 'of' C ]"). +Reserved Notation "[ 'unlockable' 'fun' C ]" (at level 0, + format "[ 'unlockable' 'fun' C ]"). + (** To define notations for tactic in intro patterns. When "=> /t" is parsed, "t:%ssripat" is actually interpreted. **) @@ -100,32 +137,28 @@ Delimit Scope ssripat_scope with ssripat. Declare Scope general_if_scope. 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 'then' vT 'else' vF" := + (CoqGenericIf c vT vF) (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 'return' R 'then' vT 'else' vF" := + (CoqGenericDependentIf c c R vT vF) (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. +Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := + (CoqGenericDependentIf c x R vT vF) (only parsing) : general_if_scope. (** Force boolean interpretation of simple if expressions. **) Declare Scope boolean_if_scope. 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 'return' R 'then' vT 'else' vF" := + (if c is true as c in bool return R then vT else vF) : 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 'then' vT 'else' vF" := + (if c%bool is true as _ in bool return _ then vT else vF) : 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. +Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := + (if c%bool is true as x in bool return R then vT else vF) : boolean_if_scope. Open Scope boolean_if_scope. @@ -149,19 +182,15 @@ Open Scope form_scope. 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. +Notation "x : T" := (CoqCast 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. +Notation "T : 'Type'" := (CoqCast T%type Type) (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. +Notation "P : 'Prop'" := (CoqCast P%type Prop) (only parsing) : core_scope. (** Constants for abstract: and #[#: name #]# intro pattern **) Definition abstract_lock := unit. @@ -170,8 +199,10 @@ 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). +Declare Scope ssr_scope. +Notation "<hidden n >" := (abstract _ n _) : ssr_scope. +Notation "T (* n *)" := (abstract T n abstract_key) : ssr_scope. +Open Scope ssr_scope. Register abstract_lock as plugins.ssreflect.abstract_lock. Register abstract_key as plugins.ssreflect.abstract_key. @@ -222,28 +253,27 @@ 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. + (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. +Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*) s s) _)) + (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. + The following are "format only" versions of the above notations. 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 "[ 'the' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) + (only printing) : form_scope. -Notation "[ 'th' 'e' sT 'of' v ]" := (@get _ sT v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v ]") : form_scope. +Notation "[ 'the' sT 'of' v ]" := (@get _ sT v _ _) + (only printing) : 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. +Notation " #[# 'the' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) + (at level 0, format " #[# 'the' sT 'of' v : 'Type' #]#") : form_scope. **) (** @@ -278,8 +308,7 @@ 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. +Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) : type_scope. (** A generic "phantom" type (actually, a unit type with a phantom parameter). @@ -330,7 +359,7 @@ 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. +Notation "=^~ r" := (ssr_converse r) : form_scope. (** Term tagging (user-level). @@ -397,11 +426,11 @@ Ltac ssrdone0 := 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' 'of' C ]" := + (@Unlockable _ _ C (unlock _)) : form_scope. -Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) - (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. +Notation "[ 'unlockable' 'fun' C ]" := + (@Unlockable _ (fun _ => _) C (unlock _)) : form_scope. (** Generic keyed constant locking. **) @@ -418,7 +447,7 @@ Proof. by case: k. Qed. Canonical locked_with_unlockable T k x := @Unlockable T x (locked_with k x) (locked_withE k x). -(** More accurate variant of unlock, and safer alternative to locked_withE. **) +(** More accurate variant of unlock, and safer alternative to locked_withE. **) Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. Proof. exact: unlock. Qed. @@ -500,3 +529,199 @@ Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. Lemma abstract_context T (P : T -> Type) x : (forall Q, Q = P -> Q x) -> P x. Proof. by move=> /(_ P); apply. Qed. + +(*****************************************************************************) +(* Constants for under, to rewrite under binders using "Leibniz eta lemmas". *) + +Module Type UNDER_EQ. +Parameter Under_eq : + forall (R : Type), R -> R -> Prop. +Parameter Under_eq_from_eq : + forall (T : Type) (x y : T), @Under_eq T x y -> x = y. + +(** [Over_eq, over_eq, over_eq_done]: for "by rewrite over_eq" *) +Parameter Over_eq : + forall (R : Type), R -> R -> Prop. +Parameter over_eq : + forall (T : Type) (x : T) (y : T), @Under_eq T x y = @Over_eq T x y. +Parameter over_eq_done : + forall (T : Type) (x : T), @Over_eq T x x. +(* We need both hints below, otherwise the test-suite does not pass *) +Hint Extern 0 (@Over_eq _ _ _) => solve [ apply over_eq_done ] : core. +(* => for [test-suite/ssr/under.v:test_big_patt1] *) +Hint Resolve over_eq_done : core. +(* => for [test-suite/ssr/over.v:test_over_1_1] *) + +(** [under_eq_done]: for Ltac-style over *) +Parameter under_eq_done : + forall (T : Type) (x : T), @Under_eq T x x. +Notation "''Under[' x ]" := (@Under_eq _ x _) + (at level 8, format "''Under[' x ]", only printing). +End UNDER_EQ. + +Module Export Under_eq : UNDER_EQ. +Definition Under_eq := @eq. +Lemma Under_eq_from_eq (T : Type) (x y : T) : + @Under_eq T x y -> x = y. +Proof. by []. Qed. +Definition Over_eq := Under_eq. +Lemma over_eq : + forall (T : Type) (x : T) (y : T), @Under_eq T x y = @Over_eq T x y. +Proof. by []. Qed. +Lemma over_eq_done : + forall (T : Type) (x : T), @Over_eq T x x. +Proof. by []. Qed. +Lemma under_eq_done : + forall (T : Type) (x : T), @Under_eq T x x. +Proof. by []. Qed. +End Under_eq. + +Register Under_eq as plugins.ssreflect.Under_eq. +Register Under_eq_from_eq as plugins.ssreflect.Under_eq_from_eq. + +Module Type UNDER_IFF. +Parameter Under_iff : Prop -> Prop -> Prop. +Parameter Under_iff_from_iff : forall x y : Prop, @Under_iff x y -> x <-> y. + +(** [Over_iff, over_iff, over_iff_done]: for "by rewrite over_iff" *) +Parameter Over_iff : Prop -> Prop -> Prop. +Parameter over_iff : + forall (x : Prop) (y : Prop), @Under_iff x y = @Over_iff x y. +Parameter over_iff_done : + forall (x : Prop), @Over_iff x x. +Hint Extern 0 (@Over_iff _ _) => solve [ apply over_iff_done ] : core. +Hint Resolve over_iff_done : core. + +(** [under_iff_done]: for Ltac-style over *) +Parameter under_iff_done : + forall (x : Prop), @Under_iff x x. +Notation "''Under[' x ]" := (@Under_iff x _) + (at level 8, format "''Under[' x ]", only printing). +End UNDER_IFF. + +Module Export Under_iff : UNDER_IFF. +Definition Under_iff := iff. +Lemma Under_iff_from_iff (x y : Prop) : + @Under_iff x y -> x <-> y. +Proof. by []. Qed. +Definition Over_iff := Under_iff. +Lemma over_iff : + forall (x : Prop) (y : Prop), @Under_iff x y = @Over_iff x y. +Proof. by []. Qed. +Lemma over_iff_done : + forall (x : Prop), @Over_iff x x. +Proof. by []. Qed. +Lemma under_iff_done : + forall (x : Prop), @Under_iff x x. +Proof. by []. Qed. +End Under_iff. + +Register Under_iff as plugins.ssreflect.Under_iff. +Register Under_iff_from_iff as plugins.ssreflect.Under_iff_from_iff. + +Definition over := (over_eq, over_iff). + +Ltac over := + by [ apply: Under_eq.under_eq_done + | apply: Under_iff.under_iff_done + | rewrite over + ]. + +(** An interface for non-Prop types; used to avoid improper instantiation + of polymorphic lemmas with on-demand implicits when they are used as views. + For example: Some_inj {T} : forall x y : T, Some x = Some y -> x = y. + Using move/Some_inj on a goal of the form Some n = Some 0 will fail: + SSReflect will interpret the view as @Some_inj ?T _top_assumption_ + since this is the well-typed application of the view with the minimal + number of inserted evars (taking ?T := Some n = Some 0), and then will + later complain that it cannot erase _top_assumption_ after having + abstracted the viewed assumption. Making x and y maximal implicits + would avoid this and force the intended @Some_inj nat x y _top_assumption_ + interpretation, but is undesireable as it makes it harder to use Some_inj + with the many SSReflect and MathComp lemmas that have an injectivity + premise. Specifying {T : nonPropType} solves this more elegantly, as then + (?T : Type) no longer unifies with (Some n = Some 0), which has sort Prop. + **) + +Module NonPropType. + +(** Implementation notes: + We rely on three interface Structures: + - test_of r, the middle structure, performs the actual check: it has two + canonical instances whose 'condition' projection are maybeProj (?P : Prop) + and tt, and which set r := true and r := false, respectively. Unifying + condition (?t : test_of ?r) with maybeProj T will thus set ?r to true if + T is in Prop as the test_Prop T instance will apply, and otherwise simplify + maybeProp T to tt and use the test_negative instance and set ?r to false. + - call_of c r sets up a call to test_of on condition c with expected result r. + It has a default instance for its 'callee' projection to Type, which + sets c := maybeProj T and r := false whe unifying with a type T. + - type is a telescope on call_of c r, which checks that unifying test_of ?r1 + with c indeed sets ?r1 := r; the type structure bundles the 'test' instance + and its 'result' value along with its call_of c r projection. The default + instance essentially provides eta-expansion for 'type'. This is only + essential for the first 'result' projection to bool; using the instance + for other projection merely avoids spurrious delta expansions that would + spoil the notProp T notation. + In detail, unifying T =~= ?S with ?S : nonPropType, i.e., + (1) T =~= @callee (@condition (result ?S) (test ?S)) (result ?S) (frame ?S) + first uses the default call instance with ?T := T to reduce (1) to + (2a) @condition (result ?S) (test ?S) =~= maybeProp T + (3) result ?S =~= false + (4) frame ?S =~= call T + along with some trivial universe-related checks which are irrelevant here. + Then the unification tries to use the test_Prop instance to reduce (2a) to + (6a) result ?S =~= true + (7a) ?P =~= T with ?P : Prop + (8a) test ?S =~= test_Prop ?P + Now the default 'check' instance with ?result := true resolves (6a) as + (9a) ?S := @check true ?test ?frame + Then (7a) can be solved precisely if T has sort at most (hence exactly) Prop, + and then (8a) is solved by the check instance, yielding ?test := test_Prop T, + and completing the solution of (2a), and _committing_ to it. But now (3) is + inconsistent with (9a), and this makes the entire problem (1) fails. + If on the othe hand T does not have sort Prop then (7a) fails and the + unification resorts to delta expanding (2a), which gives + (2b) @condition (result ?S) (test ?S) =~= tt + which is then reduced, using the test_negative instance, to + (6b) result ?S =~= false + (8b) test ?S =~= test_negative + Both are solved using the check default instance, as in the (2a) branch, giving + (9b) ?S := @check false test_negative ?frame + Then (3) and (4) are similarly soved using check, giving the final assignment + (9) ?S := notProp T + Observe that we _must_ perform the actual test unification on the arguments + of the initial canonical instance, and not on the instance itself as we do + in mathcomp/matrix and mathcomp/vector, because we want the unification to + fail when T has sort Prop. If both the test_of _and_ the result check + unifications were done as part of the structure telescope then the latter + would be a sub-problem of the former, and thus failing the check would merely + make the test_of unification backtrack and delta-expand and we would not get + failure. + **) + +Structure call_of (condition : unit) (result : bool) := Call {callee : Type}. +Definition maybeProp (T : Type) := tt. +Definition call T := Call (maybeProp T) false T. + +Structure test_of (result : bool) := Test {condition :> unit}. +Definition test_Prop (P : Prop) := Test true (maybeProp P). +Definition test_negative := Test false tt. + +Structure type := + Check {result : bool; test : test_of result; frame : call_of test result}. +Definition check result test frame := @Check result test frame. + +Module Exports. +Canonical call. +Canonical test_Prop. +Canonical test_negative. +Canonical check. +Notation nonPropType := type. +Coercion callee : call_of >-> Sortclass. +Coercion frame : type >-> call_of. +Notation notProp T := (@check false test_negative (call T)). +End Exports. + +End NonPropType. +Export NonPropType.Exports. diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 4433f2fce7..ad20113320 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -19,7 +19,6 @@ open Context open Vars open Locus open Printer -open Globnames open Termops open Tacinterp @@ -327,15 +326,15 @@ let rule_id = mk_internal_id "rewrite rule" exception PRtype_error of (Environ.env * Evd.evar_map * Pretype_errors.pretype_error) option -let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = +let id_map_redex _ sigma ~before:_ ~after = sigma, after + +let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) 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 sigma, new_rdx = map_redex env sigma ~before:rdx ~after:new_rdx in + let sigma, p = (* The resulting goal *) + Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in let pred = EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdx_ty pred in let elim, gl = let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in @@ -355,9 +354,10 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = | Pretype_errors.PretypeError (env, sigma, te) -> raise (PRtype_error (Some (env, sigma, te))) | e when CErrors.noncritical e -> raise (PRtype_error None) in - ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr_env env sigma proof_ty)); + ppdebug(lazy Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); + ppdebug(lazy Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); try refine_with - ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl + ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (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 @@ -381,11 +381,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = (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 && GlobRef.equal (ConstructRef (fst(EConstr.destConstruct sigma c))) r -let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (IndRef (fst(EConstr.destInd sigma c))) r - -let rwcltac cl rdx dir sr gl = +let rwcltac ?under ?map_redex cl rdx dir sr gl = let sr = let sigma, r = sr in let sigma = resolve_typeclasses ~where:r ~fail:false (pf_env gl) sigma in @@ -403,14 +399,14 @@ let rwcltac cl rdx dir sr gl = 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 -> + | AtomicType(e, a) when Ssrcommon.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 + pirrel_rewrite ?under ?map_redex cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl | _ -> let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) 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 + Proofview.V82.of_tactic (convert_concl cl'), rewritetac ?under dir r', gl else let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in let r3, _, r3t = @@ -421,7 +417,7 @@ let rwcltac cl rdx dir sr gl = let cl'' = EConstr.mkNamedProd (make_annot pattern_id Sorts.Relevant) 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 + let rwtacs = [rewritetac ?under 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' _ = @@ -439,7 +435,6 @@ let rwcltac cl rdx dir sr gl = in tclTHEN cvtac' rwtac gl - [@@@ocaml.warning "-3"] let lz_coq_prod = let prod = lazy (Coqlib.build_prod ()) in fun () -> Lazy.force prod @@ -547,7 +542,7 @@ let rwprocess_rule dir rule gl = in r_sigma, rules -let rwrxtac occ rdx_pat dir rule gl = +let rwrxtac ?under ?map_redex 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 = @@ -585,7 +580,7 @@ let rwrxtac occ rdx_pat dir rule gl = 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 + rwcltac ?under ?map_redex (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl ;; let ssrinstancesofrule ist dir arg gl = @@ -614,7 +609,7 @@ let ssrinstancesofrule ist dir arg 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 rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = let fail = ref false in let interp_rpattern gl gc = try interp_rpattern gl gc @@ -628,7 +623,7 @@ let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = (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 + | RWeq -> rwrxtac ?under ?map_redex 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 @@ -638,8 +633,8 @@ let rwargtac ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = (** The "rewrite" tactic *) -let ssrrewritetac ist rwargs = - tclTHENLIST (List.map (rwargtac ist) rwargs) +let ssrrewritetac ?under ?map_redex ist rwargs = + tclTHENLIST (List.map (rwargtac ?under ?map_redex ist) rwargs) (** The "unlock" tactic *) @@ -660,4 +655,3 @@ let unlocktac ist args gl = (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); Proofview.V82.of_tactic (Ssrelim.casetac key (fun ?seed:_ k -> k)) ] in tclTHENLIST (List.map utac args @ ktacs) gl - diff --git a/plugins/ssr/ssrequality.mli b/plugins/ssr/ssrequality.mli index bbcd6b900a..601968d511 100644 --- a/plugins/ssr/ssrequality.mli +++ b/plugins/ssr/ssrequality.mli @@ -48,13 +48,15 @@ val ssrinstancesofrule : Ssrast.ssrterm -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma +(* map_redex (by default the identity on after) is called on the + * redex (before) and its replacement (after). It is used to + * "rename" binders by the under tactic *) val ssrrewritetac : + ?under:bool -> + ?map_redex:(Environ.env -> Evd.evar_map -> + before:EConstr.t -> after:EConstr.t -> Evd.evar_map * EConstr.t) -> Ltac_plugin.Tacinterp.interp_sign -> - ((Ssrast.ssrdir * (int * Ssrast.ssrmmod)) * - (((Ssrast.ssrhyps option * Ssrmatching.occ) * - Ssrmatching.rpattern option) * - (ssrwkind * Ssrast.ssrterm))) - list -> Tacmach.tactic + ssrrwarg list -> Tacmach.tactic val ipat_rewrite : ssrocc -> ssrdir -> EConstr.t -> Tacmach.tactic diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index b51ffada0c..46af775296 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -219,25 +219,113 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Declare Scope fun_scope. -Delimit Scope fun_scope with FUN. -Open Scope fun_scope. +(** Parsing / printing declarations. *) +Reserved Notation "p .1" (at level 2, left associativity, format "p .1"). +Reserved Notation "p .2" (at level 2, left associativity, format "p .2"). +Reserved Notation "f ^~ y" (at level 10, y at level 8, no associativity, + format "f ^~ y"). +Reserved Notation "@^~ x" (at level 10, x at level 8, no associativity, + format "@^~ x"). +Reserved Notation "[ 'eta' f ]" (at level 0, format "[ 'eta' f ]"). +Reserved Notation "'fun' => E" (at level 200, format "'fun' => E"). + +Reserved Notation "[ 'fun' : T => E ]" (at level 0, + format "'[hv' [ 'fun' : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x => E ]" (at level 0, + x ident, format "'[hv' [ 'fun' x => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x : T => E ]" (at level 0, + x ident, format "'[hv' [ 'fun' x : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x y => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x y => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x y : T => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x y : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' ( x : T ) y => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' ( x : T ) y => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x ( y : T ) => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x ( y : T ) => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" (at level 0, + x ident, y ident, format "[ 'fun' ( x : T ) ( y : U ) => E ]" ). + +Reserved Notation "f =1 g" (at level 70, no associativity). +Reserved Notation "f =1 g :> A" (at level 70, g at next level, A at level 90). +Reserved Notation "f =2 g" (at level 70, no associativity). +Reserved Notation "f =2 g :> A" (at level 70, g at next level, A at level 90). +Reserved Notation "f \o g" (at level 50, format "f \o '/ ' g"). +Reserved Notation "f \; g" (at level 60, right associativity, + format "f \; '/ ' g"). + +Reserved Notation "{ 'morph' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'morph' f : x / a >-> r }"). +Reserved Notation "{ 'morph' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'morph' f : x / a }"). +Reserved Notation "{ 'morph' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'morph' f : x y / a >-> r }"). +Reserved Notation "{ 'morph' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'morph' f : x y / a }"). +Reserved Notation "{ 'homo' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'homo' f : x / a >-> r }"). +Reserved Notation "{ 'homo' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'homo' f : x / a }"). +Reserved Notation "{ 'homo' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y / a >-> r }"). +Reserved Notation "{ 'homo' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y / a }"). +Reserved Notation "{ 'homo' f : x y /~ a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y /~ a }"). +Reserved Notation "{ 'mono' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'mono' f : x / a >-> r }"). +Reserved Notation "{ 'mono' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'mono' f : x / a }"). +Reserved Notation "{ 'mono' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y / a >-> r }"). +Reserved Notation "{ 'mono' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y / a }"). +Reserved Notation "{ 'mono' f : x y /~ a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y /~ a }"). + +Reserved Notation "@ 'id' T" (at level 10, T at level 8, format "@ 'id' T"). +Reserved Notation "@ 'sval'" (at level 10, format "@ 'sval'"). -(** 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. +(** + 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' a ]" (at level 0, + format "[ 'rec' a ]"). +Reserved Notation "[ 'rec' a , b ]" (at level 0, + format "[ 'rec' a , b ]"). +Reserved Notation "[ 'rec' a , b , c ]" (at level 0, + format "[ 'rec' a , b , c ]"). +Reserved Notation "[ 'rec' a , b , c , d ]" (at level 0, + format "[ 'rec' a , b , c , d ]"). +Reserved Notation "[ 'rec' a , b , c , d , e ]" (at level 0, + format "[ 'rec' a , b , c , d , e ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h , i ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i , j ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h , i , j ]"). Declare Scope pair_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. +Notation "p .1" := (fst p) : pair_scope. +Notation "p .2" := (snd p) : pair_scope. Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). @@ -291,41 +379,13 @@ 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. **) +Declare Scope fun_scope. +Delimit Scope fun_scope with FUN. +Open Scope fun_scope. -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 ]"). +(** Notations for argument transpose **) +Notation "f ^~ y" := (fun x => f x y) : fun_scope. +Notation "@^~ x" := (fun f => f x) : fun_scope. (** Definitions and notation for explicit functions with simplification, @@ -344,33 +404,19 @@ 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' : T => E ]" := (SimplFun (fun _ : T => E)) : fun_scope. +Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) : fun_scope. +Notation "[ 'fun' x y => E ]" := (fun x => [fun y => 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. - + (only parsing) : 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. - + (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. - + (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. + (only parsing) : fun_scope. +Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" := (fun x : T => [fun y : U => E]) + (only parsing) : fun_scope. (** For delta functions in eqtype.v. **) Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. @@ -402,51 +448,38 @@ Typeclasses Opaque eqrel. Hint Resolve frefl rrefl : core. -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. +Notation "f1 =1 f2" := (eqfun f1 f2) : fun_scope. +Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) : fun_scope. +Notation "f1 =2 f2" := (eqrel f1 f2) : fun_scope. +Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) : 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 comp (f : B -> A) (g : C -> B) x := f (g x). +Definition catcomp g f := comp f g. 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. +Proof. by move=> eq_ff' eq_gg' x; rewrite /comp 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. +Arguments comp {A B C} f g x /. +Arguments catcomp {A B C} g f x /. +Notation "f1 \o f2" := (comp f1 f2) : fun_scope. +Notation "f1 \; f2" := (catcomp f1 f2) : fun_scope. -Notation "[ 'eta' f ]" := (fun x => f x) - (at level 0, format "[ 'eta' f ]") : fun_scope. +Notation "[ 'eta' f ]" := (fun x => f x) : fun_scope. -Notation "'fun' => E" := (fun _ => E) (at level 200, only parsing) : fun_scope. +Notation "'fun' => E" := (fun _ => E) : 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. +Notation "@ 'id' T" := (fun x : T => x) (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 idfun T x : T := x. +Arguments idfun {T} x /. Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. @@ -542,74 +575,33 @@ Definition monomorphism_2 (aR rR : _ -> _ -> sT) := 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. - + (morphism_1 f (fun x => a) (fun x => 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. - + (morphism_1 f (fun x => a) (fun 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. - + (morphism_2 f (fun x y => a) (fun x y => 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. - + (morphism_2 f (fun x y => a) (fun 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. - + (homomorphism_1 f (fun x => a) (fun x => 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. - + (homomorphism_1 f (fun x => a) (fun 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. - + (homomorphism_2 f (fun x y => a) (fun x y => 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. - + (homomorphism_2 f (fun x y => a) (fun 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. - + (homomorphism_2 f (fun y x => a) (fun 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. - + (monomorphism_1 f (fun x => a) (fun x => 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. - + (monomorphism_1 f (fun x => a) (fun 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. - + (monomorphism_2 f (fun x y => a) (fun x y => 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. - + (monomorphism_2 f (fun x y => a) (fun 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. + (monomorphism_2 f (fun y x => a) (fun x y => a)) : type_scope. (** In an intuitionistic setting, we have two degrees of injectivity. The @@ -620,9 +612,6 @@ Notation "{ 'mono' f : x y /~ a }" := 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. @@ -650,10 +639,8 @@ 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. +Lemma Some_inj {T : nonPropType} : injective (@Some T). +Proof. by move=> x y []. Qed. (** cancellation lemmas for dependent type casts. **) Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 3cadc92bcc..01d71aa96a 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -319,3 +319,172 @@ let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = 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))] + +open Proofview.Notations + +let is_app_evar sigma t = + match EConstr.kind sigma t with + | Constr.Evar _ -> true + | Constr.App(t,_) -> + begin match EConstr.kind sigma t with + | Constr.Evar _ -> true + | _ -> false end + | _ -> false + +let rec ncons n e = match n with + | 0 -> [] + | n when n > 0 -> e :: ncons (n - 1) e + | _ -> failwith "ncons" + +let intro_lock ipats = + let hnf' = Proofview.numgoals >>= fun ng -> + Proofview.tclDISPATCH + (ncons (ng - 1) ssrsmovetac @ [Proofview.tclUNIT ()]) in + let rec lock_eq () : unit Proofview.tactic = Proofview.Goal.enter begin fun _ -> + Proofview.tclORELSE + (Ssripats.tclIPAT [Ssripats.IOpTemporay; Ssripats.IOpEqGen (lock_eq ())]) + (fun _exn -> Proofview.Goal.enter begin fun gl -> + let c = Proofview.Goal.concl gl in + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + match EConstr.kind_of_type sigma c with + | Term.AtomicType(hd, args) when + Ssrcommon.is_const_ref sigma hd (Coqlib.lib_ref "core.iff.type") && + Array.length args = 2 && is_app_evar sigma args.(1) -> + Tactics.New.refine ~typecheck:true (fun sigma -> + let sigma, under_iff = + Ssrcommon.mkSsrConst "Under_iff" env sigma in + let sigma, under_from_iff = + Ssrcommon.mkSsrConst "Under_iff_from_iff" env sigma in + let ty = EConstr.mkApp (under_iff,args) in + let sigma, t = Evarutil.new_evar env sigma ty in + sigma, EConstr.mkApp(under_from_iff,Array.append args [|t|])) + | _ -> + let t = Reductionops.whd_all env sigma c in + match EConstr.kind_of_type sigma t with + | Term.AtomicType(hd, args) when + Ssrcommon.is_ind_ref sigma hd (Coqlib.lib_ref "core.eq.type") && + Array.length args = 3 && is_app_evar sigma args.(2) -> + Tactics.New.refine ~typecheck:true (fun sigma -> + let sigma, under = + Ssrcommon.mkSsrConst "Under_eq" env sigma in + let sigma, under_from_eq = + Ssrcommon.mkSsrConst "Under_eq_from_eq" env sigma in + let ty = EConstr.mkApp (under,args) in + let sigma, t = Evarutil.new_evar env sigma ty in + sigma, EConstr.mkApp(under_from_eq,Array.append args [|t|])) + | _ -> + ppdebug(lazy Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); + + Proofview.tclUNIT () + end) + end + in + hnf' <*> Ssripats.tclIPATssr ipats <*> lock_eq () + +let pretty_rename evar_map term varnames = + let rec aux term vars = + try + match vars with + | [] -> term + | Names.Name.Anonymous :: varnames -> + let name, types, body = EConstr.destLambda evar_map term in + let res = aux body varnames in + EConstr.mkLambda (name, types, res) + | Names.Name.Name _ as name :: varnames -> + let { Context.binder_relevance = r }, types, body = + EConstr.destLambda evar_map term in + let res = aux body varnames in + EConstr.mkLambda (Context.make_annot name r, types, res) + with DestKO -> term + in + aux term varnames + +let overtac = Proofview.V82.tactic (ssr_n_tac "over" ~-1) + +let check_numgoals ?(minus = 0) nh = + Proofview.numgoals >>= fun ng -> + if nh <> ng then + let errmsg = + str"Incorrect number of tactics" ++ spc() ++ + str"(expected "++int (ng - minus)++str(String.plural ng " tactic") ++ + str", was given "++ int (nh - minus)++str")." + in + CErrors.user_err errmsg + else + Proofview.tclUNIT () + +let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = + + (* total number of implied hints *) + let nh = List.length (snd hint) + (if hint = nullhint then 2 else 1) in + + let varnames = + let rec aux acc = function + | IPatId id :: rest -> aux (Names.Name.Name id :: acc) rest + | IPatClear _ :: rest -> aux acc rest + | IPatSimpl _ :: rest -> aux acc rest + | IPatAnon (One _ | Drop) :: rest -> + aux (Names.Name.Anonymous :: acc) rest + | _ -> List.rev acc in + aux [] @@ match ipats with + | None -> [] + | Some (IPatCase(Regular (l :: _)) :: _) -> l + | Some l -> l in + + (* If we find a "=> [|]" we add 1 | to get "=> [||]" for the extra + * goal (the one that is left once we run over) *) + let ipats = + match ipats with + | None -> [IPatNoop] + | Some l when pad_intro -> (* typically, ipats = Some [IPatAnon All] *) + let new_l = ncons (nh - 1) l in + [IPatCase(Regular (new_l @ [[]]))] + | Some (IPatCase(Regular []) :: _ as ipats) -> ipats + (* Erik: is the previous line correct/useful? *) + | Some (IPatCase(Regular l) :: rest) -> IPatCase(Regular(l @ [[]])) :: rest + | Some (IPatCase(Block _) :: _ as l) -> l + | Some l -> [IPatCase(Regular [l;[]])] in + + let map_redex env evar_map ~before:_ ~after:t = + ppdebug(lazy Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); + + let evar_map, ty = Typing.type_of env evar_map t in + let new_t = (* pretty-rename the bound variables *) + try begin match EConstr.destApp evar_map t with (f, ar) -> + let lam = Array.last ar in + ppdebug(lazy Pp.(str"under: mapping:" ++ + pr_econstr_env env evar_map lam)); + let new_lam = pretty_rename evar_map lam varnames in + let new_ar, len1 = Array.copy ar, pred (Array.length ar) in + new_ar.(len1) <- new_lam; + EConstr.mkApp (f, new_ar) + end with + | DestKO -> + ppdebug(lazy Pp.(str"under: cannot pretty-rename bound variables with destApp")); + t + in + ppdebug(lazy Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); + evar_map, new_t + in + let undertacs = + if hint = nohint then + Proofview.tclUNIT () + else + let betaiota = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in + (* Usefulness of check_numgoals: tclDISPATCH would be enough, + except for the error message w.r.t. the number of + provided/expected tactics, as the last one is implied *) + check_numgoals ~minus:1 nh <*> + Proofview.tclDISPATCH + ((List.map (function None -> overtac + | Some e -> ssrevaltac ist e <*> + overtac) + (if hint = nullhint then [None] else snd hint)) + @ [betaiota]) + in + let rew = + Proofview.V82.tactic + (Ssrequality.ssrrewritetac ~under:true ~map_redex ist [rule]) + in + rew <*> intro_lock ipats <*> undertacs diff --git a/plugins/ssr/ssrfwd.mli b/plugins/ssr/ssrfwd.mli index 35e89dbcea..6dd01ca6fc 100644 --- a/plugins/ssr/ssrfwd.mli +++ b/plugins/ssr/ssrfwd.mli @@ -57,3 +57,16 @@ val sufftac : (bool * Tacinterp.Value.t option list)) -> Tacmach.tactic +(* pad_intro (by default false) indicates whether the intro-pattern + "=> i..." must be turned into "=> [i...|i...|i...|]" (n+1 branches, + assuming there are n provided tactics in the ssrhint argument + "do [...|...|...]"; it is useful when the intro-pattern is "=> *"). + Otherwise, "=> i..." is turned into "=> [i...|]". *) +val undertac : + ?pad_intro:bool -> + Ltac_plugin.Tacinterp.interp_sign -> + Ssrast.ssripats option -> Ssrequality.ssrrwarg -> + Ltac_plugin.Tacinterp.Value.t Ssrast.ssrhint -> unit Proofview.tactic + +val overtac : + unit Proofview.tactic diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index f44962f213..27a558611e 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -86,6 +86,15 @@ GRAMMAR EXTEND Gram ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> { tac } ]]; END +(* Copy of ssrtacarg with LEVEL "3", useful for: "under ... do ..." *) +ARGUMENT EXTEND ssrtac3arg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } +| [ "YouShouldNotTypeThis" ] -> { CErrors.anomaly (Pp.str "Grammar placeholder match") } +END +GRAMMAR EXTEND Gram + GLOBAL: ssrtac3arg; + ssrtac3arg: [[ tac = tactic_expr LEVEL "3" -> { tac } ]]; +END + { (* Lexically closed tactic for tacticals. *) @@ -741,15 +750,33 @@ let pushIPatNoop = function | pats :: orpat -> (IPatNoop :: pats) :: orpat | [] -> [] +let test_ident_no_do strm = + match Util.stream_nth 0 strm with + | Tok.IDENT s when s <> "do" -> () + | _ -> raise Stream.Failure + +let test_ident_no_do = + Pcoq.Entry.of_parser "test_ident_no_do" test_ident_no_do + } +ARGUMENT EXTEND ident_no_do PRINTED BY { fun _ _ _ -> Names.Id.print } +| [ "YouShouldNotTypeThis" ident(id) ] -> { id } +END + + +GRAMMAR EXTEND Gram + GLOBAL: ident_no_do; + ident_no_do: [ [ test_ident_no_do; id = IDENT -> { Id.of_string id } ] ]; +END + ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } INTERPRETED BY { interp_ipats } GLOBALIZED BY { intern_ipats } | [ "_" ] -> { [IPatAnon Drop] } | [ "*" ] -> { [IPatAnon All] } | [ ">" ] -> { [IPatFastNondep] } - | [ ident(id) ] -> { [IPatId id] } + | [ ident_no_do(id) ] -> { [IPatId id] } | [ "?" ] -> { [IPatAnon (One None)] } | [ "+" ] -> { [IPatAnon Temporary] } | [ "++" ] -> { [IPatAnon Temporary; IPatAnon Temporary] } @@ -1047,6 +1074,13 @@ ARGUMENT EXTEND ssrhintarg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintar | [ ssrtacarg(arg) ] -> { mk_hint arg } END +(* Copy of ssrhintarg with LEVEL "3", useful for: "under ... do ..." *) +ARGUMENT EXTEND ssrhint3arg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintarg env sigma } +| [ "[" "]" ] -> { nullhint } +| [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } +| [ ssrtac3arg(arg) ] -> { mk_hint arg } +END + ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY { pr_ssrhintarg env sigma } | [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } END @@ -2652,6 +2686,34 @@ END { +let check_under_arg ((_dir,mult),((_occ,_rpattern),_rule)) = + if mult <> nomult then + CErrors.user_err Pp.(str"under does not support multipliers") + +} + + +TACTIC EXTEND under + | [ "under" ssrrwarg(arg) ] -> { + check_under_arg arg; + Ssrfwd.undertac ist None arg nohint + } + | [ "under" ssrrwarg(arg) ssrintros_ne(ipats) ] -> { + check_under_arg arg; + Ssrfwd.undertac ist (Some ipats) arg nohint + } + | [ "under" ssrrwarg(arg) ssrintros_ne(ipats) "do" ssrhint3arg(h) ] -> { + check_under_arg arg; + Ssrfwd.undertac ist (Some ipats) arg h + } + | [ "under" ssrrwarg(arg) "do" ssrhint3arg(h) ] -> { (* implicit "=> [*|*]" *) + check_under_arg arg; + Ssrfwd.undertac ~pad_intro:true ist (Some [IPatAnon All]) arg h + } +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 *) diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index bbe7bde78b..17e4114958 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -110,7 +110,7 @@ let endclausestac id_map clseq gl_id cl0 gl = | _ -> 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 + (Tactics.convert_hyp ~check:false (NamedDecl.map_constr unmark hyp)) in let utacs = List.map utac (pf_hyps gl) in let ugtac gl' = Proofview.V82.of_tactic diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index bf7f082192..08f028465b 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -465,7 +465,7 @@ let interp_modloc mr = (* 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 + let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in Feedback.msg_info (hov 2 pr_res ++ fnl ()) } diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index baa4ae0306..0f0f3953da 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -16,18 +16,17 @@ open Notation open Numeral open Pp open Names -open Ltac_plugin open Stdarg open Pcoq.Prim -let pr_numnot_option _ _ _ = function +let pr_numnot_option = function | Nop -> mt () | Warning n -> str "(warning after " ++ str n ++ str ")" | Abstract n -> str "(abstract after " ++ str n ++ str ")" } -ARGUMENT EXTEND numnotoption +VERNAC ARGUMENT EXTEND numnotoption PRINTED BY { pr_numnot_option } | [ ] -> { Nop } | [ "(" "warning" "after" bigint(waft) ")" ] -> { Warning waft } diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/plugin_base.dune index aac46338ea..7a23581768 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/plugin_base.dune @@ -3,7 +3,7 @@ (public_name coq.plugins.numeral_notation) (synopsis "Coq numeral notation plugin") (modules g_numeral numeral) - (libraries coq.plugins.ltac)) + (libraries coq.vernac)) (library (name string_notation_plugin) diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml index fefc15dfb2..9f2397ec38 100644 --- a/pretyping/inferCumulativity.ml +++ b/pretyping/inferCumulativity.ml @@ -12,41 +12,44 @@ open Reduction open Declarations open Constr open Univ +open Variance open Util +type inferred = IrrelevantI | CovariantI + (** Throughout this module we modify a map [variances] from local - universes to [Variance.t]. It starts as a trivial mapping to - [Irrelevant] and every time we encounter a local universe we - restrict it accordingly. *) + universes to [inferred]. It starts as a trivial mapping to + [Irrelevant] and every time we encounter a local universe we + restrict it accordingly. + [Invariant] universes are removed from the map. +*) +exception TrivialVariance + +let maybe_trivial variances = + if LMap.is_empty variances then raise TrivialVariance + else variances let infer_level_eq u variances = - if LMap.mem u variances - then LMap.set u Variance.Invariant variances - else variances + maybe_trivial (LMap.remove u variances) let infer_level_leq u variances = - match LMap.find u variances with - | exception Not_found -> variances - | varu -> LMap.set u (Variance.sup varu Variance.Covariant) variances + (* can only set Irrelevant -> Covariant so nontrivial *) + LMap.update u (function + | None -> None + | Some CovariantI as x -> x + | Some IrrelevantI -> Some CovariantI) + variances let infer_generic_instance_eq variances u = Array.fold_left (fun variances u -> infer_level_eq u variances) variances (Instance.to_array u) -let variance_pb cv_pb var = - let open Variance in - match cv_pb, var with - | _, Irrelevant -> Irrelevant - | _, Invariant -> Invariant - | CONV, Covariant -> Invariant - | CUMUL, Covariant -> Covariant - let infer_cumulative_ind_instance cv_pb mind_variance variances u = Array.fold_left2 (fun variances varu u -> - match LMap.find u variances with - | exception Not_found -> variances - | varu' -> - LMap.set u (Variance.sup varu' (variance_pb cv_pb varu)) variances) + match cv_pb, varu with + | _, Irrelevant -> variances + | _, Invariant | CONV, Covariant -> infer_level_eq u variances + | CUMUL, Covariant -> infer_level_leq u variances) variances mind_variance (Instance.to_array u) let infer_inductive_instance cv_pb env variances ind nargs u = @@ -182,6 +185,32 @@ let infer_arity_constructor is_arity env variances arcn = i is irrelevant, j is invariant. *) if not is_arity then infer_term CUMUL env variances codom else variances +open Entries + +let infer_inductive_core env params entries uctx = + let uarray = Instance.to_array @@ UContext.instance uctx in + if Array.is_empty uarray then raise TrivialVariance; + let env = Environ.push_context uctx env in + let variances = + Array.fold_left (fun variances u -> LMap.add u IrrelevantI variances) + LMap.empty uarray + in + let env, params = Typeops.check_context env params in + let variances = List.fold_left (fun variances entry -> + let variances = infer_arity_constructor true + env variances entry.mind_entry_arity + in + List.fold_left (infer_arity_constructor false env) + variances entry.mind_entry_lc) + variances + entries + in + Array.map (fun u -> match LMap.find u variances with + | exception Not_found -> Invariant + | IrrelevantI -> Irrelevant + | CovariantI -> Covariant) + uarray + let infer_inductive env mie = let open Entries in let { mind_entry_params = params; @@ -195,27 +224,11 @@ let infer_inductive env mie = | Monomorphic_entry _ -> assert false | Polymorphic_entry (_,uctx) -> uctx in - let uarray = Instance.to_array @@ UContext.instance uctx in - let env = Environ.push_context uctx env in - let variances = - Array.fold_left (fun variances u -> LMap.add u Variance.Irrelevant variances) - LMap.empty uarray - in - let env, params = Typeops.check_context env params in - let variances = List.fold_left (fun variances entry -> - let variances = infer_arity_constructor true - env variances entry.mind_entry_arity - in - List.fold_left (infer_arity_constructor false env) - variances entry.mind_entry_lc) - variances - entries - in - let variances = Array.map (fun u -> LMap.find u variances) uarray in - Some variances + try Some (infer_inductive_core env params entries uctx) + with TrivialVariance -> Some (Array.make (UContext.size uctx) Invariant) in { mie with mind_entry_variance = variances } let dummy_variance = let open Entries in function | Monomorphic_entry _ -> assert false - | Polymorphic_entry (_,uctx) -> Array.make (UContext.size uctx) Variance.Irrelevant + | Polymorphic_entry (_,uctx) -> Array.make (UContext.size uctx) Irrelevant diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index e694502231..0fcd6a9e9d 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -415,7 +415,7 @@ and nf_predicate env sigma ind mip params v pT = and nf_evar env sigma evk args = let evi = try Evd.find sigma evk with Not_found -> assert false in let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in - let ty = EConstr.Unsafe.to_constr @@ Evd.evar_concl evi in + let ty = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then begin assert (Int.equal (Array.length args) 0); mkEvar (evk, [||]), ty diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 48d981082c..f2b8671a48 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -380,7 +380,7 @@ let orelse_name name name' = match name with | Anonymous -> name' | _ -> name -let pretype_id pretype k0 loc env sigma id = +let pretype_id pretype loc env sigma id = (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context !!env) in @@ -475,10 +475,10 @@ let mark_obligation_evar sigma k evc = (* in environment [env], with existential variables [sigma] and *) (* the type constraint tycon *) -let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = +let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in - let pretype_type = pretype_type ~program_mode ~poly k0 resolve_tc in - let pretype = pretype ~program_mode ~poly k0 resolve_tc in + let pretype_type = pretype_type ~program_mode ~poly resolve_tc in + let pretype = pretype ~program_mode ~poly resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in match DAst.get t with @@ -487,7 +487,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon | GVar id -> - let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) k0 loc env sigma id in + let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) loc env sigma id in inh_conv_coerce_to_tycon ?loc env sigma t_id tycon | GEvar (id, inst) -> @@ -498,7 +498,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env try Evd.evar_key id sigma with Not_found -> error_evar_not_found ?loc !!env sigma id in let hyps = evar_filtered_context (Evd.find sigma evk) in - let sigma, args = pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk inst in + let sigma, args = pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in let j = Retyping.get_judgment_of !!env sigma c in inh_conv_coerce_to_tycon ?loc env sigma j tycon @@ -984,7 +984,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env in inh_conv_coerce_to_tycon ?loc env sigma resj tycon -and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk update = +and pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk update = let f decl (subst,update,sigma) = let id = NamedDecl.get_id decl in let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in @@ -1016,7 +1016,7 @@ and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk up let sigma, c, update = try let c = List.assoc id update in - let sigma, c = pretype ~program_mode ~poly k0 resolve_tc (mk_tycon t) env sigma c in + let sigma, c = pretype ~program_mode ~poly resolve_tc (mk_tycon t) env sigma c in check_body sigma id (Some c.uj_val); sigma, c.uj_val, List.remove_assoc id update with Not_found -> @@ -1041,7 +1041,7 @@ and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk up sigma, Array.map_of_list snd subst (* [pretype_type valcon env sigma c] coerces [c] into a type *) -and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with +and pretype_type ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with @@ -1068,7 +1068,7 @@ and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigm let sigma = if program_mode then mark_obligation_evar sigma knd utj_val else sigma in sigma, { utj_val; utj_type = s}) | _ -> - let sigma, j = pretype ~program_mode ~poly k0 resolve_tc empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in match valcon with @@ -1088,16 +1088,15 @@ let ise_pretype_gen flags env sigma lvar kind c = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let env = GlobEnv.make ~hypnaming env sigma lvar in - let k0 = Context.Rel.length (rel_context !!env) in let sigma', c', c'_ty = match kind with | WithoutTypeConstraint -> - let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> - let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in + let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses (mk_tycon exptyp) env sigma c in sigma, j.uj_val, j.uj_type | IsType -> - let sigma, tj = pretype_type ~program_mode ~poly k0 flags.use_typeclasses empty_valcon env sigma c in + let sigma, tj = pretype_type ~program_mode ~poly flags.use_typeclasses empty_valcon env sigma c in sigma, tj.utj_val, mkSort tj.utj_type in process_inference_flags flags !!env sigma (sigma',c',c'_ty) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 62e9e477f7..1fe6545ce4 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -202,7 +202,7 @@ and nf_univ_args ~nb_univs mk env sigma stk = and nf_evar env sigma evk stk = let evi = try Evd.find sigma evk with Not_found -> assert false in let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in - let concl = EConstr.Unsafe.to_constr @@ Evd.evar_concl evi in + let concl = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then nf_stk env sigma (mkEvar (evk, [||])) concl stk else match stk with diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index ef4a74b273..4f36354f79 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -73,6 +73,7 @@ let solve ?with_end_tac gi info_lvl tac pr = | None -> tac | Some _ -> Proofview.Trace.record_info_trace tac in + let nosuchgoal = Proofview.tclZERO (Proof_bullet.SuggestNoSuchGoals (1,pr)) in let tac = let open Goal_select in match gi with | SelectAlreadyFocused -> let open Proofview.Notations in @@ -86,9 +87,9 @@ let solve ?with_end_tac gi info_lvl tac pr = in Proofview.tclZERO e - | SelectNth i -> Proofview.tclFOCUS i i tac - | SelectList l -> Proofview.tclFOCUSLIST l tac - | SelectId id -> Proofview.tclFOCUSID id tac + | SelectNth i -> Proofview.tclFOCUS ~nosuchgoal i i tac + | SelectList l -> Proofview.tclFOCUSLIST ~nosuchgoal l tac + | SelectId id -> Proofview.tclFOCUSID ~nosuchgoal id tac | SelectAll -> tac in let tac = diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index 2ca4f0afb4..640feb2f5b 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -197,3 +197,15 @@ let put p b = let suggest p = (!current_behavior).suggest p + +(* Better printing for bullet exceptions *) +exception SuggestNoSuchGoals of int * Proof.t + +let _ = CErrors.register_handler begin function + | SuggestNoSuchGoals(n,proof) -> + let suffix = suggest proof in + CErrors.user_err + Pp.(str "No such " ++ str (CString.plural n "goal") ++ str "." ++ + pr_non_empty_arg (fun x -> x) suffix) + | _ -> raise CErrors.Unhandled + end diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index 0fcc647a6f..6fdf818497 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -44,3 +44,5 @@ val register_behavior : behavior -> unit *) val put : Proof.t -> t -> Proof.t val suggest : Proof.t -> Pp.t + +exception SuggestNoSuchGoals of int * Proof.t diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 86d3d9601e..08b98d702a 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -348,18 +348,3 @@ let update_global_env (pf : t) = let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac p in (p, ()))) pf in res - -(* XXX: This hook is used to provide a better error w.r.t. bullets, - however the proof engine [surprise!] knows nothing about bullets so - here we have a layering violation. The right fix is to modify the - entry point to handle this and reraise the exception with the - needed information. *) -(* let _ = - * let hook n = - * try - * let prf = give_me_the_proof pf in - * (Proof_bullet.suggest prf) - * with NoCurrentProof -> mt () - * in - * Proofview.set_nosuchgoals_hook hook *) - diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index d13763cdec..2b32838964 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -99,7 +99,7 @@ let dynamic_bullet doc { dynamic_switch = id; carry_on_data = b } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (Vernacexpr.VernacExpr([], Vernacexpr.VernacBullet (to_bullet_val b))) + recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr([], Vernacexpr.VernacBullet (to_bullet_val b))) } | `Not -> `Leaks @@ -128,7 +128,7 @@ let dynamic_curly_brace doc { dynamic_switch = id } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (Vernacexpr.VernacExpr ([], Vernacexpr.VernacEndSubproof)) + recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr ([], Vernacexpr.VernacEndSubproof)) } | `Not -> `Leaks diff --git a/stm/stm.ml b/stm/stm.ml index e1ab45163a..3eb6d03529 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -27,6 +27,8 @@ open Feedback open Vernacexpr open Vernacextend +module PG_compat = Vernacstate.Proof_global [@@ocaml.warning "-3"] + let is_vtkeep = function VtKeep _ -> true | _ -> false let get_vtkeep = function VtKeep x -> x | _ -> assert false @@ -119,7 +121,6 @@ let async_proofs_workers_extra_env = ref [||] type aast = { verbose : bool; - loc : Loc.t option; indentation : int; strlen : int; mutable expr : vernac_control; (* mutable: Proof using hinted by aux file *) @@ -139,8 +140,8 @@ let may_pierce_opaque = function | _ -> false let update_global_env () = - if Vernacstate.Proof_global.there_are_pending_proofs () then - Vernacstate.Proof_global.update_global_env () + if PG_compat.there_are_pending_proofs () then + PG_compat.update_global_env () module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation @@ -948,7 +949,7 @@ end = struct (* {{{ *) let prev = (VCS.visit id).next in if is_cached_and_valid prev then { s with proof = - Vernacstate.Proof_global.copy_terminators + PG_compat.copy_terminators ~src:((get_cached prev).proof) ~tgt:s.proof } else s with VCS.Expired -> s in @@ -957,7 +958,7 @@ end = struct (* {{{ *) if is_cached_and_valid ontop then let s = get_cached ontop in let s = { s with proof = - Vernacstate.Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in + PG_compat.copy_terminators ~src:s.proof ~tgt:pstate } in let s = { s with system = States.replace_summary s.system begin @@ -1009,8 +1010,8 @@ end = struct (* {{{ *) if feedback_processed then Hooks.(call state_computed ~doc id ~in_cache:false); VCS.reached id; - if Vernacstate.Proof_global.there_are_pending_proofs () then - VCS.goals id (Vernacstate.Proof_global.get_open_goals ()) + if PG_compat.there_are_pending_proofs () then + VCS.goals id (PG_compat.get_open_goals ()) with e -> let (e, info) = CErrors.push e in let good_id = !cur_id in @@ -1130,9 +1131,9 @@ let show_script ?proof () = try let prf = try match proof with - | None -> Some (Vernacstate.Proof_global.get_current_proof_name ()) + | None -> Some (PG_compat.get_current_proof_name ()) | Some (p,_) -> Some (p.Proof_global.id) - with Vernacstate.Proof_global.NoCurrentProof -> None + with PG_compat.NoCurrentProof -> None in let cmds = get_script prf in let _,_,_,indented_cmds = @@ -1147,12 +1148,12 @@ end (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly reduced... *) -let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t = +let stm_vernac_interp ?proof ?route id st { verbose; expr } : Vernacstate.t = (* The Stm will gain the capability to interpret commmads affecting the whole document state, such as backtrack, etc... so we start to design the stm command interpreter now *) set_id_for_feedback ?route dummy_doc id; - Aux_file.record_in_aux_set_at ?loc (); + Aux_file.record_in_aux_set_at ?loc:expr.CAst.loc (); (* We need to check if a command should be filtered from * vernac_entries, as it cannot handle it. This should go away in * future refactorings. @@ -1173,7 +1174,7 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t | VernacShow ShowScript -> ShowScript.show_script (); st (* XX we are ignoring control here *) | _ -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (CAst.make ?loc expr) + try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st expr with e -> let e = CErrors.push e in Exninfo.iraise Hooks.(call_process_error_once e) @@ -1295,7 +1296,7 @@ end = struct (* {{{ *) | Some vcs, _ -> vcs in let cb, _ = try Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) - with Failure _ -> raise Vernacstate.Proof_global.NoCurrentProof in + with Failure _ -> raise PG_compat.NoCurrentProof in let n = fold_until (fun n (_,vcs,_,_,_) -> if List.mem cb (Vcs_.branches vcs) then `Cont (n+1) else `Stop n) 0 id in @@ -1333,7 +1334,7 @@ end = struct (* {{{ *) | None -> true done; !rv - with Not_found | Vernacstate.Proof_global.NoCurrentProof -> None + with Not_found | PG_compat.NoCurrentProof -> None end (* }}} *) @@ -1594,7 +1595,7 @@ end = struct (* {{{ *) let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); - let p = Vernacstate.Proof_global.return_proof ~allow_partial:drop_pt () in + let p = PG_compat.return_proof ~allow_partial:drop_pt () in if drop_pt then feedback ~id Complete; p) @@ -1621,15 +1622,15 @@ end = struct (* {{{ *) to set the state manually here *) State.unfreeze st; let pobject, _ = - Vernacstate.Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in + PG_compat.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator []) in let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_vernac_interp stop ~proof:(pobject, terminator) st - { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }) in + { verbose = false; indentation = 0; strlen = 0; + expr = CAst.make ?loc @@ VernacExpr ([], VernacEndProof (Proved (opaque,None))) }) in ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) @@ -1758,15 +1759,15 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false stop; if drop then - let _proof = Vernacstate.Proof_global.return_proof ~allow_partial:true () in + let _proof = PG_compat.return_proof ~allow_partial:true () in `OK_ADMITTED else begin (* The original terminator, a hook, has not been saved in the .vio*) - Vernacstate.Proof_global.set_terminator (Lemmas.standard_proof_terminator []); + PG_compat.set_terminator (Lemmas.standard_proof_terminator []); let opaque = Proof_global.Opaque in let proof = - Vernacstate.Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in + PG_compat.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false start; @@ -1778,8 +1779,8 @@ end = struct (* {{{ *) (* STATE We use the state resulting from reaching start. *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp stop ~proof st - { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }); + { verbose = false; indentation = 0; strlen = 0; + expr = CAst.make ?loc @@ VernacExpr ([], VernacEndProof (Proved (opaque,None))) }); `OK proof end with e -> @@ -1791,10 +1792,11 @@ end = struct (* {{{ *) spc () ++ iprint (e, info)) | Some (_, cur) -> match VCS.visit cur with - | { step = `Cmd { cast = { loc } } } - | { step = `Fork (( { loc }, _, _, _), _) } - | { step = `Qed ( { qast = { loc } }, _) } - | { step = `Sideff (ReplayCommand { loc }, _) } -> + | { step = `Cmd { cast } } + | { step = `Fork (( cast, _, _, _), _) } + | { step = `Qed ( { qast = cast }, _) } + | { step = `Sideff (ReplayCommand cast, _) } -> + let loc = cast.expr.CAst.loc in let start, stop = Option.cata Loc.unloc (0,0) loc in msg_warning Pp.( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ @@ -2016,7 +2018,7 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:false id; State.purify (fun () -> - let Proof.{sigma=sigma0} = Proof.data (Vernacstate.Proof_global.give_me_the_proof ()) in + let Proof.{sigma=sigma0} = Proof.data (PG_compat.give_me_the_proof ()) in let g = Evd.find sigma0 r_goal in let is_ground c = Evarutil.is_ground_term sigma0 c in if not ( @@ -2028,7 +2030,7 @@ end = struct (* {{{ *) "goals only")) else begin let (i, ast) = r_ast in - Vernacstate.Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); + PG_compat.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); (* STATE SPEC: * - start : id * - return: id @@ -2037,7 +2039,7 @@ end = struct (* {{{ *) *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp r_state_fb st ast); - let Proof.{sigma} = Proof.data (Vernacstate.Proof_global.give_me_the_proof ()) in + let Proof.{sigma} = Proof.data (PG_compat.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress | Evd.Evar_defined t -> @@ -2071,20 +2073,20 @@ end = struct (* {{{ *) f () let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id - { indentation; verbose; loc; expr = e; strlen } : unit + { indentation; verbose; expr = e; strlen } : unit = let e, time, batch, fail = - let rec find ~time ~batch ~fail = function - | VernacTime (batch,{CAst.v=e}) -> find ~time:true ~batch ~fail e - | VernacRedirect (_,{CAst.v=e}) -> find ~time ~batch ~fail e - | VernacFail {CAst.v=e} -> find ~time ~batch ~fail:true e - | e -> e, time, batch, fail in + let rec find ~time ~batch ~fail v = CAst.with_loc_val (fun ?loc -> function + | VernacTime (batch,e) -> find ~time:true ~batch ~fail e + | VernacRedirect (_,e) -> find ~time ~batch ~fail e + | VernacFail e -> find ~time ~batch ~fail:true e + | e -> CAst.make ?loc e, time, batch, fail) v in find ~time:false ~batch:false ~fail:false e in let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> - Vernacstate.Proof_global.with_current_proof (fun _ p -> + PG_compat.with_current_proof (fun _ p -> let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> @@ -2092,7 +2094,7 @@ end = struct (* {{{ *) Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) (State.exn_on id ~valid:safe_id) in - let t_ast = (i, { indentation; verbose; loc; expr = e; strlen }) in + let t_ast = (i, { indentation; verbose; expr = e; strlen }) in let t_name = Goal.uid g in TaskQueue.enqueue_task queue { t_state = safe_id; t_state_fb = id; @@ -2117,7 +2119,7 @@ end = struct (* {{{ *) let open Notations in match Future.join f with | Some (pt, uc) -> - let sigma, env = Vernacstate.Proof_global.get_current_context () in + let sigma, env = PG_compat.get_current_context () in stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr_env env sigma pt) ++ spc () ++ @@ -2241,7 +2243,7 @@ let collect_proof keep cur hd brkind id = let name = function | [] -> no_name | id :: _ -> Names.Id.to_string id in - let loc = (snd cur).loc in + let loc = (snd cur).expr.CAst.loc in let is_defined_expr = function | VernacEndProof (Proved (Proof_global.Transparent,_)) -> true | _ -> false in @@ -2307,7 +2309,7 @@ let collect_proof keep cur hd brkind id = (try let name, hint = name ids, get_hint_ctx loc in let t, v = proof_no_using last in - v.expr <- VernacExpr([], VernacProof(t, Some hint)); + v.expr <- CAst.map (fun _ -> VernacExpr([], VernacProof(t, Some hint))) v.expr; `ASync (parent last,accn,name,delegate name) with Not_found -> let name = name ids in @@ -2399,8 +2401,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = end in match (VCS.get_info base_state).state with | FullState { Vernacstate.proof } -> - Option.iter Vernacstate.Proof_global.unfreeze proof; - Vernacstate.Proof_global.with_current_proof (fun _ p -> + Option.iter PG_compat.unfreeze proof; + PG_compat.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); (* STATE SPEC: @@ -2410,7 +2412,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (* STATE: We use an updated state with proof *) let st = Vernacstate.freeze_interp_state ~marshallable:false in Option.iter (fun expr -> ignore(stm_vernac_interp id st { - verbose = true; loc = None; expr; indentation = 0; + verbose = true; expr; indentation = 0; strlen = 0 } )) recovery_command | _ -> assert false @@ -2530,7 +2532,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | `ASync (block_start, nodes, name, delegate) -> (fun () -> let keep' = get_vtkeep keep in let drop_pt = keep' == VtKeepAxiom in - let block_stop, exn_info, loc = eop, (id, eop), x.loc in + let block_stop, exn_info, loc = eop, (id, eop), x.expr.CAst.loc in log_processing_async id name; VCS.create_proof_task_box nodes ~qed:id ~block_start; begin match brinfo, qed.fproof with @@ -2570,7 +2572,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepDefined -> Proof_global.Transparent in let proof = - Vernacstate.Proof_global.close_future_proof ~opaque ~feedback_id:id fp in + PG_compat.close_future_proof ~opaque ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in @@ -2578,19 +2580,19 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; - Vernacstate.Proof_global.discard_all () + PG_compat.discard_all () ), not redefine_qed, true | `Sync (name, `Immediate) -> (fun () -> reach eop; let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); - Vernacstate.Proof_global.discard_all () + PG_compat.discard_all () ), true, true | `Sync (name, reason) -> (fun () -> log_processing_sync id name reason; reach eop; let wall_clock = Unix.gettimeofday () in - record_pb_time name ?loc:x.loc (wall_clock -. !wall_clock_last_fork); + record_pb_time name ?loc:x.expr.CAst.loc (wall_clock -. !wall_clock_last_fork); let proof = match keep with | VtDrop -> None @@ -2603,7 +2605,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepOpaque -> Opaque | VtKeepDefined -> Transparent | VtKeepAxiom -> assert false in - Some(Vernacstate.Proof_global.close_proof ~opaque + Some(PG_compat.close_proof ~opaque ~keep_body_ucst_separate:false (State.exn_on id ~valid:eop)) in if keep <> VtKeep VtKeepAxiom then @@ -2612,9 +2614,9 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id ?proof st x); let wall_clock3 = Unix.gettimeofday () in - Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time" + Aux_file.record_in_aux_at ?loc:x.expr.CAst.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); - Vernacstate.Proof_global.discard_all () + PG_compat.discard_all () ), true, true | `MaybeASync (start, nodes, name, delegate) -> (fun () -> reach ~cache:true start; @@ -2875,7 +2877,7 @@ let merge_proof_branch ~valid ?id qast keep brname = VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> - Exninfo.iraise (State.exn_on ~valid Stateid.dummy (Vernacstate.Proof_global.NoCurrentProof, Exninfo.null)) + Exninfo.iraise (State.exn_on ~valid Stateid.dummy (PG_compat.NoCurrentProof, Exninfo.null)) (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) @@ -2932,7 +2934,7 @@ let get_allow_nested_proofs = (** [process_transaction] adds a node in the document *) let process_transaction ~doc ?(newtip=Stateid.fresh ()) - ({ verbose; loc; expr } as x) c = + ({ verbose; expr } as x) c = stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); let vcs = VCS.backup () in try @@ -3067,7 +3069,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); (* Vernac x may or may not start a proof *) - if not in_proof && Vernacstate.Proof_global.there_are_pending_proofs () then + if not in_proof && PG_compat.there_are_pending_proofs () then begin let bname = VCS.mk_branch_name x in let opacity_of_produced_term = function @@ -3118,11 +3120,11 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let get_ast ~doc id = match VCS.visit id with - | { step = `Cmd { cast = { loc; expr } } } - | { step = `Fork (({ loc; expr }, _, _, _), _) } - | { step = `Sideff ((ReplayCommand {loc; expr}) , _) } - | { step = `Qed ({ qast = { loc; expr } }, _) } -> - Some (Loc.tag ?loc expr) + | { step = `Cmd { cast = { expr } } } + | { step = `Fork (({ expr }, _, _, _), _) } + | { step = `Sideff ((ReplayCommand { expr }) , _) } + | { step = `Qed ({ qast = { expr } }, _) } -> + Some expr | _ -> None let stop_worker n = Slaves.cancel_worker n @@ -3139,8 +3141,8 @@ let parse_sentence ~doc sid ~entry pa = let ind_len_loc_of_id sid = if Stateid.equal sid Stateid.initial then None else match (VCS.visit sid).step with - | `Cmd { ctac = true; cast = { indentation; strlen; loc } } -> - Some (indentation, strlen, loc) + | `Cmd { ctac = true; cast = { indentation; strlen; expr } } -> + Some (indentation, strlen, expr.CAst.loc) | _ -> None (* the indentation logic works like this: if the beginning of the @@ -3167,7 +3169,8 @@ let compute_indentation ?loc sid = Option.cata (fun loc -> eff_indent, len ) (0, 0) loc -let add ~doc ~ontop ?newtip verb { CAst.loc; v=ast } = +let add ~doc ~ontop ?newtip verb ast = + let loc = ast.CAst.loc in let cur_tip = VCS.cur_tip () in if not (Stateid.equal ontop cur_tip) then user_err ?loc ~hdr:"Stm.add" @@ -3177,7 +3180,7 @@ let add ~doc ~ontop ?newtip verb { CAst.loc; v=ast } = let indentation, strlen = compute_indentation ?loc ontop in (* XXX: Classifiy vernac should be moved inside process transaction *) let clas = Vernac_classifier.classify_vernac ast in - let aast = { verbose = verb; indentation; strlen; loc; expr = ast } in + let aast = { verbose = verb; indentation; strlen; expr = ast } in match process_transaction ~doc ?newtip aast clas with | `Ok -> doc, VCS.cur_tip (), `NewTip | `Unfocus qed_id -> doc, qed_id, `Unfocus (VCS.cur_tip ()) @@ -3197,14 +3200,15 @@ let query ~doc ~at ~route s = let rec loop () = match parse_sentence ~doc at ~entry:Pvernac.main_entry s with | None -> () - | Some {CAst.loc; v=ast} -> - let indentation, strlen = compute_indentation ?loc at in - let st = State.get_cached at in - let aast = { - verbose = true; indentation; strlen; - loc; expr = ast } in - ignore(stm_vernac_interp ~route at st aast); - loop () + | Some ast -> + let loc = ast.CAst.loc in + let indentation, strlen = compute_indentation ?loc at in + let st = State.get_cached at in + let aast = { + verbose = true; indentation; strlen; + expr = ast } in + ignore(stm_vernac_interp ~route at st aast); + loop () in loop () ) diff --git a/stm/stm.mli b/stm/stm.mli index 91651e3534..9d2bf56629 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -111,7 +111,7 @@ val parse_sentence : If [newtip] is provided, then the returned state id is guaranteed to be [newtip] *) val add : doc:doc -> ontop:Stateid.t -> ?newtip:Stateid.t -> - bool -> Vernacexpr.vernac_control CAst.t -> + bool -> Vernacexpr.vernac_control -> doc * Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] (* Returns the proof state before the last tactic that was applied at or before @@ -175,7 +175,7 @@ val get_current_state : doc:doc -> Stateid.t val get_ldir : doc:doc -> Names.DirPath.t (* This returns the node at that position *) -val get_ast : doc:doc -> Stateid.t -> (Vernacexpr.vernac_control Loc.located) option +val get_ast : doc:doc -> Stateid.t -> Vernacexpr.vernac_control option (* Filename *) val set_compilation_hints : string -> unit diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 243b5c333d..674b4285d2 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -200,20 +200,20 @@ let classify_vernac e = try Vernacextend.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in - let rec static_control_classifier = function + let rec static_control_classifier v = v |> CAst.with_val (function | VernacExpr (f, e) -> let poly = Attributes.(parse_drop_extra polymorphic_nowarn f) in static_classifier ~poly e - | VernacTimeout (_,{v=e}) -> static_control_classifier e - | VernacTime (_,{v=e}) | VernacRedirect (_, {v=e}) -> + | VernacTimeout (_,e) -> static_control_classifier e + | VernacTime (_,e) | VernacRedirect (_, e) -> static_control_classifier e - | VernacFail {v=e} -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) + | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match static_control_classifier e with | ( VtQuery | VtProofStep _ | VtSideff _ | VtMeta), _ as x -> x | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtLater - | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater) + | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater)) in static_control_classifier e diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index c1ac7d201a..160e4f164e 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -548,7 +548,7 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = make_apply_entry ~name env sigma flags pri false]) else [] -let make_hints g st only_classes sign = +let make_hints g (modes,st) only_classes sign = let hintlist = List.fold_left (fun hints hyp -> @@ -565,7 +565,9 @@ let make_hints g st only_classes sign = in hint @ hints else hints) ([]) sign - in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) + in + let db = Hint_db.add_modes modes @@ Hint_db.empty st true in + Hint_db.add_list (pf_env g) (project g) hintlist db module Search = struct type autoinfo = @@ -578,29 +580,29 @@ module Search = struct (** Local hints *) let autogoal_cache = Summary.ref ~name:"autogoal_cache" - (DirPath.empty, true, Context.Named.empty, + (DirPath.empty, true, Context.Named.empty, GlobRef.Map.empty, Hint_db.empty TransparentState.full true) - let make_autogoal_hints only_classes ?(st=TransparentState.full) g = + let make_autogoal_hints only_classes (modes,st as mst) g = let open Proofview in let open Tacmach.New in let sign = Goal.hyps g in - let (dir, onlyc, sign', cached_hints) = !autogoal_cache in + let (dir, onlyc, sign', cached_modes, cached_hints) = !autogoal_cache in let cwd = Lib.cwd () in let eq c1 c2 = EConstr.eq_constr (project g) c1 c2 in if DirPath.equal cwd dir && (onlyc == only_classes) && Context.Named.equal eq sign sign' && - Hint_db.transparent_state cached_hints == st + cached_modes == modes then cached_hints else let hints = make_hints {it = Goal.goal g; sigma = project g} - st only_classes sign + mst only_classes sign in - autogoal_cache := (cwd, only_classes, sign, hints); hints + autogoal_cache := (cwd, only_classes, sign, modes, hints); hints - let make_autogoal ?(st=TransparentState.full) only_classes dep cut i g = - let hints = make_autogoal_hints only_classes ~st g in + let make_autogoal mst only_classes dep cut i g = + let hints = make_autogoal_hints only_classes mst g in { search_hints = hints; search_depth = [i]; last_tac = lazy (str"none"); search_dep = dep; @@ -695,7 +697,8 @@ module Search = struct if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl)) then let st = Hint_db.transparent_state info.search_hints in - make_autogoal_hints info.search_only_classes ~st gl' + let modes = Hint_db.modes info.search_hints in + make_autogoal_hints info.search_only_classes (modes,st) gl' else info.search_hints in let dep' = info.search_dep || Proofview.unifiable sigma' (Goal.goal gl') gls in @@ -830,19 +833,19 @@ module Search = struct (fun e' -> let (e, info) = merge_exceptions e e' in Proofview.tclZERO ~info e)) - let search_tac_gl ?st only_classes dep hints depth i sigma gls gl : + let search_tac_gl mst only_classes dep hints depth i sigma gls gl : unit Proofview.tactic = let open Proofview in let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in - let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in + let info = make_autogoal mst only_classes dep (cut_of_hints hints) i gl in search_tac hints depth 1 info - let search_tac ?(st=TransparentState.full) only_classes dep hints depth = + let search_tac mst only_classes dep hints depth = let open Proofview in let tac sigma gls i = Goal.enter begin fun gl -> - search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl end + search_tac_gl mst only_classes dep hints depth (succ i) sigma gls gl end in Proofview.Unsafe.tclGETGOALS >>= fun gls -> let gls = CList.map Proofview.drop_state gls in @@ -867,11 +870,11 @@ module Search = struct | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 - let eauto_tac ?(st=TransparentState.full) ?(unique=false) + let eauto_tac mst ?(unique=false) ~only_classes ?strategy ~depth ~dep hints = let open Proofview in let tac = - let search = search_tac ~st only_classes dep hints in + let search = search_tac mst only_classes dep hints in let dfs = match strategy with | None -> not (get_typeclasses_iterative_deepening ()) @@ -915,8 +918,8 @@ module Search = struct | Some i -> str ", with depth limit " ++ int i)); tac - let eauto_tac ?st ?unique ~only_classes ?strategy ~depth ~dep hints = - Hints.wrap_hint_warning @@ eauto_tac ?st ?unique ~only_classes ?strategy ~depth ~dep hints + let eauto_tac mst ?unique ~only_classes ?strategy ~depth ~dep hints = + Hints.wrap_hint_warning @@ eauto_tac mst ?unique ~only_classes ?strategy ~depth ~dep hints let run_on_evars env evm p tac = match evars_to_goals p evm with @@ -968,8 +971,8 @@ module Search = struct else raise Not_found with Logic_monad.TacticFailure _ -> raise Not_found - let evars_eauto env evd depth only_classes unique dep st hints p = - let eauto_tac = eauto_tac ~st ~unique ~only_classes ~depth ~dep:(unique || dep) hints in + let evars_eauto env evd depth only_classes unique dep mst hints p = + let eauto_tac = eauto_tac mst ~unique ~only_classes ~depth ~dep:(unique || dep) hints in let res = run_on_evars env evd p eauto_tac in match res with | None -> evd @@ -983,11 +986,11 @@ module Search = struct let typeclasses_resolve env evd debug depth unique p = let db = searchtable_map typeclasses_db in - typeclasses_eauto env evd ?depth unique (Hint_db.transparent_state db) [db] p + let st = Hint_db.transparent_state db in + let modes = Hint_db.modes db in + typeclasses_eauto env evd ?depth unique (modes,st) [db] p end -(** Binding to either V85 or Search implementations. *) - let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) ?strategy ~depth dbs = let dbs = List.map_filter @@ -996,8 +999,10 @@ let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) dbs in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in + let modes = List.map Hint_db.modes dbs in + let modes = List.fold_left (GlobRef.Map.union (fun _ m1 m2 -> Some (m1@m2))) GlobRef.Map.empty modes in let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in - Search.eauto_tac ~st ~only_classes ?strategy ~depth ~dep:true dbs + Search.eauto_tac (modes,st) ~only_classes ?strategy ~depth ~dep:true dbs (** We compute dependencies via a union-find algorithm. Beware of the imperative effects on the partition structure, @@ -1140,11 +1145,12 @@ let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = let gls = { it = gl ; sigma = sigma; } in let hints = searchtable_map typeclasses_db in let st = Hint_db.transparent_state hints in + let modes = Hint_db.modes hints in let depth = get_typeclasses_depth () in let gls' = try Proofview.V82.of_tactic - (Search.eauto_tac ~st ~only_classes:true ~depth [hints] ~dep:true) gls + (Search.eauto_tac (modes,st) ~only_classes:true ~depth [hints] ~dep:true) gls with Refiner.FailError _ -> raise Not_found in let evd = sig_sig gls' in diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index c950e3de3d..b9291f6124 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -27,9 +27,18 @@ type search_strategy = Dfs | Bfs val set_typeclasses_strategy : search_strategy -> unit -val typeclasses_eauto : ?only_classes:bool -> ?st:TransparentState.t -> ?strategy:search_strategy -> - depth:(Int.t option) -> - Hints.hint_db_name list -> unit Proofview.tactic +val typeclasses_eauto : + ?only_classes:bool + (** Should non-class goals be shelved and resolved at the end *) + -> ?st:TransparentState.t + (** The transparent_state used when working with local hypotheses *) + -> ?strategy:search_strategy + (** Is a traversing-strategy specified? *) + -> depth:(Int.t option) + (** Bounded or unbounded search *) + -> Hints.hint_db_name list + (** The list of hint databases to use *) + -> unit Proofview.tactic val head_of_constr : Id.t -> constr -> unit Proofview.tactic @@ -41,8 +50,8 @@ val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic module Search : sig val eauto_tac : - ?st:TransparentState.t - (** The transparent_state used when working with local hypotheses *) + Hints.hint_mode array list GlobRef.Map.t * TransparentState.t + (** The transparent_state and modes used when working with local hypotheses *) -> ?unique:bool (** Should we force a unique solution *) -> only_classes:bool diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 3019fc0231..70854e6e3c 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -515,6 +515,6 @@ let autounfold_one db cl = if did then match cl with | Some hyp -> change_in_hyp None (make_change_arg c') hyp - | None -> convert_concl_no_check c' DEFAULTcast + | None -> convert_concl ~check:false c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") end diff --git a/tactics/hints.ml b/tactics/hints.ml index 11a8816159..cc56c1c425 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -289,8 +289,6 @@ let lookup_tacs sigma concl st se = let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' -module Constr_map = Map.Make(GlobRef.Ordered) - let is_transparent_gr ts = function | VarRef id -> TransparentState.is_transparent_variable ts id | ConstRef cst -> TransparentState.is_transparent_constant ts cst @@ -520,6 +518,8 @@ val add_cut : hints_path -> t -> t val add_mode : GlobRef.t -> hint_mode array -> t -> t val cut : t -> hints_path val unfolds : t -> Id.Set.t * Cset.t +val add_modes : hint_mode array list GlobRef.Map.t -> t -> t +val modes : t -> hint_mode array list GlobRef.Map.t val fold : (GlobRef.t option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> t -> 'a -> 'a @@ -532,7 +532,7 @@ struct hintdb_unfolds : Id.Set.t * Cset.t; hintdb_max_id : int; use_dn : bool; - hintdb_map : search_entry Constr_map.t; + hintdb_map : search_entry GlobRef.Map.t; (* A list of unindexed entries starting with an unfoldable constant or with no associated pattern. *) hintdb_nopat : (GlobRef.t option * stored_data) list; @@ -548,12 +548,12 @@ struct hintdb_unfolds = (Id.Set.empty, Cset.empty); hintdb_max_id = 0; use_dn = use_dn; - hintdb_map = Constr_map.empty; + hintdb_map = GlobRef.Map.empty; hintdb_nopat = []; hintdb_name = name; } let find key db = - try Constr_map.find key db.hintdb_map + try GlobRef.Map.find key db.hintdb_map with Not_found -> empty_se let realize_tac secvars (id,tac) = @@ -650,11 +650,11 @@ struct else db | Some gr -> let oval = find gr db in - { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map } + { db with hintdb_map = GlobRef.Map.add gr (add_tac pat idv dnst oval) db.hintdb_map } let rebuild_db st' db = let db' = - { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map; + { db with hintdb_map = GlobRef.Map.map (rebuild_dn st') db.hintdb_map; hintdb_state = st'; hintdb_nopat = [] } in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat @@ -693,7 +693,7 @@ struct let remove_list grs db = let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem_f GlobRef.equal gr grs) | _ -> true in - let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in + let hintmap = GlobRef.Map.map (remove_he db.hintdb_state filter) db.hintdb_map in let hintnopat = List.filter (fun (ge, sd) -> filter sd) db.hintdb_nopat in { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } @@ -706,11 +706,11 @@ struct let iter f db = let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat); - Constr_map.iter iter_se db.hintdb_map + GlobRef.Map.iter iter_se db.hintdb_map let fold f db accu = let accu = f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in - Constr_map.fold (fun k se -> f (Some k) se.sentry_mode (get_entry se)) db.hintdb_map accu + GlobRef.Map.fold (fun k se -> f (Some k) se.sentry_mode (get_entry se)) db.hintdb_map accu let transparent_state db = db.hintdb_state @@ -724,12 +724,21 @@ struct let add_mode gr m db = let se = find gr db in let se = { se with sentry_mode = m :: se.sentry_mode } in - { db with hintdb_map = Constr_map.add gr se db.hintdb_map } + { db with hintdb_map = GlobRef.Map.add gr se db.hintdb_map } let cut db = db.hintdb_cut let unfolds db = db.hintdb_unfolds + let add_modes modes db = + let f gr e me = + Some { e with sentry_mode = me.sentry_mode @ e.sentry_mode } + in + let mode_entries = GlobRef.Map.map (fun m -> { empty_se with sentry_mode = m }) modes in + { db with hintdb_map = GlobRef.Map.union f db.hintdb_map mode_entries } + + let modes db = GlobRef.Map.map (fun se -> se.sentry_mode) db.hintdb_map + let use_dn db = db.use_dn end diff --git a/tactics/hints.mli b/tactics/hints.mli index 90a8b7fe52..7b8f96cdd8 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -162,6 +162,9 @@ module Hint_db : val cut : t -> hints_path val unfolds : t -> Id.Set.t * Cset.t + + val add_modes : hint_mode array list GlobRef.Map.t -> t -> t + val modes : t -> hint_mode array list GlobRef.Map.t end type hint_db = Hint_db.t diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 066b9c7794..5e8869f9b0 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -614,18 +614,22 @@ let cofix id = mutual_cofix id [] 0 type tactic_reduction = Reductionops.reduction_function type e_tactic_reduction = Reductionops.e_reduction_function -let pf_reduce_decl redfun where decl gl = +let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = let open Context.Named.Declaration in - let redfun' c = Tacmach.New.pf_apply redfun gl c in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then user_err (Id.print id.binder_name ++ str " has no value."); - LocalAssum (id,redfun' ty) + let (sigma, ty') = redfun false env sigma ty in + (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> - let b' = if where != InHypTypeOnly then redfun' b else b in - let ty' = if where != InHypValueOnly then redfun' ty else ty in - LocalDef (id,b',ty') + let (sigma, b') = + if where != InHypTypeOnly then redfun true env sigma b else (sigma, b) + in + let (sigma, ty') = + if where != InHypValueOnly then redfun false env sigma ty else (sigma, ty) + in + (sigma, LocalDef (id,b',ty')) (* Possibly equip a reduction with the occurrences mentioned in an occurrence clause *) @@ -695,41 +699,9 @@ let bind_red_expr_occurrences occs nbcl redexp = reduction function either to the conclusion or to a certain hypothesis *) -let reduct_in_concl (redfun,sty) = - Proofview.Goal.enter begin fun gl -> - convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty - end - -let reduct_in_hyp ?(check=false) redfun (id,where) = - Proofview.Goal.enter begin fun gl -> - convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) - end - -let revert_cast (redfun,kind as r) = - if kind == DEFAULTcast then (redfun,REVERTcast) else r - -let reduct_option ?(check=false) redfun = function - | Some id -> reduct_in_hyp ~check (fst redfun) id - | None -> reduct_in_concl (revert_cast redfun) - (** Tactic reduction modulo evars (for universes essentially) *) -let pf_e_reduce_decl redfun where decl gl = - let open Context.Named.Declaration in - let sigma = Proofview.Goal.sigma gl in - let redfun sigma c = redfun (Tacmach.New.pf_env gl) sigma c in - match decl with - | LocalAssum (id,ty) -> - if where == InHypValueOnly then - user_err (Id.print id.binder_name ++ str " has no value."); - let (sigma, ty') = redfun sigma ty in - (sigma, LocalAssum (id, ty')) - | LocalDef (id,b,ty) -> - let (sigma, b') = if where != InHypTypeOnly then redfun sigma b else (sigma, b) in - let (sigma, ty') = if where != InHypValueOnly then redfun sigma ty else (sigma, ty) in - (sigma, LocalDef (id, b', ty')) - -let e_reduct_in_concl ~check (redfun, sty) = +let e_change_in_concl ?(check = false) (redfun, sty) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let (sigma, c') = redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in @@ -737,53 +709,64 @@ let e_reduct_in_concl ~check (redfun, sty) = (convert_concl ~check c' sty) end -let e_reduct_in_hyp ?(check=false) redfun (id, where) = +let e_change_in_hyp ?(check = false) redfun (id,where) = Proofview.Goal.enter begin fun gl -> - let (sigma, decl') = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in + let sigma = Proofview.Goal.sigma gl in + let hyp = Tacmach.New.pf_get_hyp id gl in + let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_hyp ~check decl') + (convert_hyp ~check c) end -let e_reduct_option ?(check=false) redfun = function - | Some id -> e_reduct_in_hyp ~check (fst redfun) id - | None -> e_reduct_in_concl ~check (revert_cast redfun) - -(** Versions with evars to maintain the unification of universes resulting - from conversions. *) - -let e_change_in_concl (redfun,sty) = +let e_change_in_hyps ?(check=true) f args = Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.concl gl) in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_concl_no_check c sty) + let fold (env, sigma) arg = + let (redfun, id, where) = f arg in + let hyp = + try lookup_named id env + with Not_found -> + raise (RefinerError (env, sigma, NoSuchHyp id)) + in + let (sigma, d) = e_pf_change_decl redfun where hyp env sigma in + let sign = Logic.convert_hyp check (named_context_val env) sigma d in + let env = reset_with_named_context sign env in + (env, sigma) + in + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let (env, sigma) = List.fold_left fold (env, sigma) args in + let ty = Proofview.Goal.concl gl in + Proofview.Unsafe.tclEVARS sigma + <*> + Refine.refine ~typecheck:false begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true ty + end end -let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = - let open Context.Named.Declaration in - match decl with - | LocalAssum (id,ty) -> - if where == InHypValueOnly then - user_err (Id.print id.binder_name ++ str " has no value."); - let (sigma, ty') = redfun false env sigma ty in - (sigma, LocalAssum (id, ty')) - | LocalDef (id,b,ty) -> - let (sigma, b') = - if where != InHypTypeOnly then redfun true env sigma b else (sigma, b) - in - let (sigma, ty') = - if where != InHypValueOnly then redfun false env sigma ty else (sigma, ty) - in - (sigma, LocalDef (id,b',ty')) +let e_reduct_in_concl = e_change_in_concl -let e_change_in_hyp redfun (id,where) = - Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let hyp = Tacmach.New.pf_get_hyp id gl in - let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_hyp c) - end +let reduct_in_concl ?(check = false) (redfun, sty) = + let redfun env sigma c = (sigma, redfun env sigma c) in + e_change_in_concl ~check (redfun, sty) + +let e_reduct_in_hyp ?(check=false) redfun (id, where) = + let redfun _ env sigma c = redfun env sigma c in + e_change_in_hyp ~check redfun (id, where) + +let reduct_in_hyp ?(check = false) redfun (id, where) = + let redfun _ env sigma c = (sigma, redfun env sigma c) in + e_change_in_hyp ~check redfun (id, where) + +let revert_cast (redfun,kind as r) = + if kind == DEFAULTcast then (redfun,REVERTcast) else r + +let e_reduct_option ?(check=false) redfun = function + | Some id -> e_reduct_in_hyp ~check (fst redfun) id + | None -> e_change_in_concl ~check (revert_cast redfun) + +let reduct_option ?(check = false) (redfun, sty) where = + let redfun env sigma c = (sigma, redfun env sigma c) in + e_reduct_option ~check (redfun, sty) where type change_arg = Ltac_pretype.patvar_map -> env -> evar_map -> evar_map * EConstr.constr @@ -819,15 +802,21 @@ let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = | Some sigma -> (sigma, t') (* Use cumulativity only if changing the conclusion not a subterm *) -let change_on_subterm cv_pb deep t where env sigma c = +let change_on_subterm check cv_pb deep t where env sigma c = let mayneedglobalcheck = ref false in let (sigma, c) = match where with - | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c + | None -> + if check then + change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c + else + t Id.Map.empty env sigma | Some occl -> e_contextually false occl (fun subst -> - change_and_check Reduction.CONV mayneedglobalcheck true (t subst)) - env sigma c in + if check then + change_and_check Reduction.CONV mayneedglobalcheck true (t subst) + else + fun env sigma _c -> t subst env sigma) env sigma c in if !mayneedglobalcheck then begin try ignore (Typing.unsafe_type_of env sigma c) @@ -836,29 +825,41 @@ let change_on_subterm cv_pb deep t where env sigma c = end; (sigma, c) -let change_in_concl occl t = - e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) +let change_in_concl ?(check=true) occl t = + (* No need to check in e_change_in_concl, the check is done in change_on_subterm *) + e_change_in_concl ~check:false ((change_on_subterm check Reduction.CUMUL false t occl),DEFAULTcast) -let change_in_hyp occl t id = - e_change_in_hyp (fun x -> change_on_subterm Reduction.CONV x t occl) id +let change_in_hyp ?(check=true) occl t id = + (* FIXME: we set the [check] flag only to reorder hypotheses in case of + introduction of dependencies in new variables. We should separate this + check from the conversion function. *) + e_change_in_hyp ~check (fun x -> change_on_subterm check Reduction.CONV x t occl) id -let change_option occl t = function - | Some id -> change_in_hyp occl t id - | None -> change_in_concl occl t +let concrete_clause_of enum_hyps cl = match cl.onhyps with +| None -> + let f id = (id, AllOccurrences, InHyp) in + List.map f (enum_hyps ()) +| Some l -> + List.map (fun ((occs, id), w) -> (id, occs, w)) l -let change chg c cls = +let change ?(check=true) chg c cls = Proofview.Goal.enter begin fun gl -> - let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in - Tacticals.New.tclMAP (function - | OnHyp (id,occs,where) -> - change_option (bind_change_occurrences occs chg) c (Some (id,where)) - | OnConcl occs -> - change_option (bind_change_occurrences occs chg) c None) - cls + let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in + begin match cls.concl_occs with + | NoOccurrences -> Proofview.tclUNIT () + | occs -> change_in_concl ~check (bind_change_occurrences occs chg) c + end + <*> + let f (id, occs, where) = + let occl = bind_change_occurrences occs chg in + let redfun deep env sigma t = change_on_subterm check Reduction.CONV deep c occl env sigma t in + (redfun, id, where) + in + e_change_in_hyps ~check f hyps end let change_concl t = - change_in_concl None (make_change_arg t) + change_in_concl ~check:true None (make_change_arg t) (* Pour usage interne (le niveau User est pris en compte par reduce) *) let red_in_concl = reduct_in_concl (red_product,REVERTcast) @@ -881,14 +882,6 @@ let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) (* The main reduction function *) -let reduction_clause redexp cl = - let nbcl = List.length cl in - List.map (function - | OnHyp (id,occs,where) -> - (Some (id,where), bind_red_expr_occurrences occs nbcl redexp) - | OnConcl occs -> - (None, bind_red_expr_occurrences occs nbcl redexp)) cl - let reduce redexp cl = let trace env sigma = let open Printer in @@ -897,12 +890,24 @@ let reduce redexp cl = in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter begin fun gl -> - let cl' = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in - let redexps = reduction_clause redexp cl' in + let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in + let nbcl = (if cl.concl_occs = NoOccurrences then 0 else 1) + List.length hyps in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in - Tacticals.New.tclMAP (fun (where,redexp) -> - e_reduct_option ~check - (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps + begin match cl.concl_occs with + | NoOccurrences -> Proofview.tclUNIT () + | occs -> + let redexp = bind_red_expr_occurrences occs nbcl redexp in + let redfun = Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp in + e_change_in_concl ~check (revert_cast redfun) + end + <*> + let f (id, occs, where) = + let redexp = bind_red_expr_occurrences occs nbcl redexp in + let (redfun, _) = Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp in + let redfun _ env sigma c = redfun env sigma c in + (redfun, id, where) + in + e_change_in_hyps ~check f hyps end end @@ -2174,7 +2179,7 @@ let constructor_tac with_evars expctdnumopt i lbind = let nconstr = Array.length (snd (Global.lookup_inductive ind)).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; Tacticals.New.tclTHENLIST [ - convert_concl_no_check redcl DEFAULTcast; + convert_concl ~check:false redcl DEFAULTcast; intros; constructor_core with_evars (ind, i) lbind ] @@ -2203,7 +2208,7 @@ let any_constructor with_evars tacopt = Array.length (snd (Global.lookup_inductive ind)).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; Tacticals.New.tclTHENLIST [ - convert_concl_no_check redcl DEFAULTcast; + convert_concl ~check:false redcl DEFAULTcast; intros; any_constr ind nconstr 1 () ] @@ -2647,9 +2652,9 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = in Tacticals.New.tclTHENLIST [ Proofview.Unsafe.tclEVARS sigma; - convert_concl_no_check newcl DEFAULTcast; + convert_concl ~check:false newcl DEFAULTcast; intro_gen (NamingMustBe (CAst.make id)) (decode_hyp lastlhyp) true false; - Tacticals.New.tclMAP convert_hyp_no_check depdecls; + Tacticals.New.tclMAP (convert_hyp ~check:false) depdecls; eq_tac ] end @@ -2858,17 +2863,21 @@ let generalize_dep ?(with_let=false) c = | _ -> tothin in let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in - let body = - if with_let then - match EConstr.kind sigma c with - | Var id -> id |> (fun id -> pf_get_hyp id gl) |> NamedDecl.get_value - | _ -> None - else None + let is_var, body = match EConstr.kind sigma c with + | Var id -> + let body = NamedDecl.get_value (pf_get_hyp id gl) in + let is_var = Option.is_empty body && not (List.mem id init_ids) in + if with_let then is_var, body else is_var, None + | _ -> false, None in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in (* Check that the generalization is indeed well-typed *) - let (evd, _) = Typing.type_of env evd cl'' in + let evd = + (* No need to retype for variables, term is statically well-typed *) + if is_var then evd + else fst (Typing.type_of env evd cl'') + in let args = Context.Named.to_instance mkVar to_quantify_rev in tclTHENLIST [ Proofview.Unsafe.tclEVARS evd; @@ -3282,7 +3291,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN - (change_in_hyp None (make_change_arg t) (hyp0,InHypTypeOnly)) + (change_in_hyp ~check:false None (make_change_arg t) (hyp0,InHypTypeOnly)) (tac avoid) else let c = List.nth argl (i-1) in @@ -4799,7 +4808,7 @@ let symmetry_red allowred = match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN - (convert_concl_no_check concl DEFAULTcast) + (convert_concl ~check:false concl DEFAULTcast) (Tacticals.New.pf_constr_of_global eq_data.sym >>= apply) | None,eq,eq_kind -> prove_symmetry eq eq_kind end @@ -4894,7 +4903,7 @@ let transitivity_red allowred t = match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN - (convert_concl_no_check concl DEFAULTcast) + (convert_concl ~check:false concl DEFAULTcast) (match t with | None -> Tacticals.New.pf_constr_of_global eq_data.trans >>= eapply | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans >>= fun trans -> apply_list [trans; t]) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 75b5caaa36..b3914816ac 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -36,7 +36,9 @@ val introduction : Id.t -> unit Proofview.tactic val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic +[@@ocaml.deprecated "use [Tactics.convert_concl]"] val convert_hyp_no_check : named_declaration -> unit Proofview.tactic +[@@ocaml.deprecated "use [Tactics.convert_hyp]"] val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic val fix : Id.t -> int -> unit Proofview.tactic @@ -152,11 +154,11 @@ type change_arg = patvar_map -> env -> evar_map -> evar_map * constr val make_change_arg : constr -> change_arg val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic -val reduct_in_concl : tactic_reduction * cast_kind -> unit Proofview.tactic -val e_reduct_in_concl : check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic -val change_in_concl : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic +val reduct_in_concl : ?check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic +val e_reduct_in_concl : ?check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic +val change_in_concl : ?check:bool -> (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic val change_concl : constr -> unit Proofview.tactic -val change_in_hyp : (occurrences * constr_pattern) option -> change_arg -> +val change_in_hyp : ?check:bool -> (occurrences * constr_pattern) option -> change_arg -> hyp_location -> unit Proofview.tactic val red_in_concl : unit Proofview.tactic val red_in_hyp : hyp_location -> unit Proofview.tactic @@ -178,7 +180,7 @@ val unfold_in_hyp : val unfold_option : (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : - constr_pattern option -> change_arg -> clause -> unit Proofview.tactic + ?check:bool -> constr_pattern option -> change_arg -> clause -> unit Proofview.tactic val pattern_option : (occurrences * constr) list -> goal_location -> unit Proofview.tactic val reduce : red_expr -> clause -> unit Proofview.tactic diff --git a/test-suite/bugs/closed/bug_10025.v b/test-suite/bugs/closed/bug_10025.v new file mode 100644 index 0000000000..1effc771b0 --- /dev/null +++ b/test-suite/bugs/closed/bug_10025.v @@ -0,0 +1,39 @@ +Require Import Program. + +Axiom I : Type. + +Inductive S : Type := NT : I -> S. + +Axiom F : S -> Type. + +Axiom G : forall (s : S), F s -> Type. + +Section S. + +Variable init : I. +Variable my_s : F (NT init). + +Inductive foo : forall (s: S) (hole_sem: F s), Type := +| Foo : foo (NT init) my_s. + +Goal forall + (n : I) (s : F (NT n)) (ptz : foo (NT n) s) (pt : G (NT n) s) (x : unit), +match + match x with tt => tt end +with +| tt => + match + match ptz in foo x s return (forall _ : G x s, unit) with + | Foo => fun _ : G (NT init) my_s => tt + end pt + with + | tt => False + end +end. +Proof. +dependent destruction ptz. +(* Check well-typedness of goal *) +match goal with [ |- ?P ] => let t := type of P in idtac end. +Abort. + +End S. diff --git a/test-suite/bugs/closed/bug_5752.v b/test-suite/bugs/closed/bug_5752.v new file mode 100644 index 0000000000..b4218d66df --- /dev/null +++ b/test-suite/bugs/closed/bug_5752.v @@ -0,0 +1,8 @@ +Class C (A : Type) := c : A. + +Hint Mode C ! : typeclass_instances. + +Goal forall f : (forall A, C A -> C (list A)), True. +intros. + Check c. (* Loops if modes are ignored. *) +Abort. diff --git a/test-suite/bugs/closed/bug_9344.v b/test-suite/bugs/closed/bug_9344.v new file mode 100644 index 0000000000..0d44c9721a --- /dev/null +++ b/test-suite/bugs/closed/bug_9344.v @@ -0,0 +1,2 @@ +Compute _ I. +Eval native_compute in _ I. diff --git a/test-suite/bugs/closed/bug_9348.v b/test-suite/bugs/closed/bug_9348.v new file mode 100644 index 0000000000..a4673b5ffc --- /dev/null +++ b/test-suite/bugs/closed/bug_9348.v @@ -0,0 +1,3 @@ +Set Primitive Projections. +Record r {A} := R {f : A -> A}. +Compute f _ I. diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index 78a3f7c63a..4ee4aae36c 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -49,16 +49,15 @@ TO_SED_IN_BOTH=( -e s'/[0-9]*\.[0-9]*//g' # the precise timing numbers vary, so we strip them out -e s'/^-*$/------/g' # When none of the numbers get over 100 (or 1000, in per-file), the width of the table is different, so we normalize the number of dashes for table separators -e s'/+/-/g' # some code lines don't really change, but this can show up as either -0m00.01s or +0m00.01s, so we need to normalize the signs; additionally, some N/A's show up where we expect to get -∞ on the per-line file, and so the ∞-replacement gets the sign wrong, so we must correct it + -e s'/[0-9]//g' # sometimes the time is under 1 minute, sometimes it's over 1 minute, so we want to remove/normalize both instances; see https://github.com/coq/coq/issues/5675#issuecomment-487378622 ) TO_SED_IN_PER_FILE=( - -e s'/[0-9]//g' # unclear whether this is actually needed above and beyond s'/[0-9]*\.[0-9]*//g'; it's been here from the start -e s'/ */ /g' # unclear whether this is actually needed for per-file timing; it's been here from the start -e s'/\(Total.*\)-\(.*\)-/\1+\2+/g' # Overall time in the per-file timing diff should be around 0; if it comes out negative, we remove the sign ) TO_SED_IN_PER_LINE=( - -e s'/0//g' # unclear whether this is actually needed above and beyond s'/[0-9]*\.[0-9]*//g'; it's been here from the start -e s'/ */ /g' # Sometimes 0 will show up as 0m00.s, sometimes it'll end up being more like 0m00.001s; we must strip out the spaces that result from left-aligning numbers of different widths based on how many digits Coq's [-time] gives ) diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index 2ba02924c9..af202ea01c 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -1,6 +1,6 @@ The command has indeed failed with message: Last occurrence of "list'" must have "A" as 1st argument in - "A -> list' A -> list' (A * A)". + "A -> list' A -> list' (A * A)%type". Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x For foo: Argument scopes are [type_scope _] diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index bec4fc1579..94b86fc222 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -72,7 +72,7 @@ Nil : forall A : Type, list A NIL : list nat : list nat -(false && I 3)%bool /\ (I 6)%bool +(false && I 3)%bool /\ I 6 : Prop [|1, 2, 3; 4, 5, 6|] : Z * Z * Z * (Z * Z * Z) diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index 2ffc3b14e2..adab324cf0 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -30,7 +30,7 @@ Check (decomp (true,true) as t, u in (t,u)). Section A. -Notation "! A" := (forall _:nat, A) (at level 60) : type_scope. +Notation "! A" := (forall _:nat, A) (at level 60). Check ! (0=0). Check forall n, n=0. @@ -195,9 +195,9 @@ Open Scope nat_scope. Coercion is_true := fun b => b=true. Coercion of_nat n := match n with 0 => true | _ => false end. -Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10) : bool_scope. +Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10). -Check (false && I 3)%bool /\ (I 6)%bool. +Check (false && I 3)%bool /\ I 6. (**********************************************************************) (* Check notations with several recursive patterns *) diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v index 923caedace..bcb2468792 100644 --- a/test-suite/output/Notations2.v +++ b/test-suite/output/Notations2.v @@ -71,7 +71,6 @@ Check let' f x y (a:=0) z (b:bool) := x+y+z+1 in f 0 1 2. (* Note: does not work for pattern *) Module A. Notation "f ( x )" := (f x) (at level 10, format "f ( x )"). -Open Scope nat_scope. Check fun f x => f x + S x. Open Scope list_scope. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 015dac2512..d32cf67e28 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -128,27 +128,25 @@ return (1, 2, 3, 4) : nat *(1.2) : nat -! '{{x, y}}, x + y = 0 +! '{{x, y}}, x.y = 0 : Prop exists x : nat, nat -> exists y : nat, - nat -> - exists '{{u, t}}, forall z1 : nat, z1 = 0 /\ x + y = 0 /\ u + t = 0 + nat -> exists '{{u, t}}, forall z1 : nat, z1 = 0 /\ x.y = 0 /\ u.t = 0 : Prop exists x : nat, nat -> exists y : nat, - nat -> - exists '{{z, t}}, forall z2 : nat, z2 = 0 /\ x + y = 0 /\ z + t = 0 + nat -> exists '{{z, t}}, forall z2 : nat, z2 = 0 /\ x.y = 0 /\ z.t = 0 : Prop -exists_true '{{x, y}} (u := 0) '{{z, t}}, x + y = 0 /\ z + t = 0 +exists_true '{{x, y}} (u := 0) '{{z, t}}, x.y = 0 /\ z.t = 0 : Prop exists_true (A : Type) (R : A -> A -> Prop) (_ : Reflexive R), (forall x : A, R x x) : Prop exists_true (x : nat) (A : Type) (R : A -> A -> Prop) -(_ : Reflexive R) (y : nat), x + y = 0 -> forall z : A, R z z +(_ : Reflexive R) (y : nat), x.y = 0 -> forall z : A, R z z : Prop {{{{True, nat -> True}}, nat -> True}} : Prop * Prop * Prop @@ -184,22 +182,22 @@ pair (prod nat (prod nat nat))) (prod (prod nat nat) nat) fun x : nat => if x is n .+ 1 then n else 1 : nat -> nat -{'{{x, y}} : nat * nat | x + y = 0} +{'{{x, y}} : nat * nat | x.y = 0} : Set exists2' {{x, y}}, x = 0 & y = 0 : Prop myexists2 x : nat * nat, let '{{y, z}} := x in y > z & let '{{y, z}} := x in z > y : Prop -fun '({{x, y}} as z) => x + y = 0 /\ z = z +fun '({{x, y}} as z) => x.y = 0 /\ z = z : nat * nat -> Prop -myexists ({{x, y}} as z), x + y = 0 /\ z = z +myexists ({{x, y}} as z), x.y = 0 /\ z = z : Prop -exists '({{x, y}} as z), x + y = 0 /\ z = z +exists '({{x, y}} as z), x.y = 0 /\ z = z : Prop -∀ '({{x, y}} as z), x + y = 0 /\ z = z +∀ '({{x, y}} as z), x.y = 0 /\ z = z : Prop -fun '({{{{x, y}}, true}} | {{{{x, y}}, false}}) => x + y +fun '({{{{x, y}}, true}} | {{{{x, y}}, false}}) => x.y : nat * nat * bool -> nat myexists ({{{{x, y}}, true}} | {{{{x, y}}, false}}), x > y : Prop @@ -211,17 +209,17 @@ fun p : nat => if p is S n then n else 0 : nat -> nat fun p : comparison => if p is Lt then 1 else 0 : comparison -> nat -fun S : nat => [S | S + S] +fun S : nat => [S | S.S] : nat -> nat * (nat -> nat) -fun N : nat => [N | N + 0] +fun N : nat => [N | N.0] : nat -> nat * (nat -> nat) -fun S : nat => [[S | S + S]] +fun S : nat => [[S | S.S]] : nat -> nat * (nat -> nat) {I : nat | I = I} : Set {'I : True | I = I} : Prop -{'{{x, y}} : nat * nat | x + y = 0} +{'{{x, y}} : nat * nat | x.y = 0} : Set exists2 '{{y, z}} : nat * nat, y > z & z > y : Prop @@ -254,13 +252,3 @@ myfoo01 tt : nat myfoo01 tt : nat -[{0; 0}] - : list (list nat) -[{1; 2; 3}; - {4; 5; 6}; - {7; 8; 9}] - : list (list nat) -amatch = mmatch 0 (with 0 => 1| 1 => 2 end) - : unit -alist = [0; 1; 2] - : list nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 2caffad1d9..dcc8bd7165 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -59,7 +59,7 @@ Check fun f => CURRYINVLEFT (x:nat) (y:bool), f. (* Notations with variables bound both as a term and as a binder *) (* This is #4592 *) -Notation "{# x | P }" := (ex2 (fun y => x = y) (fun x => P)) : type_scope. +Notation "{# x | P }" := (ex2 (fun y => x = y) (fun x => P)). Check forall n:nat, {# n | 1 > n}. Parameter foo : forall {T}(x : T)(P : T -> Prop), Prop. @@ -183,13 +183,9 @@ Check letpair x [1] = {0}; return (1,2,3,4). (* Test spacing in #5569 *) -Section S1. -Variable plus : nat -> nat -> nat. -Infix "+" := plus. Notation "{ { xL | xR // xcut } }" := (xL+xR+xcut) (at level 0, xR at level 39, format "{ { xL | xR // xcut } }"). Check 1+1+1. -End S1. (* Test presence of notation variables in the recursive parts (introduced in dfdaf4de) *) Notation "!!! x .. y , b" := ((fun x => b), .. ((fun y => b), True) ..) (at level 200, x binder). @@ -197,12 +193,10 @@ Check !!! (x y:nat), True. (* Allow level for leftmost nonterminal when printing-only, BZ#5739 *) -Section S2. -Notation "* x" := (id x) (only printing, at level 15, format "* x") : nat_scope. -Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y") : nat_scope. +Notation "* x" := (id x) (only printing, at level 15, format "* x"). +Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y"). Check (((id 1) + 2) + 3). Check (id (1 + 2)). -End S2. (* Test contraction of "forall x, let 'pat := x in ..." into "forall 'pat, ..." *) (* for isolated "forall" (was not working already in 8.6) *) @@ -416,58 +410,3 @@ Check myfoo0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] Check myfoo01 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) End Issue8126. - -(* Test printing of notations guided by scope *) - -Module A. - -Declare Scope line_scope. -Delimit Scope line_scope with line. -Declare Scope matx_scope. -Notation "{ }" := nil (format "{ }") : line_scope. -Notation "{ x }" := (cons x nil) : line_scope. -Notation "{ x ; y ; .. ; z }" := (cons x (cons y .. (cons z nil) ..)) : line_scope. -Notation "[ ]" := nil (format "[ ]") : matx_scope. -Notation "[ l ]" := (cons l%line nil) : matx_scope. -Notation "[ l ; l' ; .. ; l'' ]" := (cons l%line (cons l'%line .. (cons l''%line nil) ..)) - (format "[ '[v' l ; '/' l' ; '/' .. ; '/' l'' ']' ]") : matx_scope. - -Open Scope matx_scope. -Check [[0;0]]. -Check [[1;2;3];[4;5;6];[7;8;9]]. - -End A. - -(* Example by Beta Ziliani *) - -Require Import Lists.List. - -Module B. - -Import ListNotations. - -Declare Scope pattern_scope. -Delimit Scope pattern_scope with pattern. - -Declare Scope patterns_scope. -Delimit Scope patterns_scope with patterns. - -Notation "a => b" := (a, b) (at level 201) : pattern_scope. -Notation "'with' p1 | .. | pn 'end'" := - ((cons p1%pattern (.. (cons pn%pattern nil) ..))) - (at level 91, p1 at level 210, pn at level 210) : patterns_scope. - -Definition mymatch (n:nat) (l : list (nat * nat)) := tt. -Arguments mymatch _ _%patterns. -Notation "'mmatch' n ls" := (mymatch n ls) (at level 0). - -Close Scope patterns_scope. -Close Scope pattern_scope. - -Definition amatch := mmatch 0 with 0 => 1 | 1 => 2 end. -Print amatch. (* Good: amatch = mmatch 0 (with 0 => 1| 1 => 2 end) *) - -Definition alist := [0;1;2]. -Print alist. - -End B. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 5bf4ec7bfb..9d972a68f7 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -21,36 +21,10 @@ Let "x" e1 e2 : expr Let "x" e1 e2 : expr -fun x : nat => (# x)%nat - : nat -> nat -fun x : nat => ## x - : nat -> nat -fun x : nat => # x - : nat -> nat -fun x : nat => ### x - : nat -> nat -fun x : nat => ## x - : nat -> nat -fun x : nat => (x.-1)%pred - : nat -> nat -∀ a : nat, a = 0 - : Prop -((∀ a : nat, a = 0) -> True)%type - : Prop -# - : Prop -# -> True - : Prop -((∀ a : nat, a = 0) -> True)%type - : Prop -## - : Prop myAnd1 True True : Prop r 2 3 : Prop -Notation Cn := Foo.FooCn -Expands to: Notation Notations4.J.Mfoo.Foo.Bar.Cn let v := 0%test17 in v : myint63 : myint63 fun y : nat => # (x, z) |-> y & y diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index b33ad17ed4..81c64418cb 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -5,8 +5,8 @@ Module A. Declare Custom Entry myconstr. Notation "[ x ]" := x (x custom myconstr at level 6). -Notation "x + y" := (Nat.add x y) (in custom myconstr at level 5) : nat_scope. -Notation "x * y" := (Nat.mul x y) (in custom myconstr at level 4) : nat_scope. +Notation "x + y" := (Nat.add x y) (in custom myconstr at level 5). +Notation "x * y" := (Nat.mul x y) (in custom myconstr at level 4). Notation "< x >" := x (in custom myconstr at level 3, x constr at level 10). Check [ < 0 > + < 1 > * < 2 >]. @@ -95,76 +95,6 @@ Check (Let "x" e1 e2). End D. -(* Check fix of #8551: a delimiter should be inserted because the - lonely notation hides the scope nat_scope, even though the latter - is open *) - -Module E. - -Notation "# x" := (S x) (at level 20) : nat_scope. -Notation "# x" := (Some x). -Check fun x => (# x)%nat. - -End E. - -(* Other tests of precedence *) - -Module F. - -Notation "# x" := (S x) (at level 20) : nat_scope. -Notation "## x" := (S x) (at level 20). -Check fun x => S x. -Open Scope nat_scope. -Check fun x => S x. -Notation "### x" := (S x) (at level 20) : nat_scope. -Check fun x => S x. -Close Scope nat_scope. -Check fun x => S x. - -End F. - -(* Lower priority of generic application rules *) - -Module G. - -Declare Scope predecessor_scope. -Delimit Scope predecessor_scope with pred. -Declare Scope app_scope. -Delimit Scope app_scope with app. -Notation "x .-1" := (Nat.pred x) (at level 10, format "x .-1") : predecessor_scope. -Notation "f ( x )" := (f x) (at level 10, format "f ( x )") : app_scope. -Check fun x => pred x. - -End G. - -(* Checking arbitration between in the presence of a notation in type scope *) - -Module H. - -Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) - (at level 200, x binder, y binder, right associativity, - format "'[ ' '[ ' ∀ x .. y ']' , '/' P ']'") : type_scope. -Check forall a, a = 0. - -Close Scope type_scope. -Check ((forall a, a = 0) -> True)%type. -Open Scope type_scope. - -Notation "#" := (forall a, a = 0). -Check #. -Check # -> True. - -Close Scope type_scope. -Check (# -> True)%type. -Open Scope type_scope. - -Declare Scope my_scope. -Notation "##" := (forall a, a = 0) : my_scope. -Open Scope my_scope. -Check ##. - -End H. - (* Fixing bugs reported by G. Gonthier in #9207 *) Module I. @@ -181,23 +111,6 @@ Check r 2 3. End I. -(* Fixing a bug reported by G. Gonthier in #9207 *) - -Module J. - -Module Import Mfoo. -Module Foo. -Definition FooCn := 2. -Module Bar. -Notation Cn := FooCn. -End Bar. -End Foo. -Export Foo.Bar. -End Mfoo. -About Cn. - -End J. - Require Import Coq.Numbers.Cyclic.Int63.Int63. Module NumeralNotations. Module Test17. diff --git a/test-suite/output/Quote.out b/test-suite/output/Quote.out deleted file mode 100644 index 998eb37cc8..0000000000 --- a/test-suite/output/Quote.out +++ /dev/null @@ -1,24 +0,0 @@ -(interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx)) -(interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop)) - (f_and (f_const A) - (f_and (f_or (f_atom End_idx) (f_const A)) - (f_or (f_const A) (f_not (f_atom End_idx)))))) -1 subgoal - - H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/ - B - ============================ - interp_f - (Node_vm B (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (Empty_vm Prop)) - (f_and (f_atom (Left_idx End_idx)) - (f_and (f_or (f_atom End_idx) (f_atom (Left_idx End_idx))) - (f_or (f_atom (Left_idx End_idx)) (f_not (f_atom End_idx))))) -1 subgoal - - H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/ - B - ============================ - interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop)) - (f_and (f_const A) - (f_and (f_or (f_atom End_idx) (f_const A)) - (f_or (f_const A) (f_not (f_atom End_idx))))) diff --git a/test-suite/output/bug_9180.out b/test-suite/output/bug_9180.out new file mode 100644 index 0000000000..ed4892b389 --- /dev/null +++ b/test-suite/output/bug_9180.out @@ -0,0 +1,4 @@ +Notation +"n .+1" := S n : nat_scope (default interpretation) +forall x : nat, x.+1 = x.+1 + : Prop diff --git a/test-suite/output/bug_9180.v b/test-suite/output/bug_9180.v new file mode 100644 index 0000000000..f221a94a50 --- /dev/null +++ b/test-suite/output/bug_9180.v @@ -0,0 +1,11 @@ +Notation succn := (Datatypes.S). + +Notation "n .+1" := (succn n) (at level 2, left associativity, + format "n .+1") : nat_scope. + +Locate ".+1". +(* Notation *) +(* "n .+1" := S n : nat_scope (default interpretation) *) +(** so Coq does not apply succn notation *) + +Check forall x : nat, x.+1 = x.+1. diff --git a/test-suite/output/ssr_under.out b/test-suite/output/ssr_under.out new file mode 100644 index 0000000000..499d25391e --- /dev/null +++ b/test-suite/output/ssr_under.out @@ -0,0 +1,4 @@ +'Under[ m - m ] +(G (fun _ : nat => 0) n >= 0) +'Under[ r = R0 \/ E r ] +(Rbar_le Rbar0 (Lub_Rbar (fun r : R => r = R0 \/ E r))) diff --git a/test-suite/output/ssr_under.v b/test-suite/output/ssr_under.v new file mode 100644 index 0000000000..fb7503d902 --- /dev/null +++ b/test-suite/output/ssr_under.v @@ -0,0 +1,30 @@ +From Coq Require Import ssreflect. + +Axiom subnn : forall n : nat, n - n = 0. +Parameter G : (nat -> nat) -> nat -> nat. +Axiom eq_G : + forall F1 F2 : nat -> nat, + (forall n : nat, F1 n = F2 n) -> + forall n : nat, G F1 n = G F2 n. + +Ltac show := match goal with [|-?g] => idtac g end. + +Lemma example_G (n : nat) : G (fun n => n - n) n >= 0. +under eq_G => m do [show; rewrite subnn]. +show. +Abort. + +Parameters (R Rbar : Set) (R0 : R) (Rbar0 : Rbar). +Parameter Rbar_le : Rbar -> Rbar -> Prop. +Parameter Lub_Rbar : (R -> Prop) -> Rbar. +Parameter Lub_Rbar_eqset : + forall E1 E2 : R -> Prop, + (forall x : R, E1 x <-> E2 x) -> + Lub_Rbar E1 = Lub_Rbar E2. + +Lemma test_Lub_Rbar (E : R -> Prop) : + Rbar_le Rbar0 (Lub_Rbar (fun x => x = R0 \/ E x)). +Proof. +under Lub_Rbar_eqset => r do show. +show. +Abort. diff --git a/test-suite/prerequisite/ssr_mini_mathcomp.v b/test-suite/prerequisite/ssr_mini_mathcomp.v index cb2c56736c..6fc630056c 100644 --- a/test-suite/prerequisite/ssr_mini_mathcomp.v +++ b/test-suite/prerequisite/ssr_mini_mathcomp.v @@ -427,6 +427,8 @@ Lemma leqnSn n : n <= n.+1. Proof. by elim: n. Qed. Lemma leq_trans n m p : m <= n -> n <= p -> m <= p. Admitted. +Lemma leq_ltn_trans n m p : m <= n -> n < p -> m < p. +Admitted. Lemma leqW m n : m <= n -> m <= n.+1. Admitted. Hint Resolve leqnSn. @@ -632,9 +634,9 @@ Fixpoint mem_seq (s : seq T) := Definition eqseq_class := seq T. Identity Coercion seq_of_eqseq : eqseq_class >-> seq. -Coercion pred_of_eq_seq (s : eqseq_class) : pred_class := [eta mem_seq s]. +Coercion pred_of_eq_seq (s : eqseq_class) : {pred T} := [eta mem_seq s]. -Canonical seq_predType := @mkPredType T (seq T) pred_of_eq_seq. +Canonical seq_predType := @PredType T (seq T) pred_of_eq_seq. Fixpoint uniq s := if s is x :: s' then (x \notin s') && uniq s' else true. diff --git a/test-suite/ssr/nonPropType.v b/test-suite/ssr/nonPropType.v new file mode 100644 index 0000000000..bcdc907b38 --- /dev/null +++ b/test-suite/ssr/nonPropType.v @@ -0,0 +1,23 @@ +Require Import ssreflect. + +(** Test the nonPropType interface and its application to prevent unwanted + instantiations in views. **) + +Lemma raw_flip {T} (x y : T) : x = y -> y = x. Proof. by []. Qed. +Lemma flip {T : nonPropType} (x y : T) : x = y -> y = x. Proof. by []. Qed. + +Lemma testSet : true = false -> True. +Proof. +Fail move/raw_flip. +have flip_true := @flip _ true. +(* flip_true : forall y : notProp bool, x = y -> y = x *) +simpl in flip_true. +(* flip_true : forall y : bool, x = y -> y = x *) +by move/flip. +Qed. + +Lemma override (t1 t2 : True) : t1 = t2 -> True. +Proof. +Fail move/flip. +by move/(@flip (notProp True)). +Qed. diff --git a/test-suite/ssr/over.v b/test-suite/ssr/over.v new file mode 100644 index 0000000000..8232741b0d --- /dev/null +++ b/test-suite/ssr/over.v @@ -0,0 +1,70 @@ +Require Import ssreflect. + +Axiom daemon : False. Ltac myadmit := case: daemon. + +(** Testing over for the 1-var case *) + +Lemma test_over_1_1 : False. +intros. +evar (I : Type); evar (R : Type); evar (x2 : I -> R). +assert (H : forall i : nat, i + 2 * i - i = x2 i). + intros i. + unfold x2 in *; clear x2; + unfold R in *; clear R; + unfold I in *; clear I. + apply Under_eq_from_eq. + Fail done. + + over. + myadmit. +Qed. + +Lemma test_over_1_2 : False. +intros. +evar (I : Type); evar (R : Type); evar (x2 : I -> R). +assert (H : forall i : nat, i + 2 * i - i = x2 i). + intros i. + unfold x2 in *; clear x2; + unfold R in *; clear R; + unfold I in *; clear I. + apply Under_eq_from_eq. + Fail done. + + by rewrite over. + myadmit. +Qed. + +(** Testing over for the 2-var case *) + +Lemma test_over_2_1 : False. +intros. +evar (I : Type); evar (J : Type); evar (R : Type); evar (x2 : I -> J -> R). +assert (H : forall i j, i + 2 * j - i = x2 i j). + intros i j. + unfold x2 in *; clear x2; + unfold R in *; clear R; + unfold J in *; clear J; + unfold I in *; clear I. + apply Under_eq_from_eq. + Fail done. + + over. + myadmit. +Qed. + +Lemma test_over_2_2 : False. +intros. +evar (I : Type); evar (J : Type); evar (R : Type); evar (x2 : I -> J -> R). +assert (H : forall i j : nat, i + 2 * j - i = x2 i j). + intros i j. + unfold x2 in *; clear x2; + unfold R in *; clear R; + unfold J in *; clear J; + unfold I in *; clear I. + apply Under_eq_from_eq. + Fail done. + + rewrite over. + done. + myadmit. +Qed. diff --git a/test-suite/ssr/predRewrite.v b/test-suite/ssr/predRewrite.v new file mode 100644 index 0000000000..2ad762ccf1 --- /dev/null +++ b/test-suite/ssr/predRewrite.v @@ -0,0 +1,28 @@ +Require Import ssreflect ssrfun ssrbool. + +(** Test the various idioms that control rewriting in boolean predicate. **) + +Definition simpl_P := [pred a | ~~ a]. +Definition nosimpl_P : pred bool := [pred a | ~~ a]. +Definition coll_P : collective_pred bool := [pred a | ~~ a]. +Definition appl_P : applicative_pred bool := [pred a | ~~ a]. +Definition can_appl_P : pred bool := [pred a | ~~ a]. +Canonical register_can_appl_P := ApplicativePred can_appl_P. +Ltac see_neg := (let x := fresh "x" in set x := {-}(~~ _); clear x). + +Lemma test_pred_rewrite (f := false) : True. +Proof. +have _: f \in simpl_P by rewrite inE; see_neg. +have _ a: simpl_P (a && f) by simpl; see_neg; rewrite andbF. +have _ a: simpl_P (a && f) by rewrite inE; see_neg; rewrite andbF. +have _: f \in nosimpl_P by rewrite inE; see_neg. +have _: nosimpl_P f. simpl. Fail see_neg. Fail rewrite inE. done. +have _: f \in coll_P. Fail rewrite inE. by rewrite in_collective; see_neg. +have _: f \in appl_P. + rewrite inE. Fail see_neg. Fail rewrite inE. simpl. Fail see_neg. + Fail rewrite app_predE. done. +have _: f \in can_appl_P. + rewrite inE. Fail see_neg. Fail rewrite inE. simpl. Fail see_neg. + by rewrite app_predE in_simpl; see_neg. +done. +Qed. diff --git a/test-suite/ssr/under.v b/test-suite/ssr/under.v new file mode 100644 index 0000000000..f285ad138b --- /dev/null +++ b/test-suite/ssr/under.v @@ -0,0 +1,234 @@ +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. +Global Unset SsrOldRewriteGoalsOrder. + +(* under <names>: {occs}[patt]<lemma>. + under <names>: {occs}[patt]<lemma> by tac1. + under <names>: {occs}[patt]<lemma> by [tac1 | ...]. + *) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Axiom daemon : False. Ltac myadmit := case: daemon. + +Module Mocks. + +(* Mock bigop.v definitions to test the behavior of under with bigops + without requiring mathcomp *) + +Definition eqfun := + fun (A B : Type) (f g : forall _ : B, A) => forall x : B, @eq A (f x) (g x). + +Section Defix. +Variables (T : Type) (n : nat) (f : forall _ : T, T) (x : T). +Fixpoint loop (m : nat) : T := + match m return T with + | O => x + | S i => f (loop i) + end. +Definition iter := loop n. +End Defix. + +Parameter eq_bigl : + forall (R : Type) (idx : R) (op : forall (_ : R) (_ : R), R) (I : Type) + (r : list I) (P1 P2 : pred I) (F : forall _ : I, R) (_ : @eqfun bool I P1 P2), + @eq R (@bigop R I idx r (fun i : I => @BigBody R I i op (P1 i) (F i))) + (@bigop R I idx r (fun i : I => @BigBody R I i op (P2 i) (F i))). + +Parameter eq_big : + forall (R : Type) (idx : R) (op : forall (_ : R) (_ : R), R) (I : Type) + (r : list I) (P1 P2 : pred I) (F1 F2 : forall _ : I, R) (_ : @eqfun bool I P1 P2) + (_ : forall (i : I) (_ : is_true (P1 i)), @eq R (F1 i) (F2 i)), + @eq R (@bigop R I idx r (fun i : I => @BigBody R I i op (P1 i) (F1 i))) + (@bigop R I idx r (fun i : I => @BigBody R I i op (P2 i) (F2 i))). + +Parameter eq_bigr : + forall (R : Type) (idx : R) (op : forall (_ : R) (_ : R), R) (I : Type) + (r : list I) (P : pred I) (F1 F2 : forall _ : I, R) + (_ : forall (i : I) (_ : is_true (P i)), @eq R (F1 i) (F2 i)), + @eq R (@bigop R I idx r (fun i : I => @BigBody R I i op (P i) (F1 i))) + (@bigop R I idx r (fun i : I => @BigBody R I i op (P i) (F2 i))). + +Parameter big_const_nat : + forall (R : Type) (idx : R) (op : forall (_ : R) (_ : R), R) (m n : nat) (x : R), + @eq R (@bigop R nat idx (index_iota m n) (fun i : nat => @BigBody R nat i op true x)) + (@iter R (subn n m) (op x) idx). + +Delimit Scope N_scope with num. +Delimit Scope nat_scope with N. + +Reserved Notation "\sum_ ( m <= i < n | P ) F" + (at level 41, F at level 41, i, m, n at level 50, + format "'[' \sum_ ( m <= i < n | P ) '/ ' F ']'"). +Reserved Notation "\sum_ ( m <= i < n ) F" + (at level 41, F at level 41, i, m, n at level 50, + format "'[' \sum_ ( m <= i < n ) '/ ' F ']'"). + +Local Notation "+%N" := addn (at level 0, only parsing). + +Notation "\sum_ ( m <= i < n | P ) F" := + (\big[+%N/0%N]_(m <= i < n | P%B) F%N) : (*nat_scope*) big_scope. +Notation "\sum_ ( m <= i < n ) F" := + (\big[+%N/0%N]_(m <= i < n) F%N) : (*nat_scope*) big_scope. + +Parameter iter_addn_0 : forall m n : nat, @eq nat (@iter nat n (addn m) O) (muln m n). + +End Mocks. + +Import Mocks. + +(*****************************************************************************) + +Lemma test_big_nested_1 (F G : nat -> nat) (m n : nat) : + \sum_(0 <= i < m) \sum_(0 <= j < n | odd (j * 1)) (i + j) = + \sum_(0 <= i < m) \sum_(0 <= j < n | odd j) (j + i). +Proof. +(* in interactive mode *) +under eq_bigr => i Hi. + under eq_big => [j|j Hj]. + { rewrite muln1. over. } + { rewrite addnC. over. } + simpl. (* or: cbv beta. *) + over. +by []. +Qed. + +Lemma test_big_nested_2 (F G : nat -> nat) (m n : nat) : + \sum_(0 <= i < m) \sum_(0 <= j < n | odd (j * 1)) (i + j) = + \sum_(0 <= i < m) \sum_(0 <= j < n | odd j) (j + i). +Proof. +(* in one-liner mode *) +under eq_bigr => i Hi do under eq_big => [j|j Hj] do [rewrite muln1 | rewrite addnC ]. +done. +Qed. + +Lemma test_big_2cond_0intro (F : nat -> nat) (m : nat) : + \sum_(0 <= i < m | odd (i + 1)) (i + 2) >= 0. +Proof. +(* in interactive mode *) +under eq_big. +{ move=> n; rewrite (addnC n 1); over. } +{ move=> i Hi; rewrite (addnC i 2); over. } +done. +Qed. + +Lemma test_big_2cond_1intro (F : nat -> nat) (m : nat) : + \sum_(0 <= i < m | odd (i + 1)) (i + 2) >= 0. +Proof. +(* in interactive mode *) +Fail under eq_big => i. +(* as it amounts to [under eq_big => [i]] *) +Abort. + +Lemma test_big_2cond_all (F : nat -> nat) (m : nat) : + \sum_(0 <= i < m | odd (i + 1)) (i + 2) >= 0. +Proof. +(* in interactive mode *) +Fail under eq_big => *. +(* as it amounts to [under eq_big => [*]] *) +Abort. + +Lemma test_big_2cond_all_implied (F : nat -> nat) (m : nat) : + \sum_(0 <= i < m | odd (i + 1)) (i + 2) >= 0. +Proof. +(* in one-liner mode *) +under eq_big do [rewrite addnC + |rewrite addnC]. +(* amounts to [under eq_big => [*|*] do [...|...]] *) +done. +Qed. + +Lemma test_big_patt1 (F G : nat -> nat) (n : nat) : + \sum_(0 <= i < n) (F i + G i) = \sum_(0 <= i < n) (G i + F i) + 0. +Proof. +under [in RHS]eq_bigr => i Hi. + by rewrite addnC over. +done. +Qed. + +Lemma test_big_patt2 (F G : nat -> nat) (n : nat) : + \sum_(0 <= i < n) (F i + F i) = + \sum_(0 <= i < n) 0 + \sum_(0 <= i < n) (F i * 2). +Proof. +under [X in _ = _ + X]eq_bigr => i Hi do rewrite mulnS muln1. +by rewrite big_const_nat iter_addn_0. +Qed. + +Lemma test_big_occs (F G : nat -> nat) (n : nat) : + \sum_(0 <= i < n) (i * 0) = \sum_(0 <= i < n) (i * 0) + \sum_(0 <= i < n) (i * 0). +Proof. +under {2}[in RHS]eq_bigr => i Hi do rewrite muln0. +by rewrite big_const_nat iter_addn_0. +Qed. + +(* Solely used, one such renaming is useless in practice, but it works anyway *) +Lemma test_big_cosmetic (F G : nat -> nat) (m n : nat) : + \sum_(0 <= i < m) \sum_(0 <= j < n | odd (j * 1)) (i + j) = + \sum_(0 <= i < m) \sum_(0 <= j < n | odd j) (j + i). +Proof. +under [RHS]eq_bigr => a A do under eq_bigr => b B do []. (* renaming bound vars *) +myadmit. +Qed. + +Lemma test_big_andb (F : nat -> nat) (m n : nat) : + \sum_(0 <= i < 5 | odd i && (i == 1)) i = 1. +Proof. +under eq_bigl => i do [rewrite andb_idl; first by move/eqP->]. +under eq_bigr => i do move/eqP=>{1}->. (* the 2nd occ should not be touched *) +myadmit. +Qed. + +Lemma test_foo (f1 f2 : nat -> nat) (f_eq : forall n, f1 n = f2 n) + (G : (nat -> nat) -> nat) + (Lem : forall f1 f2 : nat -> nat, + True -> + (forall n, f1 n = f2 n) -> + False = False -> + G f1 = G f2) : + G f1 = G f2. +Proof. +(* +under x: Lem. +- done. +- rewrite f_eq; over. +- done. + *) +under Lem => [|x|] do [done|rewrite f_eq|done]. +done. +Qed. + + +(* Inspired From Coquelicot.Lub. *) +(* http://coquelicot.saclay.inria.fr/html/Coquelicot.Lub.html#Lub_Rbar_eqset *) + +Parameters (R Rbar : Set) (R0 : R) (Rbar0 : Rbar). +Parameter Rbar_le : Rbar -> Rbar -> Prop. +Parameter Lub_Rbar : (R -> Prop) -> Rbar. +Parameter Lub_Rbar_eqset : + forall E1 E2 : R -> Prop, + (forall x : R, E1 x <-> E2 x) -> + Lub_Rbar E1 = Lub_Rbar E2. + +Lemma test_Lub_Rbar (E : R -> Prop) : + Rbar_le Rbar0 (Lub_Rbar (fun x => x = R0 \/ E x)). +Proof. +under Lub_Rbar_eqset => r. +by rewrite over. +Abort. + + +Lemma ex_iff R (P1 P2 : R -> Prop) : + (forall x : R, P1 x <-> P2 x) -> ((exists x, P1 x) <-> (exists x, P2 x)). +Proof. +by move=> H; split; move=> [x Hx]; exists x; apply H. +Qed. + +Arguments ex_iff [R P1] P2 iffP12. + +Require Import Setoid. +Lemma test_ex_iff (P : nat -> Prop) : (exists x, P x) -> True. +under ex_iff => n. +by rewrite over. +Abort. diff --git a/test-suite/success/change.v b/test-suite/success/change.v index a9821b027f..2f676cf9ad 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -68,3 +68,16 @@ eassumption. match goal with |- ?x=1 => change (x=1) with (0+x=1) end. match goal with |- 0+1=1 => trivial end. Qed. + +(* Mini-check that no_check does not check *) + +Goal True -> False. +intro H. +change_no_check nat. +apply S. +change_no_check nat with bool. +change_no_check nat in H. +change_no_check nat with (bool->bool) in H. +exact (H true). +Fail Qed. +Abort. diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index c738b57f44..0f63855b55 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -212,3 +212,14 @@ Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. Defined. End PairUsualDecidableType. + +(** And also for pairs of UsualDecidableTypeFull *) + +Module PairUsualDecidableTypeFull (D1 D2:UsualDecidableTypeFull) + <: UsualDecidableTypeFull. + + Module M := PairUsualDecidableType D1 D2. + Include Backport_DT (M). + Include HasEqDec2Bool. + +End PairUsualDecidableTypeFull. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 0236c549d5..2ec55d1bd0 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -38,6 +38,7 @@ DOCDIR := $(COQMF_DOCDIR) OCAMLFIND := $(COQMF_OCAMLFIND) CAMLFLAGS := $(COQMF_CAMLFLAGS) HASNATDYNLINK := $(COQMF_HASNATDYNLINK) +OCAMLWARN := $(COQMF_WARN) @CONF_FILE@: @PROJECT_FILE@ @COQ_MAKEFILE_INVOCATION@ @@ -176,7 +177,7 @@ COQCHKEXTRAFLAGS?= COQDOCEXTRAFLAGS?= # these flags do NOT contain the libraries, to make them easier to overwrite -COQFLAGS?=-q $(OPT) $(OTHERFLAGS) $(COQEXTRAFLAGS) +COQFLAGS?=-q $(OTHERFLAGS) $(COQEXTRAFLAGS) COQCHKFLAGS?=-silent -o $(COQCHKEXTRAFLAGS) COQDOCFLAGS?=-interpolate -utf8 $(COQDOCEXTRAFLAGS) @@ -190,9 +191,9 @@ COQMAKEFILE_VERSION:=@COQ_VERSION@ COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) - # ocamldoc fails with unknown argument otherwise -CAMLDOCFLAGS=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) +CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) +CAMLFLAGS+=$(OCAMLWARN) ifneq (,$(TIMING)) TIMING_ARG=-time diff --git a/topbin/dune b/topbin/dune index e35a3de54b..3b861afe78 100644 --- a/topbin/dune +++ b/topbin/dune @@ -28,6 +28,11 @@ (libraries coq.toplevel) (link_flags -linkall)) +(install + (section bin) + (package coq) + (files (coqc_bin.bc as coqc.byte))) + ; Workers (executables (names coqqueryworker_bin coqtacticworker_bin coqproofworker_bin) diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 416ea88c1b..8934385091 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -85,7 +85,7 @@ let ensure_exists f = let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = - let pfs = Vernacstate.Proof_global.get_all_proof_names () in + let pfs = Vernacstate.Proof_global.get_all_proof_names () [@ocaml.warning "-3"] in if not (CList.is_empty pfs) then fatal_error (str "There are pending proofs: " ++ (pfs diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 319f5c8ad6..9a18baa0bc 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -34,7 +34,7 @@ let set_type_in_type () = (******************************************************************************) -type color = [`ON | `AUTO | `OFF] +type color = [`ON | `AUTO | `EMACS | `OFF] type native_compiler = NativeOff | NativeOn of { ondemand : bool } @@ -171,7 +171,7 @@ let add_load_vernacular opts verb s = (** Options for proof general *) let set_emacs opts = Printer.enable_goal_tags_printing := true; - { opts with color = `OFF; print_emacs = true } + { opts with color = `EMACS; print_emacs = true } let set_color opts = function | "yes" | "on" -> { opts with color = `ON } diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 9bcfdca332..d7f9819bee 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type color = [`ON | `AUTO | `OFF] +type color = [`ON | `AUTO | `EMACS | `OFF] val default_toplevel : Names.DirPath.t diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 4129562065..de447db51f 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -194,6 +194,7 @@ let make_prompt () = (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) ^ " < " with Vernacstate.Proof_global.NoCurrentProof -> "Coq < " + [@@ocaml.warning "-3"] (* the coq prompt added to the default one when in emacs mode The prompt contains the current state label [n] (for global @@ -278,7 +279,7 @@ let extract_default_loc loc doc_id sid : Loc.t option = | None -> try let doc = Stm.get_doc doc_id in - Option.cata fst None Stm.(get_ast ~doc sid) + Option.cata (fun {CAst.loc} -> loc) None Stm.(get_ast ~doc sid) with _ -> loc (** Coqloop Console feedback handler *) @@ -363,6 +364,7 @@ let top_goal_print ~doc c oldp newp = let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer + [@@ocaml.warning "-3"] let exit_on_error = let open Goptions in @@ -381,22 +383,22 @@ let rec vernac_loop ~state = try let input = top_buffer.tokens in match read_sentence ~state input with - | Some { v = VernacBacktrack(bid,_,_) } -> + | Some (VernacBacktrack(bid,_,_)) -> let bid = Stateid.of_int bid in let doc, res = Stm.edit_at ~doc:state.doc bid in assert (res = `NewTip); let state = { state with doc; sid = bid } in vernac_loop ~state - | Some { v = VernacQuit } -> + | Some VernacQuit -> exit 0 - | Some { v = VernacDrop } -> + | Some VernacDrop -> if Mltop.is_ocaml_top() then (drop_last_doc := Some state; state) else (Feedback.msg_warning (str "There is no ML toplevel."); vernac_loop ~state) - | Some { v = VernacControl c; loc } -> + | Some VernacControl { loc; v=c } -> let nstate = Vernac.process_expr ~state (make ?loc c) in top_goal_print ~doc:state.doc c state.proof nstate.proof; vernac_loop ~state:nstate diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 8fae561be8..9323a57417 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -113,6 +113,7 @@ let fatal_error_exn exn = let init_color opts = let has_color = match opts.color with | `OFF -> false + | `EMACS -> false | `ON -> true | `AUTO -> Terminal.has_style Unix.stdout && @@ -133,10 +134,13 @@ let init_color opts = Topfmt.default_styles (); false (* textual markers, no color *) end in - if not term_color then - Proof_diffs.write_color_enabled term_color; - if Proof_diffs.show_diffs () && not term_color then - (prerr_endline "Error: -diffs requires enabling -color"; exit 1); + if opts.color = `EMACS then + Topfmt.set_emacs_print_strings () + else if not term_color then begin + Proof_diffs.write_color_enabled term_color; + if Proof_diffs.show_diffs () then + (prerr_endline "Error: -diffs requires enabling -color"; exit 1) + end; Topfmt.init_terminal_output ~color:term_color let print_style_tags opts = @@ -220,7 +224,6 @@ let init_toplevel ~help ~init custom_init arglist = let top_lp = Coqinit.toplevel_init_load_path () in List.iter Mltop.add_coq_path top_lp; let opts, extras = custom_init ~opts extras in - Flags.if_verbose print_header (); Mltop.init_known_plugins (); Global.set_engagement opts.impredicative_set; @@ -296,6 +299,7 @@ let rec coqc_deprecated_check args acc extras = let coqtop_init ~opts extra = init_color opts; CoqworkmgrApi.(init !async_proofs_worker_priority); + Flags.if_verbose print_header (); opts, extra let coqtop_toplevel = diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg index f2025858d7..0cac024300 100644 --- a/toplevel/g_toplevel.mlg +++ b/toplevel/g_toplevel.mlg @@ -21,7 +21,7 @@ type vernac_toplevel = | VernacControl of vernac_control module Toplevel_ : sig - val vernac_toplevel : vernac_toplevel CAst.t option Entry.t + val vernac_toplevel : vernac_toplevel option Entry.t end = struct let gec_vernac s = Entry.create ("toplevel:" ^ s) let vernac_toplevel = gec_vernac "vernac_toplevel" @@ -34,14 +34,14 @@ open Toplevel_ GRAMMAR EXTEND Gram GLOBAL: vernac_toplevel; vernac_toplevel: FIRST - [ [ IDENT "Drop"; "." -> { Some (CAst.make VernacDrop) } - | IDENT "Quit"; "." -> { Some (CAst.make VernacQuit) } + [ [ IDENT "Drop"; "." -> { Some VernacDrop } + | IDENT "Quit"; "." -> { Some VernacQuit } | IDENT "Backtrack"; n = natural ; m = natural ; p = natural; "." -> - { Some (CAst.make (VernacBacktrack (n,m,p))) } + { Some (VernacBacktrack (n,m,p)) } | cmd = Pvernac.Vernac_.main_entry -> { match cmd with | None -> None - | Some {CAst.loc; v} -> Some (CAst.make ?loc (VernacControl v)) } + | Some v -> Some (VernacControl v) } ] ] ; diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 038ff54bf6..c41f16c95b 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -20,12 +20,12 @@ open Vernacprop Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) -let checknav_simple {CAst.loc;v=cmd} = +let checknav_simple ({ CAst.loc; _ } as cmd) = if is_navigation_vernac cmd && not (is_reset cmd) then CErrors.user_err ?loc (str "Navigation commands forbidden in files.") -let checknav_deep {CAst.loc;v=ast} = - if is_deep_navigation_vernac ast then +let checknav_deep ({ CAst.loc; _ } as cmd) = + if is_deep_navigation_vernac cmd then CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.") (* Echo from a buffer based on position. @@ -70,7 +70,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = (* Force the command *) let ndoc = if check then Stm.observe ~doc nsid else doc in - let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () in + let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () [@ocaml.warning "-3"] in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> (* XXX: In non-interactive mode edit_at seems to do very weird @@ -163,10 +163,7 @@ let beautify_pass ~doc ~comments ~ids ~filename = set the comments, then we call print. This has to be done for each file. *) Pputils.beautify_comments := comments; - List.iter (fun id -> - Option.iter (fun (loc,ast) -> - pr_new_syntax ?loc ft_beautify (Some ast)) - (Stm.get_ast ~doc id)) ids; + List.iter (fun id -> pr_new_syntax ft_beautify (Stm.get_ast ~doc id)) ids; (* Is this called so comments at EOF are printed? *) pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) ft_beautify None; diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index 1269540235..197891707c 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -24,7 +24,7 @@ end expected to handle and print errors in form of exceptions, however care is taken so the state machine is left in a consistent state. *) -val process_expr : state:State.t -> Vernacexpr.vernac_control CAst.t -> State.t +val process_expr : state:State.t -> Vernacexpr.vernac_control -> State.t (** [load_vernac echo sid file] Loads [file] on top of [sid], will echo the commands if [echo] is set. Callers are expected to handle diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index feaf47df18..12df3215ad 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -12,7 +12,6 @@ open Pp open Util open Entries open Redexpr -open Declare open Constrintern open Pretyping @@ -42,10 +41,9 @@ let check_imps ~impsty ~impsbody = if not b then warn_implicits_in_term () let interp_definition ~program_mode pl bl poly red_option c ctypopt = - let open EConstr in let env = Global.env() in (* Explicitly bound universes and constraints *) - let evd, decl = Constrexpr_ops.interp_univ_decl_opt env pl in + let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in (* Build the parameters *) let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars ~program_mode env evd bl in (* Build the type *) @@ -66,24 +64,15 @@ let interp_definition ~program_mode pl bl poly red_option c ctypopt = in (* Do the reduction *) let evd, c = red_constant_body red_option env_bl evd c in - (* universe minimization *) - let evd = Evd.minimize_universes evd in - (* Substitute evars and universes, and add parameters. - Note: in program mode some evars may remain. *) - let ctx = List.map Termops.(map_rel_decl (to_constr ~abort_on_undefined_evars:false evd)) ctx in - let c = Term.it_mkLambda_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd c) ctx in - let tyopt = Option.map (fun ty -> Term.it_mkProd_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd ty) ctx) tyopt in - (* Keep only useful universes. *) - let uvars_fold uvars c = - Univ.LSet.union uvars (universes_of_constr evd (of_constr c)) - in - let uvars = List.fold_left uvars_fold Univ.LSet.empty (Option.List.cons tyopt [c]) in - let evd = Evd.restrict_universe_context evd uvars in - (* Check we conform to declared universes *) - let uctx = Evd.check_univ_decl ~poly evd decl in - (* We're done! *) - let ce = definition_entry ?types:tyopt ~univs:uctx c in - (ce, evd, decl, imps) + + (* Declare the definition *) + let c = EConstr.it_mkLambda_or_LetIn c ctx in + let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in + + let evd, ce = DeclareDef.prepare_definition ~allow_evars:program_mode + ~opaque:false ~poly evd udecl ~types:tyopt ~body:c in + + (ce, evd, udecl, imps) let check_definition ~program_mode (ce, evd, _, imps) = let env = Global.env () in diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 3f491d1dd4..d97fb523f7 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -77,11 +77,11 @@ let parse_compat_version = let open Flags in function GRAMMAR EXTEND Gram GLOBAL: vernac_control gallina_ext noedit_mode subprf; vernac_control: FIRST - [ [ IDENT "Time"; c = located_vernac -> { VernacTime (false,c) } - | IDENT "Redirect"; s = ne_string; c = located_vernac -> { VernacRedirect (s, c) } - | IDENT "Timeout"; n = natural; v = located_vernac -> { VernacTimeout(n,v) } - | IDENT "Fail"; v = located_vernac -> { VernacFail v } - | v = decorated_vernac -> { let (f, v) = v in VernacExpr(f, v) } ] + [ [ IDENT "Time"; c = vernac_control -> { CAst.make ~loc @@ VernacTime (false,c) } + | IDENT "Redirect"; s = ne_string; c = vernac_control -> { CAst.make ~loc @@ VernacRedirect (s, c) } + | IDENT "Timeout"; n = natural; v = vernac_control -> { CAst.make ~loc @@ VernacTimeout(n,v) } + | IDENT "Fail"; v = vernac_control -> { CAst.make ~loc @@ VernacFail v } + | v = decorated_vernac -> { let (f, v) = v in CAst.make ~loc @@ VernacExpr(f, v) } ] ] ; decorated_vernac: @@ -147,9 +147,6 @@ GRAMMAR EXTEND Gram ] ] ; - located_vernac: - [ [ v = vernac_control -> { CAst.make ~loc v } ] ] - ; END { diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 4e4d431e89..327efcda2b 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -1262,15 +1262,15 @@ let pr_vernac_attributes = let rec pr_vernac_control v = let return = tag_vernac v in - match v with + match v.v with | VernacExpr (f, v') -> pr_vernac_attributes f ++ pr_vernac_expr v' ++ sep_end v' - | VernacTime (_,{v}) -> + | VernacTime (_,v) -> return (keyword "Time" ++ spc() ++ pr_vernac_control v) - | VernacRedirect (s, {v}) -> + | VernacRedirect (s, v) -> return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_control v) - | VernacTimeout(n,{v}) -> + | VernacTimeout(n,v) -> return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_control v) - | VernacFail {v} -> + | VernacFail v-> return (keyword "Fail" ++ spc() ++ pr_vernac_control v) let pr_vernac v = diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index d474ef8637..4d9157089c 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -52,7 +52,7 @@ module Vernac_ = let () = let open Extend in - let act_vernac v loc = Some CAst.(make ~loc v) in + let act_vernac v loc = Some v in let act_eoi _ loc = None in let rule = [ Rule (Next (Stop, Atoken Tok.PEOI), act_eoi); diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 4bf7c9f7bd..41a2e7fd6f 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -26,7 +26,7 @@ module Vernac_ : val rec_definition : (fixpoint_expr * decl_notation list) Entry.t val noedit_mode : vernac_expr Entry.t val command_entry : vernac_expr Entry.t - val main_entry : vernac_control CAst.t option Entry.t + val main_entry : vernac_control option Entry.t val red_expr : raw_red_expr Entry.t val hint_info : Hints.hint_info_expr Entry.t end @@ -40,7 +40,7 @@ module Unsafe : sig end (** The main entry: reads an optional vernac command *) -val main_entry : proof_mode option -> vernac_control CAst.t option Entry.t +val main_entry : proof_mode option -> vernac_control option Entry.t (** Grammar entry for tactics: proof mode(s). By default Coq's grammar has an empty entry (non-terminal) for diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 60b0bdc7e7..118c126970 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -196,6 +196,18 @@ let init_tag_map styles = let default_styles () = init_tag_map (default_tag_map ()) +let set_emacs_print_strings () = + let open Terminal in + let diff = "diff." in + List.iter (fun b -> + let (name, attrs) = b in + if diff = (String.sub name 0 (String.length diff)) then + tag_map := CString.Map.add name + { attrs with prefix = Some (Printf.sprintf "<%s>" name); + suffix = Some (Printf.sprintf "</%s>" name) } + !tag_map) + (CString.Map.bindings !tag_map) + let parse_color_config str = let styles = Terminal.parse str in init_tag_map styles @@ -264,13 +276,13 @@ let make_printing_functions () = let (tpfx, ttag) = split_tag tag in if tpfx <> end_pfx then let style = get_style ttag in - match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> () in + match style.Terminal.prefix with Some s -> Format.pp_print_as ft 0 s | None -> () in let print_suffix ft tag = let (tpfx, ttag) = split_tag tag in if tpfx <> start_pfx then let style = get_style ttag in - match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> () in + match style.Terminal.suffix with Some s -> Format.pp_print_as ft 0 s | None -> () in print_prefix, print_suffix @@ -413,7 +425,7 @@ let with_output_to_file fname func input = (* For coqtop -time, we display the position in the file, and a glimpse of the executed command *) -let pr_cmd_header {CAst.loc;v=com} = +let pr_cmd_header com = let shorten s = if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s in @@ -423,7 +435,7 @@ let pr_cmd_header {CAst.loc;v=com} = | x -> x ) s in - let (start,stop) = Option.cata Loc.unloc (0,0) loc in + let (start,stop) = Option.cata Loc.unloc (0,0) com.CAst.loc in let safe_pr_vernac x = try Ppvernac.pr_vernac x with e -> str (Printexc.to_string e) in diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index b0e3b3772c..3d522a9e0f 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -46,6 +46,7 @@ val emacs_logger : ?pre_hdr:Pp.t -> Feedback.level -> Pp.t -> unit val default_styles : unit -> unit val parse_color_config : string -> unit val dump_tags : unit -> (string * Terminal.style) list +val set_emacs_print_strings : unit -> unit (** Initialization of interpretation of tags *) val init_terminal_output : color:bool -> unit @@ -72,4 +73,4 @@ val print_err_exn : exn -> unit redirected to a file [file] *) val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b -val pr_cmd_header : Vernacexpr.vernac_control CAst.t -> Pp.t +val pr_cmd_header : Vernacexpr.vernac_control -> Pp.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 3a305c3b61..0f6374c506 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1732,29 +1732,29 @@ let vernac_set_option ~local export table v = match v with let vernac_add_option key lv = let f = function - | StringRefValue s -> (get_string_table key)#add s - | QualidRefValue locqid -> (get_ref_table key)#add locqid + | StringRefValue s -> (get_string_table key).add (Global.env()) s + | QualidRefValue locqid -> (get_ref_table key).add (Global.env()) locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_remove_option key lv = let f = function - | StringRefValue s -> (get_string_table key)#remove s - | QualidRefValue locqid -> (get_ref_table key)#remove locqid + | StringRefValue s -> (get_string_table key).remove (Global.env()) s + | QualidRefValue locqid -> (get_ref_table key).remove (Global.env()) locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_mem_option key lv = let f = function - | StringRefValue s -> (get_string_table key)#mem s - | QualidRefValue locqid -> (get_ref_table key)#mem locqid + | StringRefValue s -> (get_string_table key).mem (Global.env()) s + | QualidRefValue locqid -> (get_ref_table key).mem (Global.env()) locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_print_option key = - try (get_ref_table key)#print + try (get_ref_table key).print () with Not_found -> - try (get_string_table key)#print + try (get_string_table key).print () with Not_found -> try print_option_value key with Not_found -> error_undeclared_key key @@ -2599,7 +2599,7 @@ and vernac_load ?proof ~verbosely ~st fname = CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); pstate -and interp_control ?proof ~st = function +and interp_control ?proof ~st v = match v with | { v=VernacExpr (atts, cmd) } -> interp_expr ?proof ~atts ~st cmd | { v=VernacFail v } -> @@ -2627,7 +2627,7 @@ let interp ?(verbosely=true) ?proof ~st cmd = try vernac_timeout (fun st -> let v_mod = if verbosely then Flags.verbosely else Flags.silently in let pstate = v_mod (interp_control ?proof ~st) cmd in - Vernacstate.Proof_global.set pstate; + Vernacstate.Proof_global.set pstate [@ocaml.warning "-3"]; Vernacstate.freeze_interp_state ~marshallable:false ) st with exn -> diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 71cc29b6e1..12451370c8 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -23,7 +23,7 @@ val vernac_require : val interp : ?verbosely:bool -> ?proof:Proof_global.closed_proof -> - st:Vernacstate.t -> Vernacexpr.vernac_control CAst.t -> Vernacstate.t + st:Vernacstate.t -> Vernacexpr.vernac_control -> Vernacstate.t (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d0dae1aa53..99b457effe 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -398,11 +398,12 @@ type nonrec vernac_expr = (* For extension *) | VernacExtend of extend_name * Genarg.raw_generic_argument list -type vernac_control = +type vernac_control_r = | VernacExpr of Attributes.vernac_flags * vernac_expr (* boolean is true when the `-time` batch-mode command line flag was set. the flag is used to print differently in `-time` vs `Time foo` *) - | VernacTime of bool * vernac_control CAst.t - | VernacRedirect of string * vernac_control CAst.t - | VernacTimeout of int * vernac_control CAst.t - | VernacFail of vernac_control CAst.t + | VernacTime of bool * vernac_control + | VernacRedirect of string * vernac_control + | VernacTimeout of int * vernac_control + | VernacFail of vernac_control +and vernac_control = vernac_control_r CAst.t diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index 704c5b2170..b3490c7dc6 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -13,19 +13,20 @@ open Vernacexpr -let rec under_control = function +let rec under_control v = v |> CAst.with_val (function | VernacExpr (_, c) -> c - | VernacRedirect (_,{CAst.v=c}) - | VernacTime (_,{CAst.v=c}) - | VernacFail {CAst.v=c} - | VernacTimeout (_,{CAst.v=c}) -> under_control c + | VernacRedirect (_,c) + | VernacTime (_,c) + | VernacFail c + | VernacTimeout (_,c) -> under_control c + ) -let rec has_Fail = function +let rec has_Fail v = v |> CAst.with_val (function | VernacExpr _ -> false - | VernacRedirect (_,{CAst.v=c}) - | VernacTime (_,{CAst.v=c}) - | VernacTimeout (_,{CAst.v=c}) -> has_Fail c - | VernacFail _ -> true + | VernacRedirect (_,c) + | VernacTime (_,c) + | VernacTimeout (_,c) -> has_Fail c + | VernacFail _ -> true) (* Navigation commands are allowed in a coqtop session but not in a .v file *) let is_navigation_vernac_expr = function @@ -38,17 +39,17 @@ let is_navigation_vernac_expr = function let is_navigation_vernac c = is_navigation_vernac_expr (under_control c) -let rec is_deep_navigation_vernac = function - | VernacTime (_,{CAst.v=c}) -> is_deep_navigation_vernac c - | VernacRedirect (_, {CAst.v=c}) - | VernacTimeout (_,{CAst.v=c}) | VernacFail {CAst.v=c} -> is_navigation_vernac c - | VernacExpr _ -> false +let rec is_deep_navigation_vernac v = v |> CAst.with_val (function + | VernacTime (_,c) -> is_deep_navigation_vernac c + | VernacRedirect (_, c) + | VernacTimeout (_, c) | VernacFail c -> is_navigation_vernac c + | VernacExpr _ -> false) (* NB: Reset is now allowed again as asked by A. Chlipala *) -let is_reset = function +let is_reset = CAst.with_val (function | VernacExpr ( _, VernacResetInitial) | VernacExpr (_, VernacResetName _) -> true - | _ -> false + | _ -> false) let is_debug cmd = match under_control cmd with | VernacSetOption (_, ["Ltac";"Debug"], _) -> true diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index b79f97796f..dff81ad9bb 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -82,3 +82,4 @@ module Proof_global : sig val copy_terminators : src:t option -> tgt:t option -> t option end +[@@ocaml.deprecated "This module is internal and should not be used, instead, thread the proof state"] |