diff options
133 files changed, 2466 insertions, 1488 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fd1ea325e9..708ddced15 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-02-17-V1" + CACHEKEY: "bionic_coq-V2019-03-11-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -252,12 +252,14 @@ build:base+async: variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" + allow_failure: true # See https://github.com/coq/coq/issues/9658 build:quick: <<: *build-template variables: COQ_EXTRA_CONF: "-native-compiler no" QUICK: "1" + allow_failure: true # See https://github.com/coq/coq/issues/9637 windows64: <<: *windows-template @@ -584,6 +586,9 @@ library:ci-math-comp: library:ci-sf: <<: *ci-template +library:ci-stdlib2: + <<: *ci-template-flambda + library:ci-unimath: <<: *ci-template-flambda diff --git a/CHANGES.md b/CHANGES.md index af2b7991dd..59cc17c233 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -97,6 +97,9 @@ Tactics - 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 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index bb0e388cdd..31fa3d2c4a 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1,34 +1,72 @@ # Contributing to Coq -Thank you for your interest in contributing to Coq! There are many ways to contribute, and we appreciate all of them. +Thank you for your interest in contributing to Coq! There are many ways to +contribute, and we appreciate all of them. Please make sure you read and +abide by the [Code of Conduct](CODE_OF_CONDUCT.md). ## Bug Reports -Bug reports are enormously useful to identify issues with Coq; we can't fix what we don't know about. To report a bug, please open an issue in the [Coq issue tracker](https://github.com/coq/coq/issues) (you'll need a GitHub account). You can file a bug for any of the following: - -- An anomaly. These are always considered bugs, so Coq will even ask you to file a bug report! -- An error you didn't expect. If you're not sure whether it's a bug or intentional, feel free to file a bug anyway. We may want to improve the documentation or error message. -- Missing documentation. It's helpful to track where the documentation should be improved, so please file a bug if you can't find or don't understand some bit of documentation. -- An error message that wasn't as helpful as you'd like. Bonus points for suggesting what information would have helped you. -- Bugs in CoqIDE should also be filed in the [Coq issue tracker](https://github.com/coq/coq/issues). Bugs in the Emacs plugin should be filed against [ProofGeneral](https://github.com/ProofGeneral/PG/issues), or against [company-coq](https://github.com/cpitclaudel/company-coq/issues) if they are specific to company-coq features. - -It would help if you search the existing issues before reporting a bug. This can be difficult, so consider it extra credit. We don't mind duplicate bug reports. - -When it applies, it's extremely helpful for bug reports to include sample code, and much better if the code is self-contained and complete. It's not necessary to minimize your bug or identify precisely where the issue is, since someone else can often do this if you include a complete example. We tend to include the code in the bug description itself, but if you have a very large input file then you can add it as an attachment. - -If you want to minimize your bug (or help minimize someone else's) for more extra credit, then you can use the [Coq bug minimizer](https://github.com/JasonGross/coq-tools) (specifically, the bug minimizer is the `find-bug.py` script in that repo). +Bug reports are enormously useful to identify issues with Coq; we can't fix +what we don't know about. To report a bug, please open an issue in the +[Coq issue tracker][] (you'll need a GitHub +account). You can file a bug for any of the following: + +- An anomaly. These are always considered bugs, so Coq will even ask you to + file a bug report! +- An error you didn't expect. If you're not sure whether it's a bug or + intentional, feel free to file a bug anyway. We may want to improve the + documentation or error message. +- Missing documentation. It's helpful to track where the documentation should + be improved, so please file a bug if you can't find or don't understand some + bit of documentation. +- An error message that wasn't as helpful as you'd like. Bonus points for + suggesting what information would have helped you. +- Bugs in CoqIDE should also be filed in the + [Coq issue tracker][]. + Bugs in the Emacs plugin should be filed against + [ProofGeneral](https://github.com/ProofGeneral/PG/issues), or against + [company-coq](https://github.com/cpitclaudel/company-coq/issues) if they are + specific to company-coq features. + +It would help if you search the existing issues before reporting a bug. This +can be difficult, so consider it extra credit. We don't mind duplicate bug +reports. If unsure, you are always very welcome to ask on our [Discourse forum][] +or [Gitter chat][] before, after, or while writting a bug report + +When it applies, it's extremely helpful for bug reports to include sample +code, and much better if the code is self-contained and complete. It's not +necessary to minimize your bug or identify precisely where the issue is, +since someone else can often do this if you include a complete example. We +tend to include the code in the bug description itself, but if you have a +very large input file then you can add it as an attachment. + +If you want to minimize your bug (or help minimize someone else's) for more +extra credit, then you can use the +[Coq bug minimizer](https://github.com/JasonGross/coq-tools) (specifically, +the bug minimizer is the `find-bug.py` script in that repo). + +### Triaging bug reports + +Triaging bug reports (adding labels, closing outdated / resolved bugs) +requires you to be granted some permissions. You may request members of the +**@coq/core** team to add you to the contributors team. They can do so using +this link: <https://github.com/orgs/coq/teams/contributors/members?add=true>. ## Pull requests **Beginner's guide to hacking Coq: [`dev/doc/README.md`](dev/doc/README.md)** \ **Development information and tools: [`dev/README.md`](dev/README.md)** -If you want to contribute a bug fix or feature yourself, pull requests on the [GitHub repository](https://github.com/coq/coq) are the way to contribute directly to the Coq implementation. We recommend you create a fork of the repository on GitHub and push your changes to a new "topic branch" in that fork. From there you can follow the [GitHub pull request documentation](https://help.github.com/articles/about-pull-requests/) to get your changes reviewed and pulled into the Coq source repository. +If you want to contribute a bug fix or feature yourself, pull requests on +the [GitHub repository](https://github.com/coq/coq) are the way to contribute +directly to the Coq implementation. We recommend you create a fork of the +repository on GitHub and push your changes to a new "topic branch" in that +fork. From there you can follow the +[GitHub pull request documentation](https://help.github.com/articles/about-pull-requests/) +to get your changes reviewed and pulled into the Coq source repository. Documentation for getting started with the Coq sources is located in various files in [`dev/doc`](dev/doc) (for example, [debugging.md](dev/doc/debugging.md)). -For further help with the Coq sources, feel free to join -the [Coq Gitter chat](https://gitter.im/coq/coq) and ask questions. Please make pull requests against the `master` branch. @@ -41,10 +79,10 @@ get one—, and the year of your contribution). It's helpful to run the Coq test suite with `make test-suite` before submitting your change. Our CI runs this test suite and lots of other tests, including -building external Coq developments, on every pull request, but these results +building external Coq projects, on every pull request, but these results take significantly longer to come back (on the order of a few hours). Running the test suite locally will take somewhere around 10-15 minutes. Refer to -[`dev/ci/README.md`](dev/ci/README.md#information-for-developers) for more +[`dev/ci/README-developers.md`](dev/ci/README-developers.md) for more information on CI tests, including how to run them on your private branches. If your pull request fixes a bug, please consider adding a regression test as @@ -53,19 +91,30 @@ well. See [`test-suite/README.md`](test-suite/README.md) for how to do so. If your pull request fixes a critical bug (a bug allowing a proof of `False`), please add an entry to [`dev/doc/critical-bugs`](/dev/doc/critical-bugs). -Don't be alarmed if the pull request process takes some time. It can take a few days to get feedback, approval on the final changes, and then a merge. Coq doesn't release new versions very frequently so it can take a few months for your change to land in a released version. That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. +Don't be alarmed if the pull request process takes some time. It can take a +few days to get feedback, approval on the final changes, and then a merge. +Do not hesitate to ping the reviewers if it takes longer than this. +Coq doesn't release new versions very frequently so it can take a few months +for your change to land in a released version. That said, you can start using +the latest Coq `master` branch to take advantage of all the new features, +improvements, and fixes. -Whitespace discipline (do not indent using tabs, no trailing spaces, text files end with newlines) is checked by the `lint` job on GitLab CI (using `git diff --check`). We ship a [`dev/tools/pre-commit`](/dev/tools/pre-commit) git hook which fixes these errors at commit time. `configure` automatically sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. +Whitespace discipline (do not indent using tabs, no trailing spaces, text +files end with newlines) is checked by the `lint` job on GitLab CI (using +`git diff --check`). We ship a [`dev/tools/pre-commit`](/dev/tools/pre-commit) +git hook which fixes these errors at commit time. `configure` automatically +sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. -Here are a few tags Coq developers may add to your PR and what they mean. In general feedback and requests for you as the pull request author will be in the comments and tags are only used to organize pull requests. +Here are a few tags Coq developers may add to your PR and what they mean. In +general feedback and requests for you as the pull request author will be in +the comments and tags are only used to organize pull requests. - [needs: rebase][rebase-label] indicates the PR should be rebased on top of the latest base branch (usually `master`). See the [GitHub documentation](https://help.github.com/articles/about-git-rebase/) for a brief introduction to using `git rebase`. - This label will be automatically added if you open or synchronize your PR and - it is not up-to-date with the base branch. So please, do not forget to rebase - your branch every time you update it. + We generally ask you to rebase only when there are merge conflicts or if + the PR has been opened for a long time and we want a fresh CI run. - [needs: fixing][fixing-label] indicates the PR needs a fix, as discussed in the comments. - [needs: benchmarking][benchmarking-label] and [needs: testing][testing-label] indicate the PR needs testing beyond what the test suite can handle. @@ -76,45 +125,86 @@ Here are a few tags Coq developers may add to your PR and what they mean. In gen To learn more about the merging process, you can read the [merging documentation for Coq maintainers](dev/doc/MERGING.md). -## Documentation - -Currently the process for contributing to the documentation is the same as for changing anything else in Coq, so please submit a pull request as described above. +[rebase-label]: https://github.com/coq/coq/pulls?utf8=%E2%9C%93&q=is%3Aopen%20is%3Apr%20label%3A%22needs%3A%20rebase%22 +[fixing-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+fixing%22 +[benchmarking-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+benchmarking%22 +[testing-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+testing%22 -Our issue tracker includes a flag to mark bugs related to documentation. You can view a list of documentation-related bugs using a [GitHub issue search](https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22). Many of these bugs can be fixed by contributing writing, without knowledge of Coq's OCaml source code. +[jenkins-doc]: https://github.com/coq/coq/wiki/Jenkins-(automated-benchmarking) -The sources for the [Coq reference manual](https://coq.inria.fr/distrib/current/refman/) are at [`doc/sphinx`](/doc/sphinx). These are written in reStructuredText and compiled to HTML and PDF with [Sphinx](http://www.sphinx-doc.org/). +## Documentation -You may also contribute to the informal documentation available in [Cocorico](https://github.com/coq/coq/wiki) (the Coq wiki), and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ). Both of these are editable by anyone with a GitHub account. +Currently the process for contributing to the documentation is the same as +for changing anything else in Coq, so please submit a pull request as +described above. -## Following the development +Our issue tracker includes a flag to mark bugs related to documentation. +You can view a list of documentation-related bugs using a +[GitHub issue search](https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22). +Many of these bugs can be fixed by contributing writing, without knowledge +of Coq's OCaml source code. -If you want to follow the development activity around Coq, you are encouraged -to subscribe to the [Coqdev mailing list](https://sympa.inria.fr/sympa/info/coqdev). -This mailing list has reasonably low traffic. +The sources for the [Coq reference manual](https://coq.inria.fr/distrib/current/refman/) +are at [`doc/sphinx`](/doc/sphinx). These are written in reStructuredText +and compiled to HTML and PDF with [Sphinx](http://www.sphinx-doc.org/). -You may also choose to use GitHub feature to -["watch" this repository](https://github.com/coq/coq/subscription), but be -advised that this means receiving a very large number of notifications. -GitHub gives [some advice](https://blog.github.com/2017-07-18-managing-large-numbers-of-github-notifications/#prioritize-the-notifications-you-receive) -on how to configure your e-mail client to filter these notifications. -A possible alternative is to deactivate e-mail notifications and manage your -GitHub web notifications using a tool such as [Octobox](http://octobox.io/). +You will find information on how to build the documentation in +[`doc/README.md`](doc/README.md) and information about the specificities of +the Coq Sphinx format in [`doc/sphinx/README.rst`](doc/sphinx/README.rst). -## Contributing outside this repository +You may also contribute to the informal documentation available in +[Cocorico](https://github.com/coq/coq/wiki) (the Coq wiki), and the +[Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ). Both of these are +editable by anyone with a GitHub account. -There are many useful ways to contribute to the Coq ecosystem that don't involve the Coq repository. +## Where to get help (with the Coq source code, or anything else) -Tutorials to teach Coq, and especially to teach particular advanced features, would be much appreciated. Some tutorials are listed on the [Coq website](https://coq.inria.fr/documentation). If you would like to add a link to this list, please make a pull request against the Coq website repository at https://github.com/coq/www. +We have a [Discourse forum][] (see in particular the [Coq development category][]) +and a [Gitter chat][]. Feel free to join any of them and ask questions. +People are generally happy to help and very reactive. -External plugins / libraries contribute to create a successful ecosystem around Coq. If your external development is mature enough, you may consider submitting it for addition to our CI tests. Refer to [`dev/ci/README.md`](/dev/ci/README.md) for more information. +[Coq development category]: https://coq.discourse.group/c/coq-development -Ask and answer questions on [Stack Exchange](https://stackexchange.com/filters/299857/questions-tagged-coq-on-stackexchange-sites) which has a helpful community of Coq users. +## Watching the repository -Hang out on the Coq IRC channel, `irc://irc.freenode.net/#coq`, and help answer questions. +["Watching" this repository](https://github.com/coq/coq/subscription) +can result in a very large number of notifications. We advise that if +you do, either [confifure your mailbox](https://blog.github.com/2017-07-18-managing-large-numbers-of-github-notifications/#prioritize-the-notifications-you-receive) +to handle incoming notifications efficiently, or you read your +notifications within a web browser. You can configure how you receive +notifications in [your GitHub settings](https://github.com/settings/notifications), +you can use the GitHub interface to mark as read, save for later or +mute threads. You can also manage your GitHub web notifications using +a tool such as [Octobox](http://octobox.io/). -[rebase-label]: https://github.com/coq/coq/pulls?utf8=%E2%9C%93&q=is%3Aopen%20is%3Apr%20label%3A%22needs%3A%20rebase%22 -[fixing-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+fixing%22 -[benchmarking-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+benchmarking%22 -[testing-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+testing%22 +## Contributing outside this repository -[jenkins-doc]: https://github.com/coq/coq/wiki/Jenkins-(automated-benchmarking) +There are many useful ways to contribute to the Coq ecosystem that don't +involve the Coq repository. + +Tutorials to teach Coq, and especially to teach particular advanced features, +are much appreciated. Some tutorials are listed on the +[Coq website](https://coq.inria.fr/documentation). If you would like to add +a link to this list, please make a pull request against the Coq website +repository at <https://github.com/coq/www>. + +External plugins / libraries contribute to create a successful ecosystem +around Coq. If your external development is mature enough, you may consider +submitting it for addition to our CI tests. Refer to +[`dev/ci/README-users.md`](dev/ci/README-users.md) for more information. + +Some Coq packages are not maintained by their authors anymore even if they +were useful (for instance because they changed jobs). The coq-community +organization is a place for people to take over the maintenance of such +useful packages. If you want to contribute by becoming a maintainer, you can +find a list of packages waiting for a maintainer [here](https://github.com/coq-community/manifesto/issues?q=is%3Aissue+is%3Aopen+label%3Amaintainer-wanted). +You can also propose a package that is not listed. Find out more about +coq-community in [the manifesto's README](https://github.com/coq-community/manifesto). + +Ask and answer questions on our [Discourse forum][], on [Stack Exchange][], +and on the Coq IRC channel (`irc://irc.freenode.net/#coq`). + +[Coq issue tracker]: https://github.com/coq/coq/issues +[Discourse forum]: https://coq.discourse.group/ +[Gitter chat]: https://gitter.im/coq/coq +[Stack Exchange]: https://stackexchange.com/filters/299857/questions-tagged-coq-on-stackexchange-sites @@ -75,16 +75,22 @@ endef ## Files in the source tree +# instead of using "export FOO" do "COQ_EXPORTED += FOO" +# this makes it possible to clean up the environment in the subcall +COQ_EXPORTED := COQ_EXPORTED + LEXFILES := $(call find, '*.mll') YACCFILES := $(call find, '*.mly') -export MLLIBFILES := $(call find, '*.mllib') -export MLPACKFILES := $(call find, '*.mlpack') -export MLGFILES := $(call find, '*.mlg') -export CFILES := $(call findindir, 'kernel/byterun', '*.c') +MLLIBFILES := $(call find, '*.mllib') +MLPACKFILES := $(call find, '*.mlpack') +MLGFILES := $(call find, '*.mlg') +CFILES := $(call findindir, 'kernel/byterun', '*.c') +COQ_EXPORTED +=MLLIBFILES MLPACKFILES MLGFILES CFILES # NB our find wrapper ignores the test suite MERLININFILES := $(call find, '.merlin.in') test-suite/unit-tests/.merlin.in -export MERLINFILES := $(MERLININFILES:.in=) +MERLINFILES := $(MERLININFILES:.in=) +COQ_EXPORTED += MERLINFILES # NB: The lists of currently existing .ml and .mli files will change # before and after a build or a make clean. Hence we do not export @@ -97,17 +103,21 @@ EXISTINGMLI := $(call find, '*.mli') GENMLGFILES:= $(MLGFILES:.mlg=.ml) # GRAMFILES must be in linking order -export GRAMFILES=$(addprefix gramlib/.pack/gramlib__,Ploc Plexing Gramext Grammar) -export GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) -export GENGRAMFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml -export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml -export GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h -export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) +GRAMFILES=$(addprefix gramlib/.pack/gramlib__,Ploc Plexing Gramext Grammar) +GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) +GENGRAMFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml +GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml +GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) +COQ_EXPORTED += GRAMFILES GRAMMLFILES GENGRAMFILES GENMLFILES GENHFILES GENFILES ## More complex file lists -export MLSTATICFILES := $(filter-out $(GENMLFILES), $(EXISTINGML)) -export MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI)) +MLSTATICFILES := $(filter-out $(GENMLFILES), $(EXISTINGML)) +MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI)) +COQ_EXPORTED += MLSTATICFILES MLIFILES + +export $(COQ_EXPORTED) include Makefile.common diff --git a/Makefile.build b/Makefile.build index e348b2b9b8..2e4700be88 100644 --- a/Makefile.build +++ b/Makefile.build @@ -11,6 +11,9 @@ # This makefile is normally called by the main Makefile after setting # some variables. +# Cleanup environment (avoids filling it up) +unexport $(COQ_EXPORTED) + ########################################################################### # User-customizable variables ########################################################################### @@ -617,6 +620,9 @@ gramlib/.pack/gramlib.cmxa: $(GRAMOBJS:.cmo=.cmx) gramlib/.pack/gramlib.cmx $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $^ +# used by install +gramlib/.pack/gramlib_MLLIB_DEPENDENCIES:=$(GRAMFILES) + # Specific rule for kernel.cma, with $(VMBYTEFLAGS). # This helps loading dllcoqrun.so during an ocamldebug kernel/kernel.cma: kernel/kernel.mllib @@ -859,6 +865,18 @@ $(VDFILE).d: $(D_DEPEND_BEFORE_SRC) $(VFILES) $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT ########################################################################### + +# Useful to check that the exported variables are within the win32 limits + +printenv-real: + @env + @echo + @echo -n "Maxsize (win32 limit is 8k) : " + @env | wc -L + @echo -n "Total (win32 limit is 32k) : " + @env | wc -m + + # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles Makefile $(wildcard Makefile.*) config/Makefile : ; @@ -873,5 +891,5 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; # For emacs: # Local Variables: -# mode: makefile +# mode: makefile-gmake # End: diff --git a/Makefile.ci b/Makefile.ci index 0307d39d54..9180d51bee 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -40,6 +40,7 @@ CI_TARGETS= \ ci-relation-algebra \ ci-sf \ ci-simple-io \ + ci-stdlib2 \ ci-tlc \ ci-unimath \ ci-verdi-raft \ @@ -68,25 +68,25 @@ and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ), 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 Coq Club -The Coq Club moderated mailing list is meant to be a standard way -to discuss questions about the Coq system and related topics. The -subscription link can be found at [coq.inria.fr/community](http://coq.inria.fr/community). +## Questions and discussion + +We have a number of channels to reach the user community and the +development team: -The topics to be discussed in the club should include: +- Our [Discourse forum](https://coq.discourse.group). +- Our mailing list, the [Coq-Club](https://sympa.inria.fr/sympa/info/coq-club). +- Our [Gitter channel][gitter-link], which is a good way to reach + developers for quick chat and development questions. -* technical problems; -* questions about proof developments; -* suggestions and questions about the implementation; -* announcements of proofs; -* theoretical questions about typed lambda-calculi which are - closely related to Coq. +See also [coq.inria.fr/community](https://coq.inria.fr/community.html). ## Bugs report + Please report any bug / feature request in [our issue tracker](https://github.com/coq/coq/issues). To be effective, bug reports should mention the OCaml version used diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 4329b2d743..b681fb876e 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -89,6 +89,9 @@ let eq_recarg a1 a2 = match a1, a2 with let eq_reloc_tbl = Array.equal (fun x y -> Int.equal (fst x) (fst y) && Int.equal (snd x) (snd y)) +let eq_in_context (ctx1, t1) (ctx2, t2) = + Context.Rel.equal Constr.equal ctx1 ctx2 && Constr.equal t1 t2 + let check_packet env mind ind { mind_typename; mind_arity_ctxt; mind_arity; mind_consnames; mind_user_lc; mind_nrealargs; mind_nrealdecls; mind_kelim; mind_nf_lc; @@ -105,7 +108,7 @@ let check_packet env mind ind check "mind_nrealdecls" Int.(equal ind.mind_nrealdecls mind_nrealdecls); check "mind_kelim" (check_kelim ind.mind_kelim mind_kelim); - check "mind_nf_lc" (Array.equal Constr.equal ind.mind_nf_lc mind_nf_lc); + check "mind_nf_lc" (Array.equal eq_in_context ind.mind_nf_lc mind_nf_lc); (* NB: here syntactic equality is not just an optimisation, we also care about the shape of the terms *) diff --git a/checker/checker.ml b/checker/checker.ml index 3c93ef7d36..d3f346d76b 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -273,6 +273,7 @@ let explain_exn = function | IllFormedBranch _ -> str"IllFormedBranch" | Generalization _ -> str"Generalization" | ActualType _ -> str"ActualType" + | IncorrectPrimitive _ -> str"IncorrectPrimitive" | CantApplyBadType ((n,a,b),{uj_val = hd; uj_type = hdty},args) -> let pp_arg i judge = hv 1 (str"arg " ++ int (i+1) ++ str"= " ++ diff --git a/checker/dune b/checker/dune index ee427d26c5..73cbbc8d19 100644 --- a/checker/dune +++ b/checker/dune @@ -3,8 +3,7 @@ ; If we don't pack checker we will have a problem here due to ; duplicate module names in the whole build. (library - (name checklib) - (public_name coq.checklib) + (name coq_checklib) (synopsis "Coq's Standalone Proof Checker") (modules :standard \ coqchk votour) (wrapped true) @@ -15,14 +14,14 @@ (public_name coqchk) (package coq) (modules coqchk) - (flags :standard -open Checklib) - (libraries coq.checklib)) + (flags :standard -open Coq_checklib) + (libraries coq_checklib)) (executable (name votour) (public_name votour) (package coq) (modules votour) - (flags :standard -open Checklib) - (libraries coq.checklib)) + (flags :standard -open Coq_checklib) + (libraries coq_checklib)) diff --git a/checker/values.ml b/checker/values.ml index 66467fa8f5..bcac3014be 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -261,7 +261,7 @@ let v_one_ind = v_tuple "one_inductive_body" Int; Int; List v_sortfam; - Array v_constr; + Array (v_pair v_rctxt v_constr); Array Int; Array Int; v_wfp; diff --git a/configure.ml b/configure.ml index ef38651a4d..8b6fccb5e3 100644 --- a/configure.ml +++ b/configure.ml @@ -1101,7 +1101,7 @@ let write_configml f = pr_b "native_compiler" !prefs.nativecompiler; let core_src_dirs = [ "config"; "lib"; "clib"; "kernel"; "library"; - "engine"; "pretyping"; "interp"; "gramlib/.pack"; "parsing"; "proofs"; + "engine"; "pretyping"; "interp"; "gramlib"; "gramlib/.pack"; "parsing"; "proofs"; "tactics"; "toplevel"; "printing"; "ide"; "stm"; "vernac" ] in let core_src_dirs = List.fold_left (fun acc core_src_subdir -> acc ^ " \"" ^ core_src_subdir ^ "\";\n") "" diff --git a/dev/README.md b/dev/README.md index d9fdd230d3..9761f7b96f 100644 --- a/dev/README.md +++ b/dev/README.md @@ -25,7 +25,6 @@ | [`dev/doc/universes.txt`](doc/universes.txt) | Help for debugging universes | | [`dev/doc/extensions.txt`](doc/extensions.txt) | Some help about TACTIC EXTEND | | [`dev/doc/perf-analysis`](doc/perf-analysis)| Analysis of perfs measured on the compilation of user contribs | -| [`dev/doc/cic.dtd`](doc/cic.dtd) | Official dtd of the calc. of ind. constr. for im/ex-portation | | [`dev/doc/econstr.md`](doc/econstr.md) | Describes `Econstr`, implementation of treatment of `evar` in the engine | | [`dev/doc/primproj.md`](doc/primproj.md) | Describes primitive projections | | [`dev/doc/proof-engine.md`](doc/proof-engine.md) | Tutorial on new proof engine | diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 8489bcfc3a..c8cfcf60c8 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -373,7 +373,8 @@ IF "%RUNSETUP%"=="Y" ( -P make,unzip ^
-P gdb,liblzma5 ^
-P patch,automake1.14 ^
- -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^
+ -P pkg-config ^
+ -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-windows_default_manifest ^
-P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^
-P libiconv-devel,libunistring-devel,libncurses-devel ^
-P gettext-devel,libgettextpo-devel ^
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 2e934ff0c0..43f44a80b4 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1202,7 +1202,7 @@ function make_lablgtk { make_gtk_sourceview2 if build_prep https://forge.ocamlcore.org/frs/download.php/1726 lablgtk-2.18.6 tar.gz 1 ; then # configure should be fixed to search for $TARGET_ARCH-pkg-config.exe - cp "/bin/$TARGET_ARCH-pkg-config.exe" bin_special/pkg-config.exe + cp "/bin/$TARGET_ARCH-pkg-config" bin_special/pkg-config logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXOCAML" # lablgtk shows occasional errors with -j, so don't pass $MAKE_OPT diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 74e8d3bbaa..deeec3942d 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -289,3 +289,10 @@ : "${verdi_raft_CI_REF:=master}" : "${verdi_raft_CI_GITURL:=https://github.com/uwplse/verdi-raft}" : "${verdi_raft_CI_ARCHIVEURL:=${verdi_raft_CI_GITURL}/archive}" + +######################################################################## +# stdlib2 +######################################################################## +: "${stdlib2_CI_REF:=master}" +: "${stdlib2_CI_GITURL:=https://github.com/coq/stdlib2}" +: "${stdlib2_CI_ARCHIVEURL:=${stdlib2_CI_GITURL}/archive}" diff --git a/dev/ci/ci-stdlib2.sh b/dev/ci/ci-stdlib2.sh new file mode 100755 index 0000000000..ec1c180d7d --- /dev/null +++ b/dev/ci/ci-stdlib2.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download stdlib2 + +( cd "${CI_BUILD_DIR}/stdlib2/src" && ./bootstrap && make && make install) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 43278c37b1..ac763547b6 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-02-17-V1" +# CACHEKEY: "bionic_coq-V2019-03-11-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -37,7 +37,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.3.0" \ +ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.4.0" \ CI_OPAM="menhir.20181113 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. diff --git a/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh b/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh new file mode 100644 index 0000000000..2b4c1489ad --- /dev/null +++ b/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh @@ -0,0 +1,13 @@ +_OVERLAY_BRANCH=ho-matching-occ-sel + +if [ "$CI_PULL_REQUEST" = "7819" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then + + unicoq_CI_REF="PR7819-overlay" + + mtac2_CI_REF="PR7819-overlay" + mtac2_CI_GITURL=https://github.com/mattam82/Mtac2 + + equations_CI_GITURL=https://github.com/mattam82/Coq-Equations + equations_CI_REF="PR7819-overlay" + +fi diff --git a/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh b/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh new file mode 100644 index 0000000000..1110157069 --- /dev/null +++ b/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9389" ] || [ "$CI_BRANCH" = "set-implicits" ]; then + + equations_CI_REF=set-implicits + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + mtac2_CI_REF=set-implicits + mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 + +fi diff --git a/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh b/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh new file mode 100644 index 0000000000..1af8b5430d --- /dev/null +++ b/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9476" ] || [ "$CI_BRANCH" = "context-constructor" ]; then + + quickchick_CI_REF=context-constructor + quickchick_CI_GITURL=https://github.com/ppedrot/QuickChick + + equations_CI_REF=context-constructor + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + +fi diff --git a/dev/doc/README-V1-V5.asciidoc b/dev/doc/README-V1-V5.asciidoc deleted file mode 100644 index 631fb92c97..0000000000 --- a/dev/doc/README-V1-V5.asciidoc +++ /dev/null @@ -1,378 +0,0 @@ -Notes on the prehistory of Coq -============================== -:author: Thierry Coquand, Gérard Huet & Christine Paulin-Mohring -:revdate: September 2015 -:toc: -:toc-placement: preamble -:toclevels: 1 -:showtitle: - - -This document is a copy within the Coq archive of a document written -in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin -to accompany their public release of the archive of versions 1.10 to 6.2 -of Coq and of its CONSTR ancestor. CONSTR, then Coq, was designed and -implemented in the Formel team, joint between the INRIA Rocquencourt -laboratory and the Ecole Normale Supérieure of Paris, from 1984 -onwards. - -Version 1 ---------- - -This software is a prototype type-checker for a higher-order logical -formalism known as the Theory of Constructions, presented in his PhD -thesis by Thierry Coquand, with influences from Girard's system F and -de Bruijn's Automath. The metamathematical analysis of the system is -the PhD work of Thierry Coquand. The software is mostly the work of -Gérard Huet. Most of the mathematical examples verified with the -software are due to Thierry Coquand. - -The programming language of the CONSTR software (as it was called at -the time) was a version of ML adapted from the Edinburgh LCF system -and running on a LISP backend. The main improvements from the original -LCF ML were that ML was compiled rather than interpreted (Gérard Huet -building on the original translator by Lockwood Morris), and that it -was enriched by recursively defined types (work of Guy -Cousineau). This ancestor of CAML was used and improved by Larry -Paulson for his implementation of Cambridge LCF. - -Software developments of this prototype occurred from late 1983 to -early 1985. - -Version 1.10 was frozen on December 22nd 1984. It is the version used -for the examples in Thierry Coquand's thesis, defended on January 31st -1985. There was a unique binding operator, used both for universal -quantification (dependent product) at the level of types and -functional abstraction (λ) at the level of terms/proofs, in the manner -of Automath. Substitution (λ-reduction) was implemented using de -Bruijn's indexes. - -Version 1.11 was frozen on February 19th, 1985. It is the version used -for the examples in the paper: Th. Coquand, G. Huet. __Constructions: A -Higher Order Proof System for Mechanizing Mathematics__ <<CH85>>. - -Christine Paulin joined the team at this point, for her DEA research -internship. In her DEA memoir (August 1985) she presents developments -for the _lambo_ function – _lambo(f)(n)_ computes the minimal _m_ such -that _f(m)_ is greater than _n_, for _f_ an increasing integer -function, a challenge for constructive mathematics. She also encoded -the majority voting algorithm of Boyer and Moore. - -Version 2 ---------- - -The formal system, now renamed as the _Calculus of Constructions_, was -presented with a proof of consistency and comparisons with proof -systems of Per Martin Löf, Girard, and the Automath family of N. de -Bruijn, in the paper: T. Coquand and G. Huet. __The Calculus of -Constructions__ <<CH88>>. - -An abstraction of the software design, in the form of an abstract -machine for proof checking, and a fuller sequence of mathematical -developments was presented in: Th. Coquand, G. Huet. __Concepts -Mathématiques et Informatiques Formalisés dans le Calcul des -Constructions__<<CH87>>. - -Version 2.8 was frozen on December 16th, 1985, and served for -developing the exemples in the above papers. - -This calculus was then enriched in version 2.9 with a cumulative -hierarchy of universes. Universe levels were initially explicit -natural numbers. Another improvement was the possibility of automatic -synthesis of implicit type arguments, relieving the user of tedious -redundant declarations. - -Christine Paulin wrote an article __Algorithm development in the -Calculus of Constructions__ <<P86>>. Besides _lambo_ and _majority_, -she presents quicksort and a text formatting algorithm. - -Version 2.13 of the Calculus of Constructions with universes was -frozen on June 25th, 1986. - -A synthetic presentation of type theory along constructive lines with -ML algorithms was given by Gérard Huet in his May 1986 CMU course -notes _Formal Structures for Computation and Deduction_. Its chapter -_Induction and Recursion in the Theory of Constructions_ was presented -as an invited paper at the Joint Conference on Theory and Practice of -Software Development TAPSOFT’87 at Pise in March 1987, and published -as __Induction Principles Formalized in the Calculus of -Constructions__ <<H88>>. - -Version 3 ---------- - -This version saw the beginning of proof automation, with a search -algorithm inspired from PROLOG and the applicative logic programming -programs of the course notes _Formal structures for computation and -deduction_. The search algorithm was implemented in ML by Thierry -Coquand. The proof system could thus be used in two modes: proof -verification and proof synthesis, with tactics such as `AUTO`. - -The implementation language was now called CAML, for Categorical -Abstract Machine Language. It used as backend the LLM3 virtual machine -of Le Lisp by Jérôme Chailloux. The main developers of CAML were -Michel Mauny, Ascander Suarez and Pierre Weis. - -V3.1 was started in the summer of 1986, V3.2 was frozen at the end of -November 1986. V3.4 was developed in the first half of 1987. - -Thierry Coquand held a post-doctoral position in Cambrige University -in 1986-87, where he developed a variant implementation in SML, with -which he wrote some developments on fixpoints in Scott's domains. - -Version 4 ---------- - -This version saw the beginning of program extraction from proofs, with -two varieties of the type `Prop` of propositions, indicating -constructive intent. The proof extraction algorithms were implemented -by Christine Paulin-Mohring. - -V4.1 was frozen on July 24th, 1987. It had a first identified library -of mathematical developments (directory exemples), with libraries -Logic (containing impredicative encodings of intuitionistic logic and -algebraic primitives for booleans, natural numbers and list), `Peano` -developing second-order Peano arithmetic, `Arith` defining addition, -multiplication, euclidean division and factorial. Typical developments -were the Knaster-Tarski theorem and Newman's lemma from rewriting -theory. - -V4.2 was a joint development of a team consisting of Thierry Coquand, -Gérard Huet and Christine Paulin-Mohring. A file V4.2.log records the -log of changes. It was frozen on September 1987 as the last version -implemented in CAML 2.3, and V4.3 followed on CAML 2.5, a more stable -development system. - -V4.3 saw the first top-level of the system. Instead of evaluating -explicit quotations, the user could develop his mathematics in a -high-level language called the mathematical vernacular (following -Automath terminology). The user could develop files in the vernacular -notation (with .v extension) which were now separate from the `ml` -sources of the implementation. Gilles Dowek joined the team to -develop the vernacular language as his DEA internship research. - -A notion of sticky constant was introduced, in order to keep names of -lemmas when local hypotheses of proofs were discharged. This gave a -notion of global mathematical environment with local sections. - -Another significant practical change was that the system, originally -developped on the VAX central computer of our lab, was transferred on -SUN personal workstations, allowing a level of distributed -development. The extraction algorithm was modified, with three -annotations `Pos`, `Null` and `Typ` decorating the sorts `Prop` and -`Type`. - -Version 4.3 was frozen at the end of November 1987, and was -distributed to an early community of users (among those were Hugo -Herbelin and Loic Colson). - -V4.4 saw the first version of (encoded) inductive types. Now natural -numbers could be defined as: - -[source, coq] -Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. - -These inductive types were encoded impredicatively in the calculus, -using a subsystem _rec_ due to Christine Paulin. V4.4 was frozen on -March 6th 1988. - -Version 4.5 was the first one to support inductive types and program -extraction. Its banner was _Calcul des Constructions avec -Réalisations et Synthèse_. The vernacular language was enriched to -accommodate extraction commands. - -The verification engine design was presented as: G. Huet. _The -Constructive Engine_. Version 4.5. Invited Conference, 2nd European -Symposium on Programming, Nancy, March 88. The final paper, -describing the V4.9 implementation, appeared in: A perspective in -Theoretical Computer Science, Commemorative Volume in memory of Gift -Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. - -Version 4.5 was demonstrated in June 1988 at the YoP Institute on -Logical Foundations of Functional Programming organized by Gérard Huet -at Austin, Texas. - -Version 4.6 was started during the summer of 1988. Its main -improvement was the complete rehaul of the proof synthesis engine by -Thierry Coquand, with a tree structure of goals. - -Its source code was communicated to Randy Pollack on September 2nd -1988. It evolved progressively into LEGO, proof system for Luo's -formalism of Extended Calculus of Constructions. - -The discharge tactic was modified by Gérard Huet to allow for -inter-dependencies in discharged lemmas. Christine Paulin improved the -inductive definition scheme in order to accommodate predicates of any -arity. - -Version 4.7 was started on September 6th, 1988. - -This version starts exploiting the CAML notion of module in order to -improve the modularity of the implementation. Now the term verifier is -identified as a proper module Machine, which the structure of its -internal data structures being hidden and thus accessible only through -the legitimate operations. This machine (the constructive engine) was -the trusted core of the implementation. The proof synthesis mechanism -was a separate proof term generator. Once a complete proof term was -synthesized with the help of tactics, it was entirely re-checked by -the engine. Thus there was no need to certify the tactics, and the -system took advantage of this fact by having tactics ignore the -universe levels, universe consistency check being relegated to the -final type-checking pass. This induced a certain puzzlement in early -users who saw, after a successful proof search, their `QED` followed -by silence, followed by a failure message due to a universe -inconsistency… - -The set of examples comprise set theory experiments by Hugo Herbelin, -and notably the Schroeder-Bernstein theorem. - -Version 4.8, started on October 8th, 1988, saw a major -re-implementation of the abstract syntax type `constr`, separating -variables of the formalism and metavariables denoting incomplete terms -managed by the search mechanism. A notion of level (with three values -`TYPE`, `OBJECT` and `PROOF`) is made explicit and a type judgement -clarifies the constructions, whose implementation is now fully -explicit. Structural equality is speeded up by using pointer equality, -yielding spectacular improvements. Thierry Coquand adapts the proof -synthesis to the new representation, and simplifies pattern matching -to first-order predicate calculus matching, with important performance -gain. - -A new representation of the universe hierarchy is then defined by -Gérard Huet. Universe levels are now implemented implicitly, through -a hidden graph of abstract levels constrained with an order relation. -Checking acyclicity of the graph insures well-foundedness of the -ordering, and thus consistency. This was documented in a memo _Adding -Type:Type to the Calculus of Constructions_ which was never published. - -The development version is released as a stable 4.8 at the end of -1988. - -Version 4.9 is released on March 1st 1989, with the new ``elastic'' -universe hierarchy. - -The spring of 1989 saw the first attempt at documenting the system -usage, with a number of papers describing the formalism: - -- _Metamathematical Investigations of a Calculus of Constructions_, by - Thierry Coquand <<C90>>, -- _Inductive definitions in the Calculus of Constructions_, by - Christine Paulin-Mohrin, -- _Extracting Fω's programs from proofs in the Calculus of - Constructions_, by Christine Paulin-Mohring <<P89>>, -- _The Constructive Engine_, by Gérard Huet <<H89>>, - -as well as a number of user guides: - -- _A short user's guide for the Constructions_ Version 4.10, by Gérard Huet -- _A Vernacular Syllabus_, by Gilles Dowek. -- _The Tactics Theorem Prover, User's guide_, Version 4.10, by Thierry - Coquand. - -Stable V4.10, released on May 1st, 1989, was then a mature system, -distributed with CAML V2.6. - -In the mean time, Thierry Coquand and Christine Paulin-Mohring had -been investigating how to add native inductive types to the Calculus -of Constructions, in the manner of Per Martin-Löf's Intuitionistic -Type Theory. The impredicative encoding had already been presented in: -F. Pfenning and C. Paulin-Mohring. __Inductively defined types in the -Calculus of Constructions__ <<PP90>>. An extension of the calculus -with primitive inductive types appeared in: Th. Coquand and -C. Paulin-Mohring. __Inductively defined types__ <<CP90>>. - -This led to the Calculus of Inductive Constructions, logical formalism -implemented in Versions 5 upward of the system, and documented in: -C. Paulin-Mohring. __Inductive Definitions in the System Coq - Rules -and Properties__ <<P93>>. - -The last version of CONSTR is Version 4.11, which was last distributed -in the spring of 1990. It was demonstrated at the first workshop of -the European Basic Research Action Logical Frameworks In Sophia -Antipolis in May 1990. - -At the end of 1989, Version 5.1 was started, and renamed as the system -Coq for the Calculus of Inductive Constructions. It was then ported to -the new stand-alone implementation of ML called Caml-light. - -In 1990 many changes occurred. Thierry Coquand left for Chalmers -University in Göteborg. Christine Paulin-Mohring took a CNRS -researcher position at the LIP laboratory of École Normale Supérieure -de Lyon. Project Formel was terminated, and gave rise to two teams: -Cristal at INRIA-Roquencourt, that continued developments in -functional programming with Caml-light then Ocaml, and Coq, continuing -the type theory research, with a joint team headed by Gérard Huet at -INRIA-Rocquencourt and Christine Paulin-Mohring at the LIP laboratory -of CNRS-ENS Lyon. - -Chetan Murthy joined the team in 1991 and became the main software -architect of Version 5. He completely rehauled the implementation for -efficiency. Versions 5.6 and 5.8 were major distributed versions, -with complete documentation and a library of users' developements. The -use of the RCS revision control system, and systematic ChangeLog -files, allow a more precise tracking of the software developments. - -Developments from Version 6 upwards are documented in the credits -section of Coq's Reference Manual. - -==== -September 2015 + -Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. -==== - -[bibliography] -.Bibliographic references - -- [[[CH85]]] Th. Coquand, G. Huet. _Constructions: A Higher Order - Proof System for Mechanizing Mathematics_. Invited paper, EUROCAL85, - April 1985, Linz, Austria. Springer Verlag LNCS 203, pp. 151-184. - -- [[[CH88]]] T. Coquand and G. Huet. _The Calculus of Constructions_. - Submitted on June 30th 1985, accepted on December 5th, 1985, - Information and Computation. Preprint as Rapport de Recherche Inria - n°530, Mai 1986. Final version in Information and Computation - 76,2/3, Feb. 88. - -- [[[CH87]]] Th. Coquand, G. Huet. _Concepts Mathématiques et - Informatiques Formalisés dans le Calcul des Constructions_. Invited - paper, European Logic Colloquium, Orsay, July 1985. Preprint as - Rapport de recherche INRIA n°463, Dec. 85. Published in Logic - Colloquium 1985, North-Holland, 1987. - -- [[[P86]]] C. Paulin. _Algorithm development in the Calculus of - Constructions_, preprint as Rapport de recherche INRIA n°497, - March 86. Final version in Proceedings Symposium on Logic in Computer - Science, Cambridge, MA, 1986 (IEEE Computer Society Press). - -- [[[H88]]] G. Huet. _Induction Principles Formalized in the Calculus - of Constructions_ in Programming of Future Generation Computers, - Ed. K. Fuchi and M. Nivat, North-Holland, 1988. - -- [[[C90]]] Th. Coquand. _Metamathematical Investigations of a - Calculus of Constructions_, by INRIA Research Report N°1088, - Sept. 1989, published in Logic and Computer Science, - ed. P.G. Odifreddi, Academic Press, 1990. - -- [[[P89]]] C. Paulin. _Extracting F ω's programs from proofs in the - calculus of constructions_. 16th Annual ACM Symposium on Principles - of Programming Languages, Austin. 1989. - -- [[[H89]]] G. Huet. _The constructive engine_. A perspective in - Theoretical Computer Science. Commemorative Volume for Gift - Siromoney. World Scientific Publishing (1989). - -- [[[PP90]]] F. Pfenning and C. Paulin-Mohring. _Inductively defined - types in the Calculus of Constructions_. Preprint technical report - CMU-CS-89-209, final version in Proceedings of Mathematical - Foundations of Programming Semantics, volume 442, Lecture Notes in - Computer Science. Springer-Verlag, 1990 - -- [[[CP90]]] Th. Coquand and C. Paulin-Mohring. _Inductively defined - types_. In P. Martin-Löf and G. Mints, editors, Proceedings of - Colog'88, volume 417, Lecture Notes in Computer Science. - Springer-Verlag, 1990. - -- [[[P93]]] C. Paulin-Mohring. _Inductive Definitions in the System - Coq - Rules and Properties_. In M. Bezem and J.-F. Groote, editors, - Proceedings of the conference Typed Lambda Calculi and Applications, - volume 664, Lecture Notes in Computer Science, 1993. diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index a31ab1c511..b1bfac8cc9 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -126,9 +126,9 @@ script again] This will be fixed in the future. ## Dropping from coqtop: -The following sequence is recommended: +After doing `make -f Makefile.dune voboot`, the following commands should work: ``` -dune exec coqtop.byte +dune exec dev/shim/coqbyte-prelude > Drop. # #directory "dev";; # #use "include_dune";; diff --git a/dev/doc/changes.md b/dev/doc/changes.md index e7d4b605c7..491a75bb3d 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -72,6 +72,12 @@ Libobject * `Libobject.superglobal_object` * `Libobject.superglobal_object_nodischarge` +Implicit Arguments + +- `Impargs.declare_manual_implicits` is restricted to only support declaration + of implicit binders at constant declaration time. `Impargs.set_implicits` should + be used for redeclaration of implicit arguments. + ## Changes between Coq 8.8 and Coq 8.9 ### ML API diff --git a/dev/shim/dune b/dev/shim/dune index 85a0d205da..39b4ef492c 100644 --- a/dev/shim/dune +++ b/dev/shim/dune @@ -11,6 +11,19 @@ (run chmod +x %{targets}))))) (rule + (targets coqbyte-prelude) + (deps + %{bin:coqtop.byte} + %{lib:coq.kernel:../../stublibs/dllbyterun_stubs.so} + %{project_root}/theories/Init/Prelude.vo) + (action + (with-outputs-to %{targets} + (progn + (echo "#!/usr/bin/env bash\n") + (bash "echo \"$(pwd)/%{bin:coqtop.byte} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (run chmod +x %{targets}))))) + +(rule (targets coqide-prelude) (deps %{bin:coqqueryworker.opt} diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index fac0035de1..881f7a310d 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -234,7 +234,8 @@ In addition to the objects above, the ``coqrst`` Sphinx plugin defines the follo - Behavior options - ``reset``: Send a ``Reset Initial`` command before running this block - - ``fail``: Don't die if a command fails + - ``fail``: Don't die if a command fails, implies ``warn`` (so no need to put both) + - ``warn``: Don't die if a command emits a warning - ``restart``: Send a ``Restart`` command before running this block (only works in proof mode) - ``abort``: Send an ``Abort All`` command after running this block (leaves all pending proofs if any) diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index 3e414a714c..a9d894cab5 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -313,7 +313,9 @@ constructor ``*``. It also tests that they work as expected. Unfortunately, these declarations are very verbose. In the following subsection we show how to make them more compact. -.. coqtop:: all +.. FIXME shouldn't warn + +.. coqtop:: all warn Module Add_instance_attempt. @@ -418,7 +420,9 @@ the reader can refer to :cite:`CSwcu`. The declaration of canonical instances can now be way more compact: -.. coqtop:: all +.. FIXME should not warn + +.. coqtop:: all warn Canonical Structure nat_LEQty := Eval hnf in Pack nat nat_LEQmx. diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index 3ec6c118af..e882ce6e88 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -285,7 +285,7 @@ By default, implicit arguments are omitted in patterns. So we write: .. coqtop:: all - Arguments nil [A]. + Arguments nil {A}. Arguments cons [A] _ _. Check (fun l:List nat => diff --git a/doc/sphinx/biblio.bib b/doc/sphinx/biblio.bib index d9eaa2c6c6..0467852b19 100644 --- a/doc/sphinx/biblio.bib +++ b/doc/sphinx/biblio.bib @@ -45,6 +45,58 @@ s}, year = {1972} } +@inproceedings{CH85, + title={Constructions: a higher order proof system for mechanizing mathematics}, + author={Coquand, Thierry and Huet, Gérard}, + booktitle={European Conference on Computer Algebra}, + pages={151--184}, + year={1985}, + issn = {1611-3349}, + doi = {10.1007/3-540-15983-5_13}, + url = {http://dx.doi.org/10.1007/3-540-15983-5_13}, + isbn = 9783540396840, + publisher = {Springer Berlin Heidelberg} +} + +@techreport{CH88 + TITLE = {{The calculus of constructions}}, + AUTHOR = {Coquand, T. and Huet, G{\'e}rard}, + URL = {https://hal.inria.fr/inria-00076024}, + NUMBER = {RR-0530}, + INSTITUTION = {{INRIA}}, + YEAR = {1986}, + MONTH = May, + PDF = {https://hal.inria.fr/inria-00076024/file/RR-0530.pdf}, + HAL_ID = {inria-00076024}, + HAL_VERSION = {v1}, +} + +@techreport{CH87, + TITLE = {{Concepts mathematiques et informatiques formalises dans le calcul des constructions}}, + AUTHOR = {Coquand, T. and Huet, G{\'e}rard}, + URL = {https://hal.inria.fr/inria-00076039}, + NUMBER = {RR-0515}, + INSTITUTION = {{INRIA}}, + YEAR = {1986}, + MONTH = Apr, + PDF = {https://hal.inria.fr/inria-00076039/file/RR-0515.pdf}, + HAL_ID = {inria-00076039}, + HAL_VERSION = {v1}, +} + +@techreport{C90, + TITLE = {{Metamathematical investigations of a calculus of constructions}}, + AUTHOR = {Coquand, T.}, + URL = {https://hal.inria.fr/inria-00075471}, + NUMBER = {RR-1088}, + INSTITUTION = {{INRIA}}, + YEAR = {1989}, + MONTH = Sep, + PDF = {https://hal.inria.fr/inria-00075471/file/RR-1088.pdf}, + HAL_ID = {inria-00075471}, + HAL_VERSION = {v1}, +} + @PhDThesis{Coq85, author = {Th. Coquand}, month = jan, @@ -80,6 +132,19 @@ s}, bibsource = {DBLP, http://dblp.uni-trier.de} } +@inproceedings{CP90, + title={Inductively defined types}, + author={Coquand, Thierry and Paulin, Christine}, + booktitle={COLOG-88}, + pages={50--66}, + year={1990}, + issn = {1611-3349}, + doi = {10.1007/3-540-52335-9_47}, + url = {http://dx.doi.org/10.1007/3-540-52335-9_47}, + isbn = 9783540469636, + publisher = {Springer Berlin Heidelberg} +} + @Book{Cur58, author = {Haskell B. Curry and Robert Feys and William Craig}, title = {Combinatory Logic}, @@ -216,7 +281,19 @@ s}, year = {1980} } -@InProceedings{Hue88, +@inproceedings{H88, + title={Induction principles formalized in the Calculus of Constructions}, + author={Huet, G{\'e}rard}, + booktitle={Programming of Future Generation Computers. Elsevier Science}, + year={1988}, + issn = {1611-3349}, + doi = {10.1007/3-540-17660-8_62}, + url = {http://dx.doi.org/10.1007/3-540-17660-8_62}, + isbn = 9783540477464, + publisher = {Springer Berlin Heidelberg} +} + +@InProceedings{H89, author = {G. Huet}, booktitle = {A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney}, editor = {R. Narasimhan}, @@ -305,6 +382,50 @@ s}, url = {http://www.xmailserver.org/diff2.pdf} } +@inproceedings{P86, + title={Algorithm development in the calculus of constructions}, + author={Mohring, Christine}, + booktitle={LICS}, + pages={84--91}, + year={1986} +} + +@inproceedings{P89, + title={Extracting $\Omega$'s programs from proofs in the calculus of constructions}, + author={Paulin-Mohring, Christine}, + booktitle={Proceedings of the 16th ACM SIGPLAN-SIGACT symposium on Principles of programming languages}, + pages={89--104}, + year={1989}, + doi = {10.1145/75277.75285}, + url = {http://dx.doi.org/10.1145/75277.75285}, + isbn = 0897912942, + organization = {ACM Press} +} + +@inproceedings{P93, + title={Inductive definitions in the system coq rules and properties}, + author={Paulin-Mohring, Christine}, + booktitle={International Conference on Typed Lambda Calculi and Applications}, + pages={328--345}, + year={1993}, + doi = {10.1007/bfb0037116}, + url = {http://dx.doi.org/10.1007/bfb0037116}, + isbn = 3540565175, + organization = {Springer-Verlag} +} + +@inproceedings{PP90, + title={Inductively defined types in the Calculus of Constructions}, + author={Pfenning, Frank and Paulin-Mohring, Christine}, + booktitle={International Conference on Mathematical Foundations of Programming Semantics}, + pages={209--228}, + year={1989}, + doi = {10.1007/bfb0040259}, + url = {http://dx.doi.org/10.1007/bfb0040259}, + isbn = 0387973753, + organization = {Springer-Verlag} +} + @InProceedings{Parent95b, author = {C. Parent}, booktitle = {{Mathematics of Program Construction'95}}, diff --git a/doc/sphinx/credits.rst b/doc/sphinx/credits.rst index 909af6e2f2..5873096523 100644 --- a/doc/sphinx/credits.rst +++ b/doc/sphinx/credits.rst @@ -2,10 +2,13 @@ Credits ------- +Historical roots +---------------- + Coq is a proof assistant for higher-order logic, allowing the development of computer programs consistent with their formal -specification. It is the result of about ten years of research of the -Coq project. We shall briefly survey here three main aspects: the +specification. It is the result of about ten years [#years]_ of research +of the Coq project. We shall briefly survey here three main aspects: the *logical language* in which we write our axiomatizations and specifications, the *proof assistant* which allows the development of verified mathematical proofs, and the *program extractor* which @@ -21,8 +24,8 @@ prompted Russell to restrict predicate calculus with a stratification of *types*. This effort culminated with *Principia Mathematica*, the first systematic attempt at a formal foundation of mathematics. A simplification of this system along the lines of simply typed -:math:`\lambda`-calculus occurred with Church’s *Simple Theory of -Types*. The :math:`\lambda`-calculus notation, originally used for +λ-calculus occurred with Church’s *Simple Theory of +Types*. The λ-calculus notation, originally used for expressing functionality, could also be used as an encoding of natural deduction proofs. This Curry-Howard isomorphism was used by N. de Bruijn in the *Automath* project, the first full-scale attempt to develop and @@ -32,7 +35,7 @@ Exploiting this Curry-Howard isomorphism, notable achievements in proof theory saw the emergence of two type-theoretic frameworks; the first one, Martin-Löf’s *Intuitionistic Theory of Types*, attempts a new foundation of mathematics on constructive principles. The second one, -Girard’s polymorphic :math:`\lambda`-calculus :math:`F_\omega`, is a +Girard’s polymorphic λ-calculus :math:`F_\omega`, is a very strong functional system in which we may represent higher-order logic proof structures. Combining both systems in a higher-order extension of the Automath language, T. Coquand presented in 1985 the @@ -107,15 +110,27 @@ advantage of special hardware, debuggers, and the like. We hope that |Coq| can be of use to researchers interested in experimenting with this new methodology. +.. [#years] At the time of writting, i.e. 1995. + +Brief summary of the versions up to 5.10 +---------------------------------------- + +.. note:: + This summary was written in 1995 together with the previous + section and formed the initial version of the Credits chapter + (that has since then been appended to, at each new release). + A more comprehensive description of these early versions is + available in the next few sections, which were written in 2015. + A first implementation of CoC was started in 1984 by G. Huet and T. Coquand. Its implementation language was CAML, a functional programming language from the ML family designed at INRIA in Rocquencourt. The core of this system was a proof-checker for CoC seen as a typed -:math:`\lambda`-calculus, called the *Constructive Engine*. This engine +λ-calculus, called the *Constructive Engine*. This engine was operated through a high-level notation permitting the declaration of axioms and parameters, the definition of mathematical types and objects, and the explicit construction of proof objects encoded as -:math:`\lambda`-terms. A section mechanism, designed and implemented by +λ-terms. A section mechanism, designed and implemented by G. Dowek, allowed hierarchical developments of mathematical theories. This high-level language was called the *Mathematical Vernacular*. Furthermore, an interactive *Theorem Prover* permitted the incremental @@ -189,8 +204,324 @@ definitions of “inversion predicates”. | Gérard Huet | -Credits: addendum for version 6.1 ---------------------------------- +Version 1 +--------- + +.. note:: + + These additional notes come from a document written + in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin + to accompany their public release of the archive of versions 1.10 to 6.2 + of Coq and of its CONSTR ancestor. CONSTR, then Coq, was designed and + implemented in the Formel team, joint between the INRIA Rocquencourt + laboratory and the Ecole Normale Supérieure of Paris, from 1984 + onwards. + +This software is a prototype type-checker for a higher-order logical +formalism known as the Theory of Constructions, presented in his PhD +thesis by Thierry Coquand, with influences from Girard's system F and +de Bruijn's Automath. The metamathematical analysis of the system is +the PhD work of Thierry Coquand. The software is mostly the work of +Gérard Huet. Most of the mathematical examples verified with the +software are due to Thierry Coquand. + +The programming language of the CONSTR software (as it was called at +the time) was a version of ML adapted from the Edinburgh LCF system +and running on a LISP backend. The main improvements from the original +LCF ML were that ML was compiled rather than interpreted (Gérard Huet +building on the original translator by Lockwood Morris), and that it +was enriched by recursively defined types (work of Guy +Cousineau). This ancestor of CAML was used and improved by Larry +Paulson for his implementation of Cambridge LCF. + +Software developments of this prototype occurred from late 1983 to +early 1985. + +Version 1.10 was frozen on December 22nd 1984. It is the version used +for the examples in Thierry Coquand's thesis, defended on January 31st +1985. There was a unique binding operator, used both for universal +quantification (dependent product) at the level of types and +functional abstraction (λ) at the level of terms/proofs, in the manner +of Automath. Substitution (λ-reduction) was implemented using de +Bruijn's indexes. + +Version 1.11 was frozen on February 19th, 1985. It is the version used +for the examples in the paper: T. Coquand, G. Huet. *Constructions: A +Higher Order Proof System for Mechanizing Mathematics* :cite:`CH85`. + +Christine Paulin joined the team at this point, for her DEA research +internship. In her DEA memoir (August 1985) she presents developments +for the *lambo* function – :math:`\text{lambo}(f)(n)` computes the minimal +:math:`m` such that :math:`f(m)` is greater than :math:`n`, for :math:`f` +an increasing integer function, a challenge for constructive mathematics. +She also encoded the majority voting algorithm of Boyer and Moore. + +Version 2 +--------- + +The formal system, now renamed as the *Calculus of Constructions*, was +presented with a proof of consistency and comparisons with proof +systems of Per Martin Löf, Girard, and the Automath family of N. de +Bruijn, in the paper: T. Coquand and G. Huet. *The Calculus of +Constructions* :cite:`CH88`. + +An abstraction of the software design, in the form of an abstract +machine for proof checking, and a fuller sequence of mathematical +developments was presented in: T. Coquand, G. Huet. *Concepts +Mathématiques et Informatiques Formalisés dans le Calcul des +Constructions* :cite:`CH87`. + +Version 2.8 was frozen on December 16th, 1985, and served for +developing the examples in the above papers. + +This calculus was then enriched in version 2.9 with a cumulative +hierarchy of universes. Universe levels were initially explicit +natural numbers. Another improvement was the possibility of automatic +synthesis of implicit type arguments, relieving the user of tedious +redundant declarations. + +Christine Paulin wrote an article *Algorithm development in the +Calculus of Constructions* :cite:`P86`. Besides *lambo* and *majority*, +she presents *quicksort* and a text formatting algorithm. + +Version 2.13 of the Calculus of Constructions with universes was +frozen on June 25th, 1986. + +A synthetic presentation of type theory along constructive lines with +ML algorithms was given by Gérard Huet in his May 1986 CMU course +notes *Formal Structures for Computation and Deduction*. Its chapter +*Induction and Recursion in the Theory of Constructions* was presented +as an invited paper at the Joint Conference on Theory and Practice of +Software Development TAPSOFT’87 at Pise in March 1987, and published +as *Induction Principles Formalized in the Calculus of +Constructions* :cite:`H88`. + +Version 3 +--------- + +This version saw the beginning of proof automation, with a search +algorithm inspired from PROLOG and the applicative logic programming +programs of the course notes *Formal structures for computation and +deduction*. The search algorithm was implemented in ML by Thierry +Coquand. The proof system could thus be used in two modes: proof +verification and proof synthesis, with tactics such as ``AUTO``. + +The implementation language was now called CAML, for Categorical +Abstract Machine Language. It used as backend the LLM3 virtual machine +of Le Lisp by Jérôme Chailloux. The main developers of CAML were +Michel Mauny, Ascander Suarez and Pierre Weis. + +V3.1 was started in the summer of 1986, V3.2 was frozen at the end of +November 1986. V3.4 was developed in the first half of 1987. + +Thierry Coquand held a post-doctoral position in Cambrige University +in 1986-87, where he developed a variant implementation in SML, with +which he wrote some developments on fixpoints in Scott's domains. + +Version 4 +--------- + +This version saw the beginning of program extraction from proofs, with +two varieties of the type ``Prop`` of propositions, indicating +constructive intent. The proof extraction algorithms were implemented +by Christine Paulin-Mohring. + +V4.1 was frozen on July 24th, 1987. It had a first identified library +of mathematical developments (directory ``exemples``), with libraries +``Logic`` (containing impredicative encodings of intuitionistic logic and +algebraic primitives for booleans, natural numbers and list), ``Peano`` +developing second-order Peano arithmetic, ``Arith`` defining addition, +multiplication, euclidean division and factorial. Typical developments +were the Knaster-Tarski theorem and Newman's lemma from rewriting +theory. + +V4.2 was a joint development of a team consisting of Thierry Coquand, +Gérard Huet and Christine Paulin-Mohring. A file V4.2.log records the +log of changes. It was frozen on September 1987 as the last version +implemented in CAML 2.3, and V4.3 followed on CAML 2.5, a more stable +development system. + +V4.3 saw the first top-level of the system. Instead of evaluating +explicit quotations, the user could develop his mathematics in a +high-level language called the mathematical vernacular (following +Automath terminology). The user could develop files in the vernacular +notation (with ``.v`` extension) which were now separate from the ``ml`` +sources of the implementation. Gilles Dowek joined the team to +develop the vernacular language as his DEA internship research. + +A notion of sticky constant was introduced, in order to keep names of +lemmas when local hypotheses of proofs were discharged. This gave a +notion of global mathematical environment with local sections. + +Another significant practical change was that the system, originally +developped on the VAX central computer of our lab, was transferred on +SUN personal workstations, allowing a level of distributed +development. The extraction algorithm was modified, with three +annotations ``Pos``, ``Null`` and ``Typ`` decorating the sorts ``Prop`` +and ``Type``. + +Version 4.3 was frozen at the end of November 1987, and was +distributed to an early community of users (among those were Hugo +Herbelin and Loic Colson). + +V4.4 saw the first version of (encoded) inductive types. Now natural +numbers could be defined as:: + + [source, coq] + Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. + +These inductive types were encoded impredicatively in the calculus, +using a subsystem *rec* due to Christine Paulin. V4.4 was frozen on +March 6th 1988. + +Version 4.5 was the first one to support inductive types and program +extraction. Its banner was *Calcul des Constructions avec +Réalisations et Synthèse*. The vernacular language was enriched to +accommodate extraction commands. + +The verification engine design was presented as: G. Huet. *The +Constructive Engine*. Version 4.5. Invited Conference, 2nd European +Symposium on Programming, Nancy, March 88. The final paper, +describing the V4.9 implementation, appeared in: A perspective in +Theoretical Computer Science, Commemorative Volume in memory of Gift +Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. + +Version 4.5 was demonstrated in June 1988 at the YoP Institute on +Logical Foundations of Functional Programming organized by Gérard Huet +at Austin, Texas. + +Version 4.6 was started during the summer of 1988. Its main +improvement was the complete rehaul of the proof synthesis engine by +Thierry Coquand, with a tree structure of goals. + +Its source code was communicated to Randy Pollack on September 2nd +1988. It evolved progressively into LEGO, proof system for Luo's +formalism of Extended Calculus of Constructions. + +The discharge tactic was modified by Gérard Huet to allow for +inter-dependencies in discharged lemmas. Christine Paulin improved the +inductive definition scheme in order to accommodate predicates of any +arity. + +Version 4.7 was started on September 6th, 1988. + +This version starts exploiting the CAML notion of module in order to +improve the modularity of the implementation. Now the term verifier is +identified as a proper module Machine, which the structure of its +internal data structures being hidden and thus accessible only through +the legitimate operations. This machine (the constructive engine) was +the trusted core of the implementation. The proof synthesis mechanism +was a separate proof term generator. Once a complete proof term was +synthesized with the help of tactics, it was entirely re-checked by +the engine. Thus there was no need to certify the tactics, and the +system took advantage of this fact by having tactics ignore the +universe levels, universe consistency check being relegated to the +final type-checking pass. This induced a certain puzzlement in early +users who saw, after a successful proof search, their ``QED`` followed +by silence, followed by a failure message due to a universe +inconsistency… + +The set of examples comprise set theory experiments by Hugo Herbelin, +and notably the Schroeder-Bernstein theorem. + +Version 4.8, started on October 8th, 1988, saw a major +re-implementation of the abstract syntax type ``constr``, separating +variables of the formalism and metavariables denoting incomplete terms +managed by the search mechanism. A notion of level (with three values +``TYPE``, ``OBJECT`` and ``PROOF``) is made explicit and a type judgement +clarifies the constructions, whose implementation is now fully +explicit. Structural equality is speeded up by using pointer equality, +yielding spectacular improvements. Thierry Coquand adapts the proof +synthesis to the new representation, and simplifies pattern matching +to first-order predicate calculus matching, with important performance +gain. + +A new representation of the universe hierarchy is then defined by +Gérard Huet. Universe levels are now implemented implicitly, through +a hidden graph of abstract levels constrained with an order relation. +Checking acyclicity of the graph insures well-foundedness of the +ordering, and thus consistency. This was documented in a memo *Adding +Type:Type to the Calculus of Constructions* which was never published. + +The development version is released as a stable 4.8 at the end of +1988. + +Version 4.9 is released on March 1st 1989, with the new "elastic" +universe hierarchy. + +The spring of 1989 saw the first attempt at documenting the system +usage, with a number of papers describing the formalism: + +- *Metamathematical Investigations of a Calculus of Constructions*, by + Thierry Coquand :cite:`C90`, + +- *Inductive definitions in the Calculus of Constructions*, by + Christine Paulin-Mohrin, + +- *Extracting Fω's programs from proofs in the Calculus of + Constructions*, by Christine Paulin-Mohring* :cite:`P89`, + +- *The Constructive Engine*, by Gérard Huet :cite:`H89`, + +as well as a number of user guides: + +- *A short user's guide for the Constructions*, Version 4.10, by Gérard Huet +- *A Vernacular Syllabus*, by Gilles Dowek. +- *The Tactics Theorem Prover, User's guide*, Version 4.10, by Thierry + Coquand. + +Stable V4.10, released on May 1st, 1989, was then a mature system, +distributed with CAML V2.6. + +In the mean time, Thierry Coquand and Christine Paulin-Mohring had +been investigating how to add native inductive types to the Calculus +of Constructions, in the manner of Per Martin-Löf's Intuitionistic +Type Theory. The impredicative encoding had already been presented in: +F. Pfenning and C. Paulin-Mohring. *Inductively defined types in the +Calculus of Constructions* :cite:`PP90`. An extension of the calculus +with primitive inductive types appeared in: T. Coquand and +C. Paulin-Mohring. *Inductively defined types* :cite:`CP90`. + +This led to the Calculus of Inductive Constructions, logical formalism +implemented in Versions 5 upward of the system, and documented in: +C. Paulin-Mohring. *Inductive Definitions in the System Coq - Rules +and Properties* :cite:`P93`. + +The last version of CONSTR is Version 4.11, which was last distributed +in the spring of 1990. It was demonstrated at the first workshop of +the European Basic Research Action Logical Frameworks In Sophia +Antipolis in May 1990. + +Version 5 +--------- + +At the end of 1989, Version 5.1 was started, and renamed as the system +Coq for the Calculus of Inductive Constructions. It was then ported to +the new stand-alone implementation of ML called Caml-light. + +In 1990 many changes occurred. Thierry Coquand left for Chalmers +University in Göteborg. Christine Paulin-Mohring took a CNRS +researcher position at the LIP laboratory of École Normale Supérieure +de Lyon. Project Formel was terminated, and gave rise to two teams: +Cristal at INRIA-Roquencourt, that continued developments in +functional programming with Caml-light then OCaml, and Coq, continuing +the type theory research, with a joint team headed by Gérard Huet at +INRIA-Rocquencourt and Christine Paulin-Mohring at the LIP laboratory +of CNRS-ENS Lyon. + +Chetan Murthy joined the team in 1991 and became the main software +architect of Version 5. He completely rehauled the implementation for +efficiency. Versions 5.6 and 5.8 were major distributed versions, +with complete documentation and a library of users' developements. The +use of the RCS revision control system, and systematic ChangeLog +files, allow a more precise tracking of the software developments. + +| September 2015 + +| Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. +| + +Version 6.1 +----------- The present version 6.1 of |Coq| is based on the V5.10 architecture. It was ported to the new language Objective Caml by Bruno Barras. The @@ -226,8 +557,8 @@ Barras. | Christine Paulin | -Credits: addendum for version 6.2 ---------------------------------- +Version 6.2 +----------- In version 6.2 of |Coq|, the parsing is done using camlp4, a preprocessor and pretty-printer for CAML designed by Daniel de Rauglaudre at INRIA. @@ -271,8 +602,8 @@ Loiseleur. | Christine Paulin | -Credits: addendum for version 6.3 ---------------------------------- +Version 6.3 +----------- The main changes in version V6.3 were the introduction of a few new tactics and the extension of the guard condition for fixpoint @@ -304,8 +635,8 @@ Monin from CNET Lannion. | Christine Paulin | -Credits: versions 7 -------------------- +Versions 7 +---------- The version V7 is a new implementation started in September 1999 by Jean-Christophe Filliâtre. This is a major revision with respect to the @@ -393,8 +724,8 @@ J.-F. Monin from France Telecom R & D. | Hugo Herbelin & Christine Paulin | -Credits: version 8.0 --------------------- +Version 8.0 +----------- Coq version 8 is a major revision of the |Coq| proof assistant. First, the underlying logic is slightly different. The so-called *impredicativity* @@ -495,8 +826,8 @@ under the responsibility of Christine Paulin. | (updated Apr. 2006) | -Credits: version 8.1 --------------------- +Version 8.1 +----------- Coq version 8.1 adds various new functionalities. @@ -574,8 +905,8 @@ and Yale University. | Hugo Herbelin | -Credits: version 8.2 --------------------- +Version 8.2 +----------- Coq version 8.2 adds new features, new libraries and improves on many various aspects. @@ -668,8 +999,8 @@ the Coq-Club mailing list. | Hugo Herbelin | -Credits: version 8.3 --------------------- +Version 8.3 +----------- Coq version 8.3 is before all a transition version with refinements or extensions of the existing features and libraries and a new tactic nsatz @@ -742,8 +1073,8 @@ Pierce for the excellent teaching materials they provided. | Hugo Herbelin | -Credits: version 8.4 --------------------- +Version 8.4 +----------- Coq version 8.4 contains the result of three long-term projects: a new modular library of arithmetic by Pierre Letouzey, a new proof engine by @@ -898,8 +1229,8 @@ Eelis van der Weegen. | Hugo Herbelin | -Credits: version 8.5 --------------------- +Version 8.5 +----------- Coq version 8.5 contains the result of five specific long-term projects: @@ -916,7 +1247,7 @@ Coq version 8.5 contains the result of five specific long-term projects: Matthieu Sozeau. - An implementation of primitive projections with - :math:`\eta`-conversion bringing significant performance improvements + :math:`\eta`\-conversion bringing significant performance improvements when using records by Matthieu Sozeau. The full integration of the proof engine, by Arnaud Spiwack and @@ -967,10 +1298,10 @@ messages in case of inconsistencies and allowing higher-level algorithms like unification to be entirely type safe. The internal representation of universes has been modified but this is invisible to the user. -The underlying logic has been extended with :math:`\eta`-conversion for +The underlying logic has been extended with :math:`\eta`\-conversion for records defined with primitive projections by Matthieu Sozeau. This -additional form of :math:`\eta`-conversion is justified using the same -principle than the previously added :math:`\eta`-conversion for function +additional form of :math:`\eta`\-conversion is justified using the same +principle than the previously added :math:`\eta`\-conversion for function types, based on formulations of the Calculus of Inductive Constructions with typed equality. Primitive projections, which do not carry the parameters of the record and are rigid names (not defined as a @@ -1052,8 +1383,8 @@ Tankink. Maxime Dénès coordinated the release process. | Hugo Herbelin, Matthieu Sozeau and the |Coq| development team | -Credits: version 8.6 --------------------- +Version 8.6 +----------- Coq version 8.6 contains the result of refinements, stabilization of 8.5’s features and cleanups of the internals of the system. Over the @@ -1192,8 +1523,8 @@ Dénès to put together a |Coq| consortium. | Matthieu Sozeau and the |Coq| development team | -Credits: version 8.7 --------------------- +Version 8.7 +----------- |Coq| version 8.7 contains the result of refinements, stabilization of features and cleanups of the internals of the system along with a few new features. The @@ -1298,8 +1629,8 @@ system, is now upcoming and will rely on Inria’s newly created Foundation. | Matthieu Sozeau and the |Coq| development team | -Credits: version 8.8 --------------------- +Version 8.8 +----------- |Coq| version 8.8 contains the result of refinements and stabilization of features and deprecations, cleanups of the internals of the system along @@ -1405,8 +1736,8 @@ The contacts of the Coq Consortium are Yves Bertot and Maxime Dénès. | Matthieu Sozeau for the |Coq| development team | -Credits: version 8.9 --------------------- +Version 8.9 +----------- |Coq| version 8.9 contains the result of refinements and stabilization of features and deprecations or removals of deprecated features, diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index c1eab8a970..d1b95e6203 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -606,7 +606,10 @@ Finally, it gives the definition of the usual orderings ``le``, single: ge (term) single: gt (term) -.. coqtop:: in +.. This emits a notation already used warning but it won't be shown to + the user. + +.. coqtop:: in warn Inductive le (n:nat) : nat -> Prop := | le_n : le n n diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index f1733a5ebf..59506a6ff2 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -1575,7 +1575,7 @@ Declaring Implicit Arguments -.. cmd:: Arguments @qualid {* [ @ident ] | @ident } +.. cmd:: Arguments @qualid {* [ @ident ] | { @ident } | @ident } :name: Arguments (implicits) This command is used to set implicit arguments *a posteriori*, @@ -1592,20 +1592,20 @@ Declaring Implicit Arguments This command clears implicit arguments. -.. cmdv:: Global Arguments @qualid {* [ @ident ] | @ident } +.. cmdv:: Global Arguments @qualid {* [ @ident ] | { @ident } | @ident } This command is used to recompute the implicit arguments of :token:`qualid` after ending of the current section if any, enforcing the implicit arguments known from inside the section to be the ones declared by the command. -.. cmdv:: Local Arguments @qualid {* [ @ident ] | @ident } +.. cmdv:: Local Arguments @qualid {* [ @ident ] | { @ident } | @ident } When in a module, tell not to activate the implicit arguments of :token:`qualid` declared by this command to contexts that require the module. -.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ [ @ident ] | @ident } } +.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ [ @ident ] | { @ident } | @ident } } For names of constants, inductive types, constructors, lemmas which can only be applied to a fixed number of @@ -1621,7 +1621,7 @@ Declaring Implicit Arguments .. coqtop:: reset all - Inductive list (A:Type) : Type := + Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. @@ -1629,13 +1629,15 @@ Declaring Implicit Arguments Arguments cons [A] _ _. - Arguments nil [A]. + Arguments nil {A}. Check (cons 3 nil). - Fixpoint map (A B:Type) (f:A->B) (l:list A) : list B := match l with nil => nil | cons a t => cons (f a) (map A B f t) end. + Fixpoint map (A B : Type) (f : A -> B) (l : list A) : list B := + match l with nil => nil | cons a t => cons (f a) (map A B f t) end. - Fixpoint length (A:Type) (l:list A) : nat := match l with nil => 0 | cons _ m => S (length A m) end. + Fixpoint length (A : Type) (l : list A) : nat := + match l with nil => 0 | cons _ m => S (length A m) end. Arguments map [A B] f l. @@ -1651,6 +1653,13 @@ Declaring Implicit Arguments To know which are the implicit arguments of an object, use the command :cmd:`Print Implicit` (see :ref:`displaying-implicit-args`). +.. warn:: Argument number @num is a trailing implicit so must be maximal. + + For instance in + + .. coqtop:: all warn + + Arguments prod _ [_]. Automatic declaration of implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1704,19 +1713,15 @@ of constants. For instance, the variable ``p`` below has type ``forall x,y:U, R x y -> forall z:U, R y z -> R x z``. As the variables ``x``, ``y`` and ``z`` appear strictly in the body of the type, they are implicit. -.. coqtop:: reset none - - Set Warnings "-local-declaration". - .. coqtop:: all - Variable X : Type. + Parameter X : Type. Definition Relation := X -> X -> Prop. Definition Transitivity (R:Relation) := forall x y:X, R x y -> forall z:X, R y z -> R x z. - Variables (R : Relation) (p : Transitivity R). + Parameters (R : Relation) (p : Transitivity R). Arguments p : default implicits. @@ -1724,7 +1729,7 @@ appear strictly in the body of the type, they are implicit. Print Implicit p. - Variables (a b c : X) (r1 : R a b) (r2 : R b c). + Parameters (a b c : X) (r1 : R a b) (r2 : R b c). Check (p r1 r2). diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 9ab3f905e6..9bd41d79b7 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -1023,7 +1023,7 @@ Mutually defined inductive types .. coqtop:: in - Variables A B : Set. + Parameters A B : Set. Inductive tree : Set := node : A -> forest -> tree @@ -1533,7 +1533,7 @@ the following attributes names are recognized: .. example:: - .. coqtop:: all reset + .. coqtop:: all reset warn From Coq Require Program. #[program] Definition one : nat := S _. diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index 63d6a229ed..b629d15b11 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -33,7 +33,7 @@ example, revisiting the first example of the inversion documentation: | LeO : forall n:nat, Le 0 n | LeS : forall n m:nat, Le n m -> Le (S n) (S m). - Variable P : nat -> nat -> Prop. + Parameter P : nat -> nat -> Prop. Goal forall n m:nat, Le (S n) m -> P n m. @@ -69,7 +69,7 @@ as well in this case, e.g.: .. coqtop:: in - Variable Q : forall (n m : nat), Le n m -> Prop. + Parameter Q : forall (n m : nat), Le n m -> Prop. Goal forall n m (p : Le (S n) m), Q (S n) m p. .. coqtop:: all @@ -124,7 +124,7 @@ the following example on vectors: .. coqtop:: in - Variable A : Set. + Parameter A : Set. .. coqtop:: in @@ -329,7 +329,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Variable Ack : nat -> nat -> nat. + Parameter Ack : nat -> nat -> nat. .. coqtop:: in @@ -357,7 +357,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Variable g : nat -> nat -> nat. + Parameter g : nat -> nat -> nat. .. coqtop:: in diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 3e87e8acd8..52e3029b8f 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -200,7 +200,7 @@ following form: :name: [> ... | ... | ... ] (dispatch) The expressions :n:`@expr__i` are evaluated to :n:`v__i`, for - i = 0, ..., n and all have to be tactics. The :n:`v__i` is applied to the + i = 1, ..., n and all have to be tactics. The :n:`v__i` is applied to the i-th goal, for i = 1, ..., n. It fails if the number of focused goals is not exactly n. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 2300a317f1..27360f02d3 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -30,7 +30,7 @@ When a proof is completed, the message ``Proof completed`` is displayed. One can then register this proof as a defined constant in the environment. Because there exists a correspondence between proofs and terms of λ-calculus, known as the *Curry-Howard isomorphism* -:cite:`How80,Bar81,Gir89,Hue88`, |Coq| stores proofs as terms of |Cic|. Those +:cite:`How80,Bar81,Gir89,H89`, |Coq| stores proofs as terms of |Cic|. Those terms are called *proof terms*. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index b81830f06b..b240cef40c 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -2902,6 +2902,7 @@ pattern will be used to process its instance. Axiom P : nat -> Prop. Axioms eqn leqn : nat -> nat -> bool. + Declare Scope this_scope. Notation "a != b" := (eqn a b) (at level 70) : this_scope. Notation "a <= b" := (leqn a b) (at level 70) : this_scope. Open Scope this_scope. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index b5e9a902c6..7b395900e9 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -378,7 +378,7 @@ Examples: .. coqtop:: reset none - Variables (A : Prop) (B: nat -> Prop) (C: Prop). + Parameters (A : Prop) (B: nat -> Prop) (C: Prop). .. coqtop:: out @@ -730,15 +730,15 @@ Applying theorems .. coqtop:: reset in - Variable R : nat -> nat -> Prop. + Parameter R : nat -> nat -> Prop. - Hypothesis Rtrans : forall x y z:nat, R x y -> R y z -> R x z. + Axiom Rtrans : forall x y z:nat, R x y -> R y z -> R x z. - Variables n m p : nat. + Parameters n m p : nat. - Hypothesis Rnm : R n m. + Axiom Rnm : R n m. - Hypothesis Rmp : R m p. + Axiom Rmp : R m p. Consider the goal ``(R n p)`` provable using the transitivity of ``R``: @@ -3683,11 +3683,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is Local is useless since hints do not survive anyway to the closure of sections. - .. cmdv:: Local Hint @hint_definition - - Idem for the core database. - - .. cmdv:: Hint Resolve @term {? | {? @num} {? @pattern}} + .. cmdv:: Hint Resolve @term {? | {? @num} {? @pattern}} : @ident :name: Hint Resolve This command adds :n:`simple apply @term` to the hint list with the head @@ -3706,16 +3702,16 @@ The general command to add a hint to some databases :n:`{+ @ident}` is typical example of a hint that is used only by :tacn:`eauto` is a transitivity lemma. - .. exn:: @term cannot be used as a hint + .. exn:: @term cannot be used as a hint - The head symbol of the type of :n:`@term` is a bound variable such that - this tactic cannot be associated to a constant. + The head symbol of the type of :n:`@term` is a bound variable + such that this tactic cannot be associated to a constant. - .. cmdv:: Hint Resolve {+ @term} + .. cmdv:: Hint Resolve {+ @term} : @ident Adds each :n:`Hint Resolve @term`. - .. cmdv:: Hint Resolve -> @term + .. cmdv:: Hint Resolve -> @term : @ident Adds the left-to-right implication of an equivalence as a hint (informally the hint will be used as :n:`apply <- @term`, although as mentionned @@ -3726,7 +3722,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is Adds the right-to-left implication of an equivalence as a hint. - .. cmdv:: Hint Immediate @term + .. cmdv:: Hint Immediate @term : @ident :name: Hint Immediate This command adds :n:`simple apply @term; trivial` to the hint list associated @@ -3742,37 +3738,37 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. exn:: @term cannot be used as a hint :undocumented: - .. cmdv:: Immediate {+ @term} + .. cmdv:: Immediate {+ @term} : @ident Adds each :n:`Hint Immediate @term`. - .. cmdv:: Hint Constructors @ident + .. cmdv:: Hint Constructors @qualid : @ident :name: Hint Constructors - If :n:`@ident` is an inductive type, this command adds all its constructors as + If :token:`qualid` is an inductive type, this command adds all its constructors as hints of type ``Resolve``. Then, when the conclusion of current goal has the form - :n:`(@ident ...)`, :tacn:`auto` will try to apply each constructor. + :n:`(@qualid ...)`, :tacn:`auto` will try to apply each constructor. - .. exn:: @ident is not an inductive type - :undocumented: + .. exn:: @qualid is not an inductive type + :undocumented: - .. cmdv:: Hint Constructors {+ @ident} + .. cmdv:: Hint Constructors {+ @qualid} : @ident - Adds each :n:`Hint Constructors @ident`. + Extends the previous command for several inductive types. - .. cmdv:: Hint Unfold @qualid + .. cmdv:: Hint Unfold @qualid : @ident :name: Hint Unfold This adds the tactic :n:`unfold @qualid` to the hint list that will only be - used when the head constant of the goal is :n:`@ident`. + used when the head constant of the goal is :token:`qualid`. Its cost is 4. - .. cmdv:: Hint Unfold {+ @ident} + .. cmdv:: Hint Unfold {+ @qualid} - Adds each :n:`Hint Unfold @ident`. + Extends the previous command for several defined constants. - .. cmdv:: Hint Transparent {+ @qualid} - Hint Opaque {+ @qualid} + .. cmdv:: Hint Transparent {+ @qualid} : @ident + Hint Opaque {+ @qualid} : @ident :name: Hint Transparent; Hint Opaque This adds transparency hints to the database, making :n:`@qualid` @@ -3781,8 +3777,8 @@ The general command to add a hint to some databases :n:`{+ @ident}` is discrimination network to relax or constrain it in the case of discriminated databases. - .. cmdv:: Hint Variables %( Transparent %| Opaque %) - Hint Constants %( Transparent %| Opaque %) + .. cmdv:: Hint Variables %( Transparent %| Opaque %) : @ident + Hint Constants %( Transparent %| Opaque %) : @ident :name: Hint Variables; Hint Constants This sets the transparency flag used during unification of @@ -3790,7 +3786,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is overwritting the existing settings of opacity. It is advised to use this just after a :cmd:`Create HintDb` command. - .. cmdv:: Hint Extern @num {? @pattern} => @tactic + .. cmdv:: Hint Extern @num {? @pattern} => @tactic : @ident :name: Hint Extern This hint type is to extend :tacn:`auto` with tactics other than :tacn:`apply` and @@ -3801,7 +3797,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. coqtop:: in - Hint Extern 4 (~(_ = _)) => discriminate. + Hint Extern 4 (~(_ = _)) => discriminate : core. Now, when the head of the goal is a disequality, ``auto`` will try discriminate if it does not manage to solve the goal with hints with a @@ -3820,7 +3816,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is Goal forall a b:list (nat * nat), {a = b} + {a <> b}. Info 1 auto with eqdec. - .. cmdv:: Hint Cut @regexp + .. cmdv:: Hint Cut @regexp : @ident :name: Hint Cut .. warning:: @@ -3854,7 +3850,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is semantics of ``Hint Cut e`` is to set the cut expression to ``c | e``, the initial cut expression being `emp`. - .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} + .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} : @ident :name: Hint Mode This sets an optional mode of use of the identifier :n:`@qualid`. When diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 4f46a80dcf..e5eb7eb4f5 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1115,6 +1115,8 @@ Binding arguments of a constant to an interpretation scope .. coqtop:: all Parameter g : bool -> bool. + Declare Scope mybool_scope. + Notation "@@" := true (only parsing) : bool_scope. Notation "@@" := false (only parsing): mybool_scope. @@ -1151,6 +1153,7 @@ Binding types of arguments to an interpretation scope .. coqtop:: in reset Parameter U : Set. + Declare Scope U_scope. Bind Scope U_scope with U. Parameter Uplus : U -> U -> U. Parameter P : forall T:Set, T -> U -> Prop. @@ -1575,7 +1578,7 @@ Numeral notations For example - .. coqtop:: all + .. coqtop:: all warn Check 90000. diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 8df0f2be97..eaf1b2c2ad 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -580,7 +580,8 @@ class CoqtopDirective(Directive): - Behavior options - ``reset``: Send a ``Reset Initial`` command before running this block - - ``fail``: Don't die if a command fails + - ``fail``: Don't die if a command fails, implies ``warn`` (so no need to put both) + - ``warn``: Don't die if a command emits a warning - ``restart``: Send a ``Restart`` command before running this block (only works in proof mode) - ``abort``: Send an ``Abort All`` command after running this block (leaves all pending proofs if any) @@ -835,11 +836,12 @@ class CoqtopBlocksTransform(Transform): # Behavior options opt_reset = 'reset' in options opt_fail = 'fail' in options + opt_warn = 'warn' in options opt_restart = 'restart' in options opt_abort = 'abort' in options - options = options - set(('reset', 'fail', 'restart', 'abort')) + options = options - {'reset', 'fail', 'warn', 'restart', 'abort'} - unexpected_options = list(options - set(('all', 'none', 'in', 'out'))) + unexpected_options = list(options - {'all', 'none', 'in', 'out'}) if unexpected_options: loc = get_node_location(node) raise ExtensionError("{}: Unexpected options for .. coqtop:: {}".format(loc,unexpected_options)) @@ -857,6 +859,9 @@ class CoqtopBlocksTransform(Transform): return { 'reset': opt_reset, 'fail': opt_fail, + # if errors are allowed, then warnings too + # and they should be displayed as warnings, not errors + 'warn': opt_warn or opt_fail, 'restart': opt_restart, 'abort': opt_abort, 'input': opt_input or opt_all, @@ -891,18 +896,22 @@ class CoqtopBlocksTransform(Transform): pairs = [] if options['restart']: - repl.sendone("Restart.") + repl.sendone('Restart.') if options['reset']: - repl.sendone("Reset Initial.") - repl.sendone("Set Coqtop Exit On Error.") + repl.sendone('Reset Initial.') + repl.send_initial_options() if options['fail']: - repl.sendone("Unset Coqtop Exit On Error.") + repl.sendone('Unset Coqtop Exit On Error.') + if options['warn']: + repl.sendone('Set Warnings "default".') for sentence in self.split_sentences(node.rawsource): pairs.append((sentence, repl.sendone(sentence))) if options['abort']: - repl.sendone("Abort All.") + repl.sendone('Abort All.') if options['fail']: - repl.sendone("Set Coqtop Exit On Error.") + repl.sendone('Set Coqtop Exit On Error.') + if options['warn']: + repl.sendone('Set Warnings "+default".') dli = nodes.definition_list_item() for sentence, output in pairs: @@ -923,7 +932,7 @@ class CoqtopBlocksTransform(Transform): Finds nodes to process using is_coqtop_block.""" with CoqTop(color=True) as repl: - repl.sendone("Set Coqtop Exit On Error.") + repl.send_initial_options() for node in self.document.traverse(CoqtopBlocksTransform.is_coqtop_block): try: self.add_coq_output_1(repl, node) diff --git a/doc/tools/coqrst/repl/coqtop.py b/doc/tools/coqrst/repl/coqtop.py index ddba2edd4a..26f6255069 100644 --- a/doc/tools/coqrst/repl/coqtop.py +++ b/doc/tools/coqrst/repl/coqtop.py @@ -87,6 +87,11 @@ class CoqTop: raise CoqTopError(err, sentence, self.coqtop.before) return output + def send_initial_options(self): + """Options to send when starting the toplevel and after a Reset Initial.""" + self.sendone('Set Coqtop Exit On Error.') + self.sendone('Set Warnings "+default".') + def sendmany(*sentences): """A small demo: send each sentence in sentences and print the output""" with CoqTop() as coqtop: @@ -1,12 +1,12 @@ ; Default flags for all Coq libraries. (env - (dev (flags :standard -rectypes -w -9-27+40+60)) + (dev (flags :standard -rectypes -w -9-27+40+60 \ -short-paths)) (release (flags :standard -rectypes) (ocamlopt_flags -O3 -unbox-closures)) (ireport (flags :standard -rectypes -w -9-27-40+60) (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report)) (ocaml409 - (flags :standard -strict-sequence -strict-formats -short-paths -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) + (flags :standard -strict-sequence -strict-formats -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) ; The _ profile could help factoring the above, however it doesn't ; seem to work like we'd expect/like: @@ -19,7 +19,7 @@ (deps (source_tree theories) (source_tree plugins)) - (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep opt -noglob -boot `find theories plugins -type f -name *.v`")))) + (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep both -noglob -boot `find theories plugins -type f -name *.v`")))) (alias (name vodeps) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index d70c009c6d..840c14b241 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -424,8 +424,8 @@ let new_pure_evar_full evd ?typeclass_candidate evi = let evd = Evd.declare_future_goal evk evd in (evd, evk) -let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?candidates ?naming ?typeclass_candidate - ?(principal=false) sign evd typ = +let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?(abstract_arguments = Abstraction.identity) + ?candidates ?naming ?typeclass_candidate ?(principal=false) sign evd typ = let default_naming = IntroAnonymous in let naming = Option.default default_naming naming in let name = match naming with @@ -441,6 +441,7 @@ let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?candidates ? evar_concl = typ; evar_body = Evar_empty; evar_filter = filter; + evar_abstract_arguments = abstract_arguments; evar_source = src; evar_candidates = candidates } in @@ -452,11 +453,12 @@ let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?candidates ? in (evd, newevk) -let new_evar_instance ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal sign evd typ instance = +let new_evar_instance ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate + ?principal sign evd typ instance = let open EConstr in assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); - let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal typ in + let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate ?principal typ in evd, mkEvar (newevk,Array.of_list instance) let new_evar_from_context ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal sign evd typ = @@ -469,7 +471,8 @@ let new_evar_from_context ?src ?filter ?candidates ?naming ?typeclass_candidate (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) -let new_evar ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal ?hypnaming env evd typ = +let new_evar ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate + ?principal ?hypnaming env evd typ = let sign,typ',instance,subst = push_rel_context_to_named_context ?hypnaming env evd typ in let map c = csubst_subst subst c in let candidates = Option.map (fun l -> List.map map l) candidates in @@ -477,7 +480,8 @@ let new_evar ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal ?h match filter with | None -> instance | Some filter -> Filter.filter_list filter instance in - new_evar_instance sign evd typ' ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal instance + new_evar_instance sign evd typ' ?src ?filter ?abstract_arguments ?candidates ?naming + ?typeclass_candidate ?principal instance let new_type_evar ?src ?filter ?naming ?principal ?hypnaming env evd rigid = let (evd', s) = new_sort_variable rigid evd in diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 23b240f1a0..bb0da44103 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -42,7 +42,7 @@ type naming_mode = val new_evar : ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?candidates:constr list -> + ?abstract_arguments:Abstraction.t -> ?candidates:constr list -> ?naming:intro_pattern_naming_expr -> ?typeclass_candidate:bool -> ?principal:bool -> ?hypnaming:naming_mode -> @@ -50,7 +50,7 @@ val new_evar : val new_pure_evar : ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?candidates:constr list -> + ?abstract_arguments:Abstraction.t -> ?candidates:constr list -> ?naming:intro_pattern_naming_expr -> ?typeclass_candidate:bool -> ?principal:bool -> @@ -80,7 +80,8 @@ val new_global : evar_map -> GlobRef.t -> evar_map * constr of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : - ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> + ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?abstract_arguments:Abstraction.t -> ?candidates:constr list -> ?naming:intro_pattern_naming_expr -> ?typeclass_candidate:bool -> ?principal:bool -> diff --git a/engine/evd.ml b/engine/evd.ml index f0433d3387..dd2be29bd9 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -126,6 +126,19 @@ struct end +module Abstraction = struct + + type abstraction = + | Abstract + | Imitate + + type t = abstraction list + + let identity = [] + + let abstract_last l = Abstract :: l +end + (* The kinds of existential variables are now defined in [Evar_kinds] *) (* The type of mappings for existential variables *) @@ -143,6 +156,7 @@ type evar_info = { evar_hyps : named_context_val; evar_body : evar_body; evar_filter : Filter.t; + evar_abstract_arguments : Abstraction.t; evar_source : Evar_kinds.t Loc.located; evar_candidates : constr list option; (* if not None, list of allowed instances *)} @@ -151,6 +165,7 @@ let make_evar hyps ccl = { evar_hyps = hyps; evar_body = Evar_empty; evar_filter = Filter.identity; + evar_abstract_arguments = Abstraction.identity; evar_source = Loc.tag @@ Evar_kinds.InternalHole; evar_candidates = None; } diff --git a/engine/evd.mli b/engine/evd.mli index d2d18ca486..b0fcddb068 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -77,6 +77,18 @@ sig end +module Abstraction : sig + type abstraction = + | Abstract + | Imitate + + type t = abstraction list + + val identity : t + + val abstract_last : t -> t +end + (** {6 Evar infos} *) type evar_body = @@ -94,6 +106,10 @@ type evar_info = { (** Boolean mask over {!evar_hyps}. Should have the same length. When filtered out, the corresponding variable is not allowed to occur in the solution *) + evar_abstract_arguments : Abstraction.t; + (** Boolean information over {!evar_hyps}, telling if an hypothesis instance + can be imitated or should stay abstract in HO unification problems + and inversion (see [second_order_matching_with_args] for its use). *) evar_source : Evar_kinds.t located; (** Information about the evar. *) evar_candidates : econstr list option; diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 24894fc9f5..7f1dc70d95 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1188,7 +1188,6 @@ let check_constructor_length env loc cstr len_pl pl0 = (error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs cstr))) -open Term open Declarations (* Similar to Cases.adjust_local_defs but on RCPat *) @@ -1197,16 +1196,15 @@ let insert_local_defs_in_pattern (ind,j) l = if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then (* Optimisation *) l else - let typi = mip.mind_nf_lc.(j-1) in - let (_,typi) = decompose_prod_n_assum (Context.Rel.length mib.mind_params_ctxt) typi in - let (decls,_) = decompose_prod_assum typi in + let (ctx, _) = mip.mind_nf_lc.(j-1) in + let decls = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in let rec aux decls args = match decls, args with | Context.Rel.Declaration.LocalDef _ :: decls, args -> (DAst.make @@ RCPatAtom None) :: aux decls args | _, [] -> [] (* In particular, if there were trailing local defs, they have been inserted *) | Context.Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args | _ -> assert false in - aux (List.rev decls) l + aux decls l let add_local_defs_and_check_length loc env g pl args = match g with | ConstructRef cstr -> diff --git a/interp/impargs.ml b/interp/impargs.ml index 6fd52d98dd..0f9bff7f1d 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -452,9 +452,10 @@ let compute_mib_implicits flags kn = let ind = (kn,i) in let ar, _ = Typeops.type_of_global_in_context env (IndRef ind) in ((IndRef ind,compute_semi_auto_implicits env sigma flags (of_constr ar)), - Array.mapi (fun j c -> + Array.mapi (fun j (ctx, cty) -> + let c = of_constr (Term.it_mkProd_or_LetIn cty ctx) in (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar sigma flags c)) - (Array.map of_constr mip.mind_nf_lc)) + mip.mind_nf_lc) in Array.mapi imps_one_inductive mib.mind_packets @@ -674,7 +675,7 @@ let check_inclusion l = user_err Pp.(str "Sequences of implicit arguments must be of different lengths."); aux nl | _ -> () in - aux (List.map (fun (imps,_) -> List.length imps) l) + aux (List.map snd l) let check_rigidity isrigid = if not isrigid then @@ -685,6 +686,8 @@ let projection_implicits env p impls = CList.skipn_at_least npars impls let declare_manual_implicits local ref ?enriching l = + assert (List.for_all (fun (_, (max, fi, fu)) -> fi && fu) l); + assert (List.for_all (fun (ex, _) -> match ex with ExplByPos (_,_) -> true | _ -> false) l); let flags = !implicit_args in let env = Global.env () in let sigma = Evd.from_env env in @@ -692,29 +695,71 @@ let declare_manual_implicits local ref ?enriching l = let t = of_constr t in let enriching = Option.default flags.auto enriching in let autoimpls = compute_auto_implicits env sigma flags enriching t in + let l = [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] in + let req = + if is_local local ref then ImplLocal + else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + in add_anonymous_leaf (inImplicits (req,[ref,l])) + +let maybe_declare_manual_implicits local ref ?enriching l = + match l with + | [] -> () + | _ -> declare_manual_implicits local ref ?enriching l + +(* TODO: either turn these warnings on and document them, or handle these cases sensibly *) + +let warn_set_maximal_deprecated = + CWarnings.create ~name:"set-maximal-deprecated" ~category:"deprecated" + (fun i -> strbrk ("Argument number " ^ string_of_int i ^ " is a trailing implicit so must be maximal")) + +type implicit_kind = Implicit | MaximallyImplicit | NotImplicit + +let compute_implicit_statuses autoimps l = + let rec aux i = function + | _ :: autoimps, NotImplicit :: manualimps -> None :: aux (i+1) (autoimps, manualimps) + | Name id :: autoimps, MaximallyImplicit :: manualimps -> + Some (id, Manual, (true, true)) :: aux (i+1) (autoimps, manualimps) + | Name id :: autoimps, Implicit :: manualimps -> + let imps' = aux (i+1) (autoimps, manualimps) in + let max = set_maximality imps' false in + if max then warn_set_maximal_deprecated i; + Some (id, Manual, (max, true)) :: imps' + | Anonymous :: _, (Implicit | MaximallyImplicit) :: _ -> + user_err ~hdr:"set_implicits" + (strbrk ("Argument number " ^ string_of_int i ^ " (anonymous in original definition) cannot be declared implicit.")) + | autoimps, [] -> List.map (fun _ -> None) autoimps + | [], _::_ -> assert false + in aux 0 (autoimps, l) + +let set_implicits local ref l = + let flags = !implicit_args in + let env = Global.env () in + let sigma = Evd.from_env env in + let t, _ = Typeops.type_of_global_in_context env ref in + let t = of_constr t in + let autoimpls = compute_implicits_names env sigma t in let l' = match l with | [] -> assert false | [l] -> - [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] + [DefaultImpArgs, compute_implicit_statuses autoimpls l] | _ -> check_rigidity (is_rigid env sigma t); - let l = List.map (fun imps -> (imps,List.length imps)) l in + (* Sort by number of implicits, decreasing *) + let is_implicit = function + | NotImplicit -> false + | _ -> true in + let l = List.map (fun imps -> (imps,List.count is_implicit imps)) l in let l = List.sort (fun (_,n1) (_,n2) -> n2 - n1) l in check_inclusion l; let nargs = List.length autoimpls in List.map (fun (imps,n) -> (LessArgsThan (nargs-n), - set_manual_implicits flags enriching autoimpls imps)) l in + compute_implicit_statuses autoimpls imps)) l in let req = if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l'])) -let maybe_declare_manual_implicits local ref ?enriching l = - match l with - | [] -> () - | _ -> declare_manual_implicits local ref ?enriching [l] - let extract_impargs_data impls = let rec aux p = function | (DefaultImpArgs, imps)::_ -> [None,imps] diff --git a/interp/impargs.mli b/interp/impargs.mli index 43c26b024f..0070423530 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -112,13 +112,20 @@ val declare_implicits : bool -> GlobRef.t -> unit Unsets implicits if [l] is empty. *) val declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> - manual_implicits list -> unit + manual_implicits -> unit (** If the list is empty, do nothing, otherwise declare the implicits. *) val maybe_declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> manual_implicits -> unit +type implicit_kind = Implicit | MaximallyImplicit | NotImplicit + +(** [set_implicits local ref l] + Manual declaration of implicit arguments. + `l` is a list of possible sequences of implicit statuses. *) +val set_implicits : bool -> GlobRef.t -> implicit_kind list list -> unit + val implicits_of_global : GlobRef.t -> implicits_list list val extract_impargs_data : diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index da5c4fb07b..fdc93cfa89 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -148,7 +148,7 @@ let prim_ind_to_string = function | PIT_cmp -> "cmp" let prim_type_to_string = function - | PT_int63 -> "int63" + | PT_int63 -> "int63_type" let op_or_type_to_string = function | OT_op op -> to_string op diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 6777e0c223..567850645e 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -166,7 +166,7 @@ type one_inductive_body = { mind_kelim : Sorts.family list; (** List of allowed elimination sorts *) - mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) + mind_nf_lc : (rel_context * types) array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) mind_consnrealargs : int array; (** Number of expected proper arguments of the constructors (w/o params) *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 9e0230c3ba..d56502a095 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -214,7 +214,7 @@ let subst_mind_packet sub mbp = mind_consnrealdecls = mbp.mind_consnrealdecls; mind_consnrealargs = mbp.mind_consnrealargs; mind_typename = mbp.mind_typename; - mind_nf_lc = Array.Smart.map (subst_mps sub) mbp.mind_nf_lc; + mind_nf_lc = Array.Smart.map (fun (ctx, c) -> Context.Rel.map (subst_mps sub) ctx, subst_mps sub c) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_ind_arity sub mbp.mind_arity; mind_user_lc = Array.Smart.map (subst_mps sub) mbp.mind_user_lc; @@ -299,9 +299,8 @@ let hcons_ind_arity = let hcons_mind_packet oib = let user = Array.Smart.map Constr.hcons oib.mind_user_lc in - let nf = Array.Smart.map Constr.hcons oib.mind_nf_lc in - (* Special optim : merge [mind_user_lc] and [mind_nf_lc] if possible *) - let nf = if Array.equal (==) user nf then user else nf in + let map (ctx, c) = Context.Rel.map Constr.hcons ctx, Constr.hcons c in + let nf = Array.Smart.map map oib.mind_nf_lc in { oib with mind_typename = Names.Id.hcons oib.mind_typename; mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt; diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 8f06e1e4b8..457c17907e 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -416,7 +416,9 @@ let compute_projections (kn, i as ind) mib = let pkt = mib.mind_packets.(i) in let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in - let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in + let (ctx, cty) = pkt.mind_nf_lc.(0) in + let cty = it_mkProd_or_LetIn cty ctx in + let rctx, _ = decompose_prod_assum (substl subst cty) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in (** We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not @@ -475,7 +477,7 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite (* Check one inductive *) let build_one_packet (id,cnames) ((arity,lc),(indices,splayed_lc),kelim) recarg = (* Type of constructors in normal form *) - let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b (d@paramsctxt)) splayed_lc in + let nf_lc = Array.map (fun (d, b) -> (d@paramsctxt, b)) splayed_lc in let consnrealdecls = Array.map (fun (d,_) -> Context.Rel.length d) splayed_lc in diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 848ae65c51..f4c2483c14 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -251,7 +251,11 @@ let constrained_type_of_constructor (_cstr,u as cstru) (mib,_mip as ind) = let arities_of_specif (kn,u) (mib,mip) = let specif = mip.mind_nf_lc in - Array.map (constructor_instantiate kn u mib) specif + let map (ctx, c) = + let cty = Term.it_mkProd_or_LetIn c ctx in + constructor_instantiate kn u mib cty + in + Array.map map specif let arities_of_constructors ind specif = arities_of_specif (fst (fst ind), snd ind) specif @@ -342,7 +346,8 @@ let is_correct_arity env c pj ind specif params = (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) let build_branches_type (ind,u) (_,mip as specif) params p = - let build_one_branch i cty = + let build_one_branch i (ctx, c) = + let cty = Term.it_mkProd_or_LetIn c ctx in let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (cstrsign,ccl) = Term.decompose_prod_assum typi in let nargs = Context.Rel.length cstrsign in @@ -597,6 +602,7 @@ let lambda_implicit_lift n a = (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) let abstract_mind_lc ntyps npars lc = + let lc = Array.map (fun (ctx, c) -> Term.it_mkProd_or_LetIn c ctx) lc in if Int.equal npars 0 then lc else diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 3c1464c6c9..ad35c16c22 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -139,4 +139,4 @@ val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec val lambda_implicit_lift : int -> constr -> constr -val abstract_mind_lc : int -> Int.t -> constr array -> constr array +val abstract_mind_lc : int -> Int.t -> (rel_context * constr) array -> constr array diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index cd675653cb..9397772415 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -339,9 +339,6 @@ let subst_retro_action subst action = | Register_type(prim,c) -> let c' = subst_constant subst c in if c == c' then action else Register_type(prim, c') - | Register_inline(c) -> - let c' = subst_constant subst c in - if c == c' then action else Register_inline(c') (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? diff --git a/kernel/primred.ml b/kernel/primred.ml index d95d7de7aa..d6d0a6143a 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -44,10 +44,6 @@ let add_retroknowledge env action = { retro with retro_cmp = Some r } in set_retroknowledge env retro - | Register_inline(c) -> - let (cb,r) = lookup_constant_key c env in - let cb = {cb with Declarations.const_inline_code = true} in - add_constant_key c cb !(fst r) env let get_int_type env = match env.retroknowledge.retro_int63 with diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 18fafdb6d3..e1c4cec5b5 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -38,4 +38,3 @@ let empty = { type action = | Register_ind of CPrimitives.prim_ind * inductive | Register_type of CPrimitives.prim_type * Constant.t - | Register_inline of Constant.t diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 1554fe88da..09e8140308 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -25,4 +25,3 @@ val empty : retroknowledge type action = | Register_ind of CPrimitives.prim_ind * inductive | Register_type of CPrimitives.prim_type * Constant.t - | Register_inline of Constant.t diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 964d32c6b3..481ffc290c 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -55,6 +55,7 @@ type ('constr, 'types) ptype_error = | IllFormedBranch of 'constr * pconstructor * 'constr * 'constr | Generalization of (Name.t * 'types) * ('constr, 'types) punsafe_judgment | ActualType of ('constr, 'types) punsafe_judgment * 'types + | IncorrectPrimitive of (CPrimitives.op_or_type,'types) punsafe_judgment * 'types | CantApplyBadType of (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array @@ -120,6 +121,9 @@ let error_generalization env nvar c = let error_actual_type env j expty = raise (TypeError (env, ActualType (j,expty))) +let error_incorrect_primitive env p t = + raise (TypeError (env, IncorrectPrimitive (p, t))) + let error_cant_apply_not_functional env rator randl = raise (TypeError (env, CantApplyNonFunctional (rator,randl))) @@ -175,6 +179,7 @@ let map_ptype_error f = function | IllFormedBranch (c, pc, t1, t2) -> IllFormedBranch (f c, pc, f t1, f t2) | Generalization ((na, t), j) -> Generalization ((na, f t), on_judgment f j) | ActualType (j, t) -> ActualType (on_judgment f j, f t) +| IncorrectPrimitive (p, t) -> IncorrectPrimitive ({p with uj_type=f p.uj_type}, f t) | CantApplyBadType ((n, c1, c2), j, vj) -> CantApplyBadType ((n, f c1, f c2), on_judgment f j, Array.map (on_judgment f) vj) | CantApplyNonFunctional (j, jv) -> CantApplyNonFunctional (on_judgment f j, Array.map (on_judgment f) jv) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 4b832930e1..c5ab9a4e73 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -56,6 +56,7 @@ type ('constr, 'types) ptype_error = | IllFormedBranch of 'constr * pconstructor * 'constr * 'constr | Generalization of (Name.t * 'types) * ('constr, 'types) punsafe_judgment | ActualType of ('constr, 'types) punsafe_judgment * 'types + | IncorrectPrimitive of (CPrimitives.op_or_type,'types) punsafe_judgment * 'types | CantApplyBadType of (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array @@ -112,6 +113,8 @@ val error_generalization : env -> Name.t * types -> unsafe_judgment -> 'a val error_actual_type : env -> unsafe_judgment -> types -> 'a +val error_incorrect_primitive : env -> (CPrimitives.op_or_type,types) punsafe_judgment -> types -> 'a + val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 7eb8e803b3..227a164549 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -252,6 +252,11 @@ let type_of_prim env t = in nary_int63_op (CPrimitives.arity t) return_ty +let type_of_prim_or_type env = let open CPrimitives in + function + | OT_type t -> type_of_prim_type env t + | OT_op op -> type_of_prim env op + let judge_of_int env i = make_judge (Constr.mkInt i) (type_of_int env) @@ -664,17 +669,7 @@ let judge_of_case env ci pj cj lfj = (* Building type of primitive operators and type *) -open CPrimitives - let check_primitive_type env op_t t = - match op_t with - | OT_type PT_int63 -> - (try - default_conv ~l2r:false CUMUL env mkSet t - with NotConvertible -> - CErrors.user_err Pp.(str"Was expecting the sort of this primitive type to be Set")) - | OT_op p -> - (try - default_conv ~l2r:false CUMUL env (type_of_prim env p) t - with NotConvertible -> - CErrors.user_err Pp.(str"Not the expected type for this primitive")) + let inft = type_of_prim_or_type env op_t in + try default_conv ~l2r:false CUMUL env inft t + with NotConvertible -> error_incorrect_primitive env (make_judge op_t inft) t diff --git a/lib/future.ml b/lib/future.ml index b372bedc5d..6e7c6fd9e3 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -33,7 +33,7 @@ let _ = CErrors.register_handler (function | _ -> raise CErrors.Unhandled) type fix_exn = Exninfo.iexn -> Exninfo.iexn -let id x = prerr_endline "Future: no fix_exn.\nYou have probably created a Future.computation from a value without passing the ~fix_exn argument. You probably want to chain with an already existing future instead."; x +let id x = x module UUID = struct type t = int diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 204f889f90..ef6c07bff2 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -1044,7 +1044,9 @@ let fake_match_projection env p = let indu = mkIndU (ind,u) in let ctx, paramslet = let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((fst ind, mib.mind_ntypes - i - 1), u)) in - let rctx, _ = decompose_prod_assum (Vars.substl subst mip.mind_nf_lc.(0)) in + let (ctx, cty) = mip.mind_nf_lc.(0) in + let cty = Term.it_mkProd_or_LetIn cty ctx in + let rctx, _ = decompose_prod_assum (Vars.substl subst cty) in List.chop mip.mind_consnrealdecls.(0) rctx in let ci_pp_info = { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index a60a966cec..56b3dc97cf 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -13,7 +13,6 @@ open Names open Constr open EConstr open Vars -open Termops open Util open Declarations open Globnames @@ -100,9 +99,8 @@ let kind_of_formula env sigma term = else let has_realargs=(n>0) in let is_trivial= - let is_constant c = - Int.equal (nb_prod sigma (EConstr.of_constr c)) mib.mind_nparams in - Array.exists is_constant mip.mind_nf_lc in + let is_constant n = Int.equal n 0 in + Array.exists is_constant mip.mind_consnrealargs in if Inductiveops.mis_is_recursive (ind,mib,mip) || (has_realargs && not is_trivial) then diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 8da30bd9c9..6fd2f7c2bc 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -238,7 +238,9 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = raise NoChange; end in - let eq_constr c1 c2 = Option.has_some (Evarconv.conv env sigma c1 c2) in + let eq_constr c1 c2 = + try ignore(Evarconv.unify_delay env sigma c1 c2); true + with Evarconv.UnableToUnify _ -> false in if not (noccurn sigma 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp sigma t) then nochange "not an equality"; diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 9ecc36bdf3..3f2fabeeee 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -99,8 +99,19 @@ TACTIC EXTEND is_ground | [ "is_ground" constr(ty) ] -> { is_ground ty } END +{ +let deprecated_autoapply_using = + CWarnings.create + ~name:"autoapply-using" ~category:"deprecated" + (fun () -> Pp.str "The syntax [autoapply ... using] is deprecated. Use [autoapply ... with] instead.") +} + TACTIC EXTEND autoapply -| [ "autoapply" constr(c) "using" preident(i) ] -> { autoapply c i } +| [ "autoapply" constr(c) "using" preident(i) ] -> { + deprecated_autoapply_using (); + autoapply c i + } +| [ "autoapply" constr(c) "with" preident(i) ] -> { autoapply c i } END { diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 2d833a2cde..e78d0f93a4 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -449,7 +449,7 @@ let evd_convertible env evd x y = unsolvable constraints remain, so we check that this unification does not introduce any new problem. *) let _, pbs = Evd.extract_all_conv_pbs evd in - let evd' = Evarconv.the_conv_x env x y evd in + let evd' = Evarconv.unify_delay env evd x y in let _, pbs' = Evd.extract_all_conv_pbs evd' in if evd' == evd || problem_inclusion pbs' pbs then Some evd' else None diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index a1e21aab04..543d4de0fe 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -557,7 +557,7 @@ let rec intern_atomic lf ist x = | _ -> false in let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in TacChange (None, diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 30f716d764..eac84f0543 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1766,7 +1766,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | _ -> false in let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in let c_interp patvars env sigma = diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 751f0d8334..c2dec264ad 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -294,10 +294,10 @@ Qed. End Store. -Arguments PNone [A]. +Arguments PNone {A}. Arguments PSome [A] _. -Arguments Tempty [A]. +Arguments Tempty {A}. Arguments Branch0 [A] _ _. Arguments Branch1 [A] _ _ _. @@ -311,7 +311,7 @@ Arguments mkStore [A] index contents. Arguments index [A] s. Arguments contents [A] s. -Arguments empty [A]. +Arguments empty {A}. Arguments get [A] i S. Arguments push [A] a S. @@ -319,7 +319,7 @@ Arguments get_empty [A] i. Arguments get_push_Full [A] i a S _. Arguments Full [A] _. -Arguments F_empty [A]. +Arguments F_empty {A}. Arguments F_push [A] a S _. Arguments In [A] x S F. diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index dba72337b2..f5d13053b1 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -1789,5 +1789,5 @@ End Field. End Complete. -Arguments FEO [C]. -Arguments FEI [C]. +Arguments FEO {C}. +Arguments FEI {C}. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 9ef24144d2..12f716c496 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -1507,5 +1507,5 @@ Qed. End MakeRingPol. -Arguments PEO [C]. -Arguments PEI [C]. +Arguments PEO {C}. +Arguments PEI {C}. diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index ed4ff2aa66..d6b7371647 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -813,21 +813,21 @@ Proof. by case b1; case b2; constructor; auto. Qed. End ReflectConnectives. -Arguments idP [b1]. -Arguments idPn [b1]. -Arguments negP [b1]. -Arguments negPn [b1]. -Arguments negPf [b1]. -Arguments andP [b1 b2]. -Arguments and3P [b1 b2 b3]. -Arguments and4P [b1 b2 b3 b4]. -Arguments and5P [b1 b2 b3 b4 b5]. -Arguments orP [b1 b2]. -Arguments or3P [b1 b2 b3]. -Arguments or4P [b1 b2 b3 b4]. -Arguments nandP [b1 b2]. -Arguments norP [b1 b2]. -Arguments implyP [b1 b2]. +Arguments idP {b1}. +Arguments idPn {b1}. +Arguments negP {b1}. +Arguments negPn {b1}. +Arguments negPf {b1}. +Arguments andP {b1 b2}. +Arguments and3P {b1 b2 b3}. +Arguments and4P {b1 b2 b3 b4}. +Arguments and5P {b1 b2 b3 b4 b5}. +Arguments orP {b1 b2}. +Arguments or3P {b1 b2 b3}. +Arguments or4P {b1 b2 b3 b4}. +Arguments nandP {b1 b2}. +Arguments norP {b1 b2}. +Arguments implyP {b1 b2}. Prenex Implicits idP idPn negP negPn negPf. Prenex Implicits andP and3P and4P and5P orP or3P or4P nandP norP implyP. @@ -953,7 +953,7 @@ Proof. by case: a; case: b. Qed. Lemma addbP a b : reflect (~~ a = b) (a (+) b). Proof. by case: a; case: b; constructor. Qed. -Arguments addbP [a b]. +Arguments addbP {a b}. (** Resolution tactic for blindly weeding out common terms from boolean @@ -1158,8 +1158,8 @@ Definition clone_pred U := End Predicates. -Arguments pred0 [T]. -Arguments predT [T]. +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)) @@ -1357,7 +1357,7 @@ Variant qualifier (q : nat) T := Qualifier of predPredType T. Coercion has_quality n T (q : qualifier n T) : pred_class := fun x => let: Qualifier _ p := q in p x. -Arguments has_quality n [T]. +Arguments has_quality n {T}. Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index a0b1d784f1..7216849948 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -209,7 +209,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let mind,indb = Inductive.lookup_mind_specif env (kn,i) in let tys = indb.Declarations.mind_nf_lc in let renamed_tys = - Array.mapi (fun j t -> + Array.mapi (fun j (ctx, cty) -> + let t = Term.it_mkProd_or_LetIn cty ctx in ppdebug(lazy Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); let t = Arguments_renaming.rename_type t (GlobRef.ConstructRef((kn,i),j+1)) in diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index d083d34b52..2e1554d496 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -152,7 +152,7 @@ let declare_one_prenex_implicit locality f = with _ -> errorstrm (pr_qualid f ++ str " is not declared") in let rec loop = function | a :: args' when Impargs.is_status_implicit a -> - (ExplByName (Impargs.name_of_implicit a), (true, true, true)) :: loop args' + Impargs.MaximallyImplicit :: loop args' | args' when List.exists Impargs.is_status_implicit args' -> errorstrm (str "Expected prenex implicits for " ++ pr_qualid f) | _ -> [] in @@ -165,7 +165,7 @@ let declare_one_prenex_implicit locality f = | [] -> errorstrm (str "Expected some implicits for " ++ pr_qualid f) | impls -> - Impargs.declare_manual_implicits locality fref ~enriching:false [impls] + Impargs.set_implicits locality fref [impls] } diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 552a4048b1..fb99b87108 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -213,7 +213,7 @@ let unif_EQ_args env sigma pa a = loop 0 let unif_HO env ise p c = - try Evarconv.the_conv_x env p c ise + try Evarconv.unify_delay env ise p c with Evarconv.UnableToUnify(ise, err) -> raise Pretype_errors.(PretypeError(env,ise,CannotUnify(p,c,Some err))) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 1ad90b2953..069ba9572a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -321,9 +321,9 @@ let inh_coerce_to_ind env sigma0 loc ty tyi = constructor and renounce if not able to give more information *) (* devrait être indifférent d'exiger leq ou pas puisque pour un inductif cela doit être égal *) - match cumul env sigma expected_typ ty with - | Some sigma -> sigma - | None -> sigma0 + match Evarconv.unify_leq_delay env sigma expected_typ ty with + | sigma -> sigma + | exception Evarconv.UnableToUnify _ -> sigma0 let binding_vars_of_inductive sigma = function | NotInd _ -> [] @@ -431,9 +431,9 @@ let adjust_tomatch_to_pattern ~program_mode sigma pb ((current,typ),deps,dep) = let sigma, current = if List.is_empty deps && isEvar sigma typ then (* Don't insert coercions if dependent; only solve evars *) - match cumul !!(pb.env) sigma indt typ with - | None -> sigma, current - | Some sigma -> sigma, current + match Evarconv.unify_leq_delay !!(pb.env) sigma indt typ with + | exception Evarconv.UnableToUnify _ -> sigma, current + | sigma -> sigma, current else let sigma, j = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in sigma, j.uj_val @@ -1707,9 +1707,11 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context !!env) in let sigma, ev' = Evarutil.new_evar ~src ~typeclass_candidate:false !!env sigma ty in - begin match solve_simple_eqn (evar_conv_x TransparentState.full) !!env sigma (None,ev,substl inst ev') with - | Success evd -> evdref := evd - | UnifFailure _ -> assert false + begin + let flags = (default_flags_of TransparentState.full) in + match solve_simple_eqn evar_unify flags !!env sigma (None,ev,substl inst ev') with + | Success evd -> evdref := evd + | UnifFailure _ -> assert false end; ev' | _ -> @@ -1765,9 +1767,9 @@ let build_tycon ?loc env tycon_env s subst tycon extenv sigma t = let sigma, t = abstract_tycon ?loc tycon_env sigma subst tycon extenv t in let sigma, tt = Typing.type_of !!extenv sigma t in (sigma, t, tt) in - match cumul !!env sigma tt (mkSort s) with - | None -> anomaly (Pp.str "Build_tycon: should be a type."); - | Some sigma -> + match unify_leq_delay !!env sigma tt (mkSort s) with + | exception Evarconv.UnableToUnify _ -> anomaly (Pp.str "Build_tycon: should be a type."); + | sigma -> sigma, { uj_val = t; uj_type = tt } (* For a multiple pattern-matching problem Xi on t1..tn with return @@ -1945,7 +1947,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let inh_conv_coerce_to_tycon ?loc ~program_mode env sigma j tycon = match tycon with - | Some p -> Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma j p + | Some p -> Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma + ~flags:(default_flags_of TransparentState.full) j p | None -> sigma, j (* We put the tycon inside the arity signature, possibly discovering dependencies. *) @@ -2187,15 +2190,15 @@ let constr_of_pat env sigma arsign pat avoid = let sigma, sign, i, avoid = try let env = EConstr.push_rel_context sign env in - let sigma = the_conv_x_leq (EConstr.push_rel_context sign env) - (lift (succ m) ty) (lift 1 apptype) sigma in + let sigma = unify_leq_delay (EConstr.push_rel_context sign env) sigma + (lift (succ m) ty) (lift 1 apptype) in let sigma, eq_t = mk_eq sigma (lift (succ m) ty) (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) in let neq = eq_id avoid id in sigma, LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid - with Reduction.NotConvertible -> sigma, sign, 1, avoid + with Evarconv.UnableToUnify _ -> sigma, sign, 1, avoid in (* Mark the equality as a hole *) sigma, pat', sign, lift i app, lift i apptype, realargs, n + i, avoid diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 2329b87acc..0e6aaaa408 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -64,9 +64,9 @@ let apply_coercion_args env sigma check isproj argl funj = | Prod (_,c1,c2) -> let sigma = if check then - begin match cumul env sigma (Retyping.get_type_of env sigma h) c1 with - | None -> raise NoCoercion - | Some sigma -> sigma + begin match Evarconv.unify_leq_delay env sigma (Retyping.get_type_of env sigma h) c1 with + | exception Evarconv.UnableToUnify _ -> raise NoCoercion + | sigma -> sigma end else sigma in @@ -157,7 +157,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let rec coerce_unify env x y = let x = hnf env !evdref x and y = hnf env !evdref y in try - evdref := the_conv_x_leq env x y !evdref; + evdref := Evarconv.unify_leq_delay env !evdref x y; None with UnableToUnify _ -> coerce' env x y and coerce' env x y : (EConstr.constr -> EConstr.constr) option = @@ -172,7 +172,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let rec aux tele typ typ' i co = if i < len then let hdx = l.(i) and hdy = l'.(i) in - try evdref := the_conv_x_leq env hdx hdy !evdref; + try evdref := unify_leq_delay env !evdref hdx hdy; let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co @@ -180,8 +180,8 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in let () = - try evdref := the_conv_x_leq env eqT eqT' !evdref - with UnableToUnify _ -> raise NoSubtacCoercion + try evdref := unify_leq_delay env !evdref eqT eqT' + with UnableToUnify _ -> raise NoSubtacCoercion in (* Disallow equalities on arities *) if Reductionops.is_arity env !evdref eqT then raise NoSubtacCoercion; @@ -466,7 +466,7 @@ let inh_coerce_to_prod ?loc ~program_mode env evd t = !evdref, typ' else (evd, t) -let inh_coerce_to_fail env evd rigidonly v t c1 = +let inh_coerce_to_fail flags env evd rigidonly v t c1 = if rigidonly && not (Heads.is_rigid env (EConstr.Unsafe.to_constr c1) && Heads.is_rigid env (EConstr.Unsafe.to_constr t)) then raise NoCoercion @@ -483,13 +483,16 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = | None -> evd, None, t with Not_found -> raise NoCoercion in - try (the_conv_x_leq env t' c1 evd, v') + try (unify_leq_delay ~flags env evd t' c1, v') with UnableToUnify _ -> raise NoCoercion -let rec inh_conv_coerce_to_fail ?loc env evd rigidonly v t c1 = - try (the_conv_x_leq env t c1 evd, v) +let default_flags_of env = + default_flags_of TransparentState.full + +let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigidonly v t c1 = + try (unify_leq_delay ~flags env evd t c1, v) with UnableToUnify (best_failed_evd,e) -> - try inh_coerce_to_fail env evd rigidonly v t c1 + try inh_coerce_to_fail flags env evd rigidonly v t c1 with NoCoercion -> match EConstr.kind evd (whd_all env evd t), @@ -520,10 +523,10 @@ let rec inh_conv_coerce_to_fail ?loc env evd rigidonly v t c1 = | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) -let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly env evd cj t = +let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env evd cj t = let (evd', val') = try - inh_conv_coerce_to_fail ?loc env evd rigidonly (Some cj.uj_val) cj.uj_type t + inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> try if program_mode then @@ -545,15 +548,14 @@ let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly env evd cj t let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) -let inh_conv_coerce_to ?loc ~program_mode resolve_tc = - inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc false - -let inh_conv_coerce_rigid_to ?loc ~program_mode resolve_tc = - inh_conv_coerce_to_gen ~program_mode resolve_tc ?loc true +let inh_conv_coerce_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) = + inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc false flags env evd +let inh_conv_coerce_rigid_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) = + inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc true flags env evd -let inh_conv_coerces_to ?loc env evd t t' = +let inh_conv_coerces_to ?loc env evd ?(flags=default_flags_of env) t t' = try - fst (inh_conv_coerce_to_fail ?loc env evd true None t t') + fst (inh_conv_coerce_to_fail ?loc env evd ~flags true None t t') with NoCoercion -> evd (* Maybe not enough information to unify *) diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index a941391125..43d4059785 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -45,17 +45,21 @@ val inh_coerce_to_prod : ?loc:Loc.t -> program_mode:bool -> a way [t] and [j.uj_type] are convertible; it fails if no coercion is applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) + val inh_conv_coerce_to : ?loc:Loc.t -> program_mode:bool -> bool -> - env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment + env -> evar_map -> ?flags:Evarconv.unify_flags -> + unsafe_judgment -> types -> evar_map * unsafe_judgment val inh_conv_coerce_rigid_to : ?loc:Loc.t -> program_mode:bool ->bool -> - env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment + env -> evar_map -> ?flags:Evarconv.unify_flags -> + unsafe_judgment -> types -> evar_map * unsafe_judgment (** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] is coercible to an object of type [t'] adding evar constraints if needed; it fails if no coercion exists *) val inh_conv_coerces_to : ?loc:Loc.t -> - env -> evar_map -> types -> types -> evar_map + env -> evar_map -> ?flags:Evarconv.unify_flags -> + types -> types -> evar_map (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index bb163ddaee..8e273fb4a8 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -24,14 +24,28 @@ open Evardefine open Evarsolve open Evd open Pretype_errors -open Context.Named.Declaration module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -type unify_fun = TransparentState.t -> +type unify_flags = Evarsolve.unify_flags + +type unify_fun = unify_flags -> env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> Evarsolve.unification_result +let default_transparent_state env = TransparentState.full +(* Conv_oracle.get_transp_state (Environ.oracle env) *) + +let default_flags_of ?(subterm_ts=TransparentState.empty) ts = + { modulo_betaiota = true; + open_ts = ts; closed_ts = ts; subterm_ts; + frozen_evars = Evar.Set.empty; with_cs = true; + allow_K_at_toplevel = true } + +let default_flags env = + let ts = default_transparent_state env in + default_flags_of ts + let debug_unification = ref (false) let () = Goptions.(declare_bool_option { optdepr = false; @@ -42,6 +56,16 @@ let () = Goptions.(declare_bool_option { optwrite = (fun a -> debug_unification:=a); }) +let debug_ho_unification = ref (false) +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = + "Print higher-order unification debug information"; + optkey = ["Debug";"HO";"Unification"]; + optread = (fun () -> !debug_ho_unification); + optwrite = (fun a -> debug_ho_unification:=a); +}) + (*******************************************) (* Functions to deal with impossible cases *) (*******************************************) @@ -101,42 +125,106 @@ type flex_kind_of_term = | MaybeFlexible of EConstr.t (* reducible but not necessarily reduced *) | Flexible of EConstr.existential -let flex_kind_of_term ts env evd c sk = +let is_frozen flags (evk, _) = Evar.Set.mem evk flags.frozen_evars + +let flex_kind_of_term flags env evd c sk = match EConstr.kind evd c with | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> - Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env evd c) - | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible c - | Evar ev -> Flexible ev + Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term flags.open_ts env evd c) + | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> + if flags.modulo_betaiota then MaybeFlexible c + else Rigid + | Evar ev -> + if is_frozen flags ev then Rigid + else Flexible ev | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ | Int _ -> Rigid | Meta _ -> Rigid | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) | Cast _ | App _ | Case _ -> assert false -let apprec_nohdbeta ts env evd c = +let apprec_nohdbeta flags env evd c = let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in - if Stack.not_purely_applicative sk + if flags.modulo_betaiota && Stack.not_purely_applicative sk then Stack.zip evd (fst (whd_betaiota_deltazeta_for_iota_state - ts env evd Cst_stack.empty appr)) + flags.open_ts env evd Cst_stack.empty appr)) else c let position_problem l2r = function | CONV -> None | CUMUL -> Some l2r -let occur_rigidly (evk,_ as ev) evd t = +(* [occur_rigidly ev evd t] tests if the evar ev occurs in a rigid + context in t. Precondition: t has a rigid head and is not reducible. + + That function is an under approximation of occur-check, it can return + false even if the occur-check would succeed on the normal form. This + means we might postpone unsolvable constraints which will ultimately + result in an occur-check after reductions. If it returns true, we + know that the occur-check would also return true on the normal form. + + [t] is assumed to have a rigid head, which can + appear under a elimination context (e.g. application, match or projection). + + In the inner recursive function, the result indicates if the term is + rigid (irreducible), normal (succession of constructors) or + potentially reducible. For applications, this means than an + occurrence of the evar in arguments should be looked at to find an + occur-check if the head is rigid or normal. For inductive + eliminations, only an occurrence in a rigid context of the + discriminee counts as a rigid occurrence overall, not a normal + occurrence which might disappear after reduction. *) + +type result = Rigid of bool | Normal of bool | Reducible + +let rigid_normal_occ = function Rigid b -> b | Normal b -> b | _ -> false + +let occur_rigidly flags env evd (evk,_) t = let rec aux t = match EConstr.kind evd t with - | App (f, c) -> if aux f then Array.exists aux c else false - | Construct _ | Ind _ | Sort _ | Meta _ | Fix _ | CoFix _ | Int _ -> true - | Proj (p, c) -> not (aux c) - | Evar (evk',_) -> if Evar.equal evk evk' then raise Occur else false + | App (f, c) -> + (match aux f with + | Rigid b -> Rigid (b || Array.exists (fun x -> rigid_normal_occ (aux x)) c) + | Normal b -> Normal (b || Array.exists (fun x -> rigid_normal_occ (aux x)) c) + | Reducible -> Reducible) + | Construct _ -> Normal false + | Ind _ | Sort _ -> Rigid false + | Proj (p, c) -> + let cst = Projection.constant p in + let rigid = not (TransparentState.is_transparent_constant flags.open_ts cst) in + if rigid then aux c + else (* if the evar appears rigidly in c then this elimination + cannot reduce and we have a rigid occurrence, otherwise + we don't know. *) + (match aux c with + | Rigid _ as res -> res + | Normal b -> Reducible + | Reducible -> Reducible) + | Evar (evk',l as ev) -> + if Evar.equal evk evk' then Rigid true + else if is_frozen flags ev then + Rigid (Array.exists (fun x -> rigid_normal_occ (aux x)) l) + else Reducible | Cast (p, _, _) -> aux p - | Lambda _ | LetIn _ -> false - | Const _ -> false - | Prod (_, b, t) -> ignore(aux b || aux t); true - | Rel _ | Var _ -> false - | Case (_,_,c,_) -> if eq_constr evd (mkEvar ev) c then raise Occur else false - in try ignore(aux t); false with Occur -> true + | Lambda (na, t, b) -> aux b + | LetIn (na, _, _, b) -> aux b + | Const (c,_) -> + if TransparentState.is_transparent_constant flags.open_ts c then Reducible + else Rigid false + | Prod (_, b, t) -> + let b' = aux b and t' = aux t in + if rigid_normal_occ b' || rigid_normal_occ t' then Rigid true + else Reducible + | Rel _ | Var _ -> Reducible + | Case (_,_,c,_) -> + (match aux c with + | Rigid b -> Rigid b + | _ -> Reducible) + | Meta _ | Fix _ | CoFix _ | Int _ -> Reducible + in + match aux t with + | Rigid b -> b + | Normal b -> b + | Reducible -> false (* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose the problem (t1 stack1) = (t2 stack2) into a problem @@ -365,7 +453,21 @@ let compare_cumulative_instances evd variances u u' = Success evd | Inr p -> UnifFailure (evd, UnifUnivInconsistency p) -let rec evar_conv_x ts env evd pbty term1 term2 = +let conv_fun f flags on_types = + let typefn env evd pbty term1 term2 = + let flags = { (default_flags env) with + with_cs = flags.with_cs; + frozen_evars = flags.frozen_evars } + in f flags env evd pbty term1 term2 + in + let termfn env evd pbty term1 term2 = + f flags env evd pbty term1 term2 + in + match on_types with + | TypeUnification -> typefn + | TermUnification -> termfn + +let rec evar_conv_x flags env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in let term2 = whd_head_evar evd term2 in (* Maybe convertible but since reducing can erase evars which [evar_apprec] @@ -374,7 +476,7 @@ let rec evar_conv_x ts env evd pbty term1 term2 = let ground_test = if is_ground_term evd term1 && is_ground_term evd term2 then ( let e = - match infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts) env evd term1 term2 with + match infer_conv ~catch_incon:false ~pb:pbty ~ts:flags.closed_ts env evd term1 term2 with | Some evd -> Success evd | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)) | exception Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) @@ -389,30 +491,30 @@ let rec evar_conv_x ts env evd pbty term1 term2 = | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) - let term1 = apprec_nohdbeta (fst ts) env evd term1 in - let term2 = apprec_nohdbeta (fst ts) env evd term2 in + let term1 = apprec_nohdbeta flags env evd term1 in + let term2 = apprec_nohdbeta flags env evd term2 in let default () = - evar_eqappr_x ts env evd pbty + evar_eqappr_x flags env evd pbty (whd_nored_state evd (term1,Stack.empty), Cst_stack.empty) (whd_nored_state evd (term2,Stack.empty), Cst_stack.empty) in begin match EConstr.kind evd term1, EConstr.kind evd term2 with - | Evar ev, _ when Evd.is_undefined evd (fst ev) -> - (match solve_simple_eqn (evar_conv_x ts) env evd - (position_problem true pbty,ev, term2) with + | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> + (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd + (position_problem true pbty,ev,term2) with | UnifFailure (_,OccurCheck _) -> (* Eta-expansion might apply *) default () | x -> x) - | _, Evar ev when Evd.is_undefined evd (fst ev) -> - (match solve_simple_eqn (evar_conv_x ts) env evd - (position_problem false pbty,ev, term1) with + | _, Evar ev when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> + (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd + (position_problem false pbty,ev,term1) with | UnifFailure (_, OccurCheck _) -> (* Eta-expansion might apply *) default () | x -> x) | _ -> default () end -and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty +and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) = let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) @@ -423,18 +525,18 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Some l1' -> (* Miller-Pfenning's patterns unification *) let t2 = tM in let t2 = solve_pattern_eqn env evd l1' t2 in - solve_simple_eqn (evar_conv_x ts) env evd + solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem on_left pbty,ev,t2) in let consume_stack on_left (termF,skF) (termO,skO) evd = let switch f a b = if on_left then f a b else f b a in let not_only_app = Stack.not_purely_applicative skO in - match switch (ise_stack2 not_only_app env evd (evar_conv_x ts)) skF skO with + match switch (ise_stack2 not_only_app env evd (evar_conv_x flags)) skF skO with |Some (l,r), Success i' when on_left && (not_only_app || List.is_empty l) -> - switch (evar_conv_x ts env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) + switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) |Some (r,l), Success i' when not on_left && (not_only_app || List.is_empty l) -> - switch (evar_conv_x ts env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) - |None, Success i' -> switch (evar_conv_x ts env i' pbty) termF termO + switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) + |None, Success i' -> switch (evar_conv_x flags env i' pbty) termF termO |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (evd,NotSameArgSize) in let eta env evd onleft sk term sk' term' = @@ -443,12 +545,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let c = nf_evar evd c1 in let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state - (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in + flags.open_ts env' evd Cst_stack.empty (c'1, Stack.empty) in let out2 = whd_nored_state evd (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in - if onleft then evar_eqappr_x ts env' evd CONV out1 out2 - else evar_eqappr_x ts env' evd CONV out2 out1 + if onleft then evar_eqappr_x flags env' evd CONV out1 out2 + else evar_eqappr_x flags env' evd CONV out2 out1 in let rigids env evd sk term sk' term' = let check_strict evd u u' = @@ -504,12 +606,16 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_and evd [(fun i -> try compare_heads i with Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk sk')] + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk sk')] in - let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = + let consume on_left (_, skF as apprF) (_,skM as apprM) i = + if not (Stack.is_empty skF && Stack.is_empty skM) then + consume_stack on_left apprF apprM i + else quick_fail i + in + let miller on_left ev (termF,skF as apprF) (termM, skM as apprM) i = let switch f a b = if on_left then f a b else f b a in let not_only_app = Stack.not_purely_applicative skM in - let f1 i = match Stack.list_of_app_stack skF with | None -> quick_fail evd | Some lF -> @@ -518,17 +624,17 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun () -> if not_only_app then (* Postpone the use of an heuristic *) switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) (Stack.zip evd apprF) tM else quick_fail i) - ev lF tM i - and consume (termF,skF as apprF) (termM,skM as apprM) i = - if not (Stack.is_empty skF && Stack.is_empty skM) then - consume_stack on_left apprF apprM i - else quick_fail i - and delta i = - switch (evar_eqappr_x ts env i pbty) (apprF,cstsF) - (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i cstsM (vM,skM)) + ev lF tM i + in + let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = + let switch f a b = if on_left then f a b else f b a in + let delta i = + switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i cstsM (vM,skM)) in - let default i = ise_try i [f1; consume apprF apprM; delta] + let default i = ise_try i [miller on_left ev apprF apprM; + consume on_left apprF apprM; + delta] in match EConstr.kind evd termM with | Proj (p, c) when not (Stack.is_empty skF) -> @@ -543,13 +649,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty try let termM' = Retyping.expand_projection env evd p c [] in let apprM', cstsM' = - whd_betaiota_deltazeta_for_iota_state - (fst ts) env evd cstsM (termM',skM) + whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd cstsM (termM',skM) in let delta' i = - switch (evar_eqappr_x ts env i pbty) (apprF,cstsF) (apprM',cstsM') + switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) (apprM',cstsM') in - fun i -> ise_try i [f1; consume apprF apprM'; delta'] + fun i -> ise_try i [miller on_left ev apprF apprM'; + consume on_left apprF apprM'; delta'] with Retyping.RetypeError _ -> (* Happens thanks to w_unify building ill-typed terms *) default @@ -563,7 +669,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty match EConstr.kind evd termR with | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR -> eta env evd false skR termR skF termF - | Construct u -> eta_constructor ts env evd skR u skF termF + | Construct u -> eta_constructor flags env evd skR u skF termF | _ -> UnifFailure (evd,NotSameHead) in match Stack.list_of_app_stack skF with @@ -571,12 +677,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_try evd [consume_stack on_left apprF apprR; eta] | Some lF -> let tR = Stack.zip evd apprR in - miller_pfenning on_left - (fun () -> - ise_try evd - [eta;(* Postpone the use of an heuristic *) - (fun i -> - if not (occur_rigidly ev i tR) then + miller_pfenning on_left + (fun () -> + ise_try evd + [eta;(* Postpone the use of an heuristic *) + (fun i -> + if not (occur_rigidly flags env i ev tR) then let i,tF = if isRel i tR || isVar i tR then (* Optimization so as to generate candidates *) @@ -585,95 +691,111 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else i,Stack.zip evd apprF in switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) - tF tR - else + tF tR + else UnifFailure (evd,OccurCheck (fst ev,tR)))]) - ev lF tR evd + ev lF tR evd + in + let first_order env i t1 t2 sk1 sk2 = + (* Try first-order unification *) + match ise_stack2 false env i (evar_conv_x flags) sk1 sk2 with + | None, Success i' -> + (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) + (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) + let ev1' = whd_evar i' t1 in + if isEvar i' ev1' then + solve_simple_eqn (conv_fun evar_conv_x) flags env i' + (position_problem true pbty,destEvar i' ev1',term2) + else + evar_eqappr_x flags env evd pbty + ((ev1', sk1), csts1) ((term2, sk2), csts2) + | Some (r,[]), Success i' -> + (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) + (* we now unify r[?ev1] and ?ev2 *) + let ev2' = whd_evar i' t2 in + if isEvar i' ev2' then + solve_simple_eqn (conv_fun evar_conv_x) flags env i' + (position_problem false pbty,destEvar i' ev2',Stack.zip i' (term1,r)) + else + evar_eqappr_x flags env evd pbty + ((ev2', sk1), csts1) ((term2, sk2), csts2) + | Some ([],r), Success i' -> + (* Symmetrically *) + (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) + (* we now unify ?ev1 and r[?ev2] *) + let ev1' = whd_evar i' t1 in + if isEvar i' ev1' then + solve_simple_eqn (conv_fun evar_conv_x) flags env i' + (position_problem true pbty,destEvar i' ev1',Stack.zip i' (term2,r)) + else evar_eqappr_x flags env evd pbty + ((ev1', sk1), csts1) ((term2, sk2), csts2) + | None, (UnifFailure _ as x) -> + (* sk1 and sk2 have no common outer part *) + if Stack.not_purely_applicative sk2 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid true (destEvar evd t1) appr1 appr2 + else + if Stack.not_purely_applicative sk1 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid false (destEvar evd t2) appr2 appr1 + else + (* We could instead try Miller unification, then + postpone to see if other equations help, as in: + [Check fun a b : unit => (eqᵣefl : _ a = _ a b)] *) + x + | Some _, Success _ -> + (* sk1 and sk2 have a common outer part *) + if Stack.not_purely_applicative sk2 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid true (destEvar evd t1) appr1 appr2 + else + if Stack.not_purely_applicative sk1 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid false (destEvar evd t2) appr2 appr1 + else + (* We could instead try Miller unification, then + postpone to see if other equations help, as in: + [Check fun a b c : unit => (eqᵣefl : _ a b = _ c a b)] *) + UnifFailure (i,NotSameArgSize) + | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.") in let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then let open Pp in Feedback.msg_notice (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in - match (flex_kind_of_term (fst ts) env evd term1 sk1, - flex_kind_of_term (fst ts) env evd term2 sk2) with - | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) -> + match (flex_kind_of_term flags env evd term1 sk1, + flex_kind_of_term flags env evd term2 sk2) with + | Flexible (sp1,al1), Flexible (sp2,al2) -> (* sk1[?ev1] =? sk2[?ev2] *) - let f1 i = - (* Try first-order unification *) - match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with - | None, Success i' -> - (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) - (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) - let ev1' = whd_evar i' (mkEvar ev1) in - if isEvar i' ev1' then - solve_simple_eqn (evar_conv_x ts) env i' - (position_problem true pbty,destEvar i' ev1', term2) - else - evar_eqappr_x ts env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) - | Some (r,[]), Success i' -> - (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) - (* we now unify r[?ev1] and ?ev2 *) - let ev2' = whd_evar i' (mkEvar ev2) in - if isEvar i' ev2' then - solve_simple_eqn (evar_conv_x ts) env i' - (position_problem false pbty,destEvar i' ev2',Stack.zip evd (term1,r)) - else - evar_eqappr_x ts env evd pbty - ((ev2', sk1), csts1) ((term2, sk2), csts2) - | Some ([],r), Success i' -> - (* Symmetrically *) - (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) - (* we now unify ?ev1 and r[?ev2] *) - let ev1' = whd_evar i' (mkEvar ev1) in - if isEvar i' ev1' then - solve_simple_eqn (evar_conv_x ts) env i' - (position_problem true pbty,destEvar i' ev1',Stack.zip evd (term2,r)) - else evar_eqappr_x ts env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) - | None, (UnifFailure _ as x) -> - (* sk1 and sk2 have no common outer part *) - if Stack.not_purely_applicative sk2 then - (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) - flex_rigid true ev1 appr1 appr2 - else - if Stack.not_purely_applicative sk1 then - (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) - flex_rigid false ev2 appr2 appr1 - else - (* We could instead try Miller unification, then - postpone to see if other equations help, as in: - [Check fun a b : unit => (eqᵣefl : _ a = _ a b)] *) - x - | Some _, Success _ -> - (* sk1 and sk2 have a common outer part *) - if Stack.not_purely_applicative sk2 then - (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) - flex_rigid true ev1 appr1 appr2 - else - if Stack.not_purely_applicative sk1 then - (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) - flex_rigid false ev2 appr2 appr1 - else - (* We could instead try Miller unification, then - postpone to see if other equations help, as in: - [Check fun a b c : unit => (eqᵣefl : _ a b = _ c a b)] *) - UnifFailure (i,NotSameArgSize) - | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.") - + let f1 i = first_order env i term1 term2 sk1 sk2 and f2 i = if Evar.equal sp1 sp2 then - match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with + match ise_stack2 false env i (evar_conv_x flags) sk1 sk2 with |None, Success i' -> - Success (solve_refl (fun env i pbty a1 a2 -> - is_success (evar_conv_x ts env i pbty a1 a2)) + Success (solve_refl (fun flags p env i pbty a1 a2 -> + let flags = + match p with + | TypeUnification -> default_flags env + | TermUnification -> flags + in + is_success (evar_conv_x flags env i pbty a1 a2)) flags env i' (position_problem true pbty) sp1 al1 al2) |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (i,NotSameArgSize) else UnifFailure (i,NotSameHead) - in - ise_try evd [f1; f2] + and f3 i = miller true (sp1,al1) appr1 appr2 i + and f4 i = miller false (sp2,al2) appr2 appr1 i + and f5 i = + (* We ensure failure of consuming the stacks does not + propagate an error about unification of the stacks while + the heads themselves cannot be unified, so we return + NotSameHead. *) + match consume true appr1 appr2 i with + | Success _ as x -> x + | UnifFailure _ -> quick_fail i + in + ise_try evd [f1; f2; f3; f4; f5] | Flexible ev1, MaybeFlexible v2 -> flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 @@ -687,31 +809,31 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let f1 i = (* FO *) ise_and i [(fun i -> ise_try i - [(fun i -> evar_conv_x ts env i CUMUL t1 t2); - (fun i -> evar_conv_x ts env i CUMUL t2 t1)]); - (fun i -> evar_conv_x ts env i CONV b1 b2); + [(fun i -> evar_conv_x flags env i CUMUL t1 t2); + (fun i -> evar_conv_x flags env i CUMUL t2 t1)]); + (fun i -> evar_conv_x flags env i CONV b1 b2); (fun i -> let b = nf_evar i b1 in let t = nf_evar i t1 in let na = Nameops.Name.pick na1 na2 in - evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + evar_conv_x flags (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2) - in evar_eqappr_x ts env i pbty out1 out2 + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] | Proj (p, c), Proj (p', c') when Projection.repr_equal p p' -> let f1 i = ise_and i - [(fun i -> evar_conv_x ts env i CONV c c'); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + [(fun i -> evar_conv_x flags env i CONV c c'); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2) - in evar_eqappr_x ts env i pbty out1 out2 + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] @@ -723,7 +845,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in (match res with | Some (f1,args1) -> - evar_eqappr_x ts env evd pbty ((f1,Stack.append_app args1 sk1),csts1) + evar_eqappr_x flags env evd pbty ((f1,Stack.append_app args1 sk1),csts1) (appr2,csts2) | None -> UnifFailure (evd,NotSameHead)) @@ -734,7 +856,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in (match res with | Some (f2,args2) -> - evar_eqappr_x ts env evd pbty (appr1,csts1) ((f2,Stack.append_app args2 sk2),csts2) + evar_eqappr_x flags env evd pbty (appr1,csts1) ((f2,Stack.append_app args2 sk2),csts2) | None -> UnifFailure (evd,NotSameHead)) | _, _ -> @@ -751,13 +873,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty try Success (Evd.add_universe_constraints i univs) with UniversesDiffer -> UnifFailure (i,NotSameHead) | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] | None -> UnifFailure (i,NotSameHead) and f2 i = (try - if not (snd ts) then raise Not_found - else conv_record ts env i + if not flags.with_cs then raise Not_found + else conv_record flags env i (try check_conv_record env i appr1 appr2 with Not_found -> check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) @@ -775,7 +897,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed (fst (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i Cst_stack.empty (subst1 b c, args))) + flags.open_ts env i Cst_stack.empty (subst1 b c, args))) | Fix _ -> true (* Partially applied fix can be the result of a whd call *) | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args | Case _ | App _| Cast _ -> assert false in @@ -783,20 +905,20 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed (fst (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i Cst_stack.empty (v2, applicative_stack))) in + flags.open_ts env i Cst_stack.empty (v2, applicative_stack))) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in if (EConstr.isLambda i term1 || rhs_is_already_stuck) && (not (Stack.not_purely_applicative sk1)) then - evar_eqappr_x ~rhs_is_already_stuck ts env i pbty + evar_eqappr_x ~rhs_is_already_stuck flags env i pbty (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) + flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) (appr2,csts2) else - evar_eqappr_x ts env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty (appr1,csts1) (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f1; f2; f3] end @@ -804,13 +926,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Rigid, Rigid when EConstr.isLambda evd term1 && EConstr.isLambda evd term2 -> let (na1,c1,c'1) = EConstr.destLambda evd term1 in let (na2,c2,c'2) = EConstr.destLambda evd term2 in - assert app_empty; ise_and evd - [(fun i -> evar_conv_x ts env i CONV c1 c2); + [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in let na = Nameops.Name.pick na1 na2 in - evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)] + evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2); + (* When in modulo_betaiota = false case, lambda's are not reduced *) + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 @@ -818,13 +941,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | MaybeFlexible v1, Rigid -> let f3 i = (try - if not (snd ts) then raise Not_found - else conv_record ts env i (check_conv_record env i appr1 appr2) + if not flags.with_cs then raise Not_found + else conv_record flags env i (check_conv_record env i appr1 appr2) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x ts env i pbty + evar_eqappr_x flags env i pbty (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) + flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) (appr2,csts2) in ise_try evd [f3; f4] @@ -832,13 +955,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Rigid, MaybeFlexible v2 -> let f3 i = (try - if not (snd ts) then raise Not_found - else conv_record ts env i (check_conv_record env i appr2 appr1) + if not flags.with_cs then raise Not_found + else conv_record flags env i (check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x ts env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty (appr1,csts1) (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f3; f4] @@ -867,20 +990,20 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> ise_and evd - [(fun i -> evar_conv_x ts env i CONV c1 c2); + [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in let na = Nameops.Name.pick n1 n2 in - evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] + evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> if Int.equal x1 x2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 + exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 else UnifFailure (evd,NotSameHead) | Var var1, Var var2 -> if Id.equal var1 var2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 + exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 else UnifFailure (evd,NotSameHead) | Const _, Const _ @@ -889,49 +1012,59 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Int _, Int _ -> rigids env evd sk1 term1 sk2 term2 + | Evar (sp1,al1), Evar (sp2,al2) -> (* Frozen evars *) + if Evar.equal sp1 sp2 then + match ise_stack2 false env evd (evar_conv_x flags) sk1 sk2 with + |None, Success i' -> + ise_array2 i' (fun i' -> evar_conv_x flags env i' CONV) al1 al2 + |_, (UnifFailure _ as x) -> x + |Some _, _ -> UnifFailure (evd,NotSameArgSize) + else UnifFailure (evd,NotSameHead) + | Construct u, _ -> - eta_constructor ts env evd sk1 u sk2 term2 + eta_constructor flags env evd sk1 u sk2 term2 | _, Construct u -> - eta_constructor ts env evd sk2 u sk1 term1 + eta_constructor flags env evd sk2 u sk1 term1 | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then ise_and evd [ - (fun i -> ise_array2 i (fun i' -> evar_conv_x ts env i' CONV) tys1 tys2); - (fun i -> ise_array2 i (fun i' -> evar_conv_x ts (push_rec_types recdef1 env) i' CONV) bds1 bds2); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + (fun i -> ise_array2 i (fun i' -> evar_conv_x flags env i' CONV) tys1 tys2); + (fun i -> ise_array2 i (fun i' -> evar_conv_x flags (push_rec_types recdef1 env) i' CONV) bds1 bds2); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] else UnifFailure (evd, NotSameHead) | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> if Int.equal i1 i2 then ise_and evd [(fun i -> ise_array2 i - (fun i -> evar_conv_x ts env i CONV) tys1 tys2); + (fun i -> evar_conv_x flags env i CONV) tys1 tys2); (fun i -> ise_array2 i - (fun i -> evar_conv_x ts (push_rec_types recdef1 env) i CONV) + (fun i -> evar_conv_x flags (push_rec_types recdef1 env) i CONV) bds1 bds2); (fun i -> exact_ise_stack2 env i - (evar_conv_x ts) sk1 sk2)] + (evar_conv_x flags) sk1 sk2)] else UnifFailure (evd,NotSameHead) | (Meta _, _) | (_, Meta _) -> - begin match ise_stack2 true env evd (evar_conv_x ts) sk1 sk2 with + begin match ise_stack2 true env evd (evar_conv_x flags) sk1 sk2 with |_, (UnifFailure _ as x) -> x - |None, Success i' -> evar_conv_x ts env i' CONV term1 term2 - |Some (sk1',sk2'), Success i' -> evar_conv_x ts env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) + |None, Success i' -> evar_conv_x flags env i' CONV term1 term2 + |Some (sk1',sk2'), Success i' -> evar_conv_x flags env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) end - | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _), _ -> + | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Evar _ | Lambda _), _ -> UnifFailure (evd,NotSameHead) - - | (App _ | Cast _ | Case _ | Proj _), _ -> assert false - | (LetIn _| Evar _), _ -> assert false - | (Lambda _), _ -> assert false - + | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Evar _ | Lambda _) -> + UnifFailure (evd,NotSameHead) + | Case _, _ -> UnifFailure (evd,NotSameHead) + | Proj _, _ -> UnifFailure (evd,NotSameHead) + | (App _ | Cast _), _ -> assert false + | LetIn _, _ -> assert false end -and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = +and conv_record flags env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = (* Tries to unify the states (proji params1 c1 | sk1) = (proji params2 (c (?xs:bs)) | sk2) @@ -962,7 +1095,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) (fun (i,ks,m,test) b -> if match n with Some n -> Int.equal m n | None -> false then let ty = Retyping.get_type_of env i t2 in - let test i = evar_conv_x trs env i CUMUL ty (substl ks b) in + let test i = evar_conv_x flags env i CUMUL ty (substl ks b) in (i,t2::ks, m-1, test) else let dloc = Loc.tag Evar_kinds.InternalHole in @@ -974,20 +1107,20 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) ise_and evd' [(fun i -> exact_ise_stack2 env i - (fun env' i' cpb x1 x -> evar_conv_x trs env' i' cpb x1 (substl ks x)) + (fun env' i' cpb x1 x -> evar_conv_x flags env' i' cpb x1 (substl ks x)) params1 params); (fun i -> exact_ise_stack2 env i - (fun env' i' cpb u1 u -> evar_conv_x trs env' i' cpb u1 (substl ks u)) + (fun env' i' cpb u1 u -> evar_conv_x flags env' i' cpb u1 (substl ks u)) us2 us); - (fun i -> evar_conv_x trs env i CONV c1 app); - (fun i -> exact_ise_stack2 env i (evar_conv_x trs) sk1 sk2); + (fun i -> evar_conv_x flags env i CONV c1 app); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2); test; - (fun i -> evar_conv_x trs env i CONV h2 + (fun i -> evar_conv_x flags env i CONV h2 (fst (decompose_app_vect i (substl ks h))))] else UnifFailure(evd,(*dummy*)NotSameHead) -and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = +and eta_constructor flags env evd sk1 ((ind, i), u) sk2 term2 = let open Declarations in let mib = lookup_mind (fst ind) env in match get_projections env ind with @@ -999,15 +1132,17 @@ and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = let term = Stack.zip evd (term2,sk2) in List.map (fun p -> EConstr.mkProj (Projection.make p false, term)) (Array.to_list projs) in - exact_ise_stack2 env evd (evar_conv_x (fst ts, false)) l1' + exact_ise_stack2 env evd (evar_conv_x { flags with with_cs = false}) l1' (Stack.append_app_list l2' Stack.empty) - with + with | Invalid_argument _ -> (* Stack.tail: partially applied constructor *) UnifFailure(evd,NotSameHead)) | _ -> UnifFailure (evd,NotSameHead) -let evar_conv_x ts = evar_conv_x (ts, true) +let evar_conv_x flags = evar_conv_x flags + +let evar_unify = conv_fun evar_conv_x (* Profiling *) let evar_conv_x = @@ -1018,25 +1153,26 @@ let evar_conv_x = let evar_conv_hook_get, evar_conv_hook_set = Hook.make ~default:evar_conv_x () -let evar_conv_x ts = Hook.get evar_conv_hook_get ts +let evar_conv_x flags = Hook.get evar_conv_hook_get flags let set_evar_conv f = Hook.set evar_conv_hook_set f (* We assume here |l1| <= |l2| *) -let first_order_unification ts env evd (ev1,l1) (term2,l2) = +let first_order_unification flags env evd (ev1,l1) (term2,l2) = let (deb2,rest2) = Array.chop (Array.length l2-Array.length l1) l2 in ise_and evd (* First compare extra args for better failure message *) - [(fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) rest2 l1); + [(fun i -> ise_array2 i (fun i -> evar_conv_x flags env i CONV) rest2 l1); (fun i -> (* Then instantiate evar unless already done by unifying args *) let t2 = mkApp(term2,deb2) in if is_defined i (fst ev1) then - evar_conv_x ts env i CONV t2 (mkEvar ev1) + evar_conv_x flags env i CONV t2 (mkEvar ev1) else - solve_simple_eqn ~choose:true (evar_conv_x ts) env i (None,ev1,t2))] + solve_simple_eqn ~choose:true ~imitate_defs:false + evar_unify flags env i (None,ev1,t2))] let choose_less_dependent_instance evk evd term args = let evi = Evd.find_undefined evd evk in @@ -1046,30 +1182,57 @@ let choose_less_dependent_instance evk evd term args = | [] -> None | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd) -let apply_on_subterm env evdref f c t = +type occurrence_match_test = + env -> evar_map -> constr -> + env -> evar_map -> int -> constr -> constr -> bool * evar_map + +type occurrence_selection = + | AtOccurrences of Locus.occurrences + | Unspecified of Abstraction.abstraction + +type occurrences_selection = + occurrence_match_test * occurrence_selection list + +let default_occurrence_selection = Unspecified Abstraction.Imitate + +let default_occurrence_test ~frozen_evars ts _ origsigma _ env sigma _ c pat = + let flags = { (default_flags_of ~subterm_ts:ts ts) with frozen_evars } in + match evar_conv_x flags env sigma CONV c pat with + | Success sigma -> true, sigma + | UnifFailure _ -> false, sigma + +let default_occurrences_selection ?(frozen_evars=Evar.Set.empty) ts n = + (default_occurrence_test ~frozen_evars ts, + List.init n (fun _ -> default_occurrence_selection)) + +let apply_on_subterm env evd fixedref f test c t = + let test = test env evd c in + let prc env evd = Termops.Internal.print_constr_env env evd in + let evdref = ref evd in let rec applyrec (env,(k,c) as acc) t = - (* By using eq_constr, we make an approximation, for instance, we *) - (* could also be interested in finding a term u convertible to t *) - (* such that c occurs in u *) - let eq_constr c1 c2 = match EConstr.eq_constr_universes env !evdref c1 c2 with - | None -> false - | Some cstr -> - try ignore (Evd.add_universe_constraints !evdref cstr); true - with UniversesDiffer -> false - in - if eq_constr c t then f k - else + if Evar.Set.exists (fun fixed -> occur_evar !evdref fixed t) !fixedref then match EConstr.kind !evdref t with - | Evar (evk,args) -> - let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in - let g decl a = if is_local_assum decl then applyrec acc a else a in - mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args))) - | _ -> - map_constr_with_binders_left_to_right !evdref - (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) - applyrec acc t + | Evar (ev, args) when Evar.Set.mem ev !fixedref -> t + | _ -> map_constr_with_binders_left_to_right !evdref + (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) + applyrec acc t + else + (if !debug_ho_unification then + Feedback.msg_debug Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t); + let b, evd = + try test env !evdref k c t + with e when CErrors.noncritical e -> assert false in + if b then (if !debug_ho_unification then Feedback.msg_debug (Pp.str "succeeded"); + let evd', t' = f !evdref k t in + evdref := evd'; t') + else ( + if !debug_ho_unification then Feedback.msg_debug (Pp.str "failed"); + map_constr_with_binders_left_to_right !evdref + (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) + applyrec acc t)) in - applyrec (env,(0,c)) t + let t' = applyrec (env,(0,c)) t in + !evdref, t' let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the @@ -1114,117 +1277,283 @@ let set_solve_evars f = solve_evars := f * proposition from Dan Grayson] *) +let check_selected_occs env sigma c occ occs = + let notfound = + match occs with + | AtOccurrences occs -> + (match occs with + | Locus.AtLeastOneOccurrence -> occ == 1 + | Locus.AllOccurrences -> false + | Locus.AllOccurrencesBut l -> List.last l > occ + | Locus.OnlyOccurrences l -> List.last l > occ + | Locus.NoOccurrences -> false) + | Unspecified abstract -> false + in if notfound then + raise (PretypeError (env,sigma,NoOccurrenceFound (c,None))) + else () + exception TypingFailed of evar_map -let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = +let set_of_evctx l = + List.fold_left (fun s decl -> Id.Set.add (NamedDecl.get_id decl) s) Id.Set.empty l + +(** Weaken the existentials so that they can be typed in sign and raise + an error if the term otherwise mentions variables not bound in sign. *) +let thin_evars env sigma sign c = + let evdref = ref sigma in + let ctx = set_of_evctx sign in + let rec applyrec (env,acc) t = + match kind sigma t with + | Evar (ev, args) -> + let evi = Evd.find_undefined sigma ev in + let filter = Array.map (fun c -> Id.Set.subset (collect_vars sigma c) ctx) args in + let filter = Filter.make (Array.to_list filter) in + let candidates = Option.map (List.map EConstr.of_constr) (evar_candidates evi) in + let evd, ev = restrict_evar !evdref ev filter candidates in + evdref := evd; whd_evar !evdref t + | Var id -> + if not (Id.Set.mem id ctx) then raise (TypingFailed sigma) + else t + | _ -> + map_constr_with_binders_left_to_right !evdref + (fun d (env,acc) -> (push_rel d env, acc+1)) + applyrec (env,acc) t + in + let c' = applyrec (env,0) c in + (!evdref, c') + +let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = try let evi = Evd.find_undefined evd evk in + let evi = nf_evar_info evd evi in + let env_evar_unf = evar_env evi in let env_evar = evar_filtered_env evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - let instance = List.map mkVar (List.map NamedDecl.get_id ctxt) in - + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs); + Feedback.msg_debug Pp.(str"env evars: " ++ Termops.Internal.print_env env_evar)); + let args = Array.map (nf_evar evd) args in + let vars = List.map NamedDecl.get_id ctxt in + let argsubst = List.map2 (fun id c -> (id, c)) vars (Array.to_list args) in + let instance = List.map mkVar vars in + let rhs = nf_evar evd rhs in + if not (noccur_evar env_rhs evd evk rhs) then raise (TypingFailed evd); + (* Ensure that any progress made by Typing.e_solve_evars will not contradict + the solution we are trying to build here by adding the problem as a constraint. *) + let evd = Evarutil.add_unification_pb (CONV,env_rhs,mkEvar (evk,args),rhs) evd in + let prc env evd c = Termops.Internal.print_constr_env env evd c in let rec make_subst = function - | decl'::ctxt', c::l, occs::occsl when isVarId evd (NamedDecl.get_id decl') c -> + | decl'::ctxt', c::l, occs::occsl when isVarId evd (NamedDecl.get_id decl') c -> begin match occs with - | Some _ -> - user_err Pp.(str "Cannot force abstraction on identity instance.") - | None -> - make_subst (ctxt',l,occsl) + | AtOccurrences loc when not (Locusops.is_all_occurrences loc) -> + user_err Pp.(str "Cannot force abstraction on identity instance.") + | _ -> + make_subst (ctxt',l,occsl) end - | decl'::ctxt', c::l, occs::occsl -> + | decl'::ctxt', c::l, occs::occsl -> let id = NamedDecl.get_id decl' in let t = NamedDecl.get_type decl' in let evs = ref [] in - let ty = Retyping.get_type_of env_rhs evd c in - let filter' = filter_possible_projections evd c ty ctxt args in + let c = nf_evar evd c in + (* ty is in env_rhs now *) + let ty = replace_vars argsubst t in + let filter' = filter_possible_projections evd c (nf_evar evd ty) ctxt args in (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl) - | _, _, [] -> [] - | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list.") in - - let rec set_holes evdref rhs = function - | (id,_,c,cty,evsref,filter,occs)::subst -> - let set_var k = - match occs with - | Some Locus.AllOccurrences -> mkVar id - | Some _ -> user_err Pp.(str "Selection of specific occurrences not supported") - | None -> - let evty = set_holes evdref cty subst in - let instance = Filter.filter_list filter instance in - let evd = !evdref in - let (evd, ev) = new_evar_instance sign evd evty ~filter instance in - evdref := evd; - evsref := (fst (destEvar !evdref ev),evty)::!evsref; - ev in - set_holes evdref (apply_on_subterm env_rhs evdref set_var c rhs) subst - | [] -> rhs in + | _, _, [] -> [] + | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list.") + in + let fixed = ref Evar.Set.empty in + let rec set_holes env_rhs evd rhs = function + | (id,idty,c,cty,evsref,filter,occs)::subst -> + let c = nf_evar evd c in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"set holes for: " ++ + prc env_rhs evd (mkVar id) ++ spc () ++ + prc env_rhs evd c ++ str" in " ++ + prc env_rhs evd rhs); + let occ = ref 1 in + let set_var evd k inst = + let oc = !occ in + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"Found one occurrence"); + Feedback.msg_debug Pp.(str"cty: " ++ prc env_rhs evd c)); + incr occ; + match occs with + | AtOccurrences occs -> + if Locusops.is_selected oc occs then evd, mkVar id + else evd, inst + | Unspecified prefer_abstraction -> + let evd, evty = set_holes env_rhs evd cty subst in + let evty = nf_evar evd evty in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ + str" of type: " ++ prc env_evar evd evty ++ + str " for " ++ prc env_rhs evd c); + let instance = Filter.filter_list filter instance in + (* Allow any type lower than the variable's type as the + abstracted subterm might have a smaller type, which could be + crucial to make the surrounding context typecheck. *) + let evd, evty = + if isArity evd evty then + refresh_universes ~status:Evd.univ_flexible (Some true) + env_evar_unf evd evty + else evd, evty in + let (evd, ev) = new_evar_instance sign evd evty ~filter instance in + let evk = fst (destEvar evd ev) in + evsref := (evk,evty,inst,prefer_abstraction)::!evsref; + fixed := Evar.Set.add evk !fixed; + evd, ev + in + let evd, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracted: " ++ prc env_rhs evd rhs'); + let () = check_selected_occs env_rhs evd c !occ occs in + let env_rhs' = push_named (NamedDecl.LocalAssum (id,idty)) env_rhs in + set_holes env_rhs' evd rhs' subst + | [] -> evd, rhs in let subst = make_subst (ctxt,Array.to_list args,argoccs) in - let evd, rhs = - let evdref = ref evd in - let rhs = set_holes evdref rhs subst in - !evdref, rhs - in - + let evd, rhs' = set_holes env_rhs evd rhs subst in + let rhs' = nf_evar evd rhs' in + (* Thin evars making the term typable in env_evar *) + let evd, rhs' = thin_evars env_evar evd ctxt rhs' in (* We instantiate the evars of which the value is forced by typing *) - let evd,rhs = - try !solve_evars env_evar evd rhs + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"solve_evars on: " ++ prc env_evar evd rhs'); + Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + let evd,rhs' = + try !solve_evars env_evar evd rhs' with e when Pretype_errors.precatchable_exception e -> (* Could not revert all subterms *) raise (TypingFailed evd) in + let rhs' = nf_evar evd rhs' in + (* We instantiate the evars of which the value is forced by typing *) + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"after solve_evars: " ++ prc env_evar evd rhs'); + Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let rec abstract_free_holes evd = function - | (id,idty,c,_,evsref,_,_)::l -> - let rec force_instantiation evd = function - | (evk,evty)::evs -> - let evd = - if is_undefined evd evk then - (* We force abstraction over this unconstrained occurrence *) - (* and we use typing to propagate this instantiation *) - (* This is an arbitrary choice *) - let evd = Evd.define evk (mkVar id) evd in - match evar_conv_x ts env_evar evd CUMUL idty evty with - | UnifFailure _ -> user_err Pp.(str "Cannot find an instance") - | Success evd -> - match reconsider_unif_constraints (evar_conv_x ts) evd with - | UnifFailure _ -> user_err Pp.(str "Cannot find an instance") - | Success evd -> - evd - else - evd - in - force_instantiation evd evs - | [] -> - abstract_free_holes evd l - in - force_instantiation evd !evsref - | [] -> - let evd = - try Evarsolve.check_evar_instance evd evk rhs - (evar_conv_x TransparentState.full) - with IllTypedInstance _ -> raise (TypingFailed evd) - in - Evd.define evk rhs evd + | (id,idty,c,cty,evsref,_,_)::l -> + let c = nf_evar evd c in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracting: " ++ + prc env_rhs evd (mkVar id) ++ spc () ++ + prc env_rhs evd c); + let rec force_instantiation evd = function + | (evk,evty,inst,abstract)::evs -> + let evk = Option.default evk (Evarutil.advance evd evk) in + let evd = + if is_undefined evd evk then + (* We try abstraction or concretisation for *) + (* this unconstrained occurrence *) + (* and we use typing to propagate this instantiation *) + (* We avoid making an arbitrary choice by leaving candidates *) + (* if both can work *) + let evi = Evd.find_undefined evd evk in + let vid = mkVar id in + let candidates = [inst; vid] in + try + let evd, ev = Evarutil.restrict_evar evd evk (Evd.evar_filter evi) (Some candidates) in + let evi = Evd.find evd ev in + (match evar_candidates evi with + | Some [t] -> + if not (noccur_evar env_rhs evd ev (EConstr.of_constr t)) then + raise (TypingFailed evd); + instantiate_evar evar_unify flags evd ev (EConstr.of_constr t) + | Some l when abstract = Abstraction.Abstract && + List.exists (fun c -> isVarId evd id (EConstr.of_constr c)) l -> + instantiate_evar evar_unify flags evd ev vid + | _ -> evd) + with e -> user_err (Pp.str "Cannot find an instance") + else + ((if !debug_ho_unification then + let evi = Evd.find evd evk in + let env = Evd.evar_env evi in + Feedback.msg_debug Pp.(str"evar is defined: " ++ + int (Evar.repr evk) ++ spc () ++ + prc env evd (match evar_body evi with Evar_defined c -> c + | Evar_empty -> assert false))); + evd) + in force_instantiation evd evs + | [] -> abstract_free_holes evd l + in force_instantiation evd !evsref + | [] -> + if Evd.is_defined evd evk then + (* Can happen due to dependencies: instantiating evars in the arguments of evk might + instantiate evk itself. *) + (if !debug_ho_unification then + begin + let evi = Evd.find evd evk in + let evenv = evar_env evi in + let body = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c in + Feedback.msg_debug Pp.(str"evar was defined already as: " ++ prc evenv evd body) + end; + evd) + else + try + let evi = Evd.find_undefined evd evk in + let evenv = evar_env evi in + let rhs' = nf_evar evd rhs' in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracted type before second solve_evars: " ++ + prc evenv evd rhs'); + (* solve_evars is not commuting with nf_evar, because restricting + an evar might provide a more specific type. *) + let evd, _ = !solve_evars evenv evd rhs' in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs')); + let flags = default_flags_of TransparentState.full in + Evarsolve.instantiate_evar evar_unify flags evd evk rhs' + with IllTypedInstance _ -> raise (TypingFailed evd) in - abstract_free_holes evd subst, true + let evd = abstract_free_holes evd subst in + evd, true with TypingFailed evd -> evd, false -let second_order_matching_with_args ts env evd pbty ev l t = -(* - let evd,ev = evar_absorb_arguments env evd ev l in - let argoccs = Array.map_to_list (fun _ -> None) (snd ev) in - let evd, b = second_order_matching ts env evd ev argoccs t in - if b then Success evd - else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) - if b then Success evd else - *) - let pb = (pbty,env,mkApp(mkEvar ev,l),t) in - UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) - -let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = - let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in - let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in +let default_evar_selection flags evd (ev,args) = + let evi = Evd.find_undefined evd ev in + let rec aux args abs = + match args, abs with + | _ :: args, a :: abs -> + let spec = + if not flags.allow_K_at_toplevel then + (* [evar_absorb_arguments] puts an Abstract flag for the + toplevel binders that were absorbed. *) + let occs = + if a == Abstraction.Abstract then Locus.AtLeastOneOccurrence + else Locus.AllOccurrences + in AtOccurrences occs + else Unspecified a + in spec :: aux args abs + | l, [] -> List.map (fun _ -> default_occurrence_selection) l + | [], _ :: _ -> assert false + in aux (Array.to_list args) evi.evar_abstract_arguments + +let second_order_matching_with_args flags env evd with_ho pbty ev l t = + if with_ho then + let evd,ev = evar_absorb_arguments env evd ev (Array.to_list l) in + let argoccs = default_evar_selection flags evd ev in + let test = default_occurrence_test ~frozen_evars:flags.frozen_evars flags.subterm_ts in + let evd, b = + try second_order_matching flags env evd ev (test,argoccs) t + with PretypeError (_, _, NoOccurrenceFound _) -> evd, false + in + if b then Success evd + else + UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) + else + let pb = (pbty,env,mkApp(mkEvar ev,l),t) in + UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) + +let is_beyond_capabilities = function + | CannotSolveConstraint (pb,ProblemBeyondCapabilities) -> true + | _ -> false + +let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = + let t1 = apprec_nohdbeta flags env evd (whd_head_evar evd t1) in + let t2 = apprec_nohdbeta flags env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in let () = if !debug_unification then @@ -1234,7 +1563,8 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = Termops.Internal.print_constr_env env evd t2 ++ cut ())) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in match EConstr.kind evd term1, EConstr.kind evd term2 with - | Evar (evk1,args1), (Rel _|Var _) when app_empty + | Evar (evk1,args1 as ev1), (Rel _|Var _) when app_empty + && not (is_frozen flags ev1) && List.for_all (fun a -> EConstr.eq_constr evd a term2 || isEvar evd a) (remove_instance_local_defs evd evk1 args1) -> (* The typical kind of constraint coming from pattern-matching return @@ -1244,8 +1574,9 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = | None -> let reason = ProblemBeyondCapabilities in UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) - | (Rel _|Var _), Evar (evk2,args2) when app_empty - && List.for_all (fun a -> EConstr.eq_constr evd a term1 || isEvar evd a) + | (Rel _|Var _), Evar (evk2,args2 as ev2) when app_empty + && not (is_frozen flags ev2) + && List.for_all (fun a -> EConstr.eq_constr evd a term1 || isEvar evd a) (remove_instance_local_defs evd evk2 args2) -> (* The typical kind of constraint coming from pattern-matching return type inference *) @@ -1255,36 +1586,44 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let reason = ProblemBeyondCapabilities in UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> - let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in - Success (solve_refl ~can_drop:true f env evd + let f flags ontype env evd pbty x y = + let reds = + match ontype with + | TypeUnification -> TransparentState.full + | TermUnification -> flags.open_ts + in is_fconv ~reds pbty env evd x y + in + Success (solve_refl ~can_drop:true f flags env evd (position_problem true pbty) evk1 args1 args2) | Evar ev1, Evar ev2 when app_empty -> + (* solve_evar_evar handles the cases ev1 and/or ev2 are frozen *) Success (solve_evar_evar ~force:true - (evar_define (evar_conv_x ts) ~choose:true) (evar_conv_x ts) env evd - (position_problem true pbty) ev1 ev2) - | Evar ev1,_ when Array.length l1 <= Array.length l2 -> + (evar_define evar_unify flags ~choose:true) + evar_unify flags env evd + (position_problem true pbty) ev1 ev2) + | Evar ev1,_ when not (is_frozen flags ev1) && Array.length l1 <= Array.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) (* and otherwise second-order matching *) ise_try evd - [(fun evd -> first_order_unification ts env evd (ev1,l1) appr2); + [(fun evd -> first_order_unification flags env evd (ev1,l1) appr2); (fun evd -> - second_order_matching_with_args ts env evd pbty ev1 l1 t2)] - | _,Evar ev2 when Array.length l2 <= Array.length l1 -> + second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2)] + | _,Evar ev2 when not (is_frozen flags ev2) && Array.length l2 <= Array.length l1 -> (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *) (* and otherwise second-order matching *) ise_try evd - [(fun evd -> first_order_unification ts env evd (ev2,l2) appr1); + [(fun evd -> first_order_unification flags env evd (ev2,l2) appr1); (fun evd -> - second_order_matching_with_args ts env evd pbty ev2 l2 t1)] - | Evar ev1,_ -> + second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1)] + | Evar ev1,_ when not (is_frozen flags ev1) -> (* Try second-order pattern-matching *) - second_order_matching_with_args ts env evd pbty ev1 l1 t2 - | _,Evar ev2 -> + second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2 + | _,Evar ev2 when not (is_frozen flags ev2) -> (* Try second-order pattern-matching *) - second_order_matching_with_args ts env evd pbty ev2 l2 t1 + second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1 | _ -> (* Some head evar have been instantiated, or unknown kind of problem *) - evar_conv_x ts env evd pbty t1 t2 + evar_conv_x flags env evd pbty t1 t2 let error_cannot_unify env evd pb ?reason t1 t2 = Pretype_errors.error_cannot_unify @@ -1313,7 +1652,7 @@ let max_undefined_with_candidates evd = with MaxUndefined ans -> Some ans -let rec solve_unconstrained_evars_with_candidates ts evd = +let rec solve_unconstrained_evars_with_candidates flags evd = (* max_undefined is supposed to return the most recent, hence possibly most dependent evar *) match max_undefined_with_candidates evd with @@ -1324,11 +1663,9 @@ let rec solve_unconstrained_evars_with_candidates ts evd = | a::l -> (* In case of variables, most recent ones come first *) try - let conv_algo = evar_conv_x ts in - let evd = check_evar_instance evd evk a conv_algo in - let evd = Evd.define evk a evd in - match reconsider_unif_constraints conv_algo evd with - | Success evd -> solve_unconstrained_evars_with_candidates ts evd + let evd = instantiate_evar evar_unify flags evd evk a in + match reconsider_unif_constraints evar_unify flags evd with + | Success evd -> solve_unconstrained_evars_with_candidates flags evd | UnifFailure _ -> aux l with | IllTypedInstance _ -> aux l @@ -1336,7 +1673,7 @@ let rec solve_unconstrained_evars_with_candidates ts evd = (* Expected invariant: most dependent solutions come first *) (* so as to favor progress when used with the refine tactics *) let evd = aux l in - solve_unconstrained_evars_with_candidates ts evd + solve_unconstrained_evars_with_candidates flags evd let solve_unconstrained_impossible_cases env evd = Evd.fold_undefined (fun evk ev_info evd' -> @@ -1345,35 +1682,40 @@ let solve_unconstrained_impossible_cases env evd = let j, ctx = coq_unit_judge env in let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in let ty = j_type j in - let conv_algo = evar_conv_x TransparentState.full in - let evd' = check_evar_instance evd' evk ty conv_algo in - Evd.define evk ty evd' + let flags = default_flags env in + instantiate_evar evar_unify flags evd' evk ty | _ -> evd') evd evd let solve_unif_constraints_with_heuristics env - ?(ts=Conv_oracle.get_transp_state (Environ.oracle env)) evd = - let evd = solve_unconstrained_evars_with_candidates ts evd in + ?(flags=default_flags env) ?(with_ho=false) evd = + let evd = solve_unconstrained_evars_with_candidates flags evd in let rec aux evd pbs progress stuck = match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> - (match apply_conversion_problem_heuristic ts env evd pbty t1 t2 with + (match apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 with | Success evd' -> - let (evd', rest) = extract_all_conv_pbs evd' in - begin match rest with + let evd' = solve_unconstrained_evars_with_candidates flags evd' in + let (evd', rest) = extract_all_conv_pbs evd' in + begin match rest with | [] -> aux evd' pbs true stuck - | _ -> (* Unification got actually stuck, postpone *) - aux evd pbs progress (pb :: stuck) + | l -> + (* Unification got actually stuck, postpone *) + let reason = CannotSolveConstraint (pb,ProblemBeyondCapabilities) in + aux evd pbs progress ((pb, reason):: stuck) end | UnifFailure (evd,reason) -> - error_cannot_unify env evd pb ~reason t1 t2) + if is_beyond_capabilities reason then + aux evd pbs progress ((pb,reason) :: stuck) + else aux evd [] false ((pb,reason) :: stuck)) | _ -> - if progress then aux evd stuck false [] + if progress then aux evd (List.map fst stuck) false [] else match stuck with | [] -> (* We're finished *) evd - | (pbty,env,t1,t2 as pb) :: _ -> - (* There remains stuck problems *) - error_cannot_unify env evd pb t1 t2 + | ((pbty,env,t1,t2 as pb), reason) :: _ -> + (* There remains stuck problems *) + Pretype_errors.error_cannot_unify ?loc:(loc_of_conv_pb evd pb) + env evd ~reason (t1, t2) in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in @@ -1384,16 +1726,49 @@ let solve_unif_constraints_with_heuristics env exception UnableToUnify of evar_map * unification_error -let default_transparent_state env = TransparentState.full -(* Conv_oracle.get_transp_state (Environ.oracle env) *) +let unify_delay ?flags env evd t1 t2 = + let flags = + match flags with + | None -> default_flags_of (default_transparent_state env) + | Some flags -> flags + in + match evar_conv_x flags env evd CONV t1 t2 with + | Success evd' -> evd' + | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) +let unify_leq_delay ?flags env evd t1 t2 = + let flags = + match flags with + | None -> default_flags_of (default_transparent_state env) + | Some flags -> flags + in + match evar_conv_x flags env evd CUMUL t1 t2 with + | Success evd' -> evd' + | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) + +let unify ?flags ?(with_ho=true) env evd cv_pb ty1 ty2 = + let flags = + match flags with + | None -> default_flags_of (default_transparent_state env) + | Some flags -> flags + in + let res = evar_conv_x flags env evd cv_pb ty1 ty2 in + match res with + | Success evd -> + solve_unif_constraints_with_heuristics ~flags ~with_ho env evd + | UnifFailure (evd, reason) -> + raise (PretypeError (env, evd, CannotUnify (ty1, ty2, Some reason))) + +(* deprecated *) let the_conv_x env ?(ts=default_transparent_state env) t1 t2 evd = - match evar_conv_x ts env evd CONV t1 t2 with + let flags = default_flags_of ts in + match evar_conv_x flags env evd CONV t1 t2 with | Success evd' -> evd' | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) let the_conv_x_leq env ?(ts=default_transparent_state env) t1 t2 evd = - match evar_conv_x ts env evd CUMUL t1 t2 with + let flags = default_flags_of ts in + match evar_conv_x flags env evd CUMUL t1 t2 with | Success evd' -> evd' | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) @@ -1402,7 +1777,9 @@ let make_opt = function | UnifFailure _ -> None let conv env ?(ts=default_transparent_state env) evd t1 t2 = - make_opt(evar_conv_x ts env evd CONV t1 t2) + let flags = default_flags_of ts in + make_opt(evar_conv_x flags env evd CONV t1 t2) let cumul env ?(ts=default_transparent_state env) evd t1 t2 = - make_opt(evar_conv_x ts env evd CUMUL t1 t2) + let flags = default_flags_of ts in + make_opt(evar_conv_x flags env evd CUMUL t1 t2) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 4585fac252..0fe47c2a48 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -16,28 +16,74 @@ open Locus (** {4 Unification for type inference. } *) +type unify_flags = Evarsolve.unify_flags + +(** The default subterm transparent state is no unfoldings *) +val default_flags_of : ?subterm_ts:TransparentState.t -> TransparentState.t -> unify_flags + +type unify_fun = unify_flags -> + env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result + +val conv_fun : unify_fun -> Evarsolve.unifier + exception UnableToUnify of evar_map * Pretype_errors.unification_error (** {6 Main unification algorithm for type inference. } *) -(** returns exception NotUnifiable with best known evar_map if not unifiable *) +(** There are two variants for unification: one that delays constraints outside its capabilities + ([unify_delay]) and another that tries to solve such remaining constraints using + heuristics ([unify]). *) + +(** Theses functions allow to pass arbitrary flags to the unifier and can delay constraints. + In case the flags are not specified, they default to + [default_flags_of TransparentState.full] currently. + + In case of success, the two terms are hence unifiable only if the remaining constraints + can be solved or [check_problems_are_solved] is true. + + @raises UnableToUnify in case the two terms do not unify *) + +val unify_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map +val unify_leq_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map + +(** returns exception UnableToUnify with best known evar_map if not unifiable *) val the_conv_x : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map +[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] val the_conv_x_leq : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map - +[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] (** The same function resolving evars by side-effect and catching the exception *) + val conv : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option +[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] val cumul : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option +[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] + +(** This function also calls [solve_unif_constraints_with_heuristics] to resolve any remaining + constraints. In case of success the two terms are unified without condition. + + The with_ho option tells if higher-order unification should be tried to resolve the + constraints. + + @raises a PretypeError if it cannot unify *) +val unify : ?flags:unify_flags -> ?with_ho:bool -> + env -> evar_map -> conv_pb -> constr -> constr -> evar_map (** {6 Unification heuristics. } *) (** Try heuristics to solve pending unification problems and to solve - evars with candidates *) + evars with candidates. + + The with_ho option tells if higher-order unification should be tried + to resolve the constraints. -val solve_unif_constraints_with_heuristics : env -> ?ts:TransparentState.t -> evar_map -> evar_map + @raises a PretypeError if it fails to resolve some problem *) -(** Check all pending unification problems are solved and raise an - error otherwise *) +val solve_unif_constraints_with_heuristics : + env -> ?flags:unify_flags -> ?with_ho:bool -> evar_map -> evar_map + +(** Check all pending unification problems are solved and raise a + PretypeError otherwise *) val check_problems_are_solved : env -> evar_map -> unit @@ -54,28 +100,55 @@ val check_conv_record : env -> evar_map -> (** Try to solve problems of the form ?x[args] = c by second-order matching, using typing to select occurrences *) -val second_order_matching : TransparentState.t -> env -> evar_map -> - EConstr.existential -> occurrences option list -> constr -> evar_map * bool +type occurrence_match_test = + env -> evar_map -> constr -> (* Used to precompute the local tests *) + env -> evar_map -> int -> constr -> constr -> bool * evar_map + +(** When given the choice of abstracting an occurrence or leaving it, + force abstration. *) + +type occurrence_selection = + | AtOccurrences of occurrences + | Unspecified of Abstraction.abstraction + +(** By default, unspecified, not preferring abstraction. + This provides the most general solutions. *) +val default_occurrence_selection : occurrence_selection + +type occurrences_selection = + occurrence_match_test * occurrence_selection list + +val default_occurrence_test : frozen_evars:Evar.Set.t -> TransparentState.t -> occurrence_match_test + +(** [default_occurrence_selection n] + Gives the default test and occurrences for [n] arguments *) +val default_occurrences_selection : ?frozen_evars:Evar.Set.t (* By default, none *) -> + TransparentState.t -> int -> occurrences_selection + +val second_order_matching : unify_flags -> env -> evar_map -> + EConstr.existential -> occurrences_selection -> constr -> evar_map * bool (** Declare function to enforce evars resolution by using typing constraints *) val set_solve_evars : (env -> evar_map -> constr -> evar_map * constr) -> unit -type unify_fun = TransparentState.t -> - env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result - (** Override default [evar_conv_x] algorithm. *) val set_evar_conv : unify_fun -> unit (** The default unification algorithm with evars and universes. *) val evar_conv_x : unify_fun +val evar_unify : Evarsolve.unifier + (**/**) (* For debugging *) -val evar_eqappr_x : ?rhs_is_already_stuck:bool -> TransparentState.t * bool -> +val evar_eqappr_x : ?rhs_is_already_stuck:bool -> unify_flags -> env -> evar_map -> conv_pb -> state * Cst_stack.t -> state * Cst_stack.t -> Evarsolve.unification_result + +val occur_rigidly : Evarsolve.unify_flags -> + 'a -> Evd.evar_map -> Evar.t * 'b -> EConstr.t -> bool (**/**) (** {6 Functions to deal with impossible cases } *) diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 571be7466c..a62427834d 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -139,7 +139,8 @@ let define_pure_evar_as_lambda env evd evk = let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = subterm_source evk ~where:Body (evar_source evk evd1) in - let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in + let abstract_arguments = Abstraction.abstract_last evi.evar_abstract_arguments in + let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter ~abstract_arguments in let lam = mkLambda (Name id, dom, subst_var id body) in Evd.define evk lam evd2, lam diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4c4a236620..e5f2207333 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -24,6 +24,49 @@ open Reductionops open Evarutil open Pretype_errors +type unify_flags = { + modulo_betaiota: bool; + open_ts : TransparentState.t; + closed_ts : TransparentState.t; + subterm_ts : TransparentState.t; + frozen_evars : Evar.Set.t; + allow_K_at_toplevel : bool; + with_cs : bool } + +type unification_kind = + | TypeUnification + | TermUnification + +(************************) +(* Unification results *) +(************************) + +type unification_result = + | Success of evar_map + | UnifFailure of evar_map * unification_error + +let is_success = function Success _ -> true | UnifFailure _ -> false + +let test_success unify flags b env evd c c' rhs = + is_success (unify flags b env evd c c' rhs) + +(** A unification function parameterized by: + - unification flags + - the kind of unification + - environment + - sigma + - conversion problem + - the two terms to unify. *) + +type unifier = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> unification_result + +(** A conversion function: parameterized by the kind of unification, + environment, sigma, conversion problem and the two terms to convert. + Conversion is not allowed to instantiate evars contrary to unification. *) +type conversion_check = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> bool + let normalize_evar evd ev = match EConstr.kind evd (mkEvar ev) with | Evar (evk,args) -> (evk,args) @@ -129,20 +172,6 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c = let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in refresh_universes (Some false) env sigma ty - - -(************************) -(* Unification results *) -(************************) - -type unification_result = - | Success of evar_map - | UnifFailure of evar_map * unification_error - -let is_success = function Success _ -> true | UnifFailure _ -> false - -let test_success conv_algo env evd c c' rhs = - is_success (conv_algo env evd c c' rhs) let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = match pbty with @@ -154,7 +183,7 @@ let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = exception IllTypedInstance of env * EConstr.types * EConstr.types -let recheck_applications conv_algo env evdref t = +let recheck_applications unify flags env evdref t = let rec aux env t = match EConstr.kind !evdref t with | App (f, args) -> @@ -165,7 +194,7 @@ let recheck_applications conv_algo env evdref t = if i < Array.length argsty then match EConstr.kind !evdref (whd_all env !evdref ty) with | Prod (na, dom, codom) -> - (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with + (match unify flags TypeUnification env !evdref Reduction.CUMUL argsty.(i) dom with | Success evd -> evdref := evd; aux (succ i) (subst1 args.(i) codom) | UnifFailure (evd, reason) -> @@ -734,6 +763,19 @@ let restrict_upon_filter evd evk p args = let len = Array.length args in Filter.restrict_upon oldfullfilter len (fun i -> p (Array.unsafe_get args i)) +let check_evar_instance unify flags evd evk1 body = + let evi = Evd.find evd evk1 in + let evenv = evar_env evi in + (* FIXME: The body might be ill-typed when this is called from w_merge *) + (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) + let ty = + try Retyping.get_type_of ~lax:true evenv evd body + with Retyping.RetypeError _ -> user_err (Pp.(str "Ill-typed evar instance")) + in + match unify flags TypeUnification evenv evd Reduction.CUMUL ty evi.evar_concl with + | Success evd -> evd + | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) + (***************) (* Unification *) @@ -869,12 +911,13 @@ let rec find_solution_type evarenv = function * pass [define] to [do_projection_effects] as a parameter. *) -let rec do_projection_effects define_fun env ty evd = function +let rec do_projection_effects unify flags define_fun env ty evd = function | ProjectVar -> evd | ProjectEvar ((evk,argsv),evi,id,p) -> - let evd = Evd.define evk (mkVar id) evd in + let evd = check_evar_instance unify flags evd evk (mkVar id) in + let evd = Evd.define evk (EConstr.mkVar id) evd in (* TODO: simplify constraints involving evk *) - let evd = do_projection_effects define_fun env ty evd p in + let evd = do_projection_effects unify flags define_fun env ty evd p in let ty = whd_all env evd (Lazy.force ty) in if not (isSort evd ty) then (* Don't try to instantiate if a sort because if evar_concl is an @@ -1110,9 +1153,9 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = * Note: argument f is the function used to instantiate evars. *) -let filter_compatible_candidates conv_algo env evd evi args rhs c = +let filter_compatible_candidates unify flags env evd evi args rhs c = let c' = instantiate_evar_array evi c args in - match conv_algo env evd Reduction.CONV rhs c' with + match unify flags TermUnification env evd Reduction.CONV rhs c' with | Success evd -> Some (c,evd) | UnifFailure _ -> None @@ -1122,7 +1165,7 @@ let filter_compatible_candidates conv_algo env evd evi args rhs c = exception DoesNotPreserveCandidateRestriction -let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = +let restrict_candidates unify flags env evd filter1 (evk1,argsv1) (evk2,argsv2) = let evi1 = Evd.find evd evk1 in let evi2 = Evd.find evd evk2 in match evi1.evar_candidates, evi2.evar_candidates with @@ -1133,7 +1176,7 @@ let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = let l1' = List.filter (fun c1 -> let c1' = instantiate_evar_array evi1 c1 argsv1 in let filter c2 = - let compatibility = filter_compatible_candidates conv_algo env evd evi2 argsv2 c1' c2 in + let compatibility = filter_compatible_candidates unify flags env evd evi2 argsv2 c1' c2 in match compatibility with | None -> false | Some _ -> true @@ -1200,14 +1243,14 @@ exception EvarSolvedOnTheFly of evar_map * EConstr.constr (* Try to project evk1[argsv1] on evk2[argsv2], if [ev1] is a pattern on the common domain of definition *) -let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = +let project_evar_on_evar force unify flags env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *) let fvs2 = free_vars_and_rels_up_alias_expansion env evd aliases (mkEvar ev2) in let filter1 = restrict_upon_filter evd evk1 (has_constrainable_free_vars env evd aliases force k2 evk2 fvs2) argsv1 in let candidates1 = - try restrict_candidates g env evd filter1 ev1 ev2 + try restrict_candidates unify flags env evd filter1 ev1 ev2 with DoesNotPreserveCandidateRestriction -> let evd,ev1' = do_restrict_hyps evd ev1 filter1 NoUpdate in raise (CannotProject (evd,ev1')) in @@ -1225,35 +1268,22 @@ let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (e else raise (CannotProject (evd,ev1')) -let check_evar_instance evd evk1 body conv_algo = - let evi = Evd.find evd evk1 in - let evenv = evar_env evi in - (* FIXME: The body might be ill-typed when this is called from w_merge *) - (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) - let ty = - try Retyping.get_type_of ~lax:true evenv evd body - with Retyping.RetypeError _ -> user_err Pp.(str "Ill-typed evar instance") - in - match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with - | Success evd -> evd - | UnifFailure _ -> raise (IllTypedInstance (evenv,ty, evi.evar_concl)) - let update_evar_info ev1 ev2 evd = (* We update the source of obligation evars during evar-evar unifications. *) let loc, evs1 = evar_source ev1 evd in let evi = Evd.find evd ev2 in Evd.add evd ev2 {evi with evar_source = loc, evs1} -let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) = +let solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 (evk2,_ as ev2) = try - let evd,body = project_evar_on_evar force g env evd aliases 0 pbty ev1 ev2 in + let evd,body = project_evar_on_evar force unify flags env evd aliases 0 pbty ev1 ev2 in let evd' = Evd.define_with_evar evk2 body evd in let evd' = if is_obligation_evar evd evk2 then update_evar_info evk2 (fst (destEvar evd' body)) evd' else evd' in - check_evar_instance evd' evk2 body g + check_evar_instance unify flags evd' evk2 body with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1264,22 +1294,33 @@ let preferred_orientation evd evk1 evk2 = else if is_obligation_evar evd evk2 then false else true -let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = +let solve_evar_evar_aux force f unify flags env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = let aliases = make_alias_map env evd in + let frozen_ev1 = Evar.Set.mem evk1 flags.frozen_evars in + let frozen_ev2 = Evar.Set.mem evk2 flags.frozen_evars in if preferred_orientation evd evk1 evk2 then - try solve_evar_evar_l2r force f g env evd aliases (opp_problem pbty) ev2 ev1 + try if not frozen_ev1 then + solve_evar_evar_l2r force f unify flags env evd aliases (opp_problem pbty) ev2 ev1 + else raise (CannotProject (evd,ev2)) with CannotProject (evd,ev2) -> - try solve_evar_evar_l2r force f g env evd aliases pbty ev1 ev2 - with CannotProject (evd,ev1) -> - add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd + try if not frozen_ev2 then + solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 ev2 + else raise (CannotProject (evd,ev1)) + with CannotProject (evd,ev1) -> + add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd else - try solve_evar_evar_l2r force f g env evd aliases pbty ev1 ev2 + try if not frozen_ev2 then + solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 ev2 + else raise (CannotProject (evd,ev1)) with CannotProject (evd,ev1) -> - try solve_evar_evar_l2r force f g env evd aliases (opp_problem pbty) ev2 ev1 + try if not frozen_ev1 then + solve_evar_evar_l2r force f unify flags env evd aliases (opp_problem pbty) ev2 ev1 + else raise (CannotProject (evd,ev2)) with CannotProject (evd,ev2) -> - add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd + add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd -let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = +(** Precondition: evk1 is not frozen *) +let solve_evar_evar ?(force=false) f unify flags env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = let pbty = if force then None else pbty in let evi = Evd.find evd evk1 in let downcast evk t evd = downcast evk t evd in @@ -1314,25 +1355,19 @@ let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,ar downcast evk2 t2 (downcast evk1 t1 evd) with Reduction.NotArity -> evd in - solve_evar_evar_aux force f g env evd pbty ev1 ev2 - -type conv_fun = - env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> unification_result - -type conv_fun_bool = - env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> bool + solve_evar_evar_aux force f unify flags env evd pbty ev1 ev2 (* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint * definitions. We try to unify the ti with the ui pairwise. The pairs * that don't unify are discarded (i.e. ?e is redefined so that it does not * depend on these args). *) -let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 = +let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = let evdref = ref evd in let eq_constr c1 c2 = match EConstr.eq_constr_universes env !evdref c1 c2 with | None -> false | Some cstr -> - try ignore (Evd.add_universe_constraints !evdref cstr); true + try evdref := Evd.add_universe_constraints !evdref cstr; true with UniversesDiffer -> false in if Array.equal eq_constr argsv1 argsv2 then !evdref else @@ -1340,19 +1375,26 @@ let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 = let args = Array.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in let untypedfilter = restrict_upon_filter evd evk - (fun (a1,a2) -> conv_algo env evd Reduction.CONV a1 a2) args in + (fun (a1,a2) -> unify flags TermUnification env evd Reduction.CONV a1 a2) args in let candidates = filter_candidates evd evk untypedfilter NoUpdate in let filter = closure_of_filter evd evk untypedfilter in - let evd,ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in - if Evar.equal (fst ev1) evk && can_drop then (* No refinement *) evd else + let evd',ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in + let frozen = Evar.Set.mem evk flags.frozen_evars in + if Evar.equal (fst ev1) evk && (frozen || can_drop) then + (* No refinement needed *) evd' + else (* either progress, or not allowed to drop, e.g. to preserve possibly *) (* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *) (* if e can depend on x until ?y is not resolved, or, conversely, we *) (* don't know if ?y has to be unified with ?y, until e is resolved *) - let argsv2 = restrict_instance evd evk filter argsv2 in - let ev2 = (fst ev1,argsv2) in - (* Leave a unification problem *) - add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd + if frozen then + (* We cannot prune a frozen evar *) + add_conv_oriented_pb (pbty,env,mkEvar (evk, argsv1),mkEvar (evk,argsv2)) evd + else + let argsv2 = restrict_instance evd' evk filter argsv2 in + let ev2 = (fst ev1,argsv2) in + (* Leave a unification problem *) + add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd' (* If the evar can be instantiated by a finite set of candidates known in advance, we check which of them apply *) @@ -1360,14 +1402,14 @@ let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 = exception NoCandidates exception IncompatibleCandidates -let solve_candidates conv_algo env evd (evk,argsv) rhs = +let solve_candidates unify flags env evd (evk,argsv) rhs = let evi = Evd.find evd evk in match evi.evar_candidates with | None -> raise NoCandidates | Some l -> let l' = List.map_filter - (fun c -> filter_compatible_candidates conv_algo env evd evi argsv rhs c) l in + (fun c -> filter_compatible_candidates unify flags env evd evi argsv rhs c) l in match l' with | [] -> raise IncompatibleCandidates | [c,evd] -> @@ -1375,7 +1417,7 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then let evd' = Evd.define evk c evd in - check_evar_instance evd' evk c conv_algo + check_evar_instance unify flags evd' evk c else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in @@ -1399,6 +1441,13 @@ let occur_evar_upto_types sigma n c = in try occur_rec c; false with Occur -> true +let instantiate_evar unify flags evd evk body = + (* Check instance freezing the evar to be defined, as + checking could involve the same evar definition problem again otherwise *) + let flags = { flags with frozen_evars = Evar.Set.add evk flags.frozen_evars } in + let evd' = check_evar_instance unify flags evd evk body in + Evd.define evk body evd' + (* We try to instantiate the evar assuming the body won't depend * on arguments that are not Rels or Vars, or appearing several times * (i.e. we tackle a generalization of Miller-Pfenning patterns unification) @@ -1428,7 +1477,8 @@ exception NotEnoughInformationEvarEvar of EConstr.constr exception OccurCheckIn of evar_map * EConstr.constr exception MetaOccurInBodyInternal -let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = +let rec invert_definition unify flags choose imitate_defs + env evd pbty (evk,argsv as ev) rhs = let aliases = make_alias_map env evd in let evdref = ref evd in let progress = ref false in @@ -1447,7 +1497,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = if choose then (mkVar id, p) else raise (NotUniqueInType sols) in let ty = lazy (Retyping.get_type_of env !evdref (of_alias t)) in - let evd = do_projection_effects (evar_define conv_algo ~choose) env ty !evdref p in + let evd = do_projection_effects unify flags (evar_define unify flags ~choose) env ty !evdref p in evdref := evd; c with @@ -1460,7 +1510,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let ty = find_solution_type (evar_filtered_env evi) sols in let ty' = instantiate_evar_array evi ty argsv in let (evd,evar,(evk',argsv' as ev')) = - materialize_evar (evar_define conv_algo ~choose) env !evdref 0 ev ty' in + materialize_evar (evar_define unify flags ~choose) env !evdref 0 ev ty' in let ts = expansions_of_var evd aliases t in let test c = isEvar evd c || List.exists (is_alias evd c) ts in let filter = restrict_upon_filter evd evk test argsv' in @@ -1484,13 +1534,15 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | LocalAssum _ -> project_variable (RelAlias (i-k)) | LocalDef (_,b,_) -> try project_variable (RelAlias (i-k)) - with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i (EConstr.of_constr b))) + with NotInvertibleUsingOurAlgorithm _ when imitate_defs -> + imitate envk (lift i (EConstr.of_constr b))) | Var id -> (match Environ.lookup_named id env' with | LocalAssum _ -> project_variable (VarAlias id) | LocalDef (_,b,_) -> try project_variable (VarAlias id) - with NotInvertibleUsingOurAlgorithm _ -> imitate envk (EConstr.of_constr b)) + with NotInvertibleUsingOurAlgorithm _ when imitate_defs -> + imitate envk (EConstr.of_constr b)) | LetIn (na,b,u,c) -> imitate envk (subst1 b c) | Evar (evk',args' as ev') -> @@ -1499,7 +1551,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let aliases = lift_aliases k aliases in (try let ev = (evk,Array.map (lift k) argsv) in - let evd,body = project_evar_on_evar false conv_algo env' !evdref aliases k None ev' ev in + let evd,body = project_evar_on_evar false unify flags env' !evdref aliases k None ev' ev in evdref := evd; body with @@ -1510,15 +1562,15 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* Make the virtual left evar real *) let ty = get_type_of env' evd t in let (evd,evar'',ev'') = - materialize_evar (evar_define conv_algo ~choose) env' evd k ev ty in + materialize_evar (evar_define unify flags ~choose) env' evd k ev ty in (* materialize_evar may instantiate ev' by another evar; adjust it *) let (evk',args' as ev') = normalize_evar evd ev' in let evd = (* Try to project (a restriction of) the left evar ... *) try - let evd,body = project_evar_on_evar false conv_algo env' evd aliases 0 None ev'' ev' in + let evd,body = project_evar_on_evar false unify flags env' evd aliases 0 None ev'' ev' in let evd = Evd.define evk' body evd in - check_evar_instance evd evk' body conv_algo + check_evar_instance unify flags evd evk' body with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) | CannotProject (evd,ev'') -> @@ -1555,7 +1607,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | [x] -> x | _ -> let (evd,evar'',ev'') = - materialize_evar (evar_define conv_algo ~choose) env' !evdref k ev ty in + materialize_evar (evar_define unify flags ~choose) env' !evdref k ev ty in evdref := restrict_evar evd (fst ev'') None (UpdateWith candidates); evar'') | None -> @@ -1585,7 +1637,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = else let t' = imitate (env,0) rhs in if !progress then - (recheck_applications conv_algo (evar_env evi) evdref t'; t') + (recheck_applications unify flags (evar_env evi) evdref t'; t') else t' in (!evdref,body) @@ -1594,46 +1646,30 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = * [define] tries to find an instance lhs such that * "lhs [hyps:=args]" unifies to rhs. The term "lhs" must be closed in * context "hyps" and not referring to itself. + * ev is assumed not to be frozen. *) -and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = +and evar_define unify flags ?(choose=false) ?(imitate_defs=true) env evd pbty (evk,argsv as ev) rhs = match EConstr.kind evd rhs with | Evar (evk2,argsv2 as ev2) -> if Evar.equal evk evk2 then solve_refl ~can_drop:choose - (test_success conv_algo) env evd pbty evk argsv argsv2 + (test_success unify) flags env evd pbty evk argsv argsv2 else solve_evar_evar ~force:choose - (evar_define conv_algo) conv_algo env evd pbty ev ev2 + (evar_define unify flags) unify flags env evd pbty ev ev2 | _ -> - try solve_candidates conv_algo env evd ev rhs + try solve_candidates unify flags env evd ev rhs with NoCandidates -> try - let (evd',body) = invert_definition conv_algo choose env evd pbty ev rhs in + let (evd',body) = invert_definition unify flags choose imitate_defs env evd pbty ev rhs in if occur_meta evd' body then raise MetaOccurInBodyInternal; (* invert_definition may have instantiate some evars of rhs with evk *) (* so we recheck acyclicity *) if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) let evd', body = refresh_universes pbty env evd' body in -(* Cannot strictly type instantiations since the unification algorithm - * does not unify applications from left to right. - * e.g problem f x == g y yields x==y and f==g (in that order) - * Another problem is that type variables are evars of type Type - let _ = - try - let env = evar_filtered_env evi in - let ty = evi.evar_concl in - Typing.check env evd' body ty - with e -> - msg_info - (str "Ill-typed evar instantiation: " ++ fnl() ++ - pr_evar_map evd' ++ fnl() ++ - str "----> " ++ int ev ++ str " := " ++ - print_constr body); - raise e in*) - let evd' = check_evar_instance evd' evk body conv_algo in - Evd.define evk body evd' + instantiate_evar unify flags evd' evk body with | NotEnoughInformationToProgress sols -> postpone_non_unique_projection env evd pbty ev sols rhs @@ -1648,8 +1684,8 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = let c = whd_all env evd rhs in match EConstr.kind evd c with | Evar (evk',argsv2) when Evar.equal evk evk' -> - solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma c c') - env evd pbty evk argsv argsv2 + solve_refl (fun flags _b env sigma pb c c' -> is_fconv pb env sigma c c') flags + env evd pbty evk argsv argsv2 | _ -> raise (OccurCheckIn (evd,rhs)) @@ -1683,13 +1719,13 @@ let status_changed evd lev (pbty,_,t1,t2) = (try Evar.Set.mem (head_evar evd t1) lev with NoHeadEvar -> false) || (try Evar.Set.mem (head_evar evd t2) lev with NoHeadEvar -> false) -let reconsider_unif_constraints conv_algo evd = +let reconsider_unif_constraints unify flags evd = let (evd,pbs) = extract_changed_conv_pbs evd (status_changed evd) in List.fold_left (fun p (pbty,env,t1,t2 as x) -> match p with | Success evd -> - (match conv_algo env evd pbty t1 t2 with + (match unify flags TermUnification env evd pbty t1 t2 with | Success _ as x -> x | UnifFailure (i,e) -> UnifFailure (i,CannotSolveConstraint (x,e))) | UnifFailure _ as x -> x) @@ -1702,11 +1738,12 @@ let reconsider_unif_constraints conv_algo evd = * if the problem couldn't be solved. *) (* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *) -let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = +let solve_simple_eqn unify flags ?(choose=false) ?(imitate_defs=true) + env evd (pbty,(evk1,args1 as ev1),t2) = try let t2 = whd_betaiota evd t2 in (* includes whd_evar *) - let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in - reconsider_unif_constraints conv_algo evd + let evd = evar_define unify flags ~choose ~imitate_defs env evd pbty ev1 t2 in + reconsider_unif_constraints unify flags evd with | NotInvertibleUsingOurAlgorithm t -> UnifFailure (evd,NotClean (ev1,env,t)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 4665ed29a2..ebf8230bbd 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -16,6 +16,25 @@ type alias val of_alias : alias -> EConstr.t +type unify_flags = { + modulo_betaiota : bool; + (* Enable beta-iota reductions during unification *) + open_ts : TransparentState.t; + (* Enable delta reduction according to open_ts for open terms *) + closed_ts : TransparentState.t; + (* Enable delta reduction according to closed_ts for closed terms (when calling conversion) *) + subterm_ts : TransparentState.t; + (* Enable delta reduction according to subterm_ts for selection of subterms during higher-order + unifications. *) + frozen_evars : Evar.Set.t; + (* Frozen evars are treated like rigid variables during unification: they can not be instantiated. *) + allow_K_at_toplevel : bool; + (* During higher-order unifications, allow to produce K-redexes: i.e. to produce + an abstraction for an unused argument *) + with_cs : bool + (* Enable canonical structure resolution during unification *) +} + type unification_result = | Success of evar_map | UnifFailure of evar_map * Pretype_errors.unification_error @@ -26,19 +45,49 @@ val is_success : unification_result -> bool their representative that is most ancient in the context *) val expand_vars_in_term : env -> evar_map -> constr -> constr +(** One might want to use different conversion strategies for types and terms: + e.g. preventing delta reductions when doing term unifications but allowing + arbitrary delta conversion when checking the types of evar instances. *) + +type unification_kind = + | TypeUnification + | TermUnification + +(** A unification function parameterized by: + - unification flags + - the kind of unification + - environment + - sigma + - conversion problem + - the two terms to unify. *) +type unifier = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> unification_result + +(** A conversion function: parameterized by the kind of unification, + environment, sigma, conversion problem and the two terms to convert. + Conversion is not allowed to instantiate evars contrary to unification. *) +type conversion_check = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> bool + +(** [instantiate_evar unify flags env sigma ev c] defines the evar [ev] with [c], + checking that the type of [c] is unifiable with [ev]'s declared type first. + + Preconditions: + - [ev] does not occur in [c]. + - [c] does not contain any Meta(_) + *) + +val instantiate_evar : unifier -> unify_flags -> evar_map -> + Evar.t -> constr -> evar_map + (** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]), possibly solving related unification problems, possibly leaving open some problems that cannot be solved in a unique way (except if choose is true); fails if the instance is not valid for the given [ev] *) -type conv_fun = - env -> evar_map -> conv_pb -> constr -> constr -> unification_result - -type conv_fun_bool = - env -> evar_map -> conv_pb -> constr -> constr -> bool +val evar_define : unifier -> unify_flags -> ?choose:bool -> ?imitate_defs:bool -> + env -> evar_map -> bool option -> existential -> constr -> evar_map -val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> - bool option -> existential -> constr -> evar_map val refresh_universes : ?status:Evd.rigid -> @@ -49,18 +98,18 @@ val refresh_universes : bool option (* direction: true for levels lower than the existing levels *) -> env -> evar_map -> types -> evar_map * types -val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map -> +val solve_refl : ?can_drop:bool -> conversion_check -> unify_flags -> env -> evar_map -> bool option -> Evar.t -> constr array -> constr array -> evar_map val solve_evar_evar : ?force:bool -> (env -> evar_map -> bool option -> existential -> constr -> evar_map) -> - conv_fun -> + unifier -> unify_flags -> env -> evar_map -> bool option -> existential -> existential -> evar_map -val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> +val solve_simple_eqn : unifier -> unify_flags -> ?choose:bool -> ?imitate_defs:bool -> env -> evar_map -> bool option * existential * constr -> unification_result -val reconsider_unif_constraints : conv_fun -> evar_map -> unification_result +val reconsider_unif_constraints : unifier -> unify_flags -> evar_map -> unification_result val is_unification_pattern_evar : env -> evar_map -> existential -> constr list -> constr -> alias list option @@ -75,8 +124,8 @@ val noccur_evar : env -> evar_map -> Evar.t -> constr -> bool exception IllTypedInstance of env * types * types (* May raise IllTypedInstance if types are not convertible *) -val check_evar_instance : - evar_map -> Evar.t -> constr -> conv_fun -> evar_map +val check_evar_instance : unifier -> unify_flags -> + evar_map -> Evar.t -> constr -> evar_map val remove_instance_local_defs : evar_map -> Evar.t -> 'a array -> 'a list diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index b16087031b..d150f8e1cb 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -125,7 +125,7 @@ let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = end; add_subst t subst; incr pos; (* Check nested matching subterms *) - if occs != Locus.AllOccurrences && occs != Locus.NoOccurrences then + if not (Locusops.is_all_occurrences occs) && occs != Locus.NoOccurrences then begin nested := true; ignore (subst_below k t); nested := false end; (* Do the effective substitution *) Vars.lift k (bywhat ())) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 68626597fc..affed5389f 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -514,12 +514,11 @@ let rec cases_pattern_of_glob_constr na c = ) c open Declarations -open Term open Context (* Keep only patterns which are not bound to a local definitions *) -let drop_local_defs typi args = - let (decls,_) = decompose_prod_assum typi in +let drop_local_defs params decls args = + let decls = List.skipn (Rel.length params) (List.rev decls) in let rec aux decls args = match decls, args with | [], [] -> [] @@ -531,7 +530,7 @@ let drop_local_defs typi args = end | Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args | _ -> assert false in - aux (List.rev decls) args + aux decls args let add_patterns_for_params_remove_local_defs (ind,j) l = let (mib,mip) = Global.lookup_inductive ind in @@ -540,9 +539,8 @@ let add_patterns_for_params_remove_local_defs (ind,j) l = if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then (* Optimisation *) l else - let typi = mip.mind_nf_lc.(j-1) in - let (_,typi) = decompose_prod_n_assum (Rel.length mib.mind_params_ctxt) typi in - drop_local_defs typi l in + let (ctx, _) = mip.mind_nf_lc.(j - 1) in + drop_local_defs mib.mind_params_ctxt ctx l in Util.List.addn nparams (DAst.make @@ PatVar Anonymous) l let add_alias ?loc na c = diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 4c02dc0f09..d937456bcb 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -101,7 +101,8 @@ let mis_nf_constructor_type ((ind,u),mib,mip) j = and nconstr = Array.length mip.mind_consnames in let make_Ik k = mkIndU (((fst ind),ntypes-k-1),u) in if j > nconstr then user_err Pp.(str "Not enough constructors in the type."); - substl (List.init ntypes make_Ik) (subst_instance_constr u specif.(j-1)) + let (ctx, cty) = specif.(j - 1) in + substl (List.init ntypes make_Ik) (subst_instance_constr u (Term.it_mkProd_or_LetIn cty ctx)) (* Number of constructors *) @@ -280,8 +281,7 @@ let make_case_info env ind style = let ind_tags = Context.Rel.to_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in let cstr_tags = - Array.map2 (fun c n -> - let d,_ = decompose_prod_assum c in + Array.map2 (fun (d, _) n -> Context.Rel.to_tags (List.firstn n d)) mip.mind_nf_lc mip.mind_consnrealdecls in let print_info = { ind_tags; cstr_tags; style } in @@ -462,7 +462,8 @@ let compute_projections env (kn, i as ind) = let pkt = mib.mind_packets.(i) in let { mind_nparams = nparamargs; mind_params_ctxt = params } = mib in let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in - let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in + let ctx, cty = pkt.mind_nf_lc.(0) in + let rctx, _ = decompose_prod_assum (substl subst (Term.it_mkProd_or_LetIn cty ctx)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in (* We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not @@ -622,9 +623,7 @@ let set_pattern_names env sigma ind brv = let (mib,mip) = Inductive.lookup_mind_specif env ind in let arities = Array.map - (fun c -> - Context.Rel.length ((prod_assum c)) - - mib.mind_nparams) + (fun (d, _) -> List.length d - mib.mind_nparams) mip.mind_nf_lc in Array.map2 (set_names env sigma) arities brv diff --git a/pretyping/locus.ml b/pretyping/locus.ml index 37dd120c1a..087a6b9174 100644 --- a/pretyping/locus.ml +++ b/pretyping/locus.ml @@ -20,6 +20,7 @@ type 'a or_var = type 'a occurrences_gen = | AllOccurrences + | AtLeastOneOccurrence | AllOccurrencesBut of 'a list (** non-empty *) | NoOccurrences | OnlyOccurrences of 'a list (** non-empty *) diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 6b6a3f8a9f..aaa4ce684d 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -19,15 +19,17 @@ let occurrences_map f = function | AllOccurrencesBut l -> let l' = f l in if l' = [] then AllOccurrences else AllOccurrencesBut l' - | (NoOccurrences|AllOccurrences) as o -> o + | (NoOccurrences|AllOccurrences|AtLeastOneOccurrence) as o -> o let convert_occs = function + | AtLeastOneOccurrence -> (false,[]) | AllOccurrences -> (false,[]) | AllOccurrencesBut l -> (false,l) | NoOccurrences -> (true,[]) | OnlyOccurrences l -> (true,l) let is_selected occ = function + | AtLeastOneOccurrence -> true | AllOccurrences -> true | AllOccurrencesBut l -> not (Int.List.mem occ l) | OnlyOccurrences l -> Int.List.mem occ l @@ -46,6 +48,11 @@ let is_nowhere = function | { onhyps=Some[]; concl_occs=NoOccurrences } -> true | _ -> false +let is_all_occurrences = function + | AtLeastOneOccurrence + | AllOccurrences -> true + | _ -> false + (** Clause conversion functions, parametrized by a hyp enumeration function *) (** From [clause] to [simple_clause] *) @@ -61,12 +68,12 @@ let simple_clause_of enum_hyps cl = List.map Option.make (enum_hyps ()) | Some l -> List.map (fun ((occs,id),w) -> - if occs <> AllOccurrences then error_occurrences (); + if not (is_all_occurrences occs) then error_occurrences (); if w = InHypValueOnly then error_body_selection (); Some id) l in if cl.concl_occs = NoOccurrences then hyps else - if cl.concl_occs <> AllOccurrences then error_occurrences () + if not (is_all_occurrences cl.concl_occs) then error_occurrences () else None :: hyps (** From [clause] to [concrete_clause] *) @@ -111,7 +118,7 @@ let clause_with_generic_occurrences cls = List.for_all (function ((AllOccurrences,_),_) -> true | _ -> false) hyps in let concl = match cls.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in hyps && concl @@ -122,6 +129,6 @@ let clause_with_generic_context_selection cls = List.for_all (function ((AllOccurrences,_),InHyp) -> true | _ -> false) hyps in let concl = match cls.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in hyps && concl diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli index a07c018c32..ac15fe1018 100644 --- a/pretyping/locusops.mli +++ b/pretyping/locusops.mli @@ -21,6 +21,8 @@ val convert_occs : occurrences -> bool * int list val is_selected : int -> occurrences -> bool +val is_all_occurrences : 'a occurrences_gen -> bool + (** Usual clauses *) val allHypsAndConcl : 'a clause_expr diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index b7090e69da..77ae09ee6f 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -107,7 +107,8 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib u typ params = +let type_constructor mind mib u (ctx, typ) params = + let typ = it_mkProd_or_LetIn typ ctx in let s = ind_subst mind mib u in let ctyp = substl s typ in let nparams = Array.length params in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index a92b245b91..9612932439 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -266,7 +266,7 @@ let apply_inference_hook hook env sigma frozen = match frozen with let apply_heuristics env sigma fail_evar = (* Resolve eagerly, potentially making wrong choices *) try solve_unif_constraints_with_heuristics - ~ts:(Typeclasses.classes_transparent_state ()) env sigma + ~flags:(default_flags_of (Typeclasses.classes_transparent_state ())) env sigma with e when CErrors.noncritical e -> let e = CErrors.push e in if fail_evar then iraise e else sigma @@ -562,9 +562,9 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo | GFix (vn,i) -> i | GCoFix i -> i in - begin match conv !!env sigma ftys.(fixi) t with - | None -> sigma - | Some sigma -> sigma + begin match Evarconv.unify_delay !!env sigma ftys.(fixi) t with + | exception Evarconv.UnableToUnify _ -> sigma + | sigma -> sigma end | None -> sigma in @@ -670,11 +670,11 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo match candargs with | [] -> sigma, [], j_val hj | arg :: args -> - begin match conv !!env sigma (j_val hj) arg with - | Some sigma -> - sigma, args, nf_evar sigma (j_val hj) - | None -> + begin match Evarconv.unify_delay !!env sigma (j_val hj) arg with + | exception Evarconv.UnableToUnify _ -> sigma, [], j_val hj + | sigma -> + sigma, args, nf_evar sigma (j_val hj) end in let sigma, ujval = adjust_evar_source sigma na ujval in @@ -1060,9 +1060,9 @@ and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match valcon with | None -> sigma, tj | Some v -> - begin match cumul !!env sigma v tj.utj_val with - | Some sigma -> sigma, tj - | None -> + begin match Evarconv.unify_leq_delay !!env sigma v tj.utj_val with + | sigma -> sigma, tj + | exception Evarconv.UnableToUnify _ -> error_unexpected_type ?loc:(loc_of_glob_constr c) !!env sigma tj.utj_val v end diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 2308a541fb..5db571433a 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1105,6 +1105,7 @@ let unfoldoccs env sigma (occs,name) c = | AllOccurrences -> unfold env sigma name c | OnlyOccurrences l -> unfo true l | AllOccurrencesBut l -> unfo false l + | AtLeastOneOccurrence -> unfo false [] (* Unfold reduction tactic: *) let unfoldn loccname env sigma c = diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index d732544c5c..1496712bbc 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -124,12 +124,14 @@ let typeclass_univ_instance (cl, u) = let class_info c = try GlobRef.Map.find c !classes - with Not_found -> not_a_class (Global.env()) (EConstr.of_constr (printable_constr_of_global c)) + with Not_found -> + let env = Global.env() in + not_a_class env (Evd.from_env env) (EConstr.of_constr (printable_constr_of_global c)) let global_class_of_constr env sigma c = try let gr, u = Termops.global_of_constr sigma c in - class_info gr, u - with Not_found -> not_a_class env c + GlobRef.Map.find gr !classes, u + with Not_found -> not_a_class env sigma c let dest_class_app env sigma c = let cl, args = EConstr.decompose_app sigma c in diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index 2720a3e4de..af5b3016c9 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -20,10 +20,10 @@ type typeclass_error = | NotAClass of constr | UnboundMethod of GlobRef.t * lident (* Class name, method *) -exception TypeClassError of env * typeclass_error +exception TypeClassError of env * Evd.evar_map * typeclass_error -let typeclass_error env err = raise (TypeClassError (env, err)) +let typeclass_error env sigma err = raise (TypeClassError (env, sigma, err)) -let not_a_class env c = typeclass_error env (NotAClass c) +let not_a_class env sigma c = typeclass_error env sigma (NotAClass c) -let unbound_method env cid id = typeclass_error env (UnboundMethod (cid, id)) +let unbound_method env sigma cid id = typeclass_error env sigma (UnboundMethod (cid, id)) diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index 9831627a9a..fd75781ed5 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -18,9 +18,10 @@ type typeclass_error = | NotAClass of constr | UnboundMethod of GlobRef.t * lident (** Class name, method *) -exception TypeClassError of env * typeclass_error +exception TypeClassError of env * Evd.evar_map * typeclass_error -val not_a_class : env -> constr -> 'a +val typeclass_error : env -> Evd.evar_map -> typeclass_error -> 'a -val unbound_method : env -> GlobRef.t -> lident -> 'a +val not_a_class : env -> Evd.evar_map -> constr -> 'a +val unbound_method : env -> Evd.evar_map -> GlobRef.t -> lident -> 'a diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 2e50e1ab3f..ea6e52e1f8 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -71,10 +71,10 @@ let judge_of_applied_inductive_knowing_parameters env sigma funj ind argjv = | _ -> error_cant_apply_not_functional env sigma funj argjv in - begin match Evarconv.cumul env sigma hj.uj_type c1 with - | Some sigma -> + begin match Evarconv.unify_leq_delay env sigma hj.uj_type c1 with + | sigma -> apply_rec sigma (n+1) (subst1 hj.uj_val c2) restjl - | None -> + | exception Evarconv.UnableToUnify _ -> error_cant_apply_bad_type env sigma (n, c1, hj.uj_type) funj argjv end in @@ -96,10 +96,10 @@ let judge_of_apply env sigma funj argjv = | _ -> error_cant_apply_not_functional env sigma funj argjv in - begin match Evarconv.cumul env sigma hj.uj_type c1 with - | Some sigma -> + begin match Evarconv.unify_leq_delay env sigma hj.uj_type c1 with + | sigma -> apply_rec sigma (n+1) (subst1 hj.uj_val c2) restjl - | None -> + | exception Evarconv.UnableToUnify _ -> error_cant_apply_bad_type env sigma (n, c1, hj.uj_type) funj argjv end in @@ -109,9 +109,9 @@ let check_branch_types env sigma (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then error_number_branches env sigma cj (Array.length explft); Array.fold_left2_i (fun i sigma lfj explft -> - match Evarconv.cumul env sigma lfj.uj_type explft with - | Some sigma -> sigma - | None -> + match Evarconv.unify_leq_delay env sigma lfj.uj_type explft with + | sigma -> sigma + | exception Evarconv.UnableToUnify _ -> error_ill_formed_branch env sigma cj.uj_val ((ind,i+1),u) lfj.uj_type explft) sigma lfj explft @@ -127,9 +127,9 @@ let is_correct_arity env sigma c pj ind specif params = let pt' = whd_all env sigma pt in match EConstr.kind sigma pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> - begin match Evarconv.cumul env sigma a1 a1' with - | None -> error () - | Some sigma -> + begin match Evarconv.unify_leq_delay env sigma a1 a1' with + | exception Evarconv.UnableToUnify _ -> error () + | sigma -> srec (push_rel (LocalAssum (na1,a1)) env) sigma t ar' end | Sort s, [] -> @@ -187,9 +187,9 @@ let check_type_fixpoint ?loc env sigma lna lar vdefj = let lt = Array.length vdefj in assert (Int.equal (Array.length lar) lt); Array.fold_left2_i (fun i sigma defj ar -> - match Evarconv.cumul env sigma defj.uj_type (lift lt ar) with - | Some sigma -> sigma - | None -> + match Evarconv.unify_leq_delay env sigma defj.uj_type (lift lt ar) with + | sigma -> sigma + | exception Evarconv.UnableToUnify _ -> error_ill_typed_rec_body ?loc env sigma i lna vdefj lar) sigma vdefj lar @@ -211,10 +211,10 @@ let check_allowed_sort env sigma ind c p = let judge_of_cast env sigma cj k tj = let expected_type = tj.utj_val in - match Evarconv.cumul env sigma cj.uj_type expected_type with - | None -> + match Evarconv.unify_leq_delay env sigma cj.uj_type expected_type with + | exception Evarconv.UnableToUnify _ -> error_actual_type_core env sigma cj expected_type; - | Some sigma -> + | sigma -> sigma, { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type } @@ -427,10 +427,10 @@ and execute_array env = Array.fold_left_map (execute env) let check env sigma c t = let sigma, j = execute env sigma c in - match Evarconv.cumul env sigma j.uj_type t with - | None -> + match Evarconv.unify_leq_delay env sigma j.uj_type t with + | exception Evarconv.UnableToUnify _ -> error_actual_type_core env sigma j t - | Some sigma -> sigma + | sigma -> sigma (* Type of a constr *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index ac0b58b92b..3de8c381d0 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -141,7 +141,15 @@ let abstract_list_all env evd typ c l = evd,(p,typp) let set_occurrences_of_last_arg args = - Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) + Evarconv.AtOccurrences AllOccurrences :: + List.tl (Array.map_to_list (fun _ -> Evarconv.Unspecified Abstraction.Abstract) args) + +let occurrence_test _ _ _ env sigma _ c1 c2 = + match EConstr.eq_constr_universes env sigma c1 c2 with + | None -> false, sigma + | Some cstr -> + try true, Evd.add_universe_constraints sigma cstr + with UniversesDiffer -> false, sigma let abstract_list_all_with_dependencies env evd typ c l = let (evd, ev) = new_evar env evd typ in @@ -149,8 +157,9 @@ let abstract_list_all_with_dependencies env evd typ c l = let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in let evd,b = - Evarconv.second_order_matching TransparentState.empty - env evd ev' argoccs c in + Evarconv.second_order_matching + (Evarconv.default_flags_of TransparentState.empty) + env evd ev' (occurrence_test, argoccs) c in if b then let p = nf_evar evd ev in evd, p @@ -1315,8 +1324,8 @@ let order_metas metas = (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *) -let solve_simple_evar_eqn ts env evd ev rhs = - match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) with +let solve_simple_evar_eqn flags env evd ev rhs = + match solve_simple_eqn Evarconv.evar_unify flags env evd (None,ev,rhs) with | UnifFailure (evd,reason) -> error_cannot_unify env evd ~reason (mkEvar ev,rhs); | Success evd -> evd @@ -1326,6 +1335,7 @@ let solve_simple_evar_eqn ts env evd ev rhs = is true, unification of types of metas is required *) let w_merge env with_types flags (evd,metas,evars : subst0) = + let eflags = Evarconv.default_flags_of flags.modulo_delta_types in let rec w_merge_rec evd metas evars eqns = (* Process evars *) @@ -1350,14 +1360,14 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = else let evd' = let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in - try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'' + try solve_simple_evar_eqn eflags curenv evd' ev rhs'' with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev,rhs'') in w_merge_rec evd' metas evars' eqns | _ -> let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in let evd' = - try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'' + try solve_simple_evar_eqn eflags curenv evd' ev rhs'' with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev, rhs'') in w_merge_rec evd' metas evars' eqns @@ -1649,7 +1659,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = match occurrences_of_hyp hyp occs with | NoOccurrences, InHyp -> (push_named_context_val d sign,depdecls) - | AllOccurrences, InHyp as occ -> + | (AllOccurrences | AtLeastOneOccurrence), InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in let newdecl = replace_term_occ_decl_modulo sigma occ test mkvarid d in if Context.Named.Declaration.equal (EConstr.eq_constr sigma) d newdecl diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 083661a64b..ff528bd2cf 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -61,7 +61,8 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib u typ params = +let type_constructor mind mib u (ctx, typ) params = + let typ = it_mkProd_or_LetIn typ ctx in let s = ind_subst mind mib u in let ctyp = substl s typ in let ctyp = subst_instance_constr u ctyp in diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 1b2756f49f..0f97a942ed 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -37,8 +37,8 @@ let define_and_solve_constraints evk c env evd = match List.fold_left (fun p (pbty,env,t1,t2) -> match p with - | Success evd -> Evarconv.evar_conv_x TransparentState.full env evd pbty t1 t2 - | UnifFailure _ as x -> x) (Success evd) + | Success evd -> Evarconv.evar_conv_x (Evarconv.default_flags_of TransparentState.full) env evd pbty t1 t2 + | UnifFailure _ as x -> x) (Success evd) pbs with | Success evd -> evd diff --git a/proofs/goal.ml b/proofs/goal.ml index 7245d4a004..e5688fe730 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -58,10 +58,11 @@ module V82 = struct created. *) let prev_future_goals = Evd.save_future_goals evars in let evi = { Evd.evar_hyps = hyps; - Evd.evar_concl = concl; - Evd.evar_filter = Evd.Filter.identity; - Evd.evar_body = Evd.Evar_empty; - Evd.evar_source = (Loc.tag Evar_kinds.GoalEvar); + Evd.evar_concl = concl; + Evd.evar_filter = Evd.Filter.identity; + Evd.evar_abstract_arguments = Evd.Abstraction.identity; + Evd.evar_body = Evd.Evar_empty; + Evd.evar_source = (Loc.tag Evar_kinds.GoalEvar); Evd.evar_candidates = None } in let (evars, evk) = Evarutil.new_pure_evar_full evars ~typeclass_candidate:false evi in diff --git a/stm/stm.ml b/stm/stm.ml index 8af1a2ebd2..ab388977a5 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -3205,10 +3205,9 @@ let edit_at ~doc id = let vcs = VCS.backup () in let on_cur_branch id = let rec aux cur = - if id = cur then true - else match VCS.visit cur with + match VCS.visit cur with | { step = `Fork _ } -> false - | { next } -> aux next in + | { next } -> if id = cur then true else aux next in aux (VCS.get_branch_pos (VCS.current_branch ())) in let rec is_pure_aux id = let view = VCS.visit id in diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index f824552705..3b8232d20a 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -145,7 +145,7 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = let try_do_hyps treat_id l = autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas in - if cl.concl_occs != AllOccurrences && + if not (Locusops.is_all_occurrences cl.concl_occs) && cl.concl_occs != NoOccurrences then Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index e505bb3a42..a3620f4081 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -230,8 +230,9 @@ let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in let term = applist (term, List.map (fun x -> x.hole_evar) cl.cl_holes) in let sigma' = - Evarconv.the_conv_x_leq env ~ts:flags.core_unify_flags.modulo_delta - cl.cl_concl concl sigma' + Evarconv.(unify_leq_delay + ~flags:(default_flags_of flags.core_unify_flags.modulo_delta) + env sigma' cl.cl_concl concl) in (sigma', term) end let unify_resolve_refine poly flags gl clenv = @@ -1111,7 +1112,7 @@ let initial_select_evars filter = let resolve_typeclass_evars debug depth unique env evd filter split fail = let evd = try Evarconv.solve_unif_constraints_with_heuristics - ~ts:(Typeclasses.classes_transparent_state ()) env evd + ~flags:(Evarconv.default_flags_of (Typeclasses.classes_transparent_state ())) env evd with e when CErrors.noncritical e -> evd in resolve_all_evars debug depth unique env diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index b12018cd66..3c1115d056 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -138,7 +138,7 @@ let get_sym_eq_data env (ind,u) = let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; - let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in + let constrsign,ccl = mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; (* This can be relaxed... *) @@ -173,7 +173,7 @@ let get_non_sym_eq_data env (ind,u) = let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported"; - let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in + let constrsign,ccl = mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; @@ -776,7 +776,7 @@ let build_congr env (eq,refl,ctx) ind = error "Inductive equalities with local definitions in arity not supported."; let env_with_arity = push_rel_context arityctxt env in let ty = RelDecl.get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in - let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in + let constrsign,ccl = mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; diff --git a/tactics/equality.ml b/tactics/equality.ml index 769e702da1..4a1bb37fa4 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -437,7 +437,7 @@ let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac) let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac ((c,l) : constr with_bindings) with_evars = - if occs != AllOccurrences then ( + if not (Locusops.is_all_occurrences occs) then ( rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) else Proofview.Goal.enter begin fun gl -> @@ -595,15 +595,16 @@ let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else check_required_library ["Coq";"Setoids";"Setoid"] -let check_setoid cl = +let check_setoid cl = + let concloccs = Locusops.occurrences_map (fun x -> x) cl.concl_occs in Option.fold_left - ( List.fold_left + (List.fold_left (fun b ((occ,_),_) -> - b||(Locusops.occurrences_map (fun x -> x) occ <> AllOccurrences) + b||(not (Locusops.is_all_occurrences (Locusops.occurrences_map (fun x -> x) occ))) ) ) - ((Locusops.occurrences_map (fun x -> x) cl.concl_occs <> AllOccurrences) && - (Locusops.occurrences_map (fun x -> x) cl.concl_occs <> NoOccurrences)) + (not (Locusops.is_all_occurrences concloccs) && + (concloccs <> NoOccurrences)) cl.onhyps let replace_core clause l2r eq = @@ -635,7 +636,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = let evd = if unsafe then Some (Tacmach.New.project gl) else - try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl)) + try Some (Evarconv.unify_delay (Proofview.Goal.env gl) (Tacmach.New.project gl) t1 t2) with Evarconv.UnableToUnify _ -> None in match evd with @@ -1193,9 +1194,8 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = (* is the default value typable with the expected type *) let dflt_typ = unsafe_type_of env sigma dflt in try - let sigma = Evarconv.the_conv_x_leq env dflt_typ p_i sigma in - let sigma = - Evarconv.solve_unif_constraints_with_heuristics env sigma in + let sigma = Evarconv.unify_leq_delay env sigma dflt_typ p_i in + let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in sigma, dflt with Evarconv.UnableToUnify _ -> user_err Pp.(str "Cannot solve a unification problem.") @@ -1210,11 +1210,11 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = match evopt with | Some w -> let w_type = unsafe_type_of env sigma w in - begin match Evarconv.cumul env sigma w_type a with - | Some sigma -> + begin match Evarconv.unify_leq_delay env sigma w_type a with + | sigma -> let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in sigma, applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) - | None -> + | exception Evarconv.UnableToUnify _ -> user_err Pp.(str "Cannot solve a unification problem.") end | None -> @@ -1724,7 +1724,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = tclTHENLIST ((if need_rewrite then [revert (List.map snd dephyps); - general_rewrite dir AllOccurrences true dep_proof_ok (mkVar hyp); + general_rewrite dir AtLeastOneOccurrence true dep_proof_ok (mkVar hyp); (tclMAP (fun (dest,id) -> intro_move (Some id) dest) dephyps)] else [Proofview.tclUNIT ()]) @ diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 708412720a..395b4928ce 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -106,22 +106,24 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = && (Int.equal mip.mind_nrealargs 0) then if is_strict_conjunction style (* strict conjunction *) then - let ctx = - (prod_assum sigma (snd - (decompose_prod_n_assum sigma mib.mind_nparams (EConstr.of_constr mip.mind_nf_lc.(0))))) in + let (ctx, _) = mip.mind_nf_lc.(0) in + let ctx = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in if + (* Constructor has a type of the form + c : forall (a_0 ... a_n : Type) (x_0 : A_0) ... (x_n : A_n). T **) List.for_all (fun decl -> let c = RelDecl.get_type decl in is_local_assum decl && - isRel sigma c && - Int.equal (destRel sigma c) mib.mind_nparams) ctx + Constr.isRel c && + Int.equal (Constr.destRel c) mib.mind_nparams) ctx then Some (hdapp,args) else None else + let ctx, cty = mip.mind_nf_lc.(0) in + let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in let ctyp = whd_beta_prod sigma - (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) - (EConstr.of_constr mip.mind_nf_lc.(0)) args) in + (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) cty args) in let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then (* Record or non strict conjunction *) @@ -165,12 +167,13 @@ let is_tuple sigma t = it is strict if it has the form "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) -let test_strict_disjunction n lc = - let open Term in - Array.for_all_i (fun i c -> - match (prod_assum (snd (decompose_prod_n_assum n c))) with - | [LocalAssum (_,c)] -> Constr.isRel c && Int.equal (Constr.destRel c) (n - i) - | _ -> false) 0 lc +let test_strict_disjunction (mib, mip) = + let n = List.length mib.mind_params_ctxt in + let check i (ctx, _) = match List.skipn n (List.rev ctx) with + | [LocalAssum (_, c)] -> Constr.isRel c && Int.equal (Constr.destRel c) (n - i) + | _ -> false + in + Array.for_all_i check 0 mip.mind_nf_lc let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = let (hdapp,args) = decompose_app sigma t in @@ -183,14 +186,16 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = && (Int.equal mip.mind_nrealargs 0) then if strict then - if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then + if test_strict_disjunction (mib, mip) then Some (hdapp,args) else None else - let cargs = - Array.map (fun ar -> pi2 (destProd sigma (prod_applist sigma (EConstr.of_constr ar) args))) - mip.mind_nf_lc in + let map (ctx, cty) = + let ar = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in + pi2 (destProd sigma (prod_applist sigma ar args)) + in + let cargs = Array.map map mip.mind_nf_lc in Some (hdapp,Array.to_list cargs) else None @@ -225,10 +230,8 @@ let match_with_unit_or_eq_type sigma t = match EConstr.kind sigma hdapp with | Ind (ind , _) -> let (mib,mip) = Global.lookup_inductive ind in - let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in - let zero_args c = Int.equal (nb_prod sigma (EConstr.of_constr c)) mib.mind_nparams in - if Int.equal nconstr 1 && zero_args constr_types.(0) then + if Int.equal nconstr 1 && Int.equal mip.mind_consnrealargs.(0) 0 then Some hdapp else None @@ -308,11 +311,13 @@ let match_with_equation env sigma t = let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 1 then - if is_matching env sigma coq_refl_leibniz1_pattern (EConstr.of_constr constr_types.(0)) then + let (ctx, cty) = constr_types.(0) in + let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in + if is_matching env sigma coq_refl_leibniz1_pattern cty then None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) - else if is_matching env sigma coq_refl_leibniz2_pattern (EConstr.of_constr constr_types.(0)) then + else if is_matching env sigma coq_refl_leibniz2_pattern cty then None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if is_matching env sigma coq_refl_jm_pattern (EConstr.of_constr constr_types.(0)) then + else if is_matching env sigma coq_refl_jm_pattern cty then None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) else raise NoEquationFound else raise NoEquationFound @@ -378,8 +383,9 @@ let match_with_nodep_ind sigma t = | Ind (ind, _) -> let (mib,mip) = Global.lookup_inductive ind in if Array.length (mib.mind_packets)>1 then None else - let nodep_constr c = - has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) sigma (EConstr.of_constr c) in + let nodep_constr (ctx, cty) = + let c = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in + has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) sigma c in if Array.for_all nodep_constr mip.mind_nf_lc then let params= if Int.equal mip.mind_nrealargs 0 then args else @@ -400,7 +406,7 @@ let match_with_sigma_type sigma t = && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) && has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt + 1) sigma - (EConstr.of_constr mip.mind_nf_lc.(0)) + (let (ctx, cty) = mip.mind_nf_lc.(0) in EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx)) then (*allowing only 1 existential*) Some (hdapp,args) diff --git a/tactics/ppred.ml b/tactics/ppred.ml index dd1bcd4699..d832dc279c 100644 --- a/tactics/ppred.ml +++ b/tactics/ppred.ml @@ -6,6 +6,7 @@ open Pputils let pr_with_occurrences pr keyword (occs,c) = match occs with + | AtLeastOneOccurrence -> hov 1 (pr c ++ spc () ++ keyword "at" ++ str" +") | AllOccurrences -> pr c | NoOccurrences -> diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bfbce8f6eb..ec8d4d0e14 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -20,6 +20,7 @@ open Tacmach open Clenv open Tactypes +module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration (************************************************************************) @@ -223,8 +224,8 @@ let compute_induction_names = compute_induction_names_gen true (* Compute the let-in signature of case analysis or standard induction scheme *) let compute_constructor_signatures ~rec_flag ((_,k as ity),u) = let rec analrec c recargs = - match Constr.kind c, recargs with - | Prod (_,_,c), recarg::rest -> + match c, recargs with + | RelDecl.LocalAssum _ :: c, recarg::rest -> let rest = analrec c rest in begin match Declareops.dest_recarg recarg with | Norec | Imbr _ -> true :: rest @@ -232,14 +233,13 @@ let compute_constructor_signatures ~rec_flag ((_,k as ity),u) = if rec_flag && Int.equal j k then true :: true :: rest else true :: rest end - | LetIn (_,_,_,c), rest -> false :: analrec c rest - | _, [] -> [] + | RelDecl.LocalDef _ :: c, rest -> false :: analrec c rest + | [], [] -> [] | _ -> anomaly (Pp.str "compute_constructor_signatures.") in let (mib,mip) = Global.lookup_inductive ity in - let n = mib.mind_nparams in - let lc = - Array.map (fun c -> snd (Term.decompose_prod_n_assum n c)) mip.mind_nf_lc in + let map (ctx, _) = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in + let lc = Array.map map mip.mind_nf_lc in let lrecargs = Declareops.dest_subterms mip.mind_recargs in Array.map2 analrec lc lrecargs diff --git a/tactics/tactics.ml b/tactics/tactics.ml index db59f7cfc2..415225454a 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3840,9 +3840,9 @@ let specialize_eqs id = let evars = ref (Proofview.Goal.sigma gl) in let unif env evars c1 c2 = compare_upto_variables !evars c1 c2 && - (match Evarconv.conv env !evars c1 c2 with - | Some sigma -> evars := sigma; true - | None -> false) + (match Evarconv.unify_delay env !evars c1 c2 with + | sigma -> evars := sigma; true + | exception Evarconv.UnableToUnify _ -> false) in let rec aux in_eqs ctx acc ty = match EConstr.kind !evars ty with @@ -4398,7 +4398,9 @@ let check_expected_type env sigma (elimc,bl) elimt = let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in let (_,u,_) = destProd sigma cl.cl_concl in - fun t -> Option.has_some (Evarconv.cumul env sigma t u) + fun t -> match Evarconv.unify_leq_delay env sigma t u with + | _sigma -> true + | exception Evarconv.UnableToUnify _ -> false let check_enough_applied env sigma elim = (* A heuristic to decide whether the induction arg is enough applied *) diff --git a/test-suite/Makefile b/test-suite/Makefile index 6efd47afc2..ba591ede20 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -317,8 +317,6 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v echo " $<...correctly prepared" ; \ fi; \ } > "$@" - @echo "CHECK $<" - $(HIDE)$(coqchk) -norec TestSuite.$(shell basename $< .v) > $(shell dirname $<)/$(shell basename $< .v).chk.log 2>&1 ssr: $(wildcard ssr/*.v:%.v=%.v.log) $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v arithmetic/*.v)): %.v.log: %.v $(PREREQUISITELOG) diff --git a/test-suite/bugs/closed/bug_9595.v b/test-suite/bugs/closed/bug_9595.v new file mode 100644 index 0000000000..312ed7d045 --- /dev/null +++ b/test-suite/bugs/closed/bug_9595.v @@ -0,0 +1,11 @@ +Set Primitive Projections. +Set Warnings "+non-primitive-record". + +(* 0 fields *) +Fail Record foo := { a := 0 }. + +(* anonymous field *) +Fail Record foo := { _ : nat }. + +(* squashed *) +Fail Record foo : Prop := { a : nat }. diff --git a/test-suite/bugs/closed/bug_9631.v b/test-suite/bugs/closed/bug_9631.v new file mode 100644 index 0000000000..8afeccccd4 --- /dev/null +++ b/test-suite/bugs/closed/bug_9631.v @@ -0,0 +1,7 @@ + +Fail Instance x : _. + +Existing Class True. +(* the type is checked for typeclass-ness before interping the body so + this is the same error *) +Fail Instance x : _ := I. diff --git a/test-suite/ide/reopen1.fake b/test-suite/ide/reopen1.fake new file mode 100644 index 0000000000..2c4f13de86 --- /dev/null +++ b/test-suite/ide/reopen1.fake @@ -0,0 +1,22 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# jumping outside the focused zone should signal an unfocus. + +# first proof +ADD here { Goal True. } +ADD here1 { Proof. } +ADD { Qed. } +WAIT +EDIT_AT here1 +EDIT_AT here +# fwd again +ADD here2 { Proof. } +ADD here3 { Qed. } +WAIT +EDIT_AT here2 +# Fixing the proof +ADD { Proof. } +ADD { trivial. } +ADD { Qed. } +JOIN diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.v b/test-suite/output-modulo-time/ltacprof_cutoff.v deleted file mode 100644 index b7c98aa134..0000000000 --- a/test-suite/output-modulo-time/ltacprof_cutoff.v +++ /dev/null @@ -1,28 +0,0 @@ -(* -*- coq-prog-args: ("-async-proofs" "off" "-profile-ltac") -*- *) -Require Coq.ZArith.BinInt. -Module WithIdTac. - Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). - - Ltac foo0 := idtac; sleep. - Ltac foo1 := sleep; foo0. - Ltac foo2 := sleep; foo1. - Goal True. - foo2. - Show Ltac Profile CutOff 47. - constructor. - Qed. -End WithIdTac. - -Module TestEval. - Ltac sleep := let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac. - - Ltac foo0 := idtac; do 50 (idtac; sleep). - Ltac foo1 := sleep; foo0. - Ltac foo2 := sleep; foo1. - Goal True. - Reset Ltac Profile. - foo2. - Show Ltac Profile CutOff 47. - constructor. - Qed. -End TestEval. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index ba4bc070c6..3f0717666c 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -113,7 +113,8 @@ Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: Some argument names are duplicated: F The command has indeed failed with message: -Argument z cannot be declared implicit. +Argument number 2 (anonymous in original definition) cannot be declared +implicit. The command has indeed failed with message: Extra arguments: y. The command has indeed failed with message: diff --git a/test-suite/output/PrintInfos.v b/test-suite/output/PrintInfos.v index d7c271c3ec..d95cc0e32f 100644 --- a/test-suite/output/PrintInfos.v +++ b/test-suite/output/PrintInfos.v @@ -22,7 +22,7 @@ Print comparison. Definition foo := forall x, x = 0. Parameter bar : foo. -Arguments bar [x]. +Arguments bar {x}. About bar. Print bar. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index 8a04206bb2..8732305953 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -23,7 +23,7 @@ Typeclasses Opaque id const flip compose arrow impl iff not all. (** Apply using the same opacity information as typeclass proof search. *) -Ltac class_apply c := autoapply c using typeclass_instances. +Ltac class_apply c := autoapply c with typeclass_instances. (** The unconvertible typeclass, to test that two objects of the same type are actually different. *) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index af9050da29..a48e9929c4 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1033,7 +1033,7 @@ Lemma map_ext_in_iff : forall (A B : Type)(f g:A->B) l, map f l = map g l <-> forall a, In a l -> f a = g a. Proof. split; [apply ext_in_map | apply map_ext_in]. Qed. -Arguments map_ext_in_iff [A B f g l]. +Arguments map_ext_in_iff {A B f g l}. Lemma map_ext : forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 62a871aa0e..98368d76ca 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -235,6 +235,12 @@ let scan_plugins m = let dirs = Sys.(List.filter (fun f -> is_plugin_directory @@ bpath ["plugins";f]) Array.(to_list @@ readdir "plugins")) in List.fold_left scan_mlg m dirs +(* This will be removed when we drop support for Make *) +let fix_cmo_cma file = + if String.equal Filename.(extension file) ".cmo" + then replace_ext ~file ~newext:".cma" + else file + (* Process .vfiles.d and generate a skeleton for the dune file *) let parse_coqdep_line l = match Str.(split (regexp ":") l) with @@ -249,6 +255,7 @@ let parse_coqdep_line l = the platform. Anyways, I hope we can link to coqdep instead of having to parse its output soon, that should solve this kind of issues *) + let deps = List.map fix_cmo_cma deps in Some (String.split_on_char '/' dir, VO { target; deps; }) (* Otherwise a vio file, we ignore *) | _ -> None diff --git a/vernac/classes.ml b/vernac/classes.ml index 263ebf5f5a..4664df3182 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -149,7 +149,7 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id if program_mode then let hook _ _ vis gr = let cst = match gr with ConstRef kn -> kn | _ -> assert false in - Impargs.declare_manual_implicits false gr [imps]; + Impargs.declare_manual_implicits false gr imps; let pri = intern_info pri in Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst) in @@ -234,7 +234,7 @@ let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode ct in match rest with | (n, _) :: _ -> - unbound_method env' k.cl_impl (get_id n) + unbound_method env' sigma k.cl_impl (get_id n) | _ -> let kcl_props = List.map (Termops.map_rel_decl of_constr) k.cl_props in let sigma, res = type_ctx_instance ~program_mode (push_rel_context ctx' env') sigma kcl_props props subst in diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 9bbfb8eec6..7fa99b25cb 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -529,7 +529,7 @@ let warn_non_primitive_record = (hov 0 (str "The record " ++ Nametab.pr_global_env Id.Set.empty (IndRef indsp) ++ strbrk" could not be defined as a primitive record"))) -let declare_mutual_inductive_with_eliminations mie pl impls = +let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie pl impls = (* spiwack: raises an error if the structure is supposed to be non-recursive, but isn't *) begin match mie.mind_entry_finite with @@ -543,8 +543,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls = let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in let (_, kn), prim = declare_mind mie in let mind = Global.mind_of_delta_kn kn in - if match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false - then warn_non_primitive_record (mind,0); + if primitive_expected && not prim then warn_non_primitive_record (mind,0); Declare.declare_univ_binders (IndRef (mind,0)) pl; List.iteri (fun i (indimpls, constrimpls) -> let ind = (mind,i) in diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 1d6f652385..224cce67ad 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -43,6 +43,7 @@ type one_inductive_impls = Impargs.manual_implicits list (* for constrs *) val declare_mutual_inductive_with_eliminations : + ?primitive_expected:bool -> mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> MutInd.t diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index cc9c83bd17..ae77cf12e5 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -215,7 +215,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] + Impargs.declare_manual_implicits false gr impls in let typ = it_mkProd_or_LetIn top_arity binders in hook, name, typ @@ -223,7 +223,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let typ = it_mkProd_or_LetIn top_arity binders_rel in let hook sigma _ _ l gr = if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] + Impargs.declare_manual_implicits false gr impls in hook, recname, typ in (* XXX: Capturing sigma here... bad bad *) diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 06428b53f2..2bc95dbfcd 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -64,8 +64,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) | Notation.PrimTokenNotationError(kind,ctx,sigma,te) -> wrap_vernac_error exn (Himsg.explain_prim_token_notation_error kind ctx sigma te) - | Typeclasses_errors.TypeClassError(env, te) -> - wrap_vernac_error exn (Himsg.explain_typeclass_error env te) + | Typeclasses_errors.TypeClassError(env, sigma, te) -> + wrap_vernac_error exn (Himsg.explain_typeclass_error env sigma te) | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) -> wrap_vernac_error exn (Himsg.explain_mismatched_contexts e c l x) | InductiveError e -> diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 42bee25da3..589b15fd41 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -16,6 +16,7 @@ open Util open Names open Glob_term open Vernacexpr +open Impargs open Constrexpr open Constrexpr_ops open Extend @@ -836,11 +837,11 @@ GRAMMAR EXTEND Gram ]; (* Same as [argument_spec_block], but with only implicit status and names *) more_implicits_block: [ - [ name = name -> { [(name.CAst.v, Vernacexpr.NotImplicit)] } + [ name = name -> { [(name.CAst.v, NotImplicit)] } | "["; items = LIST1 name; "]" -> - { List.map (fun name -> (name.CAst.v, Vernacexpr.Implicit)) items } + { List.map (fun name -> (name.CAst.v, Impargs.Implicit)) items } | "{"; items = LIST1 name; "}" -> - { List.map (fun name -> (name.CAst.v, Vernacexpr.MaximallyImplicit)) items } + { List.map (fun name -> (name.CAst.v, MaximallyImplicit)) items } ] ]; strategy_level: diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 9dd321be51..2ef2317d86 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -339,6 +339,20 @@ let explain_actual_type env sigma j t reason = str "while it is expected to have type" ++ brk(1,1) ++ pt ++ ppreason ++ str ".") +let explain_incorrect_primitive env sigma j exp = + let env = make_all_name_different env sigma in + let {uj_val=p;uj_type=t} = j in + let t = Reductionops.nf_betaiota env sigma t in + let exp = Reductionops.nf_betaiota env sigma exp in + (* Actually print *) + let pe = pr_ne_context_of (str "In environment") env sigma in + let (pt, pct) = pr_explicit env sigma exp t in + pe ++ + hov 0 ( + str "The primitive" ++ brk(1,1) ++ str (CPrimitives.op_or_type_to_string p) ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ spc () ++ + str "while it is expected to have type" ++ brk(1,1) ++ pt ++ str ".") + let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = let randl = jv_nf_betaiotaevar env sigma randl in let actualtyp = Reductionops.nf_betaiota env sigma actualtyp in @@ -720,7 +734,9 @@ let explain_type_error env sigma err = | Generalization (nvar, c) -> explain_generalization env sigma nvar c | ActualType (j, pt) -> - explain_actual_type env sigma j pt None + explain_actual_type env sigma j pt None + | IncorrectPrimitive (j, t) -> + explain_incorrect_primitive env sigma j t | CantApplyBadType (t, rator, randl) -> explain_cant_apply_bad_type env sigma t rator randl | CantApplyNonFunctional (rator, randl) -> @@ -1039,12 +1055,10 @@ let explain_module_internalization_error = function (* Typeclass errors *) -let explain_not_a_class env c = - let sigma = Evd.from_env env in - let c = EConstr.to_constr sigma c in - pr_constr_env env sigma c ++ str" is not a declared type class." +let explain_not_a_class env sigma c = + pr_econstr_env env sigma c ++ str" is not a declared type class." -let explain_unbound_method env cid { CAst.v = id } = +let explain_unbound_method env sigma cid { CAst.v = id } = str "Unbound method name " ++ Id.print (id) ++ spc () ++ str"of class" ++ spc () ++ pr_global cid ++ str "." @@ -1059,9 +1073,9 @@ let explain_mismatched_contexts env c i j = fnl () ++ brk (1,1) ++ hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) -let explain_typeclass_error env = function - | NotAClass c -> explain_not_a_class env c - | UnboundMethod (cid, id) -> explain_unbound_method env cid id +let explain_typeclass_error env sigma = function + | NotAClass c -> explain_not_a_class env sigma c + | UnboundMethod (cid, id) -> explain_unbound_method env sigma cid id (* Refiner errors *) diff --git a/vernac/himsg.mli b/vernac/himsg.mli index f22354cdbf..d0f42ea16b 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -26,7 +26,7 @@ val explain_inductive_error : inductive_error -> Pp.t val explain_mismatched_contexts : env -> contexts -> Constrexpr.constr_expr list -> Constr.rel_context -> Pp.t -val explain_typeclass_error : env -> typeclass_error -> Pp.t +val explain_typeclass_error : env -> Evd.evar_map -> typeclass_error -> Pp.t val explain_recursion_scheme_error : env -> recursion_scheme_error -> Pp.t diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index d22e52e960..f705f347a3 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -1033,9 +1033,9 @@ open Pputils let pr_s = function None -> str"" | Some {v=s} -> str "%" ++ str s in let pr_if b x = if b then x else str "" in let pr_br imp x = match imp with - | Vernacexpr.Implicit -> str "[" ++ x ++ str "]" - | Vernacexpr.MaximallyImplicit -> str "{" ++ x ++ str "}" - | Vernacexpr.NotImplicit -> x in + | Impargs.Implicit -> str "[" ++ x ++ str "]" + | Impargs.MaximallyImplicit -> str "{" ++ x ++ str "}" + | Impargs.NotImplicit -> x in let rec print_arguments n l = match n, l with | Some 0, l -> spc () ++ str"/" ++ print_arguments None l diff --git a/vernac/record.ml b/vernac/record.ml index 0bd15e203b..3202c9bed2 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -416,8 +416,6 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki let primitive = !primitive_flag && List.for_all (fun (_,_,_,_,fields,_,_) -> List.exists is_local_assum fields) record_data - (* will warn_non_primitive_record in declare_projections if we try - to declare a 0-field record *) in let mie = { mind_entry_params = params; @@ -431,7 +429,9 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki in let mie = InferCumulativity.infer_inductive (Global.env ()) mie in let impls = List.map (fun _ -> paramimpls, []) record_data in - let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders impls in + let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders impls + ~primitive_expected:!primitive_flag + in let map i (_, _, _, fieldimpls, fields, is_coe, coers) = let rsp = (kn, i) in (* This is ind path of idstruc *) let cstr = (rsp, 1) in @@ -487,8 +487,8 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity (DefinitionEntry proj_entry, IsDefinition Definition) in let cref = ConstRef cst in - Impargs.declare_manual_implicits false cref [paramimpls]; - Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; + Impargs.declare_manual_implicits false cref paramimpls; + Impargs.declare_manual_implicits false (ConstRef proj_cst) (List.hd fieldimpls); Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with | Some b -> Some ((if b then Backward else Forward), List.hd priorities) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index d9d824ad98..d227834fcf 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -16,7 +16,6 @@ open CAst open Util open Names open Nameops -open Term open Tacmach open Constrintern open Prettyp @@ -32,6 +31,7 @@ open Lemmas open Locality open Attributes +module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration (** TODO: make this function independent of Ltac *) @@ -133,22 +133,23 @@ let show_intro all = *) let make_cases_aux glob_ref = + let open Declarations in match glob_ref with | Globnames.IndRef ind -> - let {Declarations.mind_nparams = np} , {Declarations.mind_nf_lc = tarr} = Global.lookup_inductive ind in + let mib, mip = Global.lookup_inductive ind in Util.Array.fold_right_i - (fun i typ l -> - let al = List.rev (fst (decompose_prod typ)) in - let al = Util.List.skipn np al in + (fun i (ctx, _) l -> + let al = Util.List.skipn (List.length mib.mind_params_ctxt) (List.rev ctx) in let rec rename avoid = function | [] -> [] - | (n,_)::l -> + | RelDecl.LocalDef _ :: l -> "_" :: rename avoid l + | RelDecl.LocalAssum (n, _)::l -> let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n avoid in Id.to_string n' :: rename (Id.Set.add n' avoid) l in let al' = rename Id.Set.empty al in let consref = ConstructRef (ith_constructor_of_inductive ind (i + 1)) in (Libnames.string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty consref) :: al') :: l) - tarr [] + mip.mind_nf_lc [] | _ -> raise Not_found let make_cases s = @@ -1173,14 +1174,6 @@ let vernac_syntactic_definition ~module_local lid x y = Dumpglob.dump_definition lid false "syndef"; Metasyntax.add_syntactic_definition (Global.env()) lid.v x module_local y -let vernac_declare_implicits ~section_local r l = - match l with - | [] -> - Impargs.declare_implicits section_local (smart_global r) - | _::_ as imps -> - Impargs.declare_manual_implicits section_local (smart_global r) ~enriching:false - (List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps) - let warn_arguments_assert = CWarnings.create ~name:"arguments-assert" ~category:"vernacular" (fun sr -> @@ -1336,43 +1329,15 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red user_err (strbrk "Some argument names are duplicated: " ++ duplicates) end; - (* Parts of this code are overly complicated because the implicit arguments - API is completely crazy: positions (ExplByPos) are elaborated to - names. This is broken by design, since not all arguments have names. So - even though we eventually want to map only positions to implicit statuses, - we have to check whether the corresponding arguments have names, not to - trigger an error in the impargs code. Even better, the names we have to - check are not the current ones (after previous renamings), but the original - ones (inferred from the type). *) - let implicits = List.map (fun { name; implicit_status = i } -> (name,i)) args in let implicits = implicits :: more_implicits in - let open Vernacexpr in - let rec build_implicits inf_names implicits = - match inf_names, implicits with - | _, [] -> [] - | _ :: inf_names, (_, NotImplicit) :: implicits -> - build_implicits inf_names implicits - - (* With the current impargs API, it is impossible to make an originally - anonymous argument implicit *) - | Anonymous :: _, (name, _) :: _ -> - user_err ~hdr:"vernac_declare_arguments" - (strbrk"Argument "++ Name.print name ++ - strbrk " cannot be declared implicit.") - - | Name id :: inf_names, (name, impl) :: implicits -> - let max = impl = MaximallyImplicit in - (ExplByName id,max,false) :: build_implicits inf_names implicits - - | _ -> assert false (* already checked in [names_union] *) - in - - let implicits = List.map (build_implicits inf_names) implicits in - let implicits_specified = match implicits with [[]] -> false | _ -> true in + let implicits = List.map (List.map snd) implicits in + let implicits_specified = match implicits with + | [l] -> List.exists (function Impargs.NotImplicit -> false | _ -> true) l + | _ -> true in if implicits_specified && clear_implicits_flag then user_err Pp.(str "The \"clear implicits\" flag is incompatible with implicit annotations"); @@ -1415,10 +1380,10 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red end; if implicits_specified || clear_implicits_flag then - vernac_declare_implicits ~section_local reference implicits; + Impargs.set_implicits section_local (smart_global reference) implicits; if default_implicits_flag then - vernac_declare_implicits ~section_local reference []; + Impargs.declare_implicits section_local (smart_global reference); if red_modifiers_specified then begin match sr with diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 2eb901890b..d1da7c0602 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -237,13 +237,11 @@ type vernac_cumulative = VernacCumulative | VernacNonCumulative (** {6 The type of vernacular expressions} *) -type vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit - type vernac_argument_status = { name : Name.t; recarg_like : bool; notation_scope : string CAst.t option; - implicit_status : vernac_implicit_status; + implicit_status : Impargs.implicit_kind; } type extend_name = @@ -355,7 +353,7 @@ type nonrec vernac_expr = onlyparsing_flag | VernacArguments of qualid or_by_notation * vernac_argument_status list (* Main arguments status list *) * - (Name.t * vernac_implicit_status) list list (* Extra implicit status lists *) * + (Name.t * Impargs.implicit_kind) list list (* Extra implicit status lists *) * int option (* Number of args to trigger reduction *) * [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | @@ -409,3 +407,9 @@ type vernac_control = | VernacRedirect of string * vernac_control CAst.t | VernacTimeout of int * vernac_control | VernacFail of vernac_control + +(** Deprecated *) + +type vernac_implicit_status = Impargs.implicit_kind = + | Implicit [@ocaml.deprecated] | MaximallyImplicit [@ocaml.deprecated] | NotImplicit [@ocaml.deprecated] +[@@ocaml.deprecated "Use [Impargs.implicit_kind]"] |