diff options
347 files changed, 12933 insertions, 12175 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f1dc793ee7..1a1d31bdd7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2020-03-11-V28" + CACHEKEY: "bionic_coq-V2020-03-13-V69" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -41,6 +41,7 @@ docker-boot: except: variables: - $SKIP_DOCKER == "true" + - $ONLY_WINDOWS == "true" tags: - docker @@ -62,6 +63,9 @@ before_script: # TODO figure out how to build doc for installed Coq .build-template: stage: stage-1 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true artifacts: name: "$CI_JOB_NAME" @@ -100,6 +104,9 @@ before_script: # Template for building Coq + stdlib, typical use: overload the switch .dune-template: stage: stage-1 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: [] script: @@ -124,6 +131,9 @@ before_script: .dune-ci-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true needs: - build:edge+flambda:dune:dev @@ -151,6 +161,9 @@ before_script: .doc-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: - not-a-real-job @@ -167,6 +180,9 @@ before_script: # set dependencies when using .test-suite-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: - not-a-real-job @@ -189,11 +205,17 @@ before_script: # set dependencies when using .validate-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true dependencies: - not-a-real-job script: - - cd _install_ci + # exit 0: workaround for https://gitlab.com/gitlab-org/gitlab/issues/202505 + # the validate:quick job is sometimes started before build:quick, without artifacts + # we ignore these spurious errors so if the job fails it's a real error + - cd _install_ci || exit 0 - find lib/coq/ -name '*.vo' -fprint0 vofiles - xargs -0 --arg-file=vofiles bin/coqchk -o -m -coqlib lib/coq/ > ../coqchk.log 2>&1 || touch coqchk.failed - tail -n 1000 ../coqchk.log # the log is too big for gitlab so pipe to a file and display the tail @@ -206,6 +228,9 @@ before_script: .ci-template: stage: stage-2 + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true script: - set -e @@ -249,6 +274,9 @@ before_script: .deploy-template: stage: deploy + except: + variables: + - $ONLY_WINDOWS == "true" before_script: - which ssh-agent || ( apt-get update -y && apt-get install openssh-client -y ) - eval $(ssh-agent -s) @@ -350,6 +378,9 @@ pkg:opam: .nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git + except: + variables: + - $ONLY_WINDOWS == "true" interruptible: true stage: stage-1 variables: @@ -685,7 +716,11 @@ library:ci-fiat-crypto: - plugin:ci-rewriter library:ci-flocq: - extends: .ci-template + extends: .ci-template-flambda + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci library:ci-corn: extends: .ci-template-flambda @@ -741,6 +776,13 @@ library:ci-verdi-raft: library:ci-vst: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-flocq + dependencies: + - build:edge+flambda + - library:ci-flocq # Plugins are by definition the projects that depend on Coq's ML API @@ -9,7 +9,9 @@ ## If you're mentioned here and want to update your information, ## either amend this file and commit it, or contact the coqdev list +Guillaume Allais <guillaume.allais@ens-lyon.org> gallais <guillaume.allais@ens-lyon.org> Abhishek Anand <abhishek.anand.iitg@gmail.com> Abhishek Anand (@brixpro-home) <abhishek.anand.iitg@gmail.com> +Abhishek Anand <abhishek.anand.iitg@gmail.com> Abhishek Anand (optiplex7010@home) <abhishek.anand.iitg@gmail.com> Léo Andrès <leo@ndrs.fr> zapashcanon <leo@ndrs.fr> Jim Apple <github.public@jbapple.com> jbapple <github.public@jbapple.com> Bruno Barras <bruno.barras@inria.fr> barras <barras@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -21,13 +23,17 @@ Yves Bertot <yves.bertot@inria.fr> Yves Bertot <Yves.Bertot@inri Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@nardis.inria.fr> Frédéric Besson <frederic.besson@inria.fr> fbesson <fbesson@85f007b7-540e-0410-9357-904b9bb8a0f7> Siddharth Bhat <siddu.druid@gmail.com> Siddharth <siddu.druid@gmail.com> +Lasse Blaauwbroek <lasse@blaauwbroek.eu> Lasse Blaauwbroek <lasse@lasse-work.localdomain> Simon Boulier <simon.boulier@ens-rennes.fr> SimonBoulier <simon.boulier@ens-rennes.fr> +Simon Boulier <simon.boulier@ens-rennes.fr> SimonBoulier <SimonBoulier@users.noreply.github.com> Pierre Boutillier <pierre.boutillier@ens-lyon.org> pboutill <pboutill@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre <pierre.boutillier@ens-lyon.org> Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre Boutillier <pierre.boutillier@pps.univ-paris-diderot.fr> +Michele Caci <michele.caci@gmail.com> mcaci <michele.caci@gmail.com> Arthur Charguéraud <arthur@chargueraud.org> charguer <arthur@chargueraud.org> Xavier Clerc <xavier.clerc@inria.fr> xclerc <xclerc@85f007b7-540e-0410-9357-904b9bb8a0f7> Xavier Clerc <xavier.clerc@inria.fr> xclerc <xavier.clerc@inria.fr> +Cyril Cohen <cohen@crans.org> Cyril Cohen <CohenCyril@users.noreply.github.com> Pierre Corbineau <Pierre.Corbineau@NOSPAM@imag.fr> corbinea <corbinea@85f007b7-540e-0410-9357-904b9bb8a0f7> Judicaël Courant <courant@gforge> courant <courant@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Courtieu <Pierre.Courtieu@cnam.fr> courtieu <courtieu@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -39,8 +45,10 @@ Maxime Dénès <mail@maximedenes.fr> Maxime Dénès <maxime.dene Olivier Desmettre <desmettr@gforge> desmettr <desmettr@85f007b7-540e-0410-9357-904b9bb8a0f7> Damien Doligez <doligez@gforge> doligez <doligez@85f007b7-540e-0410-9357-904b9bb8a0f7> İsmail Dönmez <ismail-s@users.noreply.github.com> Ismail <ismail-s@users.noreply.github.com> +formalize.eth <formalize@protonmail.com> ilya <ilya@localhost.localdomain> Andres Erbsen <andreser@mit.edu> Andres Erbsen <andres@kevix.co> Jim Fehrle <jfehrle@sbcglobal.net> Jim <jfehrle@sbcglobal.net> +Jim Fehrle <jfehrle@sbcglobal.net> Jim Fehrle <jim.fehrle@gmail.com> Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> filliatr <filliatr@85f007b7-540e-0410-9357-904b9bb8a0f7> Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> Jean-Christophe Filliatre <Jean-Christophe.Filliatre@lri.fr> Julien Forest <julien.forest@ensiie.fr> jforest <jforest@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -63,6 +71,7 @@ Jason Gross <jgross@mit.edu> Jason Gross <jasongross9@gmai Vincent Gross <vgross@gforge> vgross <vgross@85f007b7-540e-0410-9357-904b9bb8a0f7> Huang Guan-Shieng <huang@gforge> huang <huang@85f007b7-540e-0410-9357-904b9bb8a0f7> Hugo Herbelin <Hugo.Herbelin@inria.fr> herbelin <herbelin@85f007b7-540e-0410-9357-904b9bb8a0f7> +Hugo Herbelin <Hugo.Herbelin@inria.fr> Hugo Herbelin <herbelin@users.noreply.github.com> Jasper Hugunin <jasperh@cs.washington.edu> Jasper Hugunin <jasper@hashplex.com> Tom Hutchinson <thutchin@gforge> thutchin <thutchin@85f007b7-540e-0410-9357-904b9bb8a0f7> Cezary Kaliszyk <cek@gforge> cek <cek@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -74,13 +83,18 @@ Matej Košík <matej.kosik@inria.fr> Matej Kosik <matej.kosik@in Matej Košík <matej.kosik@inria.fr> Matej Košík <mail@matej-kosik.net> Ambroise Lafont <chaster_killer@hotmail.fr> amblaf <you@example.com> Ambroise Lafont <chaster_killer@hotmail.fr> Ambroise <chaster_killer@hotmail.fr> -Vincent Laporte <Vincent.Laporte@fondation-inria.fr> Vincent Laporte <Vincent.Laporte@gmail.com> +Vincent Laporte <Vincent.Laporte@inria.fr> Vincent Laporte <Vincent.Laporte@gmail.com> +Vincent Laporte <Vincent.Laporte@inria.fr> Vincent Laporte <Vincent.Laporte@fondation-inria.fr> Marc Lasson <marc.lasson@gmail.com> mlasson <marc.lasson@gmail.com> William Lawvere <mundungus.corleone@gmail.com> william-lawvere <mundungus.corleone@gmail.com> +Larry Darryl Lee Jr. <llee454@gmail.com> llee454@gmail.com <llee454@gmail.com> +Xavier Leroy <xavier.leroy@college-de-france.fr> Xavier Leroy <xavier.leroy@inria.fr> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <letouzey@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <pierre.letouzey@inria.fr> Xia Li-yao <lysxia@gmail.com> Lysxia <lysxia@gmail.com> +Yishuai Li <yishuai@cis.upenn.edu> Yishuai Li <yishuai@upenn.edu> Assia Mahboubi <assia.mahboubi@inria.fr> amahboub <amahboub@85f007b7-540e-0410-9357-904b9bb8a0f7> +Kenji Maillard <kenji.maillard@inria.fr> Kenji Maillard <kenji@maillard.blue> Evgeny Makarov <emakarov@gforge> emakarov <emakarov@85f007b7-540e-0410-9357-904b9bb8a0f7> Gregory Malecha <gmalecha@eecs.harvard.edu> Gregory Malecha <gmalecha@cs.harvard.edu> Gregory Malecha <gmalecha@eecs.harvard.edu> Gregory Malecha <gmalecha@gmail.com> @@ -103,9 +117,11 @@ Christine Paulin <cpaulin@gforge> mohring <mohring@85f007b7-540 Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> ppedrot <ppedrot@85f007b7-540e-0410-9357-904b9bb8a0f7> Frederic Peschanski <frederic.peschanski@lip6.fr> fredokun <frederic.peschanski@lip6.fr> Clément Pit-Claudel <clement.pitclaudel@live.com> Clément Pit--Claudel <clement.pitclaudel@live.com> +Clément Pit-Claudel <clement.pitclaudel@live.com> Clément Pit-Claudel <cpitclaudel@users.noreply.github.com> Loïc Pottier <pottier@gforge> pottier <pottier@85f007b7-540e-0410-9357-904b9bb8a0f7> Matthias Puech <puech@gforge> puech <puech@85f007b7-540e-0410-9357-904b9bb8a0f7> Lars Rasmusson <lars.rasmusson@sics.se> larsr <Lars.Rasmusson@sics.se> +Lars Rasmusson <lars.rasmusson@sics.se> larsr <Lars.Rasmusson@gmail.com> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> ddr <ddr@85f007b7-540e-0410-9357-904b9bb8a0f7> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel De Rauglaudre <ddr@gforge> @@ -116,6 +132,7 @@ Pierre Roux <pierre@roux01.fr> Pierre Roux <pierre.roux@oner Matthew Ryan <mr_1993@hotmail.co.uk> mrmr1993 <mr_1993@hotmail.co.uk> Claudio Sacerdoti Coen <sacerdot@gforge> sacerdot <sacerdot@85f007b7-540e-0410-9357-904b9bb8a0f7> Kazuhiko Sakaguchi <pi8027@gmail.com> Kazuhiko Sakaguchi <sakaguchi@coins.tsukuba.ac.jp> +Kazuhiko Sakaguchi <pi8027@gmail.com> Kazuhiko Sakaguchi <sakaguchi@peano-system.jp> Vincent Siles <vsiles@gforge> vsiles <vsiles@85f007b7-540e-0410-9357-904b9bb8a0f7> Michael Soegtrop <michael.soegtrop@intel.com> Michael Soegtrop <7895506+MSoegtropIMC@users.noreply.github.com> Elie Soubiran <soubiran@gforge> soubiran <soubiran@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -138,8 +155,9 @@ Benjamin Werner <werner@gforge> werner <werner@85f007b7-540e- Wang Zhuyang <hawnzug@gmail.com> hawnzug <hawnzug@gmail.com> Beta Ziliani <beta@mpi-sws.org> Beta Ziliani <bziliani@famaf.unc.edu.ar> Beta Ziliani <beta@mpi-sws.org> beta <beta@mpi-sws.org> -Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Theo Zimmermann <theo.zimmermann@ens.fr> -Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Théo Zimmermann <theo.zimmi@gmail.com> +Théo Zimmermann <theo.zimmermann@inria.fr> Theo Zimmermann <theo.zimmermann@ens.fr> +Théo Zimmermann <theo.zimmermann@inria.fr> Théo Zimmermann <theo.zimmi@gmail.com> +Théo Zimmermann <theo.zimmermann@inria.fr> Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> # Anonymous accounts diff --git a/.ocamlformat b/.ocamlformat index 4480935e3b..62e609fb55 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.13.0 +version=0.14.0 profile=ocamlformat # to enable a whole directory, put "disable=false" in dir/.ocamlformat @@ -11,4 +11,4 @@ cases-exp-indent=2 field-space=loose exp-grouping=preserve break-cases=fit -doc-comments=before +doc-comments-val=before diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index d9adaf5dc7..3582d18cf6 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -30,17 +30,18 @@ well. - [Helping triage existing issues](#helping-triage-existing-issues) - [Code changes](#code-changes) - [Using GitHub pull requests](#using-github-pull-requests) + - [Fixing bugs and performing small changes](#fixing-bugs-and-performing-small-changes) + - [Proposing large changes: Coq Enhancement Proposals](#proposing-large-changes-coq-enhancement-proposals) + - [Seeking early feedback on work-in-progress](#seeking-early-feedback-on-work-in-progress) - [Taking feedback into account](#taking-feedback-into-account) - [Understanding automatic feedback](#understanding-automatic-feedback) - [Understanding reviewers' feedback](#understanding-reviewers-feedback) - [Fixing your branch](#fixing-your-branch) - [Improving the official documentation](#improving-the-official-documentation) - [Contributing to the standard library](#contributing-to-the-standard-library) - - [Fixing bugs and performing small changes](#fixing-bugs-and-performing-small-changes) - - [Proposing large changes: Coq Enhancement Proposals](#proposing-large-changes-coq-enhancement-proposals) - - [Collaborating on a pull request](#collaborating-on-a-pull-request) - [Becoming a maintainer](#becoming-a-maintainer) - [Reviewing pull requests](#reviewing-pull-requests) + - [Collaborating on a pull request](#collaborating-on-a-pull-request) - [Merging pull requests](#merging-pull-requests) - [Additional notes for pull request reviewers and assignees](#additional-notes-for-pull-request-reviewers-and-assignees) - [Joining / leaving maintainer teams](#joining--leaving-maintainer-teams) @@ -443,6 +444,72 @@ several months after your PR is merged). That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. +#### Fixing bugs and performing small changes #### + +Before fixing a bug, it is best to check that it was reported before: + +- If it was already reported and you intend to fix it, self-assign the + issue (if you have the permission), or leave a comment marking your + intention to work on it (and a contributor with write-access may + then assign the issue to you). + +- If the issue already has an assignee, you should check with them if + they still intend to work on it. If the assignment is several + weeks, months, or even years (!) old, there are good chances that it + does not reflect their current priorities. + +- If the bug has not been reported before, it can be a good idea to + open an issue about it, while stating that you are preparing a fix. + The issue can be the place to discuss about the bug itself while the + PR will be the place to discuss your proposed fix. + +It is generally a good idea to add a regression test to the +test-suite. See the test-suite [README][test-suite-README] for how to +do so. + +Small fixes do not need any documentation, or changelog update. New, +or updated, user-facing features, and major bug fixes do. See above +on how to contribute to the documentation, and the README in +[`doc/changelog`][user-changelog] for how to add a changelog entry. + +#### Proposing large changes: Coq Enhancement Proposals #### + +You are always welcome to open a PR for a change of any size. +However, you should be aware that the larger the change, the higher +the chances it will take very long to review, and possibly never get +merged. + +So it is recommended that before spending a lot of time coding, you +seek feedback from maintainers to see if your change would be +supported, and if they have recommendations about its implementation. +You can do this informally by opening an issue, or more formally by +producing a design document as a [Coq Enhancement Proposal][CEP]. + +Another recommendation is that you do not put several unrelated +changes in the same PR (even if you produced them together). In +particular, make sure you split bug fixes into separate PRs when this +is possible. More generally, smaller-sized PRs, or PRs changing less +components, are more likely to be reviewed and merged promptly. + +#### Seeking early feedback on work-in-progress #### + +You should always feel free to open your PR before the documentation, +changelog entry and tests are ready. That's the purpose of the +checkboxes in the PR template which you can leave unticked. This can +be a way of getting reviewers' approval before spending time on +writing the documentation (but you should still do it before your PR +can be merged). + +If even the implementation is not ready but you are still looking for +early feedback on your code changes, please use the [draft +PR](#draft-pull-requests) mechanism. + +If you are looking for feedback on the design of your change, rather +than on its implementation, then please refrain from opening a PR. +You may open an issue to start a discussion, or create a [Coq +Enhancement Proposal][CEP] if you have a clear enough view of the +design to write a document about it. + ### Taking feedback into account ### #### Understanding automatic feedback #### @@ -503,9 +570,10 @@ We have a linter that checks a few different things: [Style guide](#style-guide) for additional style recommendations. - **Code is properly formatted**: for some parts of the codebase, formatting will be enforced using the - [`ocamlformat`](https://github.com/ocaml-ppx/ocamlformat) tool. You - can integrate the formatter in your editor of choice (see docs) or - use `dune build @fmt --auto-promote` to fix this kind of errors. + [`ocamlformat`](https://github.com/ocaml-ppx/ocamlformat) tool. + Formatting issues will also be fixed automatically by the pre-commit + hook mentioned above (you may also use `dune build @fmt + --auto-promote` to fix this kind of errors). You may run the linter yourself with `dev/lint-repository.sh`. @@ -643,59 +711,35 @@ Add coqdoc comments to extend the [standard library documentation][stdlib-doc]. See the [coqdoc documentation][coqdoc-documentation] to learn more. -### Fixing bugs and performing small changes ### - -Before fixing a bug, it is best to check that it was reported before: - -- If it was already reported and you intend to fix it, self-assign the - issue (if you have the permission), or leave a comment marking your - intention to work on it (and a contributor with write-access may - then assign the issue to you). - -- If the issue already has an assignee, you should check with them if - they still intend to work on it. If the assignment is several - weeks, months, or even years (!) old, there are good chances that it - does not reflect their current priorities. - -- If the bug has not been reported before, it can be a good idea to - open an issue about it, while stating that you are preparing a fix. - The issue can be the place to discuss about the bug itself while the - PR will be the place to discuss your proposed fix. - -In any case, feel free to just ignore the recommendation above, and -jump ahead and open a PR with your fix. If it is not yet complete, do -not hesitate to open a [*draft PR*][GitHub-draft-PR] to get early -feedback, and talk to developers on [Gitter][]. - -It is generally a good idea to add a regression test to the -test-suite. See the test-suite [README][test-suite-README] for how to -do so. - -Small fixes do not need any documentation, or changelog update. New, -or updated, user-facing features, and major bug fixes do. See above -on how to contribute to the documentation, and the README in -[`doc/changelog`][user-changelog] for how to add a changelog entry. +## Becoming a maintainer ## -### Proposing large changes: Coq Enhancement Proposals ### +### Reviewing pull requests ### -You are always welcome to open a PR for a change of any size. -However, you should be aware that the larger the change, the higher -the chances it will take very long to review, and possibly never get -merged. +You can start reviewing PRs as soon as you feel comfortable doing so +(anyone can review anything, although some designated reviewers +will have to give a final approval before a PR can be merged, as is +explained in the next sub-section). -So it is recommended that before spending a lot of time coding, you -seek feedback from maintainers to see if your change would be -supported, and if they have recommendations about its implementation. -You can do this informally by opening an issue, or more formally by -producing a design document as a [Coq Enhancement Proposal][CEP]. +Reviewers should ensure that the code that is changed or introduced is +in good shape and will not be a burden to maintain, is unlikely to +break anything, or the compatibility-breakage has been identified and +validated, includes documentation, changelog entries, and test files +when necessary. Reviewers can use labels, or change requests to +further emphasize what remains to be changed before they can approve +the PR. Once reviewers are satisfied (regarding the part they +reviewed), they should formally approve the PR, possibly stating what +they reviewed. -Another recommendation is that you do not put several unrelated -changes in the same PR (even if you produced them together). In -particular, make sure you split bug fixes into separate PRs when this -is possible. More generally, smaller-sized PRs, or PRs changing less -components, are more likely to be reviewed and merged promptly. +That being said, reviewers should also make sure that they do not make +the contributing process harder than necessary: they should make it +clear which comments are really required to perform before approving, +and which are just suggestions. They should strive to reduce the +number of rounds of feedback that are needed by posting most of their +comments at the same time. If they are opposed to the change, they +should clearly say so from the beginning to avoid the contributor +spending time in vain. -### Collaborating on a pull request ### +#### Collaborating on a pull request #### Beyond making suggestions to a PR author during the review process, you may want to collaborate further by checking out the code, making @@ -720,42 +764,14 @@ else), this should be reflected by adding ["Co-authored-by:" tags][GitHub-co-authored-by] at the end of the commit message. The line should contain the co-author name and committer e-mail address. -## Becoming a maintainer ## - -### Reviewing pull requests ### - -You can start reviewing PRs as soon as you feel comfortable doing so -(anyone can review anything, although some designated reviewers -will have to give a final approval before a PR can be merged, as is -explained in the next sub-section). - -Reviewers should ensure that the code that is changed or introduced is -in good shape and will not be a burden to maintain, is unlikely to -break anything, or the compatibility-breakage has been identified and -validated, includes documentation, changelog entries, and test files -when necessary. Reviewers can use labels, or change requests to -further emphasize what remains to be changed before they can approve -the PR. Once reviewers are satisfied (regarding the part they -reviewed), they should formally approve the PR, possibly stating what -they reviewed. - -That being said, reviewers should also make sure that they do not make -the contributing process harder than necessary: they should make it -clear which comments are really required to perform before approving, -and which are just suggestions. They should strive to reduce the -number of rounds of feedback that are needed by posting most of their -comments at the same time. If they are opposed to the change, they -should clearly say so from the beginning to avoid the contributor -spending time in vain. - ### Merging pull requests ### Our [CODEOWNERS][] file associates a team of maintainers to each -component. When a PR is opened (or a draft PR is marked as ready for -review), GitHub will automatically request reviews to maintainer teams -of affected components. As soon as it is the case, one available -member of a team that was requested a review should self-assign the -PR, and will act as its shepherd from then on. +component. When a PR is opened (or a [draft PR](#draft-pull-requests) +is marked as ready for review), GitHub will automatically request +reviews to maintainer teams of affected components. As soon as it is +the case, one available member of a team that was requested a review +should self-assign the PR, and will act as its shepherd from then on. The PR assignee is responsible for making sure that all the proposed changes have been reviewed by relevant maintainers (at least one @@ -1099,6 +1115,33 @@ 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][]. +##### Draft pull requests ##### + +[Draft PRs][GitHub-draft-PR] are a mechanism proposed by GitHub to +open a pull request before it is ready for review. + +Opening a draft PR is a way of announcing a change and seeking early +feedback without formally requesting maintainers' reviews. Indeed, +you should avoid cluttering our maintainers' review request lists +before a change is ready on your side. + +When opening a draft PR, make sure to give it a descriptive enough +title so that interested developers still notice it in their +notification feed. You may also advertise it by talking about it in +our [developer chat][Gitter]. If you know which developer would be +able to provide useful feedback to you, you may also ping them. + +###### Turning a PR into draft mode ###### + +If a PR was opened as ready for review, but it turns out that it still +needs work, it can be transformed into a draft PR. + +In this case, previous review requests won't be removed automatically. +Someone with write access to the repository should remove them +manually. Afterwards, upon marking the PR as ready for review, +someone with write access will have to manually add the review +requests that were previously removed. + #### GitLab documentation, tips and tricks #### We use GitLab mostly for its CI service. The [Coq organization on diff --git a/Makefile.build b/Makefile.build index 5b26f11b12..d705219757 100644 --- a/Makefile.build +++ b/Makefile.build @@ -201,12 +201,12 @@ DEPENDENCIES := \ # Default timing command # Use /usr/bin/env time on linux, gtime on Mac OS -TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" +TIMEFMT?="$@ (real: %e, user: %U, sys: %S, mem: %M ko)" ifneq (,$(TIMED)) -ifeq (0,$(shell /usr/bin/env time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +ifeq (0,$(shell /usr/bin/env time -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=/usr/bin/env time -f $(TIMEFMT) else -ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=gtime -f $(TIMEFMT) else STDTIME?=time @@ -269,10 +269,6 @@ OPT:= BESTOBJ:=.cmo BESTLIB:=.cma BESTDYN:=.cma - -# needed while booting if non -local -CAML_LD_LIBRARY_PATH := $(PWD)/kernel/byterun:$(CAML_LD_LIBRARY_PATH) -export CAML_LD_LIBRARY_PATH endif define bestobj diff --git a/Makefile.ci b/Makefile.ci index d4383fd409..1a5e8166a2 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -76,6 +76,8 @@ ci-quickchick: ci-ext-lib ci-simple-io ci-metacoq: ci-equations +ci-vst: ci-flocq + # Generic rule, we use make to ease CI integration $(CI_TARGETS): ci-%: +./dev/ci/ci-wrapper.sh $* diff --git a/Makefile.doc b/Makefile.doc index effd624cff..8be032ceb3 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -100,6 +100,9 @@ doc-stdlib: \ full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf +sphinx-clean: + rm -rf $(SPHINXBUILDDIR) + .PHONY: plugin-tutorial plugin-tutorial: states tools +$(MAKE) COQBIN=$(PWD)/bin/ -C $(PLUGINTUTO) diff --git a/Makefile.dune b/Makefile.dune index 9e1747a4c3..b002c7709d 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -59,7 +59,7 @@ voboot: @echo "This target is empty and not needed anymore" states: - dune build --display=short $(DUNEOPT) dev/shim/coqtop-prelude + dune build $(DUNEOPT) dev/shim/coqtop-prelude NONDOC_INSTALL_TARGETS:=coq.install coqide-server.install coqide.install diff --git a/checker/check.ml b/checker/check.ml index bb3255338f..31bfebc3d5 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -255,7 +255,7 @@ let try_locate_qualified_library lib = match lib with (*s Low-level interning of libraries from files *) let raw_intern_library f = - System.raw_intern_state Coq_config.vo_magic_number f + ObjFile.open_in ~file:f (************************************************************************) (* Internalise libraries *) @@ -294,57 +294,56 @@ type intern_mode = Rec | Root | Dep (* Rec = standard, Root = -norec, Dep = depe (* Dependency graph *) let depgraph = ref LibraryMap.empty -let marshal_in_segment ~validate ~value f ch = +let marshal_in_segment ~validate ~value ~segment f ch = + let () = LargeFile.seek_in ch segment.ObjFile.pos in if validate then - let v, stop, digest = + let v = try - let stop = input_binary_int ch in let v = Analyze.parse_channel ch in let digest = Digest.input ch in - v, stop, digest + let () = if not (String.equal digest segment.ObjFile.hash) then raise Exit in + v with _ -> user_err (str "Corrupted file " ++ quote (str f)) in - let () = Validate.validate ~debug:!Flags.debug value v in + let () = Validate.validate value v in let v = Analyze.instantiate v in - Obj.obj v, stop, digest + Obj.obj v else - System.marshal_in_segment f ch + System.marshal_in f ch -let skip_in_segment f ch = - try - let stop = (input_binary_int ch : int) in - seek_in ch stop; - let digest = Digest.input ch in - stop, digest - with _ -> - user_err (str "Corrupted file " ++ quote (str f)) - -let marshal_or_skip ~validate ~value f ch = +let marshal_or_skip ~validate ~value ~segment f ch = if validate then - let v, pos, digest = marshal_in_segment ~validate ~value f ch in - Some v, pos, digest + let v = marshal_in_segment ~validate:true ~value ~segment f ch in + Some v else - let pos, digest = skip_in_segment f ch in - None, pos, digest + None let intern_from_file ~intern_mode (dir, f) = let validate = intern_mode <> Dep in Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try + (* First pass to read the metadata of the file *) let ch = System.with_magic_number_check raw_intern_library f in - let (sd:summary_disk), _, digest = marshal_in_segment ~validate ~value:Values.v_libsum f ch in - let (md:library_disk), _, digest = marshal_in_segment ~validate ~value:Values.v_lib f ch in - let (opaque_csts:seg_univ option), _, udg = marshal_in_segment ~validate ~value:Values.v_univopaques f ch in - let (tasks:'a option), _, _ = marshal_in_segment ~validate ~value:Values.(Opt Any) f ch in - let (table:seg_proofs option), pos, checksum = - marshal_or_skip ~validate ~value:Values.v_opaquetable f ch in + let seg_sd = ObjFile.get_segment ch ~segment:"summary" in + let seg_md = ObjFile.get_segment ch ~segment:"library" in + let seg_univs = ObjFile.get_segment ch ~segment:"universes" in + let seg_tasks = ObjFile.get_segment ch ~segment:"tasks" in + let seg_opaque = ObjFile.get_segment ch ~segment:"opaques" in + let () = ObjFile.close_in ch in + (* Actually read the data *) + let ch = open_in_bin f in + + let (sd:summary_disk) = marshal_in_segment ~validate ~value:Values.v_libsum ~segment:seg_sd f ch in + let (md:library_disk) = marshal_in_segment ~validate ~value:Values.v_lib ~segment:seg_md f ch in + let (opaque_csts:seg_univ option) = marshal_in_segment ~validate ~value:Values.v_univopaques ~segment:seg_univs f ch in + let (tasks:'a option) = marshal_in_segment ~validate ~value:Values.(Opt Any) ~segment:seg_tasks f ch in + let (table:seg_proofs option) = + marshal_or_skip ~validate ~value:Values.v_opaquetable ~segment:seg_opaque f ch in (* Verification of the final checksum *) let () = close_in ch in let ch = open_in_bin f in - if not (String.equal (Digest.channel ch pos) checksum) then - user_err ~hdr:"intern_from_file" (str "Checksum mismatch"); let () = close_in ch in if dir <> sd.md_name then user_err ~hdr:"intern_from_file" @@ -361,8 +360,9 @@ let intern_from_file ~intern_mode (dir, f) = end; Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = - if opaque_csts <> None then Safe_typing.Dvivo (digest,udg) - else (Safe_typing.Dvo_or_vi digest) in + let open ObjFile in + if opaque_csts <> None then Safe_typing.Dvivo (seg_md.hash, seg_univs.hash) + else (Safe_typing.Dvo_or_vi seg_md.hash) in sd,md,table,opaque_csts,digest with e -> Flags.if_verbose chk_pp (str" failed!]" ++ fnl ()); raise e in depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph; diff --git a/checker/check.mllib b/checker/check.mllib index d47a93c70d..a16a871dc3 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -1,5 +1,6 @@ Analyze +CheckFlags CheckInductive Mod_checking CheckTypes diff --git a/checker/checkFlags.ml b/checker/checkFlags.ml new file mode 100644 index 0000000000..1f5e76bd83 --- /dev/null +++ b/checker/checkFlags.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Declarations + +let set_local_flags flags env = + let flags = + { (Environ.typing_flags env) with + check_guarded = flags.check_guarded; + check_positive = flags.check_positive; + check_universes = flags.check_universes; + conv_oracle = flags.conv_oracle; + cumulative_sprop = flags.cumulative_sprop; + } + in + Environ.set_typing_flags flags env diff --git a/checker/checkFlags.mli b/checker/checkFlags.mli new file mode 100644 index 0000000000..2e41e656f1 --- /dev/null +++ b/checker/checkFlags.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val set_local_flags : Declarations.typing_flags -> Environ.env -> Environ.env +(** Set flags except for those ignored by the checker (eg vm_compute). *) diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index a1d5aedb01..c370a77ea0 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -164,16 +164,7 @@ let check_inductive env mind mb = mind_private; mind_typing_flags; } = (* Locally set typing flags for further typechecking *) - let mb_flags = mb.mind_typing_flags in - let env = Environ.set_typing_flags - {env.env_typing_flags with - check_guarded = mb_flags.check_guarded; - check_positive = mb_flags.check_positive; - check_universes = mb_flags.check_universes; - conv_oracle = mb_flags.conv_oracle; - } - env - in + let env = CheckFlags.set_local_flags mb.mind_typing_flags env in Indtypes.check_inductive env ~sec_univs:None mind entry in let check = check mind in diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 44b7089fd0..8fd81d43be 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -17,14 +17,7 @@ let set_indirect_accessor f = indirect_accessor := f let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ Constant.print kn); - let cb_flags = cb.const_typing_flags in - let env = Environ.set_typing_flags - {env.env_typing_flags with - check_guarded = cb_flags.check_guarded; - check_universes = cb_flags.check_universes; - conv_oracle = cb_flags.conv_oracle;} - env - in + let env = CheckFlags.set_local_flags cb.const_typing_flags env in let poly, env = match cb.const_universes with | Monomorphic ctx -> diff --git a/checker/validate.ml b/checker/validate.ml index 66367cb002..20884c4d01 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -208,11 +208,10 @@ let print_frame = function | CtxField i -> Printf.sprintf "fld=%i" i | CtxTag i -> Printf.sprintf "tag=%i" i -let validate ~debug v (o, mem) = +let validate v (o, mem) = try val_gen v mem mt_ec o with ValidObjError(msg,ctx,obj) -> - (if debug then - let ctx = List.rev_map print_frame ctx in - print_endline ("Context: "^String.concat"/"ctx); - pr_obj mem obj); + let rctx = List.rev_map print_frame ctx in + print_endline ("Context: "^String.concat"/"rctx); + pr_obj mem obj; failwith ("Validation failed: "^msg^" (in "^(print_frame (List.hd ctx))^")") diff --git a/checker/validate.mli b/checker/validate.mli index 9ddc510e4a..1204b528f9 100644 --- a/checker/validate.mli +++ b/checker/validate.mli @@ -10,4 +10,4 @@ open Analyze -val validate : debug:bool -> Values.value -> data * obj LargeArray.t -> unit +val validate : Values.value -> data * obj LargeArray.t -> unit diff --git a/checker/values.ml b/checker/values.ml index 12f7135cdf..9bd381e4a9 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -241,7 +241,10 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_opaque|]; [|v_primitive|]|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] + v_tuple "typing_flags" + [|v_bool; v_bool; v_bool; + v_oracle; v_bool; v_bool; + v_bool; v_bool; v_bool|] let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] @@ -372,6 +375,17 @@ let v_compiled_lib = let v_obj = Dyn +let v_globref = Sum("globref",0,[| + [|v_id|]; + [|v_cst|]; + [|v_ind|]; + [|v_cons|] + |]) + +let v_ext_gref = Sum("extended_global_reference",0,[|[|v_globref|];[|v_kn|]|]) + +let v_open_filter = Sum ("open_filter",1,[|[|v_hset v_ext_gref|]|]) + let rec v_aobjs = Sum("algebraic_objects", 0, [| [|v_libobjs|]; [|v_mp;v_subst|] @@ -383,7 +397,7 @@ and v_libobjt = Sum("Libobject.t",0, [| v_substobjs |]; [| v_aobjs |]; [| v_libobjs |]; - [| List v_mp |]; + [| List (v_pair v_open_filter v_mp)|]; [| v_obj |] |]) diff --git a/checker/votour.ml b/checker/votour.ml index a83ba20dd6..3fb3ccadf4 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -349,14 +349,63 @@ let parse_header chan = let size64 = input_binary_int chan in { magic; length; size32; size64; objects } +module ObjFile = +struct + type segment = { name : string; - mutable pos : int; - typ : Values.value; + pos : int64; + len : int64; + hash : Digest.t; mutable header : header; } -let make_seg name typ = { name; typ; pos = 0; header = dummy_header } +let input_int32 ch = + let accu = ref 0l in + for _i = 0 to 3 do + let c = input_byte ch in + accu := Int32.add (Int32.shift_left !accu 8) (Int32.of_int c) + done; + !accu + +let input_int64 ch = + let accu = ref 0L in + for _i = 0 to 7 do + let c = input_byte ch in + accu := Int64.add (Int64.shift_left !accu 8) (Int64.of_int c) + done; + !accu + +let input_segment_summary ch = + let nlen = input_int32 ch in + let name = really_input_string ch (Int32.to_int nlen) in + let pos = input_int64 ch in + let len = input_int64 ch in + let hash = Digest.input ch in + { name; pos; len; hash; header = dummy_header } + +let rec input_segment_summaries ch n accu = + if Int32.equal n 0l then Array.of_list (List.rev accu) + else + let s = input_segment_summary ch in + let accu = s :: accu in + input_segment_summaries ch (Int32.pred n) accu + +let parse_segments ch = + let magic = input_int32 ch in + let version = input_int32 ch in + let summary_pos = input_int64 ch in + let () = LargeFile.seek_in ch summary_pos in + let nsum = input_int32 ch in + let seg = input_segment_summaries ch nsum [] in + for i = 0 to Array.length seg - 1 do + let () = LargeFile.seek_in ch seg.(i).pos in + let header = parse_header ch in + seg.(i).header <- header + done; + (magic, version, seg) + +end let visit_vo f = Printf.printf "\nWelcome to votour !\n"; @@ -364,13 +413,13 @@ let visit_vo f = Printf.printf "Object sizes are in words (%d bits)\n" Sys.word_size; Printf.printf "At prompt, <n> enters the <n>-th child, u goes up 1 level, x exits\n\n%!"; - let segments = [| - make_seg "summary" Values.v_libsum; - make_seg "library" Values.v_lib; - make_seg "univ constraints of opaque proofs" Values.v_univopaques; - make_seg "STM tasks" (Opt Values.v_stm_seg); - make_seg "opaque proofs" Values.v_opaquetable; - |] in + let known_segments = [ + "summary", Values.v_libsum; + "library", Values.v_lib; + "universes", Values.v_univopaques; + "tasks", (Opt Values.v_stm_seg); + "opaques", Values.v_opaquetable; + ] in let repr = if Sys.word_size = 64 then (module ReprMem : S) else (module ReprObj : S) (* On 32-bit machines, representation may exceed the max size of arrays *) @@ -379,28 +428,23 @@ let visit_vo f = let module Visit = Visit(Repr) in while true do let ch = open_in_bin f in - let magic = input_binary_int ch in - Printf.printf "File format: %d\n%!" magic; - for i=0 to Array.length segments - 1 do - let pos = input_binary_int ch in - segments.(i).pos <- pos_in ch; - let header = parse_header ch in - segments.(i).header <- header; - seek_in ch pos; - ignore(Digest.input ch); - done; + let (_magic, version, segments) = ObjFile.parse_segments ch in + Printf.printf "File format: %ld\n%!" version; Printf.printf "The file has %d segments, choose the one to visit:\n" (Array.length segments); - Array.iteri (fun i { name; pos; header } -> + Array.iteri (fun i ObjFile.{ name; pos; header } -> let size = if Sys.word_size = 64 then header.size64 else header.size32 in - Printf.printf " %d: %s, starting at byte %d (size %iw)\n" i name pos size) + Printf.printf " %d: %s, starting at byte %Ld (size %iw)\n" i name pos size) segments; match read_num (Array.length segments) with | Some seg -> - seek_in ch segments.(seg).pos; + let seg = segments.(seg) in + let open ObjFile in + LargeFile.seek_in ch seg.pos; let o = Repr.input ch in let () = Visit.init () in - Visit.visit segments.(seg).typ o [] + let typ = try List.assoc seg.name known_segments with Not_found -> Any in + Visit.visit typ o [] | None -> () done diff --git a/config/coq_config.mli b/config/coq_config.mli index 6ed4bf9b8e..12856cb6e6 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -35,7 +35,7 @@ val caml_version : string (* OCaml version used to compile Coq *) val caml_version_nums : int list (* OCaml version used to compile Coq by components *) val date : string (* release date *) val compile_date : string (* compile date *) -val vo_magic_number : int +val vo_version : int32 val state_magic_number : int val all_src_dirs : string list diff --git a/configure.ml b/configure.ml index eaa0e321b0..0eff70999d 100644 --- a/configure.ml +++ b/configure.ml @@ -983,7 +983,7 @@ let config_runtime () = ["-dllib";"-lcoqrun";"-dllpath";("\"" ^ coqtop ^ "/kernel/byterun\"")] | _ -> let ld="CAML_LD_LIBRARY_PATH" in - build_loadpath := sprintf "export %s:='%s/kernel/byterun':$(%s)" ld coqtop ld; + build_loadpath := sprintf "export %s:=%s/kernel/byterun:$(%s)" ld coqtop ld; ["-dllib";"-lcoqrun";"-dllpath";coqlib/"kernel/byterun"] let vmbyteflags = config_runtime () @@ -1059,6 +1059,7 @@ let write_configml f = let pr_s = pr "let %s = %S\n" in let pr_b = pr "let %s = %B\n" in let pr_i = pr "let %s = %d\n" in + let pr_i32 = pr "let %s = %dl\n" in let pr_p s o = pr "let %s = %S\n" s (match o with Relative s -> s | Absolute s -> s) in let pr_li n l = pr "let %s = [%s]\n" n (String.concat ";" (List.map string_of_int l)) in @@ -1086,7 +1087,7 @@ let write_configml f = pr_s "exec_extension" exe; pr "let gtk_platform = `%s\n" !idearchdef; pr_b "has_natdynlink" hasnatdynlink; - pr_i "vo_magic_number" vo_magic; + pr_i32 "vo_version" vo_magic; pr_i "state_magic_number" state_magic; pr_s "browser" browser; pr_s "wwwcoq" !prefs.coqwebsite; diff --git a/dev/base_include b/dev/base_include index 96a867475d..45e79147c1 100644 --- a/dev/base_include +++ b/dev/base_include @@ -129,7 +129,7 @@ open Elim open Equality open Hipattern open Inv -open Leminv +open Ltac_plugin.Leminv open Tacticals open Tactics open Eqschemes diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index e9f8324f28..7a9531216e 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download Flocq -( cd "${CI_BUILD_DIR}/Flocq" && autoconf && ./configure && ./remake "-j${NJOBS}" ) +( cd "${CI_BUILD_DIR}/Flocq" && autoconf && ./configure && ./remake "-j${NJOBS}" && ./remake install ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 58677b8496..e240ea3ba1 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-03-11-V28" +# CACHEKEY: "bionic_coq-V2020-03-13-V69" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -22,7 +22,7 @@ RUN pip3 install sphinx==1.8.0 sphinx_rtd_theme==0.2.5b2 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 # We need to install OPAM 2.0 manually for now. -RUN wget https://github.com/ocaml/opam/releases/download/2.0.5/opam-2.0.5-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam +RUN wget https://github.com/ocaml/opam/releases/download/2.0.6/opam-2.0.6-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam # Basic OPAM setup ENV NJOBS="2" \ @@ -57,7 +57,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ # EDGE switch ENV COMPILER_EDGE="4.10.0" \ - BASE_OPAM_EDGE="dune.2.5.0 dune-release.1.3.3 ocamlformat.0.13.0" + BASE_OPAM_EDGE="dune.2.5.0 dune-release.1.3.3 ocamlformat.0.14.0" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh b/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh new file mode 100644 index 0000000000..4170799be7 --- /dev/null +++ b/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11820" ] || [ "$CI_BRANCH" = "partial-import" ]; then + + elpi_CI_REF=partial-import + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + +fi diff --git a/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh b/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh new file mode 100644 index 0000000000..cd6b408813 --- /dev/null +++ b/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh @@ -0,0 +1,24 @@ +if [ "$CI_PULL_REQUEST" = "11896" ] || [ "$CI_BRANCH" = "evar-inst-list" ]; then + + coqhammer_CI_REF="evar-inst-list" + coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer + + elpi_CI_REF="evar-inst-list" + elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi + + equations_CI_REF="evar-inst-list" + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + + metacoq_CI_REF="evar-inst-list" + metacoq_CI_GITURL=https://github.com/ppedrot/metacoq + + mtac2_CI_REF="evar-inst-list" + mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 + + quickchick_CI_REF="evar-inst-list" + quickchick_CI_GITURL=https://github.com/ppedrot/QuickChick + + unicoq_CI_REF="evar-inst-list" + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + +fi diff --git a/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh b/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh new file mode 100644 index 0000000000..6bee3c7bb6 --- /dev/null +++ b/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "12023" ] || [ "$CI_BRANCH" = "master+fixing-empty-Ltac-v-file" ]; then + + fiat_crypto_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + fiat_crypto_CI_GITURL=https://github.com/herbelin/fiat-crypto + + mtac2_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + mtac2_CI_GITURL=https://github.com/herbelin/Mtac2 + + metacoq_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + metacoq_CI_GITURL=https://github.com/herbelin/template-coq + + unimath_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + unimath_CI_GITURL=https://github.com/herbelin/UniMath + +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index eac8d86b0a..9498ab8bbb 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -9,6 +9,13 @@ ### ML API +Proof state and constant declaration: + +- A large consolidation of the API handling interactive and + non-interactive constant has been performed; low-level APIs are no + longer available, and the functionality of the `Proof_global` module + has been merged into `Declare`. + Notations: - Most operators on numerals have moved to file numTok.ml. @@ -68,7 +75,6 @@ Proof state: information related to the constant declaration. Some functions have been renamed from `start_proof` to `start_lemma` - Plugins that require access to the information about currently opened lemmas can add one of the `![proof]` attributes to their `mlg` entry, which will refine the type accordingly. See diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 7002cbffac..00050a89e1 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -59,8 +59,8 @@ let prrecarg = function let ppwf_paths x = pp (Rtree.pp_tree prrecarg x) let get_current_context () = - try Vernacstate.Proof_global.get_current_context () - with Vernacstate.Proof_global.NoCurrentProof -> + try Vernacstate.Declare.get_current_context () + with Vernacstate.Declare.NoCurrentProof -> let env = Global.env() in Evd.from_env env, env [@@ocaml.warning "-3"] @@ -287,7 +287,7 @@ let constr_display csr = "LetIn("^(name_display na)^","^(term_display b)^"," ^(term_display t)^","^(term_display c)^")" | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" - | Evar (e,l) -> "Evar("^(Pp.string_of_ppcmds (Evar.print e))^","^(array_display l)^")" + | Evar (e,l) -> "Evar("^(Pp.string_of_ppcmds (Evar.print e))^","^(array_display (Array.of_list l))^")" | Const (c,u) -> "Const("^(Constant.to_string c)^","^(universes_display u)^")" | Ind ((sp,i),u) -> "MutInd("^(MutInd.to_string sp)^","^(string_of_int i)^","^(universes_display u)^")" @@ -383,7 +383,7 @@ let print_pure_constr csr = Array.iter (fun x -> print_space (); box_display x) l; print_string ")" | Evar (e,l) -> print_string "Evar#"; print_int (Evar.repr e); print_string "{"; - Array.iter (fun x -> print_space (); box_display x) l; + List.iter (fun x -> print_space (); box_display x) l; print_string"}" | Const (c,u) -> print_string "Cons("; sp_con_display c; diff --git a/doc/changelog/01-kernel/11972-fix-require-in-section.rst b/doc/changelog/01-kernel/11972-fix-require-in-section.rst new file mode 100644 index 0000000000..7a2fa9185f --- /dev/null +++ b/doc/changelog/01-kernel/11972-fix-require-in-section.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Using :cmd:`Require` inside a section caused an anomaly when closing + the section. (`#11972 <https://github.com/coq/coq/pull/11972>`_, by + Gaëtan Gilbert, fixing `#11783 + <https://github.com/coq/coq/issues/11783>`_, reported by Attila + Boros). diff --git a/doc/changelog/04-tactics/11023-nativecompute-timing.rst b/doc/changelog/04-tactics/11023-nativecompute-timing.rst deleted file mode 100644 index e8cdfcca21..0000000000 --- a/doc/changelog/04-tactics/11023-nativecompute-timing.rst +++ /dev/null @@ -1,7 +0,0 @@ -- The :flag:`NativeCompute Timing` flag causes calls to - :tacn:`native_compute` (as well as kernel calls to the native - compiler) to emit separate timing information about compilation, - execution, and reification. It replaces the timing information - previously emitted when the `-debug` flag was set, and allows more - fine-grained timing of the native compiler (`#11023 - <https://github.com/coq/coq/pull/11023>`_, by Jason Gross). diff --git a/doc/changelog/04-tactics/11025-nativecompute-timing.rst b/doc/changelog/04-tactics/11025-nativecompute-timing.rst new file mode 100644 index 0000000000..cb77457c31 --- /dev/null +++ b/doc/changelog/04-tactics/11025-nativecompute-timing.rst @@ -0,0 +1,11 @@ +- **Changed:** The :flag:`NativeCompute Timing` flag causes calls to + :tacn:`native_compute` (as well as kernel calls to the native + compiler) to emit separate timing information about conversion to + native code, compilation, execution, and reification. It replaces + the timing information previously emitted when the `-debug` flag was + set, and allows more fine-grained timing of the native compiler + (`#11025 <https://github.com/coq/coq/pull/11025>`_, by Jason Gross). + Additionally, the timing information now uses real time rather than + user time (Fixes `#11962 + <https://github.com/coq/coq/issues/11962>`_, `#11963 + <https://github.com/coq/coq/pull/11963>`_, by Jason Gross) diff --git a/doc/changelog/04-tactics/11883-fix-autounfold.rst b/doc/changelog/04-tactics/11883-fix-autounfold.rst new file mode 100644 index 0000000000..83ff177380 --- /dev/null +++ b/doc/changelog/04-tactics/11883-fix-autounfold.rst @@ -0,0 +1,13 @@ +- **Fixed:** + The behavior of :tacn:`autounfold` no longer depends on the names of terms and modules + (`#11883 <https://github.com/coq/coq/pull/11883>`_, + fixes `#7812 <https://github.com/coq/coq/issues/7812>`_, + by Attila Gáspár). +- **Changed:** + `at` clauses can no longer be used with :tacn:`autounfold`. Since they had no effect, it is safe to remove them + (`#11883 <https://github.com/coq/coq/pull/11883>`_, + by Attila Gáspár). +- **Changed:** + :tacn:`autounfold` no longer fails when the :cmd:`Opaque` command is used on constants in the hint databases + (`#11883 <https://github.com/coq/coq/pull/11883>`_, + by Attila Gáspár). diff --git a/doc/changelog/04-tactics/11976-deprecate-omega.rst b/doc/changelog/04-tactics/11976-deprecate-omega.rst new file mode 100644 index 0000000000..59c9612d17 --- /dev/null +++ b/doc/changelog/04-tactics/11976-deprecate-omega.rst @@ -0,0 +1,5 @@ +- **Deprecated:** + The :tacn:`omega` tactic is deprecated; + use :tacn:`lia` from the :ref:`Micromega <micromega>` plugin instead + (`#11976 <https://github.com/coq/coq/pull/11976>`_, + by Vincent Laporte). diff --git a/doc/changelog/04-tactics/12023-master+fixing-empty-Ltac-v-file.rst b/doc/changelog/04-tactics/12023-master+fixing-empty-Ltac-v-file.rst new file mode 100644 index 0000000000..f10208e9b2 --- /dev/null +++ b/doc/changelog/04-tactics/12023-master+fixing-empty-Ltac-v-file.rst @@ -0,0 +1,6 @@ +- **Changed:** + Tactics with qualified name of the form ``Coq.Init.Notations`` are + now qualified with prefix ``Coq.Init.Ltac``; users of the -noinit + option should now import Coq.Init.Ltac if they want to use Ltac + (`#12023 <https://github.com/coq/coq/pull/12023>`_, + by Hugo Herbelin; minor source of incompatibilities). diff --git a/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst b/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst new file mode 100644 index 0000000000..7af2b4d97b --- /dev/null +++ b/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Anomaly with induction schemes whose conclusion is not normalized + (`#12116 <https://github.com/coq/coq/pull/12116>`_, + by Hugo Herbelin; fixes + `#12045 <https://github.com/coq/coq/pull/12045>`_) diff --git a/doc/changelog/07-commands-and-options/12034-cumul-sprop.rst b/doc/changelog/07-commands-and-options/12034-cumul-sprop.rst new file mode 100644 index 0000000000..ad7cf44482 --- /dev/null +++ b/doc/changelog/07-commands-and-options/12034-cumul-sprop.rst @@ -0,0 +1,5 @@ +- **Changed:** + Added :flag:`Cumulative StrictProp` to control cumulativity of + |SProp| and deprecated now redundant command line + ``--cumulative-sprop`` (`#12034 + <https://github.com/coq/coq/pull/12034>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst b/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst new file mode 100644 index 0000000000..0f30b5f5e8 --- /dev/null +++ b/doc/changelog/07-commands-and-options/12070-native-compiler-disabled.rst @@ -0,0 +1,5 @@ +- **Changed:** + Ignore -native-compiler option when built without native compute + support. + (`#12070 <https://github.com/coq/coq/pull/12070>`_, + by Pierre Roux). diff --git a/doc/changelog/08-tools/12026-master+coqdoc-self-linked-defs-wish7093.rst b/doc/changelog/08-tools/12026-master+coqdoc-self-linked-defs-wish7093.rst new file mode 100644 index 0000000000..5c4ef82b8b --- /dev/null +++ b/doc/changelog/08-tools/12026-master+coqdoc-self-linked-defs-wish7093.rst @@ -0,0 +1,4 @@ +- **Added:** + Definitions in coqdoc link to themselves, giving access in html to their own url + (`#12026 <https://github.com/coq/coq/pull/12026>`_, + by Hugo Herbelin; granting `#7093 <https://github.com/coq/coq/pull/7093>`_). diff --git a/doc/changelog/08-tools/12033-master+coqdoc-fix7697-passing-binders-location.rst b/doc/changelog/08-tools/12033-master+coqdoc-fix7697-passing-binders-location.rst new file mode 100644 index 0000000000..af0d28305a --- /dev/null +++ b/doc/changelog/08-tools/12033-master+coqdoc-fix7697-passing-binders-location.rst @@ -0,0 +1,5 @@ +- **Added:** + Add hyperlinks on bound variables for coqdoc + (`#12033 <https://github.com/coq/coq/pull/12033>`_, + by Hugo Herbelin; it incidentally fixes + `#7697 <https://github.com/coq/coq/pull/7697>`_). diff --git a/doc/changelog/08-tools/12037-coqdoc-preformatted.rst b/doc/changelog/08-tools/12037-coqdoc-preformatted.rst new file mode 100644 index 0000000000..bf65719516 --- /dev/null +++ b/doc/changelog/08-tools/12037-coqdoc-preformatted.rst @@ -0,0 +1,6 @@ +- **Fixed:** + ``coqdoc`` now reports the location of a mismatched opening ``[[`` instead of + throwing an uninformative exception. + (`#12037 <https://github.com/coq/coq/pull/12037>`_, + fixes `#9670 <https://github.com/coq/coq/issues/9670>`_, + by Lysxia). diff --git a/doc/changelog/08-tools/12091-master+coqdoc-css-target.rst b/doc/changelog/08-tools/12091-master+coqdoc-css-target.rst new file mode 100644 index 0000000000..f6af5d40e8 --- /dev/null +++ b/doc/changelog/08-tools/12091-master+coqdoc-css-target.rst @@ -0,0 +1,4 @@ +- **Added:** + ``Coqdoc``: Highlighting of the exact position of the target of links + (`#12091 <https://github.com/coq/coq/pull/12091>`_, + by Hugo Herbelin). diff --git a/doc/changelog/08-tools/12126-adjust-timed-name.rst b/doc/changelog/08-tools/12126-adjust-timed-name.rst new file mode 100644 index 0000000000..c305b384d9 --- /dev/null +++ b/doc/changelog/08-tools/12126-adjust-timed-name.rst @@ -0,0 +1,8 @@ +- **Changed:** + The output of ``make TIMED=1`` (and therefore the timing targets + such as ``print-pretty-timed`` and ``print-pretty-timed-diff``) now + displays the full name of the output file being built, rather than + the stem of the rule (which was usually the filename without the + extension, but in general could be anything for user-defined rules + involving ``%``) (`#12126 + <https://github.com/coq/coq/pull/12126>`_, by Jason Gross). diff --git a/doc/changelog/09-coqide/12060-ide-disable-csd.rst b/doc/changelog/09-coqide/12060-ide-disable-csd.rst new file mode 100644 index 0000000000..b61ab26007 --- /dev/null +++ b/doc/changelog/09-coqide/12060-ide-disable-csd.rst @@ -0,0 +1,6 @@ +- **Changed:** + CoqIDE now uses native window frames by default on Windows. + The GTK window frames can be restored by setting the `GTK_CSD` environment variable to `1` + (`#12060 <https://github.com/coq/coq/pull/12060>`_, + fixes `#11080 <https://github.com/coq/coq/issues/11080>`_, + by Attila Gáspár). diff --git a/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst b/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst new file mode 100644 index 0000000000..6b1148a9a8 --- /dev/null +++ b/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Highlighting style consistently applied to all three buffers of CoqIDE + (`#12106 <https://github.com/coq/coq/pull/12106>`_, + by Hugo Herbelin; fixes + `#11506 <https://github.com/coq/coq/pull/11506>`_). diff --git a/doc/changelog/10-standard-library/11957-signotations.rst b/doc/changelog/10-standard-library/11957-signotations.rst new file mode 100644 index 0000000000..fc5d434274 --- /dev/null +++ b/doc/changelog/10-standard-library/11957-signotations.rst @@ -0,0 +1,4 @@ +- **Added:** + notations for sigma types: ``{ x & P & Q }``, ``{ ' pat & P }``, ``{ ' pat & P & Q }`` + (`#11957 <https://github.com/coq/coq/pull/11957>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12014-ollibs-vector.rst b/doc/changelog/10-standard-library/12014-ollibs-vector.rst new file mode 100644 index 0000000000..87625dd23b --- /dev/null +++ b/doc/changelog/10-standard-library/12014-ollibs-vector.rst @@ -0,0 +1,10 @@ +- **Added:** + Properties of some operations on vectors: + + - ``nth_order``: ``nth_order_hd``, ``nth_order_tl``, ``nth_order_ext`` + - ``replace``: ``nth_order_replace_eq``, ``nth_order_replace_neq``, ``replace_id``, ``replace_replace_eq``, ``replace_replace_neq`` + - ``map``: ``map_id``, ``map_map``, ``map_ext_in``, ``map_ext`` + - ``Forall`` and ``Forall2``: ``Forall_impl``, ``Forall_forall``, ``Forall_nth_order``, ``Forall2_nth_order`` + + (`#12014 <https://github.com/coq/coq/pull/12014>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12031-ollibs-cpermutation.rst b/doc/changelog/10-standard-library/12031-ollibs-cpermutation.rst new file mode 100644 index 0000000000..95b4cce2f7 --- /dev/null +++ b/doc/changelog/10-standard-library/12031-ollibs-cpermutation.rst @@ -0,0 +1,4 @@ +- **Added:** + Definition and properties of cyclic permutations / circular shifts: ``CPermutation`` + (`#12031 <https://github.com/coq/coq/pull/12031>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12044-issue-12015.rst b/doc/changelog/10-standard-library/12044-issue-12015.rst new file mode 100644 index 0000000000..166fc80fb0 --- /dev/null +++ b/doc/changelog/10-standard-library/12044-issue-12015.rst @@ -0,0 +1,10 @@ +- **Fixed:** + Rewrote ``Structures.OrderedTypeEx.String_as_OT.compare`` + to avoid huge proof terms + (Fixes `#12015 <https://github.com/coq/coq/issues/12015>`_, + `#12044 <https://github.com/coq/coq/pull/12044>`_, + by formalize.eth (formalize@protonmail.com)). +- **Added:** + Added ``Structures.OrderedTypeEx.Ascii_as_OT`` + (`#12044 <https://github.com/coq/coq/pull/12044>`_, + by formalize.eth (formalize@protonmail.com)). diff --git a/doc/changelog/10-standard-library/12119-issue12119.rst b/doc/changelog/10-standard-library/12119-issue12119.rst new file mode 100644 index 0000000000..42672b1465 --- /dev/null +++ b/doc/changelog/10-standard-library/12119-issue12119.rst @@ -0,0 +1,5 @@ +- **Changed:** + new lemma ``NoDup_incl_NoDup`` in ``List.v`` + to remove useless hypothesis `NoDup l'` in ``Sorting.Permutation.NoDup_Permutation_bis`` + (`#12119 <https://github.com/coq/coq/pull/12119>`_, + by Olivier Laurent). diff --git a/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css b/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css deleted file mode 100644 index d23ea8f362..0000000000 --- a/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css +++ /dev/null @@ -1,329 +0,0 @@ -body { padding: 0px 0px; - margin: 0px 0px; - background-color: white } - -#page { display: block; - padding: 0px; - margin: 0px; - padding-bottom: 10px; } - -#header { display: block; - position: relative; - padding: 0; - margin: 0; - vertical-align: middle; - border-bottom-style: solid; - border-width: thin } - -#header h1 { padding: 0; - margin: 0;} - - -/* Contents */ - -#main{ display: block; - padding: 10px; - font-family: sans-serif; - font-size: 100%; - line-height: 100% } - -#main h1 { line-height: 95% } /* allow for multi-line headers */ - -#main a.idref:visited {color : #416DFF; text-decoration : none; } -#main a.idref:link {color : #416DFF; text-decoration : none; } -#main a.idref:hover {text-decoration : none; } -#main a.idref:active {text-decoration : none; } - -#main a.modref:visited {color : #416DFF; text-decoration : none; } -#main a.modref:link {color : #416DFF; text-decoration : none; } -#main a.modref:hover {text-decoration : none; } -#main a.modref:active {text-decoration : none; } - -#main .keyword { color : #cf1d1d } -#main { color: black } - -.section { background-color: rgb(60%,60%,100%); - padding-top: 13px; - padding-bottom: 13px; - padding-left: 3px; - margin-top: 5px; - margin-bottom: 5px; - font-size : 175% } - -h2.section { background-color: rgb(80%,80%,100%); - padding-left: 3px; - padding-top: 12px; - padding-bottom: 10px; - font-size : 130% } - -h3.section { background-color: rgb(90%,90%,100%); - padding-left: 3px; - padding-top: 7px; - padding-bottom: 7px; - font-size : 115% } - -h4.section { -/* - background-color: rgb(80%,80%,80%); - max-width: 20em; - padding-left: 5px; - padding-top: 5px; - padding-bottom: 5px; -*/ - background-color: white; - padding-left: 0px; - padding-top: 0px; - padding-bottom: 0px; - font-size : 100%; - font-weight : bold; - text-decoration : underline; - } - -#main .doc { margin: 0px; - font-family: sans-serif; - font-size: 100%; - line-height: 125%; - max-width: 40em; - color: black; - padding: 10px; - background-color: #90bdff} - -.inlinecode { - display: inline; -/* font-size: 125%; */ - color: #666666; - font-family: monospace } - -.doc .inlinecode { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.doc .inlinecode .id { - color: rgb(30%,30%,70%); -} - -.inlinecodenm { - display: inline; - color: #444444; -} - -.doc .code { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.comment { - display: inline; - font-family: monospace; - color: rgb(50%,50%,80%); -} - -.code { - display: block; -/* padding-left: 15px; */ - font-size: 110%; - font-family: monospace; - } - -table.infrule { - border: 0px; - margin-left: 50px; - margin-top: 10px; - margin-bottom: 10px; -} - -td.infrule { - font-family: monospace; - text-align: center; -/* color: rgb(35%,35%,70%); */ - padding: 0px; - line-height: 100%; -} - -tr.infrulemiddle hr { - margin: 1px 0 1px 0; -} - -.infrulenamecol { - color: rgb(60%,60%,60%); - font-size: 80%; - padding-left: 1em; - padding-bottom: 0.1em -} - -/* Pied de page */ - -#footer { font-size: 65%; - font-family: sans-serif; } - -/* Identifiers: <span class="id" title="...">) */ - -.id { display: inline; } - -.id[title="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[title="var"] { - color: rgb(40%,0%,40%); -} - -.id[title="variable"] { - color: rgb(40%,0%,40%); -} - -.id[title="definition"] { - color: rgb(0%,40%,0%); -} - -.id[title="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[title="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[title="instance"] { - color: rgb(0%,40%,0%); -} - -.id[title="projection"] { - color: rgb(0%,40%,0%); -} - -.id[title="method"] { - color: rgb(0%,40%,0%); -} - -.id[title="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[title="record"] { - color: rgb(0%,0%,80%); -} - -.id[title="class"] { - color: rgb(0%,0%,80%); -} - -.id[title="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -/* Deprecated rules using the 'type' attribute of <span> (not xhtml valid) */ - -.id[type="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[type="var"] { - color: rgb(40%,0%,40%); -} - -.id[type="variable"] { - color: rgb(40%,0%,40%); -} - -.id[type="definition"] { - color: rgb(0%,40%,0%); -} - -.id[type="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[type="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[type="instance"] { - color: rgb(0%,40%,0%); -} - -.id[type="projection"] { - color: rgb(0%,40%,0%); -} - -.id[type="method"] { - color: rgb(0%,40%,0%); -} - -.id[type="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[type="record"] { - color: rgb(0%,0%,80%); -} - -.id[type="class"] { - color: rgb(0%,0%,80%); -} - -.id[type="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -.inlinecode .id { - color: rgb(0%,0%,0%); -} - - -/* TOC */ - -#toc h2 { - padding: 10px; - background-color: rgb(60%,60%,100%); -} - -#toc li { - padding-bottom: 8px; -} - -/* Index */ - -#index { - margin: 0; - padding: 0; - width: 100%; -} - -#index #frontispiece { - margin: 1em auto; - padding: 1em; - width: 60%; -} - -.booktitle { font-size : 140% } -.authors { font-size : 90%; - line-height: 115%; } -.moreauthors { font-size : 60% } - -#index #entrance { - text-align: center; -} - -#index #entrance .spacer { - margin: 0 30px 0 30px; -} - -#index #footer { - position: absolute; - bottom: 0; -} - -.paragraph { - height: 0.75em; -} - -ul.doclist { - margin-top: 0em; - margin-bottom: 0em; -} diff --git a/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css b/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css deleted file mode 100644 index 32c0b33166..0000000000 --- a/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css +++ /dev/null @@ -1,801 +0,0 @@ -body -{ - background: white; - color:#444; - font:normal normal normal small/1.5em "Lucida Grande", Verdana, sans-serif; - margin:0; - padding:0; -} - -h2 -{ - font-size:150%; - font-weight:normal; - margin:20px 0 0; -} - -h3 -{ - font-size:130%; - font-weight:normal; -} - -a:link,a:visited -{ - color:#660403; - font-weight:normal; - text-decoration:none; -} - -a:hover -{ - color: red; - text-decoration:none; -} - -#container -{ - margin: 0; - padding: 0; - } - - /*----------header, logo and site name styles----------*/ - #headertop - { - display: block; - /* position:absolute; */ - min-width: 700px; - top: 0; - width: 100%; - height:30px; - z-index: 1; - background: transparent url('images/header_top.png') repeat-x; - } - - #header - { - min-width: 700px; - width: 100%; height:70px; - position: relative; - left: 0; top: 0; - background: transparent url('images/header_bot.png') repeat-x; - } - - #logo - { - float:left; - z-index: 2; - position: absolute; - top: -15px; - left: 0px; - } - - #logo img - { - border:0; - float:left; - } - - #logoWrapper - { - line-height:4em; - } - - #siteName - { - position: relative; - top: 10px; left: 80px; - color:#fff; - float:left; - font-size:350%; - } - - #siteName a - { - color:#fff; - text-decoration:none; - } - - #siteName a:hover - { - color:#ddd; - text-decoration:none; - } - - #siteSlogan - { - color:#eee; - float:left; - font-size:170%; - margin:50px 0 0 10px; - text-transform:lowercase; - white-space:nowrap; - } - - /*----------nav styles -- primary links in header----------*/ - - #nav -{ - position:absolute; right:0; - margin: 0; - padding: 5px; - } - -#nav ul - { - list-style:none outside none; - list-style-image:none; - margin:0; - padding:0; - } - - #nav li - { - display: inline; - margin: 0; padding: 4px; - } - - #nav li a - { - border:medium none; - color:#ccc; - font-weight:normal; - padding-left:10px; - padding-right:10px; - text-decoration:none; - } - - #nav li a:hover - { - background:#7B0505 none repeat; - border:medium none; - border-left:1px solid #ddd; - border-right:1px solid #ddd; - color:#fff; - padding: 6px 9px 5px 9px; - } - - -/************** FOOTER *******************/ - - -#footer -{ - background:transparent url('images/footer.png') repeat-x; - width:100%; - clear:both; - font-size:85%; - text-align:center; - /* position:fixed; */ - margin: 0; - padding: 0; -} - - -#nav-footer -{ - display: inline; - color:#444; - margin: 0; - padding: 0; - text-align:right; - } - -#nav-footer ul - { - list-style:none outside none; - list-style-image:none; - margin:0; - padding:0px; padding-right: 5px; - } - -#nav-footer li -{ - display:inline; padding: 4px; -} - - #nav-footer li a - { - border:medium none; - color:#ccc; - font-size: 11px; - font-weight:normal; - padding-left: 10px; - padding-right: 10px; - text-decoration:none; - } - - #nav-footer li a:hover - { - background:#7B0505 none repeat; - border:medium none; - border-left:1px solid #ddd; - border-right:1px solid #ddd; - color:#fff; - margin:0; - padding: 3px 9px 0px 9px; - } - - - /*----------main content----------*/ - #content - { - display: block; - position: static; - -/* min-width: 640px; */ - max-width: 800px; - - margin-left:40px; - margin-right:300px; - padding: 2ex 2ex; - - z-index:1; - } - -.content { - display: block; - position: relative; - - margin: 0; - padding: 0; -} - - /*----------sidebar styles----------*/ - #sidebarWrapper - { - /* background:transparent url('images/sidebar_bottom.jpg') no-repeat scroll left bottom;*/ - display:block; - position:fixed; - /* avant : top: 100px; right:0px*/ - top: 15px; /* 180 */ - right:0px; - left: auto; - - margin-right: 0px; - - /* avant - width: 12%; - min-width:80px; */ - - /* width: 18%; */ - /* min-*/ - width:270px; - - z-index:0; - overflow:hidden; - -/* ajout precedent:*/ -/* min-height:320px; - padding:10px; - background-image:url('http://www.lix.polytechnique.fr/Labo/Denis.Cousineau/data/coq/rttr340bis.png'); - background-repeat : repeat-x ;*/ - -/* last ajout */ - /* min-height:510px; */ /* 360 */ - padding-left:0px; - padding-right:0px; - padding-top:105px; /* 40 */ - padding-bottom:/*105px*/115px; - /* background:transparent url('http://www.lix.polytechnique.fr/Labo/Denis.Cousineau/data/coq/trig6b.png') no-repeat scroll left top; */ - background:transparent url('images/sidebarbot.png') no-repeat scroll right bottom; - - } - -#sidebar { - padding-left: 40px; - padding-top: 105px; - overflow: visible; - background:transparent url('images/sidebartop.png') no-repeat scroll right top; -} - -#sidebar .title -{ - /* avant :border-bottom:1px solid #eee;*/ - /* avant : color:#660403;*/ - color:#2D0102; - font-size:120%; - font-weight:bold; - line-height:19px; - margin:10px 0; -} - -/*----------page styles----------*/ -.pageTitle -{ - color:#2D0102; - font-size:220%; - margin:10px 0 20px; -} - -.mission -{ - background-color:#efefef; - border:solid 1px #ccc; - margin:0 0 10px 0; - padding:10px; -} - -.messages -{ - color:#C80000; - font-size:110%; - margin:10px 0; -} - -/*----------node styles----------*/ -.nodeTitle -{ - background: url('images/nodeTitle.gif') no-repeat 0 100%; - color:#9a0000; - font-size: 100%; - margin:0; -} - -.nodeTitle a -{ - color:#660403; - text-decoration:none; -} - -.nodeTitle a:hover -{ - color:#d00000; - text-decoration:none; -} - -.node -{ - margin:0 0 20px; -} - -.content p -{ - margin:10px 0; -} - -.submitted -{ - color:#a3a3a3; - font-size:70%; -} - -.nodeLinks -{ - font-size:95%; - margin:0; - padding:0; -} - -.taxonomy -{ - background:url('icons/tag_red.png') no-repeat 0 7px; - font-size:80%; - padding:0 0 5px 16px; -} - -/*----------comment styles----------*/ -.commentTitle -{ - Border-bottom:1px solid #ddd; - color:#9a0000; - font-size:130%; - margin:20px 0 0; -} - -.commentTitle a -{ - color:#660403; - text-decoration:none; -} - -.commentTitle a:hover -{ - color:#d00000; - text-decoration:none; -} - -.commentLinks -{ - background:#f7f7f7; - border:1px solid #e1e1e1; - color:#444; - font-size:95%; - margin:20px 0 30px; - padding:4px 0 4px 4px; -} - - -/*----------img styles----------*/ -img -{ - padding:3px; -} - -/*----------icons for links----------*/ -.comment_comments a -{ - background:url('icons/comment.png') no-repeat 0 2px; - padding-bottom:5px; - padding-left:20px; -} - -.node_read_more a -{ - background:url('icons/page_white_go.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} - -.comment_add a,.comment_reply a -{ - background:url('icons/comment_add.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} -.comment_delete a -{ - background:url('icons/comment_delete.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} - -.comment_edit a -{ - background:url('icons/comment_edit.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} - -/*----------TinyMCE editor----------*/ -body.mceContentBody -{ - background:#fff; - color:#000; - font-size:12px; -} - -body.mceContentBody a:link -{ - color:#ff0000; -} - -/*----------table styles----------*/ -table -{ - margin:1em 0; - width:100%; -} - -thead th -{ - border-bottom:2px solid #AAA; - color:#494949; - font-weight:bold; -} - -td,th -{ - padding:.3em 0 .5em; -} - -tr.even,tr.odd,tbody th -{ - border:solid #D5D6D7; - border-width:1px 0; -} - -tr.even -{ - background:#fff; -} - -td.region,td.module,td.container -{ - background:#D5D6D7; - border-bottom:1px solid #AAA; - border-top:1.5em solid #fff; - color:#455067; - font-weight:bold; -} - -tr:first-child td.region,tr:first-child td.module,tr:first-child td.container -{ - border-top-width:0; -} - -td.menu-disabled,td.menu-disabled a -{ - background-color:#D5C2C2; - color:#000; -} - -/*----------other styles----------*/ - -.block -{ - margin:5px 0 20px; -} - -.thumbnail,.preview -{ - border:1px solid #ccc; -} - -.lstlisting { - display: block; - font-family: monospace; - white-space: pre; - margin: 1em 0; -} -.center { - text-align: center; -} -.centered { - display: block-inline; -} - -/*----------download table------------*/ - -table.downloadtable -{ - width:90%; - margin-left:auto; - margin-right:auto; -} - -table.downloadtable td.downloadheader -{ -padding: 2px 1em; -font-weight: bold; -font-size: 120%; -color: white; -background: transparent url('images/header_bot.png') repeat-x; -/*background-color: #660403; */ -border: solid 2px white; -border-left: none; -} - -table.downloadtable td.downloadcategory -{ -padding: 2px 1em; -background-color: #dfbfbe; -text-indent: 0; -} - -table.downloadtable td.downloadsize -{ -text-indent: 0; -white-space: nowrap; -height: 52px; -} - -table.downloadtable td -{ -padding: 2px 1em; -background-color: #dfbfbe; -border-right: solid white 2px; -} - - -table.downloadtable td.downloadtopline -{ -border-top: solid white 2px; -} - -table.downloadtable td.downloadtoprightline -{ -border-top: solid 2px white; -border-right: solid 2px white; -} - -table.downloadtable td.downloadbottomline -{ -border-bottom: solid 2px white; -border-right: solid 2px white; -} - -table.downloadtable td.downloadbottomrightline -{ -border-bottom: solid 2px white; -border-right: solid 2px white; -} - -table.downloadtable td.downloadrightline -{ -border-right: solid 2px white; -} - -table.downloadtable td.downloadback -{ -background-color: #efe4e4; -} - -table.downloadtable td.downloadbottomback -{ -border-bottom: solid 2px white; -background-color: #efe4e4; -} - - -/*********** Normal text style ************/ - -p { - text-indent:3em; -} - -ul { - margin: 0px; - margin-left:4em; - padding: 0px; - list-style-type:square; -} - -li -{ - text-indent: 0px; - margin: 0px; - padding: 0px; -} - -tt { font-size: 1em; } - -pre { font-size: 1em; } - -/*********** Framework ***********/ -.framework -{ - display: block; - position:relative; - border:solid 1px #660033; - margin: 8ex 1em; /* 8ex 8ex 1em 1em; */ - padding: 0; -} - -.frameworkcontent -{ - position:relative; - left:0px; - - - margin: 0; - padding: .5ex 2em; - - text-indent: 2em; - text-align: justify; -} - - -.frameworklabel -{ - display: inline; - position:relative; - top:-1.3ex; - - margin-left:2ex; - padding-top:.4ex; - padding-bottom:.4ex; - padding-right:1ex; - padding-left:1ex; - - border: none; - background: white; - color: black; - - font-weight: bold; - font-size:115%; -} - -.frameworklinks { - display:block; - position:relative; - top:1.4ex; - - margin-right:2ex; - - text-align:right; - font-size:100% - } - -.frameworklinks ul -{ - display: inline; - padding: 0px 1ex; - - border: none; - background: white; -} - - -.frameworklinks li - { - display:inline; - padding: 1ex 0px; - } - - .frameworklinks li a -{ - border:medium none; - - margin: 0px 1ex; - padding-left:2px; - padding-right:3px; - - font-weight:normal; - text-decoration:none; - - color: #660003; -} - - .frameworklinks li a:hover - { - color: red; - - border: none; - } - -/* General flat lists */ -.flatlist li {display: inline} - -/* For sections in bycat.html */ -.bycatsection dt { - text-indent: 3em -} - -.bycatsection dt a -{ - font-weight: bold; - color:#444; -} - -/* footnote is used in the new contribution form */ -.footnote { - text-indent: 0pt; - font-size: 80%; - color: silver; - text-align: justify -} - -/****************** CoqIDE Screenshots *****************/ - - -.SCpager { - position:relative; - top:5px; - width:630px; - background: transparent url('images/header_bot.png') repeat-x; - padding:4px; -} - -.SCpagercontent { - width:390px; - position:relative; - margin-left:auto; - margin-right:auto; -} - -.SCthumb { - height:45px; - margin-left:2px; - margin-right:2px; -} - -.SCthumbselected { - height:55px; - margin-left:2px; - margin-right:2px; -} - -.SCcontent { - position:relative; - top:5px; - width:638px; - background-color: #dfbfbe; -} - -.SCscreenshot { - position:relative; - height:400px; - width:auto; - margin:15px auto 15px 19px; -} diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 73d94c2a51..8c2090f3be 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -286,8 +286,8 @@ END VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY | ![ proof_query ] [ "ExploreProof" ] -> { fun ~pstate -> - let sigma, env = Pfedit.get_current_context pstate in - let pprf = Proof.partial_proof (Proof_global.get_proof pstate) in + let sigma, env = Declare.get_current_context pstate in + let pprf = Proof.partial_proof (Declare.Proof.get_proof pstate) in Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 8c4dc0e8a6..b94b1fc657 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,8 +1,6 @@ -let edeclare ?hook ~name ~poly ~scope ~kind ~opaque ~udecl ~impargs sigma body tyopt = - DeclareDef.declare_definition ~name ~scope ~kind ~impargs ?hook - ~opaque ~poly ~udecl ~types:tyopt ~body sigma - let declare_definition ~poly name sigma body = let udecl = UState.default_univ_decl in - edeclare ~name ~poly ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsDefinition Definition) ~opaque:false ~impargs:[] ~udecl sigma body None + let scope = DeclareDef.Global Declare.ImportDefaultBehavior in + let kind = Decls.(IsDefinition Definition) in + DeclareDef.declare_definition ~name ~scope ~kind ~impargs:[] ~udecl + ~opaque:false ~poly ~types:None ~body sigma diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index f706633da9..77bf58aac6 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -1,4 +1,4 @@ -.. _ micromega: +.. _micromega: Micromega: tactics for solving arithmetic goals over ordered rings ================================================================== diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index daca43e65e..e1b1ee8e8d 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -1,4 +1,4 @@ -.. _omega: +.. _omega_chapter: Omega: a solver for quantifier-free problems in Presburger Arithmetic ===================================================================== @@ -7,20 +7,18 @@ Omega: a solver for quantifier-free problems in Presburger Arithmetic .. warning:: - The :tacn:`omega` tactic is about to be deprecated in favor of the - :tacn:`lia` tactic. The goal is to consolidate the arithmetic - solving capabilities of Coq into a single engine; moreover, - :tacn:`lia` is in general more powerful than :tacn:`omega` (it is a - complete Presburger arithmetic solver while :tacn:`omega` was known - to be incomplete). - - Work is in progress to make sure that there are no regressions - (including no performance regression) when switching from - :tacn:`omega` to :tacn:`lia` in existing projects. However, we - already recommend using :tacn:`lia` in new or refactored proof - scripts. We also ask that you report (in our `bug tracker - <https://github.com/coq/coq/issues>`_) any issue you encounter, - especially if the issue was not present in :tacn:`omega`. + The :tacn:`omega` tactic is deprecated in favor of the :tacn:`lia` + tactic. The goal is to consolidate the arithmetic solving + capabilities of Coq into a single engine; moreover, :tacn:`lia` is + in general more powerful than :tacn:`omega` (it is a complete + Presburger arithmetic solver while :tacn:`omega` was known to be + incomplete). + + It is recommended to switch from :tacn:`omega` to :tacn:`lia` in existing + projects. We also ask that you report (in our `bug tracker + <https://github.com/coq/coq/issues>`_) any issue you encounter, especially + if the issue was not present in :tacn:`omega`. If no new issues are + reported, :tacn:`omega` will be removed soon. Note that replacing :tacn:`omega` with :tacn:`lia` can break non-robust proof scripts which rely on incompleteness bugs of @@ -30,6 +28,11 @@ Description of ``omega`` ------------------------ .. tacn:: omega + :name: omega + + .. deprecated:: 8.12 + + Use :tacn:`lia` instead. :tacn:`omega` is a tactic for solving goals in Presburger arithmetic, i.e. for proving formulas made of equations and inequalities over the @@ -118,7 +121,7 @@ loaded by .. example:: - .. coqtop:: all + .. coqtop:: all warn Require Import Omega. diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 9acdd18b89..b2d3687780 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -240,3 +240,10 @@ so correctly converts ``x`` and ``y``. the kernel when it is passed a term with incorrect relevance marks. To avoid conversion issues as in ``late_mark`` you may wish to use it to find when your tactics are producing incorrect marks. + +.. flag:: Cumulative StrictProp + :name: Cumulative StrictProp + + Set this flag (it is off by default) to make the kernel accept + cumulativity between |SProp| and other universes. This makes + typechecking incomplete. diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index a08495badd..2958d866ac 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -227,7 +227,7 @@ constraints by prefixing the level names with symbols. Because inductive subtypings are only produced by comparing inductives to themselves with universes changed, they amount to variance information: each universe is either invariant, covariant or -irrelevant (there are no contravariant subtypings in Coq), +irrelevant (there are no contravariant subtypings in |Coq|), respectively represented by the symbols `=`, `+` and `*`. Here we see that :g:`list` binds an irrelevant universe, so any two @@ -426,6 +426,19 @@ mode, introduced universe names can be referred to in terms. Note that local universe names shadow global universe names. During a proof, one can use :cmd:`Show Universes` to display the current context of universes. +It is possible to provide only some universe levels and let |Coq| infer the others +by adding a :g:`+` in the list of bound universe levels: + +.. coqtop:: all + + Fail Definition foobar@{u} : Type@{u} := Type. + Definition foobar@{u +} : Type@{u} := Type. + Set Printing Universes. + Print foobar. + +This can be used to find which universes need to be explicitly bound in a given +definition. + Definitions can also be instantiated explicitly, giving their full instance: diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 31fb1b7382..6615b98660 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -55,7 +55,8 @@ __ 811Reals_ Additionally, while the :tacn:`omega` tactic is not yet deprecated in this version of Coq, it should soon be the case and we already recommend users to switch to :tacn:`lia` in new proof scripts (see -also the warning message in the :ref:`corresponding chapter <omega>`). +also the warning message in the :ref:`corresponding chapter +<omega_chapter>`). The ``dev/doc/critical-bugs`` file documents the known critical bugs of |Coq| and affected releases. See the `Changes in 8.11+beta1`_ @@ -481,10 +482,12 @@ Changes in 8.11+beta1 .. _811Reals: - **Added:** - Module `Reals.ConstructiveCauchyReals` defines constructive real numbers + Module `Reals.Cauchy.ConstructiveCauchyReals` defines constructive real numbers by Cauchy sequences of rational numbers (`#10445 <https://github.com/coq/coq/pull/10445>`_, by Vincent Semeria, with the help and review of Guillaume Melquiond and Bas Spitters). + This module is not meant to be imported directly, please import + `Reals.Abstract.ConstructiveReals` instead. - **Added:** New module `Reals.ClassicalDedekindReals` defines Dedekind real numbers as boolean-valued functions along with 3 logical axioms: diff --git a/doc/sphinx/coqdoc.css b/doc/sphinx/coqdoc.css deleted file mode 100644 index a325a33842..0000000000 --- a/doc/sphinx/coqdoc.css +++ /dev/null @@ -1,338 +0,0 @@ -/************************************************************************/ -/* * The Coq Proof Assistant / The Coq Development Team */ -/* v * Copyright INRIA, CNRS and contributors */ -/* <O___,, * (see version control and CREDITS file for authors & dates) */ -/* \VV/ **************************************************************/ -/* // * This file is distributed under the terms of the */ -/* * GNU Lesser General Public License Version 2.1 */ -/* * (see LICENSE file for the text of the license) */ -/************************************************************************/ -body { padding: 0px 0px; - margin: 0px 0px; - background-color: white } - -#page { display: block; - padding: 0px; - margin: 0px; - padding-bottom: 10px; } - -#header { display: block; - position: relative; - padding: 0; - margin: 0; - vertical-align: middle; - border-bottom-style: solid; - border-width: thin } - -#header h1 { padding: 0; - margin: 0;} - - -/* Contents */ - -#main{ display: block; - padding: 10px; - font-family: sans-serif; - font-size: 100%; - line-height: 100% } - -#main h1 { line-height: 95% } /* allow for multi-line headers */ - -#main a.idref:visited {color : #416DFF; text-decoration : none; } -#main a.idref:link {color : #416DFF; text-decoration : none; } -#main a.idref:hover {text-decoration : none; } -#main a.idref:active {text-decoration : none; } - -#main a.modref:visited {color : #416DFF; text-decoration : none; } -#main a.modref:link {color : #416DFF; text-decoration : none; } -#main a.modref:hover {text-decoration : none; } -#main a.modref:active {text-decoration : none; } - -#main .keyword { color : #cf1d1d } -#main { color: black } - -.section { background-color: rgb(60%,60%,100%); - padding-top: 13px; - padding-bottom: 13px; - padding-left: 3px; - margin-top: 5px; - margin-bottom: 5px; - font-size : 175% } - -h2.section { background-color: rgb(80%,80%,100%); - padding-left: 3px; - padding-top: 12px; - padding-bottom: 10px; - font-size : 130% } - -h3.section { background-color: rgb(90%,90%,100%); - padding-left: 3px; - padding-top: 7px; - padding-bottom: 7px; - font-size : 115% } - -h4.section { -/* - background-color: rgb(80%,80%,80%); - max-width: 20em; - padding-left: 5px; - padding-top: 5px; - padding-bottom: 5px; -*/ - background-color: white; - padding-left: 0px; - padding-top: 0px; - padding-bottom: 0px; - font-size : 100%; - font-weight : bold; - text-decoration : underline; - } - -#main .doc { margin: 0px; - font-family: sans-serif; - font-size: 100%; - line-height: 125%; - max-width: 40em; - color: black; - padding: 10px; - background-color: #90bdff } - -.inlinecode { - display: inline; -/* font-size: 125%; */ - color: #666666; - font-family: monospace } - -.doc .inlinecode { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.doc .inlinecode .id { - color: rgb(30%,30%,70%); -} - -.inlinecodenm { - display: inline; - color: #444444; -} - -.doc .code { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.comment { - display: inline; - font-family: monospace; - color: rgb(50%,50%,80%); -} - -.code { - display: block; -/* padding-left: 15px; */ - font-size: 110%; - font-family: monospace; - } - -table.infrule { - border: 0px; - margin-left: 50px; - margin-top: 10px; - margin-bottom: 10px; -} - -td.infrule { - font-family: monospace; - text-align: center; -/* color: rgb(35%,35%,70%); */ - padding: 0px; - line-height: 100%; -} - -tr.infrulemiddle hr { - margin: 1px 0 1px 0; -} - -.infrulenamecol { - color: rgb(60%,60%,60%); - font-size: 80%; - padding-left: 1em; - padding-bottom: 0.1em -} - -/* Pied de page */ - -#footer { font-size: 65%; - font-family: sans-serif; } - -/* Identifiers: <span class="id" title="...">) */ - -.id { display: inline; } - -.id[title="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[title="var"] { - color: rgb(40%,0%,40%); -} - -.id[title="variable"] { - color: rgb(40%,0%,40%); -} - -.id[title="definition"] { - color: rgb(0%,40%,0%); -} - -.id[title="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[title="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[title="instance"] { - color: rgb(0%,40%,0%); -} - -.id[title="projection"] { - color: rgb(0%,40%,0%); -} - -.id[title="method"] { - color: rgb(0%,40%,0%); -} - -.id[title="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[title="record"] { - color: rgb(0%,0%,80%); -} - -.id[title="class"] { - color: rgb(0%,0%,80%); -} - -.id[title="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -/* Deprecated rules using the 'type' attribute of <span> (not xhtml valid) */ - -.id[type="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[type="var"] { - color: rgb(40%,0%,40%); -} - -.id[type="variable"] { - color: rgb(40%,0%,40%); -} - -.id[type="definition"] { - color: rgb(0%,40%,0%); -} - -.id[type="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[type="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[type="instance"] { - color: rgb(0%,40%,0%); -} - -.id[type="projection"] { - color: rgb(0%,40%,0%); -} - -.id[type="method"] { - color: rgb(0%,40%,0%); -} - -.id[type="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[type="record"] { - color: rgb(0%,0%,80%); -} - -.id[type="class"] { - color: rgb(0%,0%,80%); -} - -.id[type="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -.inlinecode .id { - color: rgb(0%,0%,0%); -} - - -/* TOC */ - -#toc h2 { - padding: 10px; - background-color: rgb(60%,60%,100%); -} - -#toc li { - padding-bottom: 8px; -} - -/* Index */ - -#index { - margin: 0; - padding: 0; - width: 100%; -} - -#index #frontispiece { - margin: 1em auto; - padding: 1em; - width: 60%; -} - -.booktitle { font-size : 140% } -.authors { font-size : 90%; - line-height: 115%; } -.moreauthors { font-size : 60% } - -#index #entrance { - text-align: center; -} - -#index #entrance .spacer { - margin: 0 30px 0 30px; -} - -#index #footer { - position: absolute; - bottom: 0; -} - -.paragraph { - height: 0.75em; -} - -ul.doclist { - margin-top: 0em; - margin-bottom: 0em; -} diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 78b1f02383..57c8683aaa 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -422,7 +422,12 @@ are now available through the dot notation. If :n:`@module_binder`\s are specified, declares a functor with parameters given by the list of :token:`module_binder`\s. -.. cmd:: Import {+ @qualid } +.. cmd:: Import {+ @filtered_import } + + .. insertprodn filtered_import filtered_import + + .. prodn:: + filtered_import ::= @qualid {? ( {+, @qualid {? ( .. ) } } ) } If :token:`qualid` denotes a valid basic module (i.e. its module type is a signature), makes its components available by their short names. @@ -465,12 +470,50 @@ are now available through the dot notation. Check B.T. -.. cmd:: Export {+ @qualid } + Appending a module name with a parenthesized list of names will + make only those names available with short names, not other names + defined in the module nor will it activate other features. + + The names to import may be constants, inductive types and + constructors, and notation aliases (for instance, Ltac definitions + cannot be selectively imported). If they are from an inner module + to the one being imported, they must be prefixed by the inner path. + + The name of an inductive type may also be followed by ``(..)`` to + import it, its constructors and its eliminators if they exist. For + this purpose "eliminator" means a constant in the same module whose + name is the inductive type's name suffixed by one of ``_sind``, + ``_ind``, ``_rec`` or ``_rect``. + + .. example:: + + .. coqtop:: reset in + + Module A. + Module B. + Inductive T := C. + Definition U := nat. + End B. + Definition Z := Prop. + End A. + Import A(B.T(..), Z). + + .. coqtop:: all + + Check B.T. + Check B.C. + Check Z. + Fail Check B.U. + Check A.B.U. + +.. cmd:: Export {+ @filtered_import } :name: Export Similar to :cmd:`Import`, except that when the module containing this command is imported, the :n:`{+ @qualid }` are imported as well. + The selective import syntax also works with Export. + .. exn:: @qualid is not a module. :undocumented: diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index ab3d70eaca..a045120b70 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -1,3 +1,5 @@ +.. |GtkSourceView| replace:: :smallcaps:`GtkSourceView` + .. _coqintegrateddevelopmentenvironment: |Coq| Integrated Development Environment @@ -145,7 +147,18 @@ presented as a notebook. The first section is for selecting the text font used for scripts, goal and message windows. -The second and third sections are for controlling colors and style. +The second and third sections are for controlling colors and style of +the three main buffers. A predefined |Coq| highlighting style as well +as standard |GtkSourceView| styles are available. Other styles can be +added e.g. in ``$HOME/.local/share/gtksourceview-3.0/styles/`` (see +the general documentation about |GtkSourceView| for the various +possibilities). Note that the style of the rest of graphical part of +Coqide is not under the control of |GtkSourceView| but of GTK+ and +governed by files such as ``settings.ini`` and ``gtk.css`` in +``$XDG_CONFIG_HOME/gtk-3.0`` or files in +``$HOME/.themes/NameOfTheme/gtk-3.0``, as well as the environment +variable ``GTK_THEME`` (search on internet for the various +possibilities). The fourth section is for customizing the editor. It includes in particular the ability to activate an Emacs mode named diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 921c7bbbf7..bc77e2e58c 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -245,9 +245,9 @@ file timing data: COQDEP Fast.v COQDEP Slow.v COQC Slow.v - Slow (user: 0.34 mem: 395448 ko) + Slow.vo (user: 0.34 mem: 395448 ko) COQC Fast.v - Fast (user: 0.01 mem: 45184 ko) + Fast.vo (user: 0.01 mem: 45184 ko) + ``pretty-timed`` this target stores the output of ``make TIMED=1`` into @@ -280,15 +280,15 @@ file timing data: COQDEP Fast.v COQDEP Slow.v COQC Slow.v - Slow (user: 0.36 mem: 393912 ko) + Slow.vo (user: 0.36 mem: 393912 ko) COQC Fast.v - Fast (user: 0.05 mem: 45992 ko) + Fast.vo (user: 0.05 mem: 45992 ko) Time | File Name -------------------- 0m00.41s | Total -------------------- - 0m00.36s | Slow - 0m00.05s | Fast + 0m00.36s | Slow.vo + 0m00.05s | Fast.vo + ``print-pretty-timed-diff`` @@ -338,8 +338,8 @@ file timing data: -------------------------------------------------------- 0m00.39s | Total | 0m00.35s || +0m00.03s | +11.42% -------------------------------------------------------- - 0m00.37s | Slow | 0m00.01s || +0m00.36s | +3600.00% - 0m00.02s | Fast | 0m00.34s || -0m00.32s | -94.11% + 0m00.37s | Slow.vo | 0m00.01s || +0m00.36s | +3600.00% + 0m00.02s | Fast.vo | 0m00.34s || -0m00.32s | -94.11% The following targets and ``Makefile`` variables allow collection of per- diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index 0ace9ef5b9..b63ae32311 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -353,7 +353,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in reset - Require Import Omega. + Require Import Lia. .. coqtop:: in @@ -367,7 +367,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Hint Rewrite g0 g1 g2 using omega : base1. + Hint Rewrite g0 g1 g2 using lia : base1. .. coqtop:: in diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 62708b01ed..1772362351 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1715,6 +1715,7 @@ performance issue. .. coqtop:: reset in + Set Warnings "-omega-is-deprecated". Require Import Coq.omega.Omega. Ltac mytauto := tauto. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 90a991794f..28c5359a04 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1624,9 +1624,15 @@ previous :token:`i_item` have been performed. The second entry in the :token:`i_view` grammar rule, ``/ltac:(`` :token:`tactic` ``)``, executes :token:`tactic`. -Notations can be used to name tactics, for example:: +Notations can be used to name tactics, for example - Notation myop := (ltac:(some ltac code)) : ssripat_scope. +.. coqtop:: none + + Tactic Notation "my" "ltac" "code" := idtac. + +.. coqtop:: in warn + + Notation "'myop'" := (ltac:(my ltac code)) : ssripat_scope. lets one write just ``/myop`` in the intro pattern. Note the scope annotation: views are interpreted opening the ``ssripat`` scope. @@ -2607,7 +2613,7 @@ After the :token:`i_pattern`, a list of binders is allowed. .. coqtop:: reset none From Coq Require Import ssreflect. - From Coq Require Import Omega. + From Coq Require Import ZArith Lia. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -2615,7 +2621,7 @@ After the :token:`i_pattern`, a list of binders is allowed. .. coqtop:: all Lemma test : True. - have H x (y : nat) : 2 * x + y = x + x + y by omega. + have H x (y : nat) : 2 * x + y = x + x + y by lia. A proof term provided after ``:=`` can mention these bound variables (that are automatically introduced with the given names). @@ -2625,7 +2631,7 @@ with parentheses even if no type is specified: .. coqtop:: all restart - have (x) : 2 * x = x + x by omega. + have (x) : 2 * x = x + x by lia. The :token:`i_item` and :token:`s_item` can be used to interpret the asserted hypothesis with views (see section :ref:`views_and_reflection_ssr`) or simplify the resulting @@ -2668,9 +2674,9 @@ context entry name. Arguments Sub {_} _ _. Lemma test n m (H : m + 1 < n) : True. - have @i : 'I_n by apply: (Sub m); omega. + have @i : 'I_n by apply: (Sub m); lia. -Note that the subterm produced by :tacn:`omega` is in general huge and +Note that the subterm produced by :tacn:`lia` is in general huge and uninteresting, and hence one may want to hide it. For this purpose the ``[: name ]`` intro pattern and the tactic ``abstract`` (see :ref:`abstract_ssr`) are provided. @@ -2680,7 +2686,7 @@ For this purpose the ``[: name ]`` intro pattern and the tactic .. coqtop:: all abort Lemma test n m (H : m + 1 < n) : True. - have [:pm] @i : 'I_n by apply: (Sub m); abstract: pm; omega. + have [:pm] @i : 'I_n by apply: (Sub m); abstract: pm; lia. The type of ``pm`` can be cleaned up by its annotation ``(*1*)`` by just simplifying it. The annotations are there for technical reasons only. @@ -2694,7 +2700,7 @@ with have and an explicit term, they must be used as follows: Lemma test n m (H : m + 1 < n) : True. have [:pm] @i : 'I_n := Sub m pm. - by omega. + by lia. In this case the abstract constant ``pm`` is assigned by using it in the term that follows ``:=`` and its corresponding goal is left to be @@ -2712,7 +2718,7 @@ makes use of it). .. coqtop:: all abort Lemma test n m (H : m + 1 < n) : True. - have [:pm] @i k : 'I_(n+k) by apply: (Sub m); abstract: pm k; omega. + have [:pm] @i k : 'I_(n+k) by apply: (Sub m); abstract: pm k; lia. Last, notice that the use of intro patterns for abstract constants is orthogonal to the transparent flag ``@`` for have. @@ -2963,7 +2969,7 @@ illustrated in the following example. .. coqtop:: reset none - From Coq Require Import ssreflect Omega. + From Coq Require Import ssreflect Lia. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 6a280b74c2..7e6da490fb 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -1875,6 +1875,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) Lemma induction_test : forall n:nat, n = n -> n <= n. intros n H. induction n. + exact (le_n 0). .. exn:: Not an inductive product. :undocumented: @@ -2076,7 +2077,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) Now we are in a contradictory context and the proof can be solved. - .. coqtop:: all + .. coqtop:: all abort inversion H. @@ -2104,68 +2105,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) See also the larger example of :tacn:`dependent induction` and an explanation of the underlying technique. -.. tacn:: function induction (@qualid {+ @term}) - :name: function induction - - The tactic functional induction performs case analysis and induction - following the definition of a function. It makes use of a principle - generated by ``Function`` (see :ref:`advanced-recursive-functions`) or - ``Functional Scheme`` (see :ref:`functional-scheme`). - Note that this tactic is only available after a ``Require Import FunInd``. - -.. example:: - - .. coqtop:: reset all - - Require Import FunInd. - Functional Scheme minus_ind := Induction for minus Sort Prop. - Check minus_ind. - Lemma le_minus (n m:nat) : n - m <= n. - functional induction (minus n m) using minus_ind; simpl; auto. - Qed. - -.. note:: - :n:`(@qualid {+ @term})` must be a correct full application - of :n:`@qualid`. In particular, the rules for implicit arguments are the - same as usual. For example use :n:`@qualid` if you want to write implicit - arguments explicitly. - -.. note:: - Parentheses around :n:`@qualid {+ @term}` are not mandatory and can be skipped. - -.. note:: - :n:`functional induction (f x1 x2 x3)` is actually a wrapper for - :n:`induction x1, x2, x3, (f x1 x2 x3) using @qualid` followed by a cleaning - phase, where :n:`@qualid` is the induction principle registered for :g:`f` - (by the ``Function`` (see :ref:`advanced-recursive-functions`) or - ``Functional Scheme`` (see :ref:`functional-scheme`) - command) corresponding to the sort of the goal. Therefore - ``functional induction`` may fail if the induction scheme :n:`@qualid` is not - defined. See also :ref:`advanced-recursive-functions` for the function - terms accepted by ``Function``. - -.. note:: - There is a difference between obtaining an induction scheme - for a function by using :g:`Function` (see :ref:`advanced-recursive-functions`) - and by using :g:`Functional Scheme` after a normal definition using - :g:`Fixpoint` or :g:`Definition`. See :ref:`advanced-recursive-functions` - for details. - -.. seealso:: :ref:`advanced-recursive-functions`, :ref:`functional-scheme` and :tacn:`inversion` - -.. exn:: Cannot find induction information on @qualid. - :undocumented: - -.. exn:: Not the right number of induction arguments. - :undocumented: - -.. tacv:: functional induction (@qualid {+ @term}) as @simple_intropattern using @term with @bindings_list - - Similarly to :tacn:`induction` and :tacn:`elim`, this allows giving - explicitly the name of the introduced variables, the induction principle, and - the values of dependent premises of the elimination scheme, including - *predicates* for mutual induction when :n:`@qualid` is part of a mutually - recursive definition. +.. seealso:: :tacn:`functional induction` .. tacn:: discriminate @term :name: discriminate @@ -2672,6 +2612,8 @@ and an explanation of the underlying technique. assumption. Qed. +.. seealso:: :tacn:`functional inversion` + .. tacn:: fix @ident @num :name: fix @@ -3134,8 +3076,10 @@ the conversion in hypotheses :n:`{+ @ident}`. .. flag:: NativeCompute Timing This flag causes all calls to the native compiler to print - timing information for the compilation, execution, and - reification phases of native compilation. + timing information for the conversion to native code, + compilation, execution, and reification phases of native + compilation. Timing is printed in units of seconds of + wall-clock time. .. flag:: NativeCompute Profiling @@ -4008,10 +3952,10 @@ At Coq startup, only the core database is nonempty and can be used. :arith: This database contains all lemmas about Peano’s arithmetic proved in the directories Init and Arith. -:zarith: contains lemmas about binary signed integers from the directories - theories/ZArith. When required, the module Omega also extends the - database zarith with a high-cost hint that calls ``omega`` on equations - and inequalities in ``nat`` or ``Z``. +:zarith: contains lemmas about binary signed integers from the + directories theories/ZArith. The database also contains + high-cost hints that call :tacn:`lia` on equations and + inequalities in ``nat`` or ``Z``. :bool: contains lemmas about booleans, mostly from directory theories/Bool. @@ -4602,42 +4546,6 @@ symbol :g:`=`. Analogous to :tacn:`dependent rewrite ->` but uses the equality from right to left. -Inversion ---------- - -.. tacn:: functional inversion @ident - :name: functional inversion - - :tacn:`functional inversion` is a tactic that performs inversion on hypothesis - :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid - {+ @term}` where :n:`@qualid` must have been defined using Function (see - :ref:`advanced-recursive-functions`). Note that this tactic is only - available after a ``Require Import FunInd``. - - .. exn:: Hypothesis @ident must contain at least one Function. - :undocumented: - - .. exn:: Cannot find inversion information for hypothesis @ident. - - This error may be raised when some inversion lemma failed to be generated by - Function. - - - .. tacv:: functional inversion @num - - This does the same thing as :n:`intros until @num` followed by - :n:`functional inversion @ident` where :token:`ident` is the - identifier for the last introduced hypothesis. - - .. tacv:: functional inversion @ident @qualid - functional inversion @num @qualid - - If the hypothesis :token:`ident` (or :token:`num`) has a type of the form - :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where - :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to - functional inversion, this variant allows choosing which :token:`qualid` - is inverted. - Classical tactics ----------------- @@ -4694,18 +4602,6 @@ Automating The goal is not of the form :g:`t = u`. Especially note that :tacn:`btauto` doesn't introduce variables into the context on its own. -.. tacn:: omega - :name: omega - - The tactic :tacn:`omega`, due to Pierre Crégut, is an automatic decision - procedure for Presburger arithmetic. It solves quantifier-free - formulas built with `~`, `\\/`, `/\\`, `->` on top of equalities, - inequalities and disequalities on both the type :g:`nat` of natural numbers - and :g:`Z` of binary integers. This tactic must be loaded by the command - ``Require Import Omega``. See the additional documentation about omega - (see Chapter :ref:`omega`). - - .. tacn:: ring :name: ring diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 7d031b9b7a..60fdbf0a9d 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -91,9 +91,15 @@ capital letter. This command supports the :attr:`local`, :attr:`global` and :attr:`export` attributes. They are described :ref:`here <set_unset_scope_qualifiers>`. - .. warn:: There is no option @setting_name. + .. warn:: There is no flag or option with this name: "@setting_name". - This message also appears for unknown flags. + This warning message can be raised by :cmd:`Set` and + :cmd:`Unset` when :n:`@setting_name` is unknown. It is a + warning rather than an error because this helps library authors + produce Coq code that is compatible with several Coq versions. + To preserve the same behavior, they may need to set some + compatibility flags or options that did not exist in previous + Coq versions. .. cmd:: Unset @setting_name :name: Unset @@ -119,6 +125,20 @@ capital letter. whether the table contains each specified value, otherise this is equivalent to :cmd:`Print Table`. The `for` clause is not valid for flags and options. + .. exn:: There is no flag, option or table with this name: "@setting_name". + + This error message is raised when calling the :cmd:`Test` + command (without the `for` clause), or the :cmd:`Print Table` + command, for an unknown :n:`@setting_name`. + + .. exn:: There is no qualid-valued table with this name: "@setting_name". + There is no string-valued table with this name: "@setting_name". + + These error messages are raised when calling the :cmd:`Add` or + :cmd:`Remove` commands, or the :cmd:`Test` command with the + `for` clause, if :n:`@setting_name` is unknown or does not have + the right type. + .. cmd:: Print Options Prints the current value of all flags and options, and the names of all tables. @@ -1076,6 +1096,8 @@ Controlling Typing Flags Print the status of the three typing flags: guard checking, positivity checking and universe checking. +See also :flag:`Cumulative StrictProp` in the |SProp| chapter. + .. example:: .. coqtop:: all reset diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index 34197c4fcf..e05be7c2c2 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -190,146 +190,7 @@ Combined Scheme Check tree_forest_mutrect. -.. _functional-scheme: - -Generation of induction principles with ``Functional`` ``Scheme`` ------------------------------------------------------------------ - - -.. cmd:: Functional Scheme @ident__0 := Induction for @ident' Sort @sort {* with @ident__i := Induction for @ident__i' Sort @sort} - - This command is a high-level experimental tool for - generating automatically induction principles corresponding to - (possibly mutually recursive) functions. First, it must be made - available via ``Require Import FunInd``. - Each :n:`@ident__i` is a different mutually defined function - name (the names must be in the same order as when they were defined). This - command generates the induction principle for each :n:`@ident__i`, following - the recursive structure and case analyses of the corresponding function - :n:`@ident__i'`. - -.. warning:: - - There is a difference between induction schemes generated by the command - :cmd:`Functional Scheme` and these generated by the :cmd:`Function`. Indeed, - :cmd:`Function` generally produces smaller principles that are closer to how - a user would implement them. See :ref:`advanced-recursive-functions` for details. - -.. example:: - - Induction scheme for div2. - - We define the function div2 as follows: - - .. coqtop:: all - - Require Import FunInd. - Require Import Arith. - - Fixpoint div2 (n:nat) : nat := - match n with - | O => 0 - | S O => 0 - | S (S n') => S (div2 n') - end. - - The definition of a principle of induction corresponding to the - recursive structure of `div2` is defined by the command: - - .. coqtop:: all - - Functional Scheme div2_ind := Induction for div2 Sort Prop. - - You may now look at the type of div2_ind: - - .. coqtop:: all - - Check div2_ind. - - We can now prove the following lemma using this principle: - - .. coqtop:: all - - Lemma div2_le' : forall n:nat, div2 n <= n. - intro n. - pattern n, (div2 n). - apply div2_ind; intros. - auto with arith. - auto with arith. - simpl; auto with arith. - Qed. - - We can use directly the functional induction (:tacn:`function induction`) tactic instead - of the pattern/apply trick: - - .. coqtop:: all - - Reset div2_le'. - - Lemma div2_le : forall n:nat, div2 n <= n. - intro n. - functional induction (div2 n). - auto with arith. - auto with arith. - auto with arith. - Qed. - -.. example:: - - Induction scheme for tree_size. - - We define trees by the following mutual inductive type: - - .. original LaTeX had "Variable" instead of "Axiom", which generates an ugly warning - - .. coqtop:: reset all - - Axiom A : Set. - - Inductive tree : Set := - node : A -> forest -> tree - with forest : Set := - | empty : forest - | cons : tree -> forest -> forest. - - We define the function tree_size that computes the size of a tree or a - forest. Note that we use ``Function`` which generally produces better - principles. - - .. coqtop:: all - - Require Import FunInd. - - Function tree_size (t:tree) : nat := - match t with - | node A f => S (forest_size f) - end - with forest_size (f:forest) : nat := - match f with - | empty => 0 - | cons t f' => (tree_size t + forest_size f') - end. - - Notice that the induction principles ``tree_size_ind`` and ``forest_size_ind`` - generated by ``Function`` are not mutual. - - .. coqtop:: all - - Check tree_size_ind. - - Mutual induction principles following the recursive structure of ``tree_size`` - and ``forest_size`` can be generated by the following command: - - .. coqtop:: all - - Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop - with forest_size_ind2 := Induction for forest_size Sort Prop. - - You may now look at the type of `tree_size_ind2`: - - .. coqtop:: all - - Check tree_size_ind2. +.. seealso:: :ref:`functional-scheme` .. _derive-inversion: diff --git a/doc/sphinx/using/libraries/funind.rst b/doc/sphinx/using/libraries/funind.rst index ed00f3d455..40f9eedcf0 100644 --- a/doc/sphinx/using/libraries/funind.rst +++ b/doc/sphinx/using/libraries/funind.rst @@ -13,7 +13,7 @@ The following command is available when the ``FunInd`` library has been loaded v This command is a generalization of :cmd:`Fixpoint`. It is a wrapper for several ways of defining a function *and* other useful related objects, namely: an induction principle that reflects the recursive - structure of the function (see :tacn:`function induction`) and its fixpoint equality. + structure of the function (see :tacn:`functional induction`) and its fixpoint equality. This defines a function similar to those defined by :cmd:`Fixpoint`. As in :cmd:`Fixpoint`, the decreasing argument must be given (unless the function is not recursive), but it might not @@ -27,7 +27,7 @@ The following command is available when the ``FunInd`` library has been loaded v to structurally recursive functions (i.e. when :n:`@fixannot` is a :n:`struct` clause). - See :tacn:`function induction` and :cmd:`Functional Scheme` for how to use + See :tacn:`functional induction` and :cmd:`Functional Scheme` for how to use the induction principle to reason easily about the function. The form of the :n:`@fixannot` clause determines which definition mechanism :cmd:`Function` uses. @@ -166,4 +166,235 @@ terminating functions. :tacn:`functional inversion` will not be available for the function. -.. seealso:: :ref:`functional-scheme` and :tacn:`function induction` +Tactics +------- + +.. tacn:: functional induction (@qualid {+ @term}) + :name: functional induction + + The tactic functional induction performs case analysis and induction + following the definition of a function. It makes use of a principle + generated by :cmd:`Function` or :cmd:`Functional Scheme`. + Note that this tactic is only available after a ``Require Import FunInd``. + + .. example:: + + .. coqtop:: reset all + + Require Import FunInd. + Functional Scheme minus_ind := Induction for minus Sort Prop. + Check minus_ind. + Lemma le_minus (n m:nat) : n - m <= n. + functional induction (minus n m) using minus_ind; simpl; auto. + Qed. + + .. note:: + :n:`(@qualid {+ @term})` must be a correct full application + of :n:`@qualid`. In particular, the rules for implicit arguments are the + same as usual. For example use :n:`@qualid` if you want to write implicit + arguments explicitly. + + .. note:: + Parentheses around :n:`@qualid {+ @term}` are not mandatory and can be skipped. + + .. note:: + :n:`functional induction (f x1 x2 x3)` is actually a wrapper for + :n:`induction x1, x2, x3, (f x1 x2 x3) using @qualid` followed by a cleaning + phase, where :n:`@qualid` is the induction principle registered for :g:`f` + (by the :cmd:`Function` or :cmd:`Functional Scheme` command) + corresponding to the sort of the goal. Therefore + :tacn:`functional induction` may fail if the induction scheme :n:`@qualid` is not + defined. + + .. note:: + There is a difference between obtaining an induction scheme + for a function by using :cmd:`Function` + and by using :cmd:`Functional Scheme` after a normal definition using + :cmd:`Fixpoint` or :cmd:`Definition`. + + .. exn:: Cannot find induction information on @qualid. + :undocumented: + + .. exn:: Not the right number of induction arguments. + :undocumented: + + .. tacv:: functional induction (@qualid {+ @term}) as @simple_intropattern using @term with @bindings_list + + Similarly to :tacn:`induction` and :tacn:`elim`, this allows giving + explicitly the name of the introduced variables, the induction principle, and + the values of dependent premises of the elimination scheme, including + *predicates* for mutual induction when :n:`@qualid` is part of a mutually + recursive definition. + +.. tacn:: functional inversion @ident + :name: functional inversion + + :tacn:`functional inversion` is a tactic that performs inversion on hypothesis + :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid + {+ @term}` where :n:`@qualid` must have been defined using :cmd:`Function`. + Note that this tactic is only available after a ``Require Import FunInd``. + + .. exn:: Hypothesis @ident must contain at least one Function. + :undocumented: + + .. exn:: Cannot find inversion information for hypothesis @ident. + + This error may be raised when some inversion lemma failed to be generated by + Function. + + + .. tacv:: functional inversion @num + + This does the same thing as :n:`intros until @num` followed by + :n:`functional inversion @ident` where :token:`ident` is the + identifier for the last introduced hypothesis. + + .. tacv:: functional inversion @ident @qualid + functional inversion @num @qualid + + If the hypothesis :token:`ident` (or :token:`num`) has a type of the form + :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where + :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to + functional inversion, this variant allows choosing which :token:`qualid` + is inverted. + +.. _functional-scheme: + +Generation of induction principles with ``Functional`` ``Scheme`` +----------------------------------------------------------------- + + +.. cmd:: Functional Scheme @ident__0 := Induction for @ident' Sort @sort {* with @ident__i := Induction for @ident__i' Sort @sort} + + This command is a high-level experimental tool for + generating automatically induction principles corresponding to + (possibly mutually recursive) functions. First, it must be made + available via ``Require Import FunInd``. + Each :n:`@ident__i` is a different mutually defined function + name (the names must be in the same order as when they were defined). This + command generates the induction principle for each :n:`@ident__i`, following + the recursive structure and case analyses of the corresponding function + :n:`@ident__i'`. + +.. warning:: + + There is a difference between induction schemes generated by the command + :cmd:`Functional Scheme` and these generated by the :cmd:`Function`. Indeed, + :cmd:`Function` generally produces smaller principles that are closer to how + a user would implement them. See :ref:`advanced-recursive-functions` for details. + +.. example:: + + Induction scheme for div2. + + We define the function div2 as follows: + + .. coqtop:: all + + Require Import FunInd. + Require Import Arith. + + Fixpoint div2 (n:nat) : nat := + match n with + | O => 0 + | S O => 0 + | S (S n') => S (div2 n') + end. + + The definition of a principle of induction corresponding to the + recursive structure of `div2` is defined by the command: + + .. coqtop:: all + + Functional Scheme div2_ind := Induction for div2 Sort Prop. + + You may now look at the type of div2_ind: + + .. coqtop:: all + + Check div2_ind. + + We can now prove the following lemma using this principle: + + .. coqtop:: all + + Lemma div2_le' : forall n:nat, div2 n <= n. + intro n. + pattern n, (div2 n). + apply div2_ind; intros. + auto with arith. + auto with arith. + simpl; auto with arith. + Qed. + + We can use directly the functional induction (:tacn:`functional induction`) tactic instead + of the pattern/apply trick: + + .. coqtop:: all + + Reset div2_le'. + + Lemma div2_le : forall n:nat, div2 n <= n. + intro n. + functional induction (div2 n). + auto with arith. + auto with arith. + auto with arith. + Qed. + +.. example:: + + Induction scheme for tree_size. + + We define trees by the following mutual inductive type: + + .. original LaTeX had "Variable" instead of "Axiom", which generates an ugly warning + + .. coqtop:: reset all + + Axiom A : Set. + + Inductive tree : Set := + node : A -> forest -> tree + with forest : Set := + | empty : forest + | cons : tree -> forest -> forest. + + We define the function tree_size that computes the size of a tree or a + forest. Note that we use ``Function`` which generally produces better + principles. + + .. coqtop:: all + + Require Import FunInd. + + Function tree_size (t:tree) : nat := + match t with + | node A f => S (forest_size f) + end + with forest_size (f:forest) : nat := + match f with + | empty => 0 + | cons t f' => (tree_size t + forest_size f') + end. + + Notice that the induction principles ``tree_size_ind`` and ``forest_size_ind`` + generated by ``Function`` are not mutual. + + .. coqtop:: all + + Check tree_size_ind. + + Mutual induction principles following the recursive structure of ``tree_size`` + and ``forest_size`` can be generated by the following command: + + .. coqtop:: all + + Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop + with forest_size_ind2 := Induction for forest_size Sort Prop. + + You may now look at the type of `tree_size_ind2`: + + .. coqtop:: all + + Check tree_size_ind2. diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 67d0b37e81..65c88ed8d5 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -44,6 +44,7 @@ theories/micromega/Refl.v theories/micromega/RingMicromega.v theories/micromega/Tauto.v theories/micromega/VarMap.v +theories/micromega/ZArith_hints.v theories/micromega/ZCoeff.v theories/micromega/ZMicromega.v theories/micromega/ZifyInst.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 7fa621c11c..b2c9c936c9 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -13,6 +13,7 @@ through the <tt>Require Import</tt> command.</p> The core library (automatically loaded when starting Coq) </dt> <dd> + theories/Init/Ltac.v theories/Init/Notations.v theories/Init/Datatypes.v theories/Init/Logic.v @@ -444,6 +445,7 @@ through the <tt>Require Import</tt> command.</p> theories/Sorting/PermutSetoid.v theories/Sorting/Mergesort.v theories/Sorting/Sorted.v + theories/Sorting/CPermutation.v </dd> <dt> <b>Wellfounded</b>: diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index b448d0f9d3..57243207f0 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -188,20 +188,19 @@ class CoqObject(ObjectDescription): def _add_index_entry(self, name, target): """Add `name` (pointing to `target`) to the main index.""" assert isinstance(name, str) - if not name.startswith("_"): - # remove trailing . , found in commands, but not ... (ellipsis) - trim = name.endswith(".") and not name.endswith("...") - index_text = name[:-1] if trim else name - if self.index_suffix: - index_text += " " + self.index_suffix - self.indexnode['entries'].append(('single', index_text, target, '', None)) + # remove trailing . , found in commands, but not ... (ellipsis) + trim = name.endswith(".") and not name.endswith("...") + index_text = name[:-1] if trim else name + if self.index_suffix: + index_text += " " + self.index_suffix + self.indexnode['entries'].append(('single', index_text, target, '', None)) aliases = None # additional indexed names for a command or other object def add_target_and_index(self, name, _, signode): """Attach a link target to `signode` and an index entry for `name`. This is only called (from ``ObjectDescription.run``) if ``:noindex:`` isn't specified.""" - if name: + if name and not (isinstance(name, str) and name.startswith('_')): target = self._add_target(signode, name) self._add_index_entry(name, target) if self.aliases is not None: diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index a01f57eb22..700170b3c6 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -511,6 +511,12 @@ strategy_flag: [ | OPTINREF ] +filtered_import: [ +| REPLACE global "(" LIST1 one_import_filter_name SEP "," ")" +| WITH global OPT [ "(" LIST1 one_import_filter_name SEP "," ")" ] +| DELETE global +] + functor_app_annot: [ | OPTINREF ] @@ -900,14 +906,14 @@ command: [ | DELETE "Unset" option_table | REPLACE "Set" option_table option_setting | WITH OPT "Export" "Set" option_table (* set flag *) -| REPLACE "Test" option_table "for" LIST1 option_ref_value -| WITH "Test" option_table OPT ( "for" LIST1 option_ref_value ) +| REPLACE "Test" option_table "for" LIST1 table_value +| WITH "Test" option_table OPT ( "for" LIST1 table_value ) | DELETE "Test" option_table (* hide the fact that table names are limited to 2 IDENTs *) -| REPLACE "Add" IDENT IDENT LIST1 option_ref_value -| WITH "Add" option_table LIST1 option_ref_value -| DELETE "Add" IDENT LIST1 option_ref_value +| REPLACE "Add" IDENT IDENT LIST1 table_value +| WITH "Add" option_table LIST1 table_value +| DELETE "Add" IDENT LIST1 table_value | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident @@ -963,9 +969,9 @@ command: [ | DELETE "Preterm" (* hide the fact that table names are limited to 2 IDENTs *) -| REPLACE "Remove" IDENT IDENT LIST1 option_ref_value -| WITH "Remove" option_table LIST1 option_ref_value -| DELETE "Remove" IDENT LIST1 option_ref_value +| REPLACE "Remove" IDENT IDENT LIST1 table_value +| WITH "Remove" option_table LIST1 table_value +| DELETE "Remove" IDENT LIST1 table_value | DELETE "Restore" "State" IDENT | DELETE "Restore" "State" ne_string | "Restore" "State" [ IDENT | ne_string ] @@ -1544,7 +1550,7 @@ SPLICE: [ | constructor_type | record_binder | at_level_opt -| option_ref_value +| table_value | positive_search_mark | in_or_out_modules | option_setting @@ -1582,6 +1588,7 @@ SPLICE: [ | searchabout_queries | locatable | scope_delimiter +| one_import_filter_name ] (* end SPLICE *) RENAME: [ diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index dc7e0fba37..4274dccb40 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -524,12 +524,12 @@ command: [ | "Set" option_table option_setting | "Unset" option_table | "Print" "Table" option_table -| "Add" IDENT IDENT LIST1 option_ref_value -| "Add" IDENT LIST1 option_ref_value -| "Test" option_table "for" LIST1 option_ref_value +| "Add" IDENT IDENT LIST1 table_value +| "Add" IDENT LIST1 table_value +| "Test" option_table "for" LIST1 table_value | "Test" option_table -| "Remove" IDENT IDENT LIST1 option_ref_value -| "Remove" IDENT LIST1 option_ref_value +| "Remove" IDENT IDENT LIST1 table_value +| "Remove" IDENT LIST1 table_value | "Write" "State" IDENT | "Write" "State" ne_string | "Restore" "State" IDENT @@ -1031,8 +1031,8 @@ gallina_ext: [ | "Collection" identref ":=" section_subset_expr | "Require" export_token LIST1 global | "From" global "Require" export_token LIST1 global -| "Import" LIST1 global -| "Export" LIST1 global +| "Import" LIST1 filtered_import +| "Export" LIST1 filtered_import | "Include" module_type_inl LIST0 ext_module_expr | "Include" "Type" module_type_inl LIST0 ext_module_type | "Transparent" LIST1 smart_global @@ -1057,6 +1057,15 @@ gallina_ext: [ | "Export" "Unset" option_table ] +filtered_import: [ +| global +| global "(" LIST1 one_import_filter_name SEP "," ")" +] + +one_import_filter_name: [ +| global OPT [ "(" ".." ")" ] +] + export_token: [ | "Import" | "Export" @@ -1309,7 +1318,7 @@ option_setting: [ | STRING ] -option_ref_value: [ +table_value: [ | global | STRING ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index ac986f9adf..e71c80f829 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -497,6 +497,10 @@ constructor: [ | ident LIST0 binder OPT of_type ] +filtered_import: [ +| qualid OPT [ "(" LIST1 ( qualid OPT [ "(" ".." ")" ] ) SEP "," ")" ] +] + cofix_definition: [ | ident_decl LIST0 binder OPT ( ":" type ) OPT [ ":=" term ] OPT decl_notations ] @@ -849,8 +853,8 @@ command: [ | "Collection" ident ":=" section_subset_expr | "Require" OPT [ "Import" | "Export" ] LIST1 qualid | "From" dirpath "Require" OPT [ "Import" | "Export" ] LIST1 qualid -| "Import" LIST1 qualid -| "Export" LIST1 qualid +| "Import" LIST1 filtered_import +| "Export" LIST1 filtered_import | "Include" module_type_inl LIST0 ( "<+" module_expr_inl ) | "Include" "Type" LIST1 module_type_inl SEP "<+" | "Transparent" LIST1 smart_qualid diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 4508633858..ca681e58f8 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -355,7 +355,7 @@ let iter_with_full_binders sigma g f n c = | Lambda (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c | LetIn (na,b,t,c) -> f n b; f n t; f (g (LocalDef (na, b, t)) n) c | App (c,l) -> f n c; Array.Fun1.iter f n l - | Evar (_,l) -> Array.Fun1.iter f n l + | Evar (_,l) -> List.iter (fun c -> f n c) l | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> @@ -717,7 +717,7 @@ let val_of_named_context e = val_of_named_context (cast_named_context unsafe_eq let named_context_of_val e = cast_named_context (sym unsafe_eq) (named_context_of_val e) let of_existential : Constr.existential -> existential = - let gen : type a b. (a,b) eq -> 'c * b array -> 'c * a array = fun Refl x -> x in + let gen : type a b. (a,b) eq -> 'c * b list -> 'c * a list = fun Refl x -> x in gen unsafe_eq let lookup_rel i e = cast_rel_decl (sym unsafe_eq) (lookup_rel i e) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index fdcdfe11f4..5fcadfcef7 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -200,7 +200,7 @@ let make_pure_subst evi args = match args with | a::rest -> (rest, (NamedDecl.get_id decl, a)::l) | _ -> anomaly (Pp.str "Instance does not match its signature.")) - (evar_filtered_context evi) (Array.rev_to_list args,[])) + (evar_filtered_context evi) (List.rev args,[])) (*------------------------------------* * functional operations on evar sets * @@ -448,7 +448,7 @@ let new_evar_instance ?src ?filter ?abstract_arguments ?candidates ?naming ?type 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 ?abstract_arguments ?candidates ?naming ?typeclass_candidate ?principal typ in - evd, mkEvar (newevk,Array.of_list instance) + evd, mkEvar (newevk, instance) let new_evar_from_context ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal sign evd typ = let instance = List.map (NamedDecl.get_id %> EConstr.mkVar) (named_context_of_val sign) in @@ -506,7 +506,7 @@ let generalize_evar_over_rels sigma (ev,args) = List.fold_left2 (fun (c,inst as x) a d -> if isRel sigma a then (mkNamedProd_or_LetIn d c,a::inst) else x) - (evi.evar_concl,[]) (Array.to_list args) sign + (evi.evar_concl,[]) args sign (************************************) (* Removing a dependency in an evar *) @@ -594,7 +594,7 @@ let rec check_and_clear_in_constr env evdref err ids global c = (* No dependency at all, we can keep this ev's context hyp *) (ri, true::filter) with Depends id -> (Id.Map.add (NamedDecl.get_id h) id ri, false::filter)) - ctxt (Array.to_list l) (Id.Map.empty,[]) in + ctxt l (Id.Map.empty,[]) in (* Check if some rid to clear in the context of ev has dependencies in the type of ev and adjust the source of the dependency *) let _nconcl = @@ -736,7 +736,7 @@ let undefined_evars_of_term evd t = match EConstr.kind evd c with | Evar (n, l) -> let acc = Evar.Set.add n acc in - Array.fold_left evrec acc l + List.fold_left evrec acc l | _ -> EConstr.fold evd evrec acc c in evrec Evar.Set.empty t diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 1dec63aaf0..b5c7ccb283 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -88,7 +88,7 @@ val new_evar_instance : named_context_val -> evar_map -> types -> constr list -> evar_map * constr -val make_pure_subst : evar_info -> 'a array -> (Id.t * 'a) list +val make_pure_subst : evar_info -> 'a list -> (Id.t * 'a) list val safe_evar_value : evar_map -> Constr.existential -> Constr.constr option diff --git a/engine/evd.ml b/engine/evd.ml index 65fe261ff4..5642145f6d 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -233,32 +233,27 @@ exception NotInstantiatedEvar (* Note: let-in contributes to the instance *) let evar_instance_array test_id info args = - let len = Array.length args in - let rec instrec filter ctxt i = match filter, ctxt with - | [], [] -> - if Int.equal i len then [] - else instance_mismatch () - | false :: filter, _ :: ctxt -> - instrec filter ctxt i - | true :: filter, d :: ctxt -> - if i < len then - let c = Array.unsafe_get args i in - if test_id d c then instrec filter ctxt (succ i) - else (NamedDecl.get_id d, c) :: instrec filter ctxt (succ i) - else instance_mismatch () + let rec instrec filter ctxt args = match filter, ctxt, args with + | [], [], [] -> [] + | false :: filter, _ :: ctxt, args -> + instrec filter ctxt args + | true :: filter, d :: ctxt, c :: args -> + if test_id d c then instrec filter ctxt args + else (NamedDecl.get_id d, c) :: instrec filter ctxt args | _ -> instance_mismatch () in match Filter.repr (evar_filter info) with | None -> - let map i d = - if (i < len) then - let c = Array.unsafe_get args i in - if test_id d c then None else Some (NamedDecl.get_id d, c) - else instance_mismatch () + let rec instance ctxt args = match ctxt, args with + | [], [] -> [] + | d :: ctxt, c :: args -> + if test_id d c then instance ctxt args + else (NamedDecl.get_id d, c) :: instance ctxt args + | _ -> instance_mismatch () in - List.map_filter_i map (evar_context info) + instance (evar_context info) args | Some filter -> - instrec filter (evar_context info) 0 + instrec filter (evar_context info) args let make_evar_instance_array info args = evar_instance_array (NamedDecl.get_id %> isVarId) info args @@ -794,7 +789,7 @@ let restrict evk filter ?candidates ?src evd = | _ -> Evar.Set.add evk evd.last_mods in let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in - let id_inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in + let id_inst = List.map (NamedDecl.get_id %> mkVar) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in let evar_flags = declare_restricted_evar evd.evar_flags evk evk' in @@ -1405,7 +1400,7 @@ let evars_of_term evd c = let rec evrec acc c = let c = MiniEConstr.whd_evar evd c in match kind c with - | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) + | Evar (n, l) -> Evar.Set.add n (List.fold_left evrec acc l) | _ -> Constr.fold evrec acc c in evrec Evar.Set.empty c @@ -1413,7 +1408,7 @@ let evars_of_term evd c = let evar_nodes_of_term c = let rec evrec acc c = match kind c with - | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) + | Evar (n, l) -> Evar.Set.add n (List.fold_left evrec acc l) | _ -> Constr.fold evrec acc c in evrec Evar.Set.empty c diff --git a/engine/evd.mli b/engine/evd.mli index bbdb63a467..c6c4a71b22 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -247,9 +247,9 @@ val existential_opt_value : evar_map -> econstr pexistential -> econstr option val existential_opt_value0 : evar_map -> existential -> constr option val evar_instance_array : (Constr.named_declaration -> 'a -> bool) -> evar_info -> - 'a array -> (Id.t * 'a) list + 'a list -> (Id.t * 'a) list -val instantiate_evar_array : evar_info -> econstr -> econstr array -> econstr +val instantiate_evar_array : evar_info -> econstr -> econstr list -> econstr val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map diff --git a/engine/termops.ml b/engine/termops.ml index 16f2a87c1e..6d779e6a35 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -636,8 +636,8 @@ let map_constr_with_binders_left_to_right sigma g f l c = if b' == b then c else mkProj (p, b') | Evar (e,al) -> - let al' = Array.map_left (f l) al in - if Array.for_all2 (==) al' al then c + let al' = List.map_left (f l) al in + if List.for_all2 (==) al' al then c else mkEvar (e, al') | Case (ci,p,b,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) @@ -707,8 +707,8 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let c' = f l c in if c' == c then cstr else mkProj (p, c') | Evar (e,al) -> - let al' = Array.map (f l) al in - if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') + let al' = List.map (f l) al in + if List.for_all2 (==) al al' then cstr else mkEvar (e, al') | Case (ci,p,c,bl) when userview -> let p' = map_return_predicate_with_full_binders sigma g f l ci p in let c' = f l c in diff --git a/engine/uState.ml b/engine/uState.ml index ff85f09efa..abd5f2828f 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -39,7 +39,7 @@ type t = uctx_weak_constraints : UPairSet.t } -let initial_sprop_cumulative = UGraph.make_sprop_cumulative UGraph.initial_universes +let initial_sprop_cumulative = UGraph.set_cumulative_sprop true UGraph.initial_universes let empty = { uctx_names = UNameMap.empty, LMap.empty; @@ -57,11 +57,11 @@ let elaboration_sprop_cumul = ~key:["Elaboration";"StrictProp";"Cumulativity"] ~value:true let make ~lbound u = - let u = if elaboration_sprop_cumul () then UGraph.make_sprop_cumulative u else u in - { empty with - uctx_universes = u; - uctx_universes_lbound = lbound; - uctx_initial_universes = u} + let u = UGraph.set_cumulative_sprop (elaboration_sprop_cumul ()) u in + { empty with + uctx_universes = u; + uctx_universes_lbound = lbound; + uctx_initial_universes = u} let is_empty ctx = ContextSet.is_empty ctx.uctx_local && @@ -547,10 +547,11 @@ let emit_side_effects eff u = merge_seff u uctx let update_sigma_env uctx env = - let univs = UGraph.make_sprop_cumulative (Environ.universes env) in + let univs = UGraph.set_cumulative_sprop (elaboration_sprop_cumul()) (Environ.universes env) in let eunivs = - { uctx with uctx_initial_universes = univs; - uctx_universes = univs } + { uctx with + uctx_initial_universes = univs; + uctx_universes = univs } in merge_seff eunivs eunivs.uctx_local diff --git a/engine/univSubst.ml b/engine/univSubst.ml index 6000650ad9..a691239ee2 100644 --- a/engine/univSubst.ml +++ b/engine/univSubst.ml @@ -131,7 +131,7 @@ let nf_evars_and_universes_opt_subst f subst = let rec aux c = match kind c with | Evar (evk, args) -> - let args = Array.map aux args in + let args = List.map aux args in (match try f (evk, args) with Not_found -> None with | None -> mkEvar (evk, args) | Some c -> aux c) diff --git a/ide/coqide.ml b/ide/coqide.ml index 3b36875e3a..ab2a17798e 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -1293,7 +1293,10 @@ let build_ui () = (* Initializing hooks *) let refresh_style style = let style = style_manager#style_scheme style in - let iter_session v = v.script#source_buffer#set_style_scheme style in + let iter_session v = + v.script#source_buffer#set_style_scheme style; + v.proof#source_buffer#set_style_scheme style; + v.messages#default_route#source_buffer#set_style_scheme style in List.iter iter_session notebook#pages in let refresh_language lang = diff --git a/ide/coqide_WIN32.ml.in b/ide/coqide_WIN32.ml.in index 2d3964f210..be8aab9e49 100644 --- a/ide/coqide_WIN32.ml.in +++ b/ide/coqide_WIN32.ml.in @@ -44,6 +44,7 @@ let () = Coq.gio_channel_of_descr_socket := Glib.Io.channel_of_descr_socket; set_win32_path (); Coq.interrupter := win32_interrupt; - reroute_stdout_stderr () + reroute_stdout_stderr (); + try ignore (Unix.getenv "GTK_CSD") with Not_found -> Unix.putenv "GTK_CSD" "0" let init () = () diff --git a/ide/idetop.ml b/ide/idetop.ml index 0ef7fca41f..fa458e7c6e 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -232,32 +232,32 @@ let goals () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; try - let newp = Vernacstate.Proof_global.give_me_the_proof () in + let newp = Vernacstate.Declare.give_me_the_proof () in if Proof_diffs.show_diffs () then begin let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in let diff_goal_map = Proof_diffs.make_goal_map oldp newp in Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) end else Some (export_pre_goals Proof.(data newp) process_goal) - with Vernacstate.Proof_global.NoCurrentProof -> None + with Vernacstate.Declare.NoCurrentProof -> None [@@ocaml.warning "-3"];; let evars () = try let doc = get_doc () in set_doc @@ Stm.finish ~doc; - let pfts = Vernacstate.Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Declare.give_me_the_proof () in let Proof.{ sigma } = Proof.data pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in Some el - with Vernacstate.Proof_global.NoCurrentProof -> None + with Vernacstate.Declare.NoCurrentProof -> None [@@ocaml.warning "-3"] let hints () = try - let pfts = Vernacstate.Proof_global.give_me_the_proof () in + let pfts = Vernacstate.Declare.give_me_the_proof () in let Proof.{ goals; sigma } = Proof.data pfts in match goals with | [] -> None @@ -266,7 +266,7 @@ let hints () = let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in Some (hint_hyps, concl_next_tac) - with Vernacstate.Proof_global.NoCurrentProof -> None + with Vernacstate.Declare.NoCurrentProof -> None [@@ocaml.warning "-3"] (** Other API calls *) @@ -287,11 +287,11 @@ let status force = List.rev_map Names.Id.to_string l in let proof = - try Some (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) - with Vernacstate.Proof_global.NoCurrentProof -> None + try Some (Names.Id.to_string (Vernacstate.Declare.get_current_proof_name ())) + with Vernacstate.Declare.NoCurrentProof -> None in let allproofs = - let l = Vernacstate.Proof_global.get_all_proof_names () in + let l = Vernacstate.Declare.get_all_proof_names () in List.map Names.Id.to_string l in { @@ -340,7 +340,7 @@ let import_search_constraint = function | Interface.Include_Blacklist -> Search.Include_Blacklist let search flags = - let pstate = Vernacstate.Proof_global.get_pstate () in + let pstate = Vernacstate.Declare.get_pstate () in List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index b99e5f8069..6e22172d05 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -28,6 +28,7 @@ end class type message_view = object inherit GObj.widget + method source_buffer : GSourceView3.source_buffer method connect : message_view_signals method clear : unit method add : Pp.t -> unit @@ -44,7 +45,8 @@ class type message_view = let message_view () : message_view = let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true - ~tag_table:Tags.Message.table () + ~tag_table:Tags.Message.table + ?style_scheme:(style_manager#style_scheme source_style#get) () in let mark = buffer#create_mark ~left_gravity:false buffer#start_iter in let box = GPack.vbox () in @@ -88,6 +90,8 @@ let message_view () : message_view = val push = new GUtil.signal () + method source_buffer = buffer + method connect = new message_view_signals_impl box#as_widget push diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 21c11b2754..054dd0e571 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -18,6 +18,7 @@ end class type message_view = object inherit GObj.widget + method source_buffer : GSourceView3.source_buffer method connect : message_view_signals method clear : unit method add : Pp.t -> unit diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 3e03ef11f7..1de63953af 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -15,6 +15,7 @@ open Ideutils class type proof_view = object inherit GObj.widget + method source_buffer : GSourceView3.source_buffer method buffer : GText.buffer method refresh : force:bool -> unit method clear : unit -> unit @@ -195,7 +196,8 @@ let display mode (view : #GText.view_skel) goals hints evars = let proof_view () = let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true - ~tag_table:Tags.Proof.table () + ~tag_table:Tags.Proof.table + ?style_scheme:(style_manager#style_scheme source_style#get) () in let text_buffer = new GText.buffer buffer#as_buffer in let view = GSourceView3.source_view @@ -217,6 +219,8 @@ let proof_view () = val mutable evars = None val mutable last_width = -1 + method source_buffer = buffer + method buffer = text_buffer method clear () = buffer#set_text "" diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli index db6fb9e9cd..8217f72066 100644 --- a/ide/wg_ProofView.mli +++ b/ide/wg_ProofView.mli @@ -11,6 +11,7 @@ class type proof_view = object inherit GObj.widget + method source_buffer : GSourceView3.source_buffer method buffer : GText.buffer method refresh : force:bool -> unit method clear : unit -> unit diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index d4369e9bd1..d6097304ec 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -121,9 +121,10 @@ let rec constr_expr_eq e1 e2 = constr_expr_eq a1 a2 && Option.equal constr_expr_eq t1 t2 && constr_expr_eq b1 b2 - | CAppExpl((proj1,r1,_),al1), CAppExpl((proj2,r2,_),al2) -> + | CAppExpl((proj1,r1,u1),al1), CAppExpl((proj2,r2,u2),al2) -> Option.equal Int.equal proj1 proj2 && qualid_eq r1 r2 && + eq_universes u1 u2 && List.equal constr_expr_eq al1 al2 | CApp((proj1,e1),al1), CApp((proj2,e2),al2) -> Option.equal Int.equal proj1 proj2 && @@ -158,8 +159,8 @@ let rec constr_expr_eq e1 e2 = Id.equal id1 id2 && List.equal instance_eq c1 c2 | CSort s1, CSort s2 -> Glob_ops.glob_sort_eq s1 s2 - | CCast(t1,c1), CCast(t2,c2) -> - constr_expr_eq t1 t2 && cast_expr_eq c1 c2 + | CCast(t1,c1), CCast(t2,c2) -> + constr_expr_eq t1 t2 && cast_expr_eq c1 c2 | CNotation(inscope1, n1, s1), CNotation(inscope2, n2, s2) -> Option.equal notation_with_optional_scope_eq inscope1 inscope2 && notation_eq n1 n2 && diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 7a14ca3e48..a37bac3275 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -282,9 +282,9 @@ let insert_pat_alias ?loc p = function | Anonymous -> p | Name _ as na -> CAst.make ?loc @@ CPatAlias (p,(CAst.make ?loc na)) -let rec insert_coercion ?loc l c = match l with +let rec insert_entry_coercion ?loc l c = match l with | [] -> c - | (inscope,ntn)::l -> CAst.make ?loc @@ CNotation (Some inscope,ntn,([insert_coercion ?loc l c],[],[],[])) + | (inscope,ntn)::l -> CAst.make ?loc @@ CNotation (Some inscope,ntn,([insert_entry_coercion ?loc l c],[],[],[])) let rec insert_pat_coercion ?loc l c = match l with | [] -> c @@ -453,7 +453,8 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = with No_match -> let loc = pat.CAst.loc in match DAst.get pat with - | PatVar (Name id) when entry_has_ident custom -> CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) + | PatVar (Name id) when entry_has_global custom || entry_has_ident custom -> + CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) | pat -> match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match @@ -615,6 +616,10 @@ let is_projection nargs r = let is_hole = function CHole _ | CEvar _ -> true | _ -> false +let isCRef_no_univ = function + | CRef (_,None) -> true + | _ -> false + let is_significant_implicit a = not (is_hole (a.CAst.v)) @@ -849,7 +854,7 @@ let extern_possible_prim_token (custom,scopes) r = | Some coercion -> match availability_of_prim_token n sc scopes with | None -> raise No_match - | Some key -> insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) + | Some key -> insert_entry_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) let filter_enough_applied nargs l = match nargs with @@ -931,7 +936,8 @@ let rec extern inctx ?impargs scopes vars r = match DAst.get r with | GRef (ref,us) when entry_has_global (fst scopes) -> CAst.make ?loc (extern_ref vars ref us) - | GVar id when entry_has_ident (fst scopes) -> CAst.make ?loc (extern_var ?loc id) + | GVar id when entry_has_global (fst scopes) || entry_has_ident (fst scopes) -> + CAst.make ?loc (extern_var ?loc id) | c -> @@ -1081,7 +1087,7 @@ let rec extern inctx ?impargs scopes vars r = | GFloat f -> extern_float f (snd scopes) - in insert_coercion coercion (CAst.make ?loc c) + in insert_entry_coercion coercion (CAst.make ?loc c) and extern_typ ?impargs (subentry,(_,scopes)) = extern true ?impargs (subentry,(Notation.current_type_scope_name (),scopes)) @@ -1279,14 +1285,11 @@ and extern_notation (custom,scopes as allscopes) vars t rules = pi3 (extern_local_binder (subentry,(scopt,scl@scopes')) vars bl)) binderlists in let c = make_notation loc specific_ntn (l,ll,bl,bll) in - let c = insert_coercion coercion (insert_delimiters c key) in + let c = insert_entry_coercion coercion (insert_delimiters c key) in let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in CAst.make ?loc @@ extern_applied_notation nallargs argsimpls c args) | SynDefRule kn -> - match availability_of_entry_coercion custom InConstrEntrySomeLevel with - | None -> raise No_match - | Some coercion -> let l = List.map (fun (c,(subentry,(scopt,scl))) -> extern true (subentry,(scopt,scl@snd scopes)) vars c) @@ -1296,7 +1299,10 @@ and extern_notation (custom,scopes as allscopes) vars t rules = let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in let c = CAst.make ?loc @@ extern_applied_syntactic_definition nallargs argsimpls (a,cf) l args in - insert_coercion coercion c + if isCRef_no_univ c.CAst.v && entry_has_global custom then c + else match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> insert_entry_coercion coercion c with No_match -> extern_notation allscopes vars t rules diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 905d9f1e5b..b72802d911 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -53,6 +53,12 @@ type var_internalization_type = | Method | Variable +type var_unique_id = string + +let var_uid = + let count = ref 0 in + fun id -> incr count; Id.to_string id ^ ":" ^ string_of_int !count + type var_internalization_data = (* type of the "free" variable, for coqdoc, e.g. while typing the constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) @@ -60,7 +66,9 @@ type var_internalization_data = (* signature of impargs of the variable *) Impargs.implicit_status list * (* subscopes of the args of the variable *) - scope_name option list + scope_name option list * + (* unique ID for coqdoc links *) + var_unique_id type internalization_env = (var_internalization_data) Id.Map.t @@ -177,15 +185,18 @@ let parsing_explicit = ref false let empty_internalization_env = Id.Map.empty -let compute_internalization_data env sigma ty typ impl = +let compute_internalization_data env sigma id ty typ impl = let impl = compute_implicits_with_manual env sigma typ (is_implicit_args()) impl in - (ty, impl, compute_arguments_scope sigma typ) + (ty, impl, compute_arguments_scope sigma typ, var_uid id) let compute_internalization_env env sigma ?(impls=empty_internalization_env) ty = List.fold_left3 - (fun map id typ impl -> Id.Map.add id (compute_internalization_data env sigma ty typ impl) map) + (fun map id typ impl -> Id.Map.add id (compute_internalization_data env sigma id ty typ impl) map) impls +let extend_internalization_data (r, impls, scopes, uid) impl scope = + (r, impls@[impl], scopes@[scope], uid) + (**********************************************************************) (* Contracting "{ _ }" in notations *) @@ -341,7 +352,7 @@ let impls_binder_list = let impls_type_list n ?(args = []) = let rec aux acc n c = match DAst.get c with | GProd (na,bk,_,c) -> aux (build_impls n bk na acc) (n+1) c - | _ -> (Variable,List.rev acc,[]) + | _ -> List.rev acc in aux args n let impls_term_list n ?(args = []) = @@ -351,7 +362,7 @@ let impls_term_list n ?(args = []) = let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in let n,acc' = List.fold_left (fun (n,acc) (na, bk, _, _) -> (n+1,build_impls n bk na acc)) (n,acc) args.(nb) in aux acc' n bds.(nb) - |_ -> (Variable,List.rev acc,[]) + |_ -> List.rev acc in aux args n (* Check if in binder "(x1 x2 .. xn : t)", none of x1 .. xn-1 occurs in t *) @@ -431,8 +442,9 @@ let push_name_env ntnvars implargs env = if Id.Map.is_empty ntnvars && Id.equal id ldots_var then error_ldots_var ?loc; set_var_scope ?loc id false (env.tmp_scope,env.scopes) ntnvars; - Dumpglob.dump_binding ?loc id; - pure_push_name_env (id,implargs) env + let uid = var_uid id in + Dumpglob.dump_binding ?loc uid; + pure_push_name_env (id,(Variable,implargs,[],uid)) env let remember_binders_impargs env bl = List.map_filter (fun (na,_,_,_) -> @@ -463,7 +475,7 @@ let intern_generalized_binder intern_type ntnvars let ty' = intern_type {env with ids = ids; unb = true} ty in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:ids ~allowed:ids' ty' in let env' = List.fold_left - (fun env {loc;v=x} -> push_name_env ntnvars (Variable,[],[])(*?*) env (make ?loc @@ Name x)) + (fun env {loc;v=x} -> push_name_env ntnvars [](*?*) env (make ?loc @@ Name x)) env fvs in let b' = check_implicit_meaningful ?loc b' env in let bl = List.map @@ -530,7 +542,7 @@ let intern_cases_pattern_as_binder ?loc ntnvars env p = user_err ?loc (str "Unsupported nested \"as\" clause."); il,disjpat in - let env = List.fold_right (fun {loc;v=id} env -> push_name_env ntnvars (Variable,[],[]) env (make ?loc @@ Name id)) il env in + let env = List.fold_right (fun {loc;v=id} env -> push_name_env ntnvars [] env (make ?loc @@ Name id)) il env in let na = alias_of_pat (List.hd disjpat) in let ienv = Name.fold_right Id.Set.remove na env.ids in let id = Namegen.next_name_away_with_default "pat" na ienv in @@ -586,7 +598,7 @@ let intern_generalization intern env ntnvars loc bk ak c = GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None), acc)) in List.fold_right (fun ({loc;v=id} as lid) (env, acc) -> - let env' = push_name_env ntnvars (Variable,[],[]) env CAst.(make @@ Name id) in + let env' = push_name_env ntnvars [] env CAst.(make @@ Name id) in (env', abs lid acc)) fvs (env,c) in c' @@ -677,7 +689,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam if onlyident then (* Do not try to interpret a variable as a constructor *) let na = out_patvar pat in - let env = push_name_env ntnvars (Variable,[],[]) env (make ?loc:pat.loc na) in + let env = push_name_env ntnvars [] env (make ?loc:pat.loc na) in (renaming,env), None, na else (* Interpret as a pattern *) @@ -989,7 +1001,7 @@ let string_of_ty = function | Variable -> "var" let gvar (loc, id) us = match us with -| None -> DAst.make ?loc @@ GVar id +| None | Some [] -> DAst.make ?loc @@ GVar id | Some _ -> user_err ?loc (str "Variable " ++ Id.print id ++ str " cannot have a universe instance") @@ -1004,9 +1016,9 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = else (* Is [id] registered with implicit arguments *) try - let ty,impls,argsc = Id.Map.find id env.impls in + let ty,impls,argsc,uid = Id.Map.find id env.impls in let tys = string_of_ty ty in - Dumpglob.dump_reference ?loc "<>" (Id.to_string id) tys; + Dumpglob.dump_reference ?loc "<>" uid tys; gvar (loc,id) us, make_implicits_list impls, argsc with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) @@ -2084,7 +2096,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = List.rev_append match_td matchs) tms ([],Id.Set.empty,Id.Map.empty,[]) in let env' = Id.Set.fold - (fun var bli -> push_name_env ntnvars (Variable,[],[]) bli (CAst.make @@ Name var)) + (fun var bli -> push_name_env ntnvars [] bli (CAst.make @@ Name var)) (Id.Set.union ex_ids as_in_vars) (restart_lambda_binders env) in @@ -2122,17 +2134,17 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* "in" is None so no match to add *) let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,na,None) in let p' = Option.map (fun u -> - let env'' = push_name_env ntnvars (Variable,[],[]) env' + let env'' = push_name_env ntnvars [] env' (CAst.make na') in intern_type (slide_binders env'') u) po in DAst.make ?loc @@ GLetTuple (List.map (fun { CAst.v } -> v) nal, (na', p'), b', - intern (List.fold_left (push_name_env ntnvars (Variable,[],[])) env nal) c) + intern (List.fold_left (push_name_env ntnvars []) env nal) c) | CIf (c, (na,po), b1, b2) -> let env' = reset_tmp_scope env in let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,na,None) in (* no "in" no match to ad too *) let p' = Option.map (fun p -> - let env'' = push_name_env ntnvars (Variable,[],[]) env + let env'' = push_name_env ntnvars [] env (CAst.make na') in intern_type (slide_binders env'') p) po in DAst.make ?loc @@ diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 9f06f16258..2eb96aad56 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -43,26 +43,28 @@ type var_internalization_type = | Method | Variable -type var_internalization_data = - var_internalization_type * - (* type of the "free" variable, for coqdoc, e.g. while typing the - constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) - - Impargs.implicit_status list * (* signature of impargs of the variable *) - Notation_term.scope_name option list (* subscopes of the args of the variable *) +(** This collects relevant information for interning local variables: + - their coqdoc kind (a recursive call in a inductive, fixpoint of class; or a bound variable) + e.g. while typing the constructor of JMeq, "JMeq" behaves as a variable of type Inductive + - their implicit arguments + - their argument scopes *) +type var_internalization_data (** A map of free variables to their implicit arguments and scopes *) type internalization_env = var_internalization_data Id.Map.t val empty_internalization_env : internalization_env -val compute_internalization_data : env -> evar_map -> var_internalization_type -> +val compute_internalization_data : env -> evar_map -> Id.t -> var_internalization_type -> types -> Impargs.manual_implicits -> var_internalization_data val compute_internalization_env : env -> evar_map -> ?impls:internalization_env -> var_internalization_type -> Id.t list -> types list -> Impargs.manual_implicits list -> internalization_env +val extend_internalization_data : + var_internalization_data -> Impargs.implicit_status -> scope_name option -> var_internalization_data + type ltac_sign = { ltac_vars : Id.Set.t; (** Variables of Ltac which may be bound to a term *) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index e659a5ac5c..57ec708b07 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -246,8 +246,6 @@ let add_glob_kn ?loc kn = let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in add_glob_gen ?loc sp lib_dp "syndef" -let dump_binding ?loc id = () - let dump_def ?loc ty secpath id = Option.iter (fun loc -> if !glob_output = Feedback then Feedback.feedback (Feedback.GlobDef (loc, id, secpath, ty)) @@ -275,3 +273,6 @@ let dump_notation (loc,(df,_)) sc sec = Option.iter (fun loc -> let location = (Loc.make_loc (i, i+1)) in dump_def ~loc:location "not" (Names.DirPath.to_string (Lib.current_dirpath sec)) (cook_notation df sc) ) loc + +let dump_binding ?loc uid = + dump_def ?loc "binder" "<>" uid diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 5409b20472..14e5a81308 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -36,7 +36,7 @@ val dump_secvar : ?loc:Loc.t -> Names.Id.t -> unit val dump_libref : ?loc:Loc.t -> Names.DirPath.t -> string -> unit val dump_notation_location : (int * int) list -> Constrexpr.notation -> (Notation.notation_location * Notation_term.scope_name option) -> unit -val dump_binding : ?loc:Loc.t -> Names.Id.Set.elt -> unit +val dump_binding : ?loc:Loc.t -> string -> unit val dump_notation : (Constrexpr.notation * Notation.notation_location) Loc.located -> Notation_term.scope_name option -> bool -> unit diff --git a/interp/notation.ml b/interp/notation.ml index 6291a88bb0..0afbb9cd62 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -206,7 +206,7 @@ let classify_scope (local,_,_ as o) = let inScope : bool * bool * scope_item -> obj = declare_object {(default_object "SCOPE") with cache_function = cache_scope; - open_function = open_scope; + open_function = simple_open open_scope; subst_function = subst_scope; discharge_function = discharge_scope; classify_function = classify_scope } @@ -980,9 +980,12 @@ let subst_prim_token_interpretation (subs,infos) = let classify_prim_token_interpretation infos = if infos.pt_local then Dispose else Substitute infos +let open_prim_token_interpretation i o = + if Int.equal i 1 then cache_prim_token_interpretation o + let inPrimTokenInterp : prim_token_infos -> obj = declare_object {(default_object "PRIM-TOKEN-INTERP") with - open_function = (fun i o -> if Int.equal i 1 then cache_prim_token_interpretation o); + open_function = simple_open open_prim_token_interpretation; cache_function = cache_prim_token_interpretation; subst_function = subst_prim_token_interpretation; classify_function = classify_prim_token_interpretation} diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 767c69e3b6..7184f5ea29 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -67,11 +67,18 @@ let subst_syntax_constant (subst,(local,syndef)) = let classify_syntax_constant (local,_ as o) = if local then Dispose else Substitute o +let filtered_open_syntax_constant f i ((_,kn),_ as o) = + let in_f = match f with + | Unfiltered -> true + | Names ns -> Globnames.(ExtRefSet.mem (SynDef kn) ns) + in + if in_f then open_syntax_constant i o + let in_syntax_constant : (bool * syndef) -> obj = declare_object {(default_object "SYNDEF") with cache_function = cache_syntax_constant; load_function = load_syntax_constant; - open_function = open_syntax_constant; + open_function = filtered_open_syntax_constant; subst_function = subst_syntax_constant; classify_function = classify_syntax_constant } diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index c31cdae6f5..de02882370 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -613,7 +613,7 @@ let rec to_constr lfts v = subst_constr subs f) | FEvar ((ev,args),env) -> let subs = comp_subs lfts env in - mkEvar(ev,Array.map (fun a -> subst_constr subs a) args) + mkEvar(ev,List.map (fun a -> subst_constr subs a) args) | FLIFT (k,a) -> to_constr (el_shft k lfts) a | FInt i -> @@ -1408,7 +1408,7 @@ and norm_head info tab m = Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in mkFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds)) | FEvar((i,args),env) -> - mkEvar(i, Array.map (fun a -> kl info tab (mk_clos env a)) args) + mkEvar(i, List.map (fun a -> kl info tab (mk_clos env a)) args) | FProj (p,c) -> mkProj (p, kl info tab c) | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ | FConstruct _ diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 8c7aa6b17a..65de52c0f6 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -670,7 +670,7 @@ let rec lambda_of_constr env c = match Constr.kind c with | Meta _ -> raise (Invalid_argument "Cbytegen.lambda_of_constr: Meta") | Evar (evk, args) -> - let args = lambda_of_args env 0 args in + let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in Levar (evk, args) | Cast (c, _, _) -> lambda_of_constr env c @@ -799,9 +799,6 @@ and lambda_of_args env start args = (fun i -> lambda_of_constr env args.(start + i)) else empty_args - - - (*********************************) let dump_lambda = ref false diff --git a/kernel/constr.ml b/kernel/constr.ml index ade03fdf93..703e3616a0 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -71,7 +71,7 @@ type case_info = (* [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) -type 'constr pexistential = existential_key * 'constr array +type 'constr pexistential = existential_key * 'constr list type ('constr, 'types) prec_declaration = Name.t binder_annot array * 'types array * 'constr array type ('constr, 'types) pfixpoint = @@ -110,7 +110,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = type t = (t, t, Sorts.t, Instance.t) kind_of_term type constr = t -type existential = existential_key * constr array +type existential = existential_key * constr list type types = constr @@ -470,7 +470,7 @@ let fold f acc c = match kind c with | LetIn (_,b,t,c) -> f (f (f acc b) t) c | App (c,l) -> Array.fold_left f (f acc c) l | Proj (_p,c) -> f acc c - | Evar (_,l) -> Array.fold_left f acc l + | Evar (_,l) -> List.fold_left f acc l | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | Fix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl @@ -490,7 +490,7 @@ let iter f c = match kind c with | LetIn (_,b,t,c) -> f b; f t; f c | App (c,l) -> f c; Array.iter f l | Proj (_p,c) -> f c - | Evar (_,l) -> Array.iter f l + | Evar (_,l) -> List.iter f l | Case (_,p,c,bl) -> f p; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl @@ -509,7 +509,7 @@ let iter_with_binders g f n c = match kind c with | Lambda (_,t,c) -> f n t; f (g n) c | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.Fun1.iter f n l - | Evar (_,l) -> Array.Fun1.iter f n l + | Evar (_,l) -> List.iter (fun c -> f n c) l | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl | Proj (_p,c) -> f n c | Fix (_,(_,tl,bl)) -> @@ -536,7 +536,7 @@ let fold_constr_with_binders g f n acc c = | LetIn (_na,b,t,c) -> f (g n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_p,c) -> f n acc c - | Evar (_,l) -> Array.fold_left (f n) acc l + | Evar (_,l) -> List.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(_,tl,bl)) -> let n' = iterate g (Array.length tl) n in @@ -657,7 +657,7 @@ let map_gen userview f c = match kind c with if t' == t then c else mkProj (p, t') | Evar (e,l) -> - let l' = Array.Smart.map f l in + let l' = List.Smart.map f l in if l'==l then c else mkEvar (e, l') | Case (ci,p,b,bl) when userview -> @@ -722,7 +722,8 @@ let fold_map f accu c = match kind c with if t' == t then accu, c else accu, mkProj (p, t') | Evar (e,l) -> - let accu, l' = Array.Smart.fold_left_map f accu l in + (* Doesn't matter, we should not hashcons evars anyways *) + let accu, l' = List.fold_left_map f accu l in if l'==l then accu, c else accu, mkEvar (e, l') | Case (ci,p,b,bl) -> @@ -782,7 +783,7 @@ let map_with_binders g f l c0 = match kind c0 with if t' == t then c0 else mkProj (p, t') | Evar (e, al) -> - let al' = Array.Fun1.Smart.map f l al in + let al' = List.Smart.map (fun c -> f l c) al in if al' == al then c0 else mkEvar (e, al') | Case (ci, p, c, bl) -> @@ -834,7 +835,7 @@ let fold_with_full_binders g f n acc c = | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_,c) -> f n acc c - | Evar (_,l) -> Array.fold_left (f n) acc l + | Evar (_,l) -> List.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in @@ -880,7 +881,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t Int.equal len (Array.length l2) && leq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq 0 c1 c2 - | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal (eq 0) l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && List.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> (* The args length currently isn't used but may as well pass it. *) Constant.equal c1 c2 && leq_universes (GlobRef.ConstRef c1) nargs u1 u2 @@ -1039,7 +1040,7 @@ let constr_ord_int f t1 t2 = | Meta m1, Meta m2 -> Int.compare m1 m2 | Meta _, _ -> -1 | _, Meta _ -> 1 | Evar (e1,l1), Evar (e2,l2) -> - (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 + (Evar.compare =? (List.compare f)) e1 e2 l1 l2 | Evar _, _ -> -1 | _, Evar _ -> 1 | Sort s1, Sort s2 -> Sorts.compare s1 s2 | Sort _, _ -> -1 | _, Sort _ -> 1 @@ -1141,7 +1142,7 @@ let hasheq t1 t2 = n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2 | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2 | Proj (p1,c1), Proj(p2,c2) -> p1 == p2 && c1 == c2 - | Evar (e1,l1), Evar (e2,l2) -> e1 == e2 && array_eqeq l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> e1 == e2 && List.equal (==) l1 l2 | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 @@ -1221,7 +1222,7 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let l, hl = hash_term_array l in (App (c,l), combinesmall 7 (combine hl hc)) | Evar (e,l) -> - let l, hl = hash_term_array l in + let l, hl = hash_list_array l in (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) | Const (c,u) -> let c' = sh_con c in @@ -1289,6 +1290,14 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let h = !accu land 0x3FFFFFFF in (HashsetTermArray.repr h t term_array_table, h) + and hash_list_array l = + let fold accu c = + let c, h = sh_rec c in + (combine accu h, c) + in + let h, l = List.fold_left_map fold 0 l in + (l, h land 0x3FFFFFFF) + in (* Make sure our statically allocated Rels (1 to 16) are considered as canonical, and hence hash-consed to themselves *) @@ -1316,7 +1325,7 @@ let rec hash t = | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash c)) | Evar (e,l) -> - combinesmall 8 (combine (Evar.hash e) (hash_term_array l)) + combinesmall 8 (combine (Evar.hash e) (hash_term_list l)) | Const (c,u) -> combinesmall 9 (combine (Constant.hash c) (Instance.hash u)) | Ind (ind,u) -> @@ -1339,6 +1348,9 @@ let rec hash t = and hash_term_array t = Array.fold_left (fun acc t -> combine acc (hash t)) 0 t +and hash_term_list t = + List.fold_left (fun acc t -> combine (hash t) acc) 0 t + module CaseinfoHash = struct type t = case_info @@ -1458,7 +1470,7 @@ let rec debug_print c = prlist_with_sep spc debug_print (Array.to_list l) ++ str")") | Evar (e,l) -> hov 1 (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++ - prlist_with_sep spc debug_print (Array.to_list l) ++str"}") + prlist_with_sep spc debug_print l ++str"}") | Const (c,u) -> str"Cst(" ++ pr_puniverses (Constant.debug_print c) u ++ str")" | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i) u ++ str")" | Construct (((sp,i),j),u) -> diff --git a/kernel/constr.mli b/kernel/constr.mli index 16919b705a..00051d7551 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -83,7 +83,7 @@ val mkFloat : Float64.t -> constr val mkMeta : metavariable -> constr (** Constructs an existential variable *) -type existential = Evar.t * constr array +type existential = Evar.t * constr list val mkEvar : existential -> constr (** Construct a sort *) @@ -203,9 +203,9 @@ val mkCoFix : cofixpoint -> constr (** {6 Concrete type for making pattern-matching. } *) -(** [constr array] is an instance matching definitional [named_context] in +(** [constr list] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) -type 'constr pexistential = Evar.t * 'constr array +type 'constr pexistential = Evar.t * 'constr list type ('constr, 'types, 'sort, 'univs) kind_of_term = | Rel of int (** Gallina-variable introduced by [forall], [fun], [let-in], [fix], or [cofix]. *) diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 244cd2865d..11d4120d7c 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -92,6 +92,8 @@ type typing_flags = { indices_matter: bool; (** The universe of an inductive type must be above that of its indices. *) + cumulative_sprop : bool; + (** SProp <= Type *) } (* some contraints are in constant_constraints, some other may be in diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 20dc21900c..b347152c16 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -26,6 +26,7 @@ let safe_flags oracle = { enable_VM = true; enable_native_compiler = true; indices_matter = true; + cumulative_sprop = false; } (** {6 Arities } *) diff --git a/kernel/environ.ml b/kernel/environ.ml index de8692ff21..cf01711fe7 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -431,7 +431,7 @@ let push_subgraph (levels,csts) env = in map_universes add_subgraph env -let set_engagement c env = (* Unsafe *) +let set_engagement c env = { env with env_stratification = { env.env_stratification with env_engagement = c } } @@ -445,6 +445,7 @@ let same_flags { share_reduction; enable_VM; enable_native_compiler; + cumulative_sprop; } alt = check_guarded == alt.check_guarded && check_positive == alt.check_positive && @@ -453,14 +454,18 @@ let same_flags { indices_matter == alt.indices_matter && share_reduction == alt.share_reduction && enable_VM == alt.enable_VM && - enable_native_compiler == alt.enable_native_compiler + enable_native_compiler == alt.enable_native_compiler && + cumulative_sprop == alt.cumulative_sprop [@warning "+9"] -let set_typing_flags c env = (* Unsafe *) +let set_cumulative_sprop b = map_universes (UGraph.set_cumulative_sprop b) + +let set_typing_flags c env = if same_flags env.env_typing_flags c then env - else { env with env_typing_flags = c } + else set_cumulative_sprop c.cumulative_sprop { env with env_typing_flags = c } -let make_sprop_cumulative = map_universes UGraph.make_sprop_cumulative +let set_cumulative_sprop b env = + set_typing_flags {env.env_typing_flags with cumulative_sprop=b} env let set_allow_sprop b env = { env with env_stratification = diff --git a/kernel/environ.mli b/kernel/environ.mli index 25ecdfd852..4195f112ca 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -310,7 +310,7 @@ val push_subgraph : Univ.ContextSet.t -> env -> env val set_engagement : engagement -> env -> env val set_typing_flags : typing_flags -> env -> env -val make_sprop_cumulative : env -> env +val set_cumulative_sprop : bool -> env -> env val set_allow_sprop : bool -> env -> env val sprop_allowed : env -> bool diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index f987164d52..662ad550b8 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -99,7 +99,7 @@ let rec infer_fterm cv_pb infos variances hd stk = end | FEvar ((_,args),e) -> let variances = infer_stack infos variances stk in - infer_vect infos variances (Array.map (mk_clos e) args) + infer_list infos variances (List.map (mk_clos e) args) | FRel _ -> infer_stack infos variances stk | FInt _ -> infer_stack infos variances stk | FFloat _ -> infer_stack infos variances stk @@ -168,6 +168,9 @@ and infer_stack infos variances (stk:CClosure.stack) = and infer_vect infos variances v = Array.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances v +and infer_list infos variances v = + List.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances v + let infer_term cv_pb env variances c = let open CClosure in let infos = (create_clos_infos all env, create_tab ()) in diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index aa513c1536..317141e324 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -405,7 +405,7 @@ let rec map_kn f f' c = if (ct'== ct && l'==l) then c else mkApp (ct',l') | Evar (e,l) -> - let l' = Array.Smart.map func l in + let l' = List.Smart.map func l in if (l'==l) then c else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 9ed0f6f411..02ee501f5f 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -474,7 +474,7 @@ let rec lambda_of_constr cache env sigma c = | Evar (evk,args as ev) -> (match evar_value sigma ev with | None -> - let args = Array.map (lambda_of_constr cache env sigma) args in + let args = Array.map_of_list (fun c -> lambda_of_constr cache env sigma c) args in Levar(evk, args) | Some t -> lambda_of_constr cache env sigma t) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 6cfe44c5ff..a5fcfae1fc 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -96,14 +96,14 @@ let mk_accu (a : atom) : t = else let data = { data with acc_arg = x :: data.acc_arg } in let ans = Obj.repr (accumulate data) in - let () = Obj.set_tag ans accumulate_tag [@ocaml.alert "--deprecated"] in + let () = Obj.set_tag ans accumulate_tag [@ocaml.warning "-3"] in ans in let acc = { acc_atm = a; acc_arg = [] } in let ans = Obj.repr (accumulate acc) in (** FIXME: use another representation for accumulators, this causes naked pointers. *) - let () = Obj.set_tag ans accumulate_tag [@ocaml.alert "--deprecated"] in + let () = Obj.set_tag ans accumulate_tag [@ocaml.warning "-3"] in (Obj.obj ans : t) let get_accu (k : accumulator) = diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 7574d7b21e..4ff90dd70d 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -367,9 +367,9 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in - convert_vect l2r infos el1 el2 - (Array.map (mk_clos env1) args1) - (Array.map (mk_clos env2) args2) cuniv + convert_list l2r infos el1 el2 + (List.map (mk_clos env1) args1) + (List.map (mk_clos env2) args2) cuniv else raise NotConvertible (* 2 index known to be bound to no constant *) @@ -702,6 +702,13 @@ and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = in Array.fold_right3 fold ci.ci_cstr_nargs br1 br2 cuniv +and convert_list l2r infos lft1 lft2 v1 v2 cuniv = match v1, v2 with +| [], [] -> cuniv +| c1 :: v1, c2 :: v2 -> + let cuniv = ccnv CONV l2r infos lft1 lft2 c1 c2 cuniv in + convert_list l2r infos lft1 lft2 v1 v2 cuniv +| _, _ -> raise NotConvertible + let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 181ec4860c..9fabb441d1 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -113,11 +113,22 @@ type library_info = DirPath.t * vodigest (** Functor and funsig parameters, most recent first *) type module_parameters = (MBId.t * module_type_body) list +type compiled_library = { + comp_name : DirPath.t; + comp_mod : module_body; + comp_deps : library_info array; + comp_enga : engagement; + comp_natsymbs : Nativevalues.symbols +} + +type reimport = compiled_library * Univ.ContextSet.t * vodigest + (** Part of the safe_env at a section opening time to be backtracked *) type section_data = { rev_env : Environ.env; rev_univ : Univ.ContextSet.t; rev_objlabels : Label.Set.t; + rev_reimport : reimport list; } type safe_environment = @@ -232,8 +243,6 @@ let set_native_compiler b senv = let flags = Environ.typing_flags senv.env in set_typing_flags { flags with enable_native_compiler = b } senv -let make_sprop_cumulative senv = { senv with env = Environ.make_sprop_cumulative senv.env } - let set_allow_sprop b senv = { senv with env = Environ.set_allow_sprop b senv.env } (** Check that the engagement [c] expected by a library matches @@ -301,6 +310,7 @@ sig type t val repr : t -> side_effect list val empty : t + val is_empty : t -> bool val add : side_effect -> t -> t val concat : t -> t -> t end = @@ -319,6 +329,7 @@ type t = { seff : side_effect list; elts : SeffSet.t } let repr eff = eff.seff let empty = { seff = []; elts = SeffSet.empty } +let is_empty { seff; elts } = List.is_empty seff && SeffSet.is_empty elts let add x es = if SeffSet.mem x es.elts then es else { seff = x :: es.seff; elts = SeffSet.add x es.elts } @@ -349,6 +360,7 @@ let push_private_constants env eff = List.fold_left add_if_undefined env eff let empty_private_constants = SideEffects.empty +let is_empty_private_constants c = SideEffects.is_empty c let concat_private = SideEffects.concat let universes_of_private eff = @@ -1002,74 +1014,6 @@ let add_module l me inl senv = in (mp,mb.mod_delta),senv'' -(** {6 Interactive sections *) - -let open_section senv = - let custom = { - rev_env = senv.env; - rev_univ = senv.univ; - rev_objlabels = senv.objlabels; - } in - let sections = Section.open_section ~custom senv.sections in - { senv with sections=Some sections } - -let close_section senv = - let open Section in - let sections0 = get_section senv.sections in - let env0 = senv.env in - (* First phase: revert the declarations added in the section *) - let sections, entries, cstrs, revert = Section.close_section sections0 in - let rec pop_revstruct accu entries revstruct = match entries, revstruct with - | [], revstruct -> accu, revstruct - | _ :: _, [] -> - CErrors.anomaly (Pp.str "Unmatched section data") - | entry :: entries, (lbl, leaf) :: revstruct -> - let data = match entry, leaf with - | SecDefinition kn, SFBconst cb -> - let () = assert (Label.equal lbl (Constant.label kn)) in - `Definition (kn, cb) - | SecInductive ind, SFBmind mib -> - let () = assert (Label.equal lbl (MutInd.label ind)) in - `Inductive (ind, mib) - | (SecDefinition _ | SecInductive _), (SFBconst _ | SFBmind _) -> - CErrors.anomaly (Pp.str "Section content mismatch") - | (SecDefinition _ | SecInductive _), (SFBmodule _ | SFBmodtype _) -> - CErrors.anomaly (Pp.str "Module inside a section") - in - pop_revstruct (data :: accu) entries revstruct - in - let redo, revstruct = pop_revstruct [] entries senv.revstruct in - (* Don't revert the delayed constraints. If some delayed constraints were - forced inside the section, they have been turned into global monomorphic - that are going to be replayed. Those that are not forced are not readded - by {!add_constant_aux}. *) - let { rev_env = env; rev_univ = univ; rev_objlabels = objlabels } = revert in - (* Do not revert the opaque table, the discharged opaque constants are - referring to it. *) - let env = Environ.set_opaque_tables env (Environ.opaque_tables senv.env) in - let senv = { senv with env; revstruct; sections; univ; objlabels; } in - (* Second phase: replay the discharged section contents *) - let senv = push_context_set ~strict:true cstrs senv in - let modlist = Section.replacement_context env0 sections0 in - let cooking_info seg = - let { abstr_ctx; abstr_subst; abstr_uctx } = seg in - let abstract = (abstr_ctx, abstr_subst, abstr_uctx) in - { Opaqueproof.modlist; abstract } - in - let fold senv = function - | `Definition (kn, cb) -> - let info = cooking_info (Section.segment_of_constant env0 kn sections0) in - let r = { Cooking.from = cb; info } in - let cb = Term_typing.translate_recipe senv.env kn r in - (* Delayed constants are already in the global environment *) - add_constant_aux senv (kn, cb) - | `Inductive (ind, mib) -> - let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in - let mib = Cooking.cook_inductive info mib in - add_checked_mind ind mib senv - in - List.fold_left fold senv redo - (** {6 Starting / ending interactive modules and module types } *) let start_module l senv = @@ -1275,14 +1219,6 @@ let add_include me is_module inl senv = (** {6 Libraries, i.e. compiled modules } *) -type compiled_library = { - comp_name : DirPath.t; - comp_mod : module_body; - comp_deps : library_info array; - comp_enga : engagement; - comp_natsymbs : Nativevalues.symbols -} - let module_of_library lib = lib.comp_mod type native_library = Nativecode.global list @@ -1351,14 +1287,93 @@ let import lib cst vodigest senv = Modops.add_linked_module mb linkinfo env in let env = Environ.add_native_symbols lib.comp_name lib.comp_natsymbs env in + let sections = + Option.map (Section.map_custom (fun custom -> + {custom with rev_reimport = (lib,cst,vodigest) :: custom.rev_reimport})) + senv.sections + in mp, { senv with env; modresolver = Mod_subst.add_delta_resolver mb.mod_delta senv.modresolver; required = DPmap.add lib.comp_name vodigest senv.required; loads = (mp,mb)::senv.loads; + sections; } +(** {6 Interactive sections *) + +let open_section senv = + let custom = { + rev_env = senv.env; + rev_univ = senv.univ; + rev_objlabels = senv.objlabels; + rev_reimport = []; + } in + let sections = Section.open_section ~custom senv.sections in + { senv with sections=Some sections } + +let close_section senv = + let open Section in + let sections0 = get_section senv.sections in + let env0 = senv.env in + (* First phase: revert the declarations added in the section *) + let sections, entries, cstrs, revert = Section.close_section sections0 in + let rec pop_revstruct accu entries revstruct = match entries, revstruct with + | [], revstruct -> accu, revstruct + | _ :: _, [] -> + CErrors.anomaly (Pp.str "Unmatched section data") + | entry :: entries, (lbl, leaf) :: revstruct -> + let data = match entry, leaf with + | SecDefinition kn, SFBconst cb -> + let () = assert (Label.equal lbl (Constant.label kn)) in + `Definition (kn, cb) + | SecInductive ind, SFBmind mib -> + let () = assert (Label.equal lbl (MutInd.label ind)) in + `Inductive (ind, mib) + | (SecDefinition _ | SecInductive _), (SFBconst _ | SFBmind _) -> + CErrors.anomaly (Pp.str "Section content mismatch") + | (SecDefinition _ | SecInductive _), (SFBmodule _ | SFBmodtype _) -> + CErrors.anomaly (Pp.str "Module inside a section") + in + pop_revstruct (data :: accu) entries revstruct + in + let redo, revstruct = pop_revstruct [] entries senv.revstruct in + (* Don't revert the delayed constraints. If some delayed constraints were + forced inside the section, they have been turned into global monomorphic + that are going to be replayed. Those that are not forced are not readded + by {!add_constant_aux}. *) + let { rev_env = env; rev_univ = univ; rev_objlabels = objlabels; rev_reimport } = revert in + (* Do not revert the opaque table, the discharged opaque constants are + referring to it. *) + let env = Environ.set_opaque_tables env (Environ.opaque_tables senv.env) in + let senv = { senv with env; revstruct; sections; univ; objlabels; } in + (* Second phase: replay Requires *) + let senv = List.fold_left (fun senv (lib,cst,vodigest) -> snd (import lib cst vodigest senv)) + senv (List.rev rev_reimport) + in + (* Third phase: replay the discharged section contents *) + let senv = push_context_set ~strict:true cstrs senv in + let modlist = Section.replacement_context env0 sections0 in + let cooking_info seg = + let { abstr_ctx; abstr_subst; abstr_uctx } = seg in + let abstract = (abstr_ctx, abstr_subst, abstr_uctx) in + { Opaqueproof.modlist; abstract } + in + let fold senv = function + | `Definition (kn, cb) -> + let info = cooking_info (Section.segment_of_constant env0 kn sections0) in + let r = { Cooking.from = cb; info } in + let cb = Term_typing.translate_recipe senv.env kn r in + (* Delayed constants are already in the global environment *) + add_constant_aux senv (kn, cb) + | `Inductive (ind, mib) -> + let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in + let mib = Cooking.cook_inductive info mib in + add_checked_mind ind mib senv + in + List.fold_left fold senv redo + (** {6 Safe typing } *) type judgment = Environ.unsafe_judgment diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index f8d5d319a9..f5bd27ca12 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -50,6 +50,8 @@ type 'a safe_transformer = safe_environment -> 'a * safe_environment type private_constants val empty_private_constants : private_constants +val is_empty_private_constants : private_constants -> bool + val concat_private : private_constants -> private_constants -> private_constants (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in [e1] must be more recent than those of [e2]. *) @@ -133,7 +135,6 @@ val set_check_positive : bool -> safe_transformer0 val set_check_universes : bool -> safe_transformer0 val set_VM : bool -> safe_transformer0 val set_native_compiler : bool -> safe_transformer0 -val make_sprop_cumulative : safe_transformer0 val set_allow_sprop : bool -> safe_transformer0 val check_engagement : Environ.env -> Declarations.set_predicativity -> unit diff --git a/kernel/section.ml b/kernel/section.ml index 948a967f96..8c36f16799 100644 --- a/kernel/section.ml +++ b/kernel/section.ml @@ -45,6 +45,8 @@ let has_poly_univs sec = sec.has_poly_univs let all_poly_univs sec = sec.all_poly_univs +let map_custom f sec = {sec with sec_custom = f sec.sec_custom} + let find_emap e (cmap, imap) = match e with | SecDefinition con -> Cmap.find con cmap | SecInductive ind -> Mindmap.find ind imap diff --git a/kernel/section.mli b/kernel/section.mli index 89739c7da2..2ebb4564b3 100644 --- a/kernel/section.mli +++ b/kernel/section.mli @@ -19,6 +19,9 @@ type 'a t val depth : 'a t -> int (** Number of nested sections. *) +val map_custom : ('a -> 'a) -> 'a t -> 'a t +(** Modify the custom data *) + (** {6 Manipulating sections} *) type section_entry = diff --git a/kernel/sorts.ml b/kernel/sorts.ml index 466fbacca4..3a89b73bd5 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -12,6 +12,8 @@ open Univ type family = InSProp | InProp | InSet | InType +let all_families = [InSProp; InProp; InSet; InType] + type t = | SProp | Prop diff --git a/kernel/sorts.mli b/kernel/sorts.mli index 49549e224d..fe939b1d95 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -12,6 +12,8 @@ type family = InSProp | InProp | InSet | InType +val all_families : family list + type t = private | SProp | Prop diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 449cd0f0f9..5f5f0ef8cd 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -37,7 +37,7 @@ let g_map f g = if g.graph == g' then g else {g with graph=g'} -let make_sprop_cumulative g = {g with sprop_cumulative=true} +let set_cumulative_sprop b g = {g with sprop_cumulative=b} let check_smaller_expr g (u,n) (v,m) = let diff = n - m in diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 8a8c09e911..8d9afb0990 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -13,8 +13,8 @@ open Univ (** {6 Graphs of universes. } *) type t -val make_sprop_cumulative : t -> t -(** Don't use this in the kernel, it makes the system incomplete. *) +val set_cumulative_sprop : bool -> t -> t +(** Makes the system incomplete. *) type 'a check_function = t -> 'a -> 'a -> bool diff --git a/lib/lib.mllib b/lib/lib.mllib index 2db59712b9..4e08e87084 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -14,6 +14,7 @@ CWarnings AcyclicGraph Rtree System +ObjFile Explore CProfile Future diff --git a/lib/objFile.ml b/lib/objFile.ml new file mode 100644 index 0000000000..96db51a010 --- /dev/null +++ b/lib/objFile.ml @@ -0,0 +1,229 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open System + +let magic_number = 0x436F7121l (* "Coq!" *) + +let error_corrupted file s = + CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") + +let open_trapping_failure name = + try open_out_bin name + with e when CErrors.noncritical e -> + CErrors.user_err ~hdr:"System.open" (str "Can't open " ++ str name) + +(* + +int32: big-endian, 4 bytes +int64: big-endian, 8 bytes + +-- string -- +int32 | length of the next field +data | + +-- segment summary -- +string | name +int64 | absolute position +int64 | length (without hash) +hash | MD5 (16 bytes) + +-- segment -- +... | binary data +hash | MD5 (16 bytes) + +-- summary -- +int32 | number of segment summaries +s1 | +... | segment summaries +sn | + +-- vo -- +int32 | magic number +int32 | Coq version +int64 | absolute position of the summary +... | segments +summary | + +*) + +type segment = { + name : string; + pos : int64; + len : int64; + hash : Digest.t; +} + +type in_handle = { + in_filename : string; + in_channel : in_channel; + in_segments : segment CString.Map.t; +} + +type out_handle = { + out_filename : string; + out_channel : out_channel; + mutable out_segments : segment CString.Map.t; +} + +let input_int32 ch = + let accu = ref 0l in + for _i = 0 to 3 do + let c = input_byte ch in + accu := Int32.add (Int32.shift_left !accu 8) (Int32.of_int c) + done; + !accu + +let input_int64 ch = + let accu = ref 0L in + for _i = 0 to 7 do + let c = input_byte ch in + accu := Int64.add (Int64.shift_left !accu 8) (Int64.of_int c) + done; + !accu + +let output_int32 ch n = + for i = 0 to 3 do + output_byte ch (Int32.to_int (Int32.shift_right_logical n (24 - 8 * i))) + done + +let output_int64 ch n = + for i = 0 to 7 do + output_byte ch (Int64.to_int (Int64.shift_right_logical n (56 - 8 * i))) + done + +let input_segment_summary ch = + let nlen = input_int32 ch in + let name = really_input_string ch (Int32.to_int nlen) in + let pos = input_int64 ch in + let len = input_int64 ch in + let hash = Digest.input ch in + { name; pos; len; hash } + +let output_segment_summary ch seg = + let nlen = Int32.of_int (String.length seg.name) in + let () = output_int32 ch nlen in + let () = output_string ch seg.name in + let () = output_int64 ch seg.pos in + let () = output_int64 ch seg.len in + let () = Digest.output ch seg.hash in + () + +let rec input_segment_summaries ch n accu = + if Int32.equal n 0l then accu + else + let s = input_segment_summary ch in + let accu = CString.Map.add s.name s accu in + input_segment_summaries ch (Int32.pred n) accu + +let marshal_in_segment (type a) h ~segment : a * Digest.t = + let { in_channel = ch } = h in + let s = CString.Map.find segment h.in_segments in + let () = LargeFile.seek_in ch s.pos in + let (v : a) = marshal_in h.in_filename ch in + let () = assert (Int64.equal (LargeFile.pos_in ch) (Int64.add s.pos s.len)) in + let h = Digest.input ch in + let () = assert (String.equal h s.hash) in + (v, s.hash) + +let marshal_out_segment h ~segment v = + let { out_channel = ch } = h in + let () = assert (not (CString.Map.mem segment h.out_segments)) in + let pos = LargeFile.pos_out ch in + let () = Marshal.to_channel ch v [] in + let () = flush ch in + let pos' = LargeFile.pos_out ch in + let len = Int64.sub pos' pos in + let hash = + let in_ch = open_in_bin h.out_filename in + let () = LargeFile.seek_in in_ch pos in + let digest = Digest.channel in_ch (Int64.to_int len) in + let () = close_in in_ch in + digest + in + let () = Digest.output ch hash in + let s = { name = segment; pos; len; hash } in + let () = h.out_segments <- CString.Map.add segment s h.out_segments in + () + +let marshal_out_binary h ~segment = + let { out_channel = ch } = h in + let () = assert (not (CString.Map.mem segment h.out_segments)) in + let pos = LargeFile.pos_out ch in + let finish () = + let () = flush ch in + let pos' = LargeFile.pos_out ch in + let len = Int64.sub pos' pos in + let hash = + let in_ch = open_in_bin h.out_filename in + let () = LargeFile.seek_in in_ch pos in + let digest = Digest.channel in_ch (Int64.to_int len) in + let () = close_in in_ch in + digest + in + let () = Digest.output ch hash in + let s = { name = segment; pos; len; hash } in + h.out_segments <- CString.Map.add segment s h.out_segments + in + ch, finish + +let open_in ~file = + try + let ch = open_in_bin file in + let magic = input_int32 ch in + let version = input_int32 ch in + let () = + if not (Int32.equal magic magic_number) then + let e = { filename = file; actual = version; expected = magic_number } in + raise (Bad_magic_number e) + in + let () = + let expected = Coq_config.vo_version in + if not (Int32.equal version expected) then + let e = { filename = file; actual = version; expected } in + raise (Bad_version_number e) + in + let summary_pos = input_int64 ch in + let () = LargeFile.seek_in ch summary_pos in + let nsum = input_int32 ch in + let seg = input_segment_summaries ch nsum CString.Map.empty in + { in_filename = file; in_channel = ch; in_segments = seg } + with + | End_of_file -> error_corrupted file "premature end of file" + | Failure s | Sys_error s -> error_corrupted file s + +let close_in ch = + close_in ch.in_channel + +let get_segment ch ~segment = + CString.Map.find segment ch.in_segments + +let segments ch = ch.in_segments + +let open_out ~file = + let ch = open_trapping_failure file in + let () = output_int32 ch magic_number in + let () = output_int32 ch Coq_config.vo_version in + let () = output_int64 ch 0L (* placeholder *) in + { out_channel = ch; out_segments = CString.Map.empty; out_filename = file } + +let close_out { out_channel = ch; out_segments = seg } = + let () = flush ch in + let pos = LargeFile.pos_out ch in + (* Write the segment summary *) + let () = output_int32 ch (Int32.of_int (CString.Map.cardinal seg)) in + let iter _ s = output_segment_summary ch s in + let () = CString.Map.iter iter seg in + (* Overwrite the position place holder *) + let () = LargeFile.seek_out ch 8L in + let () = output_int64 ch pos in + let () = flush ch in + close_out ch diff --git a/lib/objFile.mli b/lib/objFile.mli new file mode 100644 index 0000000000..b15b04ee54 --- /dev/null +++ b/lib/objFile.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val magic_number : int32 + +type segment = { + name : string; + pos : int64; + len : int64; + hash : Digest.t; +} + +type in_handle +type out_handle + +val open_in : file:string -> in_handle +val close_in : in_handle -> unit +val marshal_in_segment : in_handle -> segment:string -> 'a * Digest.t +val get_segment : in_handle -> segment:string -> segment +val segments : in_handle -> segment CString.Map.t + +val open_out : file:string -> out_handle +val close_out : out_handle -> unit +val marshal_out_segment : out_handle -> segment:string -> 'a -> unit +val marshal_out_binary : out_handle -> segment:string -> out_channel * (unit -> unit) +(** [marshal_out_binary oh segment] is a low level, stateful, API returning + [oc, stop]. Once called no other API can be used on the same [oh] and only + [Stdlib.output_*] APIs should be used on [oc]. [stop ()] must be invoked in + order to signal that all data was written to [oc] (which should not be used + afterwards). Only after calling [stop] the other API can be used on [oh]. *) diff --git a/lib/system.ml b/lib/system.ml index d7f5fa26ab..4e98651d6e 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -182,36 +182,9 @@ let marshal_in filename ch = | End_of_file -> error_corrupted filename "premature end of file" | Failure s -> error_corrupted filename s -let digest_out = Digest.output -let digest_in filename ch = - try Digest.input ch - with - | End_of_file -> error_corrupted filename "premature end of file" - | Failure s -> error_corrupted filename s - -let marshal_out_segment f ch v = - let start = pos_out ch in - output_binary_int ch 0; (* dummy value for stop *) - marshal_out ch v; - let stop = pos_out ch in - seek_out ch start; - output_binary_int ch stop; - seek_out ch stop; - digest_out ch (Digest.file f) - -let marshal_in_segment f ch = - let stop = (input_binary_int f ch : int) in - let v = marshal_in f ch in - let digest = digest_in f ch in - v, stop, digest - -let skip_in_segment f ch = - let stop = (input_binary_int f ch : int) in - seek_in ch stop; - stop, digest_in f ch - -type magic_number_error = {filename: string; actual: int; expected: int} +type magic_number_error = {filename: string; actual: int32; expected: int32} exception Bad_magic_number of magic_number_error +exception Bad_version_number of magic_number_error let raw_extern_state magic filename = let channel = open_trapping_failure filename in @@ -225,8 +198,8 @@ let raw_intern_state magic filename = if not (Int.equal actual_magic magic) then raise (Bad_magic_number { filename=filename; - actual=actual_magic; - expected=magic}); + actual=Int32.of_int actual_magic; + expected=Int32.of_int magic}); channel with | End_of_file -> error_corrupted filename "premature end of file" @@ -256,10 +229,14 @@ let intern_state magic filename = let with_magic_number_check f a = try f a - with Bad_magic_number {filename=fname;actual=actual;expected=expected} -> + with + | Bad_magic_number {filename=fname; _} -> + CErrors.user_err ~hdr:"with_magic_number_check" + (str"File " ++ str fname ++ strbrk" is corrupted.") + | Bad_version_number {filename=fname;actual=actual;expected=expected} -> CErrors.user_err ~hdr:"with_magic_number_check" - (str"File " ++ str fname ++ strbrk" has bad magic number " ++ - int actual ++ str" (expected " ++ int expected ++ str")." ++ + (str"File " ++ str fname ++ strbrk" has bad version number " ++ + (str @@ Int32.to_string actual) ++ str" (expected " ++ (str @@ Int32.to_string expected) ++ str")." ++ spc () ++ strbrk "It is corrupted or was compiled with another version of Coq.") diff --git a/lib/system.mli b/lib/system.mli index 00701379bd..4a8c35b6ea 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -68,8 +68,9 @@ val file_exists_respecting_case : string -> string -> bool when the check fails, with the full file name and expected/observed magic numbers. *) -type magic_number_error = {filename: string; actual: int; expected: int} +type magic_number_error = {filename: string; actual: int32; expected: int32} exception Bad_magic_number of magic_number_error +exception Bad_version_number of magic_number_error val raw_extern_state : int -> string -> out_channel @@ -87,15 +88,6 @@ val with_magic_number_check : ('a -> 'b) -> 'a -> 'b val marshal_out : out_channel -> 'a -> unit val marshal_in : string -> in_channel -> 'a -(** Clones of Digest.output and Digest.input (with nice error message) *) - -val digest_out : out_channel -> Digest.t -> unit -val digest_in : string -> in_channel -> Digest.t - -val marshal_out_segment : string -> out_channel -> 'a -> unit -val marshal_in_segment : string -> in_channel -> 'a * int * Digest.t -val skip_in_segment : string -> in_channel -> int * Digest.t - (** {6 Time stamps.} *) type time diff --git a/library/global.ml b/library/global.ml index abc04a5e14..5c847fda96 100644 --- a/library/global.ml +++ b/library/global.ml @@ -99,7 +99,9 @@ let set_check_guarded c = globalize0 (Safe_typing.set_check_guarded c) let set_check_positive c = globalize0 (Safe_typing.set_check_positive c) let set_check_universes c = globalize0 (Safe_typing.set_check_universes c) let typing_flags () = Environ.typing_flags (env ()) -let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative +let set_cumulative_sprop b = + set_typing_flags {(typing_flags()) with Declarations.cumulative_sprop = b} +let is_cumulative_sprop () = (typing_flags()).Declarations.cumulative_sprop let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants cd = globalize (Safe_typing.export_private_constants cd) diff --git a/library/global.mli b/library/global.mli index e7133a1034..2acd7e2a67 100644 --- a/library/global.mli +++ b/library/global.mli @@ -36,7 +36,8 @@ val set_check_guarded : bool -> unit val set_check_positive : bool -> unit val set_check_universes : bool -> unit val typing_flags : unit -> Declarations.typing_flags -val make_sprop_cumulative : unit -> unit +val set_cumulative_sprop : bool -> unit +val is_cumulative_sprop : unit -> bool val set_allow_sprop : bool -> unit val sprop_allowed : unit -> bool diff --git a/library/globnames.ml b/library/globnames.ml index 9126a467bf..bc24fbf096 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -117,3 +117,10 @@ module ExtRefOrdered = struct | SynDef kn -> combinesmall 2 (KerName.hash kn) end + +module ExtRefMap = HMap.Make(ExtRefOrdered) +module ExtRefSet = ExtRefMap.Set + +let subst_extended_reference sub = function + | SynDef kn -> SynDef (subst_kn sub kn) + | TrueGlobal gr -> TrueGlobal (subst_global_reference sub gr) diff --git a/library/globnames.mli b/library/globnames.mli index fb1583e16c..8acea5ef28 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -61,3 +61,10 @@ module ExtRefOrdered : sig val equal : t -> t -> bool val hash : t -> int end + +module ExtRefSet : CSig.SetS with type elt = extended_global_reference +module ExtRefMap : CMap.ExtS + with type key = extended_global_reference + and module Set := ExtRefSet + +val subst_extended_reference : substitution -> extended_global_reference -> extended_global_reference diff --git a/library/goptions.ml b/library/goptions.ml index 73132868d7..666ba8ee2e 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -24,6 +24,10 @@ type option_value = | StringValue of string | StringOptValue of string option +type table_value = + | StringRefValue of string + | QualidRefValue of qualid + (** Summary of an option status *) type option_state = { opt_depr : bool; @@ -35,8 +39,13 @@ type option_state = { let nickname table = String.concat " " table +let error_no_table_of_this_type ~kind key = + user_err ~hdr:"Goptions" + (str ("There is no " ^ kind ^ "-valued table with this name: \"" ^ nickname key ^ "\".")) + let error_undeclared_key key = - user_err ~hdr:"Goptions" (str (nickname key) ++ str ": no table or option of this type") + user_err ~hdr:"Goptions" + (str ("There is no flag, option or table with this name: \"" ^ nickname key ^ "\".")) (****************************************************************************) (* 1- Tables *) @@ -90,7 +99,7 @@ module MakeTable = let inGo : option_mark * A.t -> obj = Libobject.declare_object {(Libobject.default_object nick) with Libobject.load_function = load_options; - Libobject.open_function = load_options; + Libobject.open_function = simple_open load_options; Libobject.cache_function = cache_options; Libobject.subst_function = subst_options; Libobject.classify_function = (fun x -> Substitute x)} @@ -184,6 +193,23 @@ end module MakeRefTable = functor (A : RefConvertArg) -> MakeTable (RefConvert(A)) +type iter_table_aux = { aux : 'a. 'a table_of_A -> Environ.env -> 'a -> unit } + +let iter_table f key lv = + let aux = function + | StringRefValue s -> + begin + try f.aux (get_string_table key) (Global.env()) s + with Not_found -> error_no_table_of_this_type ~kind:"string" key + end + | QualidRefValue locqid -> + begin + try f.aux (get_ref_table key) (Global.env()) locqid + with Not_found -> error_no_table_of_this_type ~kind:"qualid" key + end + in + List.iter aux lv + (****************************************************************************) (* 2- Flags. *) @@ -262,7 +288,7 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) declare_object { (default_object (nickname key)) with load_function = load_options; - open_function = open_options; + open_function = simple_open open_options; cache_function = cache_options; subst_function = subst_options; discharge_function = discharge_options; @@ -387,9 +413,10 @@ let declare_interpreted_string_option_and_ref ~depr ~key ~(value:'a) from_string (* Setting values of options *) let warn_unknown_option = - CWarnings.create ~name:"unknown-option" ~category:"option" - (fun key -> strbrk "There is no option " ++ - str (nickname key) ++ str ".") + CWarnings.create + ~name:"unknown-option" ~category:"option" + (fun key -> strbrk "There is no flag or option with this name: \"" ++ + str (nickname key) ++ str "\".") let set_option_value ?(locality = OptDefault) check_and_cast key v = let opt = try Some (get_option key) with Not_found -> None in diff --git a/library/goptions.mli b/library/goptions.mli index 336cae420c..150954cbac 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -187,6 +187,10 @@ type option_value = | StringValue of string | StringOptValue of string option +type table_value = + | StringRefValue of string + | QualidRefValue of qualid + val set_option_value : ?locality:option_locality -> ('a -> option_value -> option_value) -> option_name -> 'a -> unit (** [set_option_value ?locality f name v] sets [name] to the result of @@ -204,4 +208,7 @@ type option_state = { val get_tables : unit -> option_state OptionMap.t val print_tables : unit -> Pp.t +type iter_table_aux = { aux : 'a. 'a table_of_A -> Environ.env -> 'a -> unit } +val iter_table : iter_table_aux -> option_name -> table_value list -> unit + val error_undeclared_key : option_name -> 'a diff --git a/library/lib.ml b/library/lib.ml index e7e6dc640a..830777003b 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -46,7 +46,7 @@ let iter_objects f i prefix = List.iter (fun (id,obj) -> f i (make_oname prefix id, obj)) let load_atomic_objects i pr = iter_objects load_object i pr -let open_atomic_objects i pr = iter_objects open_object i pr +let open_atomic_objects f i pr = iter_objects (open_object f) i pr let subst_atomic_objects subst seg = let subst_one = fun (id,obj as node) -> diff --git a/library/lib.mli b/library/lib.mli index 949b5e26c2..56ea35ec60 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -35,7 +35,8 @@ type lib_objects = (Id.t * Libobject.t) list (** {6 Object iteration functions. } *) -val open_atomic_objects : int -> Nametab.object_prefix -> lib_atomic_objects -> unit +val open_atomic_objects : Libobject.open_filter + -> int -> Nametab.object_prefix -> lib_atomic_objects -> unit val load_atomic_objects : int -> Nametab.object_prefix -> lib_atomic_objects -> unit val subst_atomic_objects : Mod_subst.substitution -> lib_atomic_objects -> lib_atomic_objects (*val load_and_subst_objects : int -> Libnames.Nametab.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*) diff --git a/library/libobject.ml b/library/libobject.ml index 0681e12449..c38e0d891b 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -18,11 +18,36 @@ type 'a substitutivity = type object_name = Libnames.full_path * Names.KerName.t +module NSet = Globnames.ExtRefSet + +type open_filter = + | Unfiltered + | Names of NSet.t + +let simple_open f filter i o = match filter with + | Unfiltered -> f i o + | Names _ -> () + +let filter_and f1 f2 = match f1, f2 with + | Unfiltered, f | f, Unfiltered -> Some f + | Names n1, Names n2 -> + let n = NSet.inter n1 n2 in + if NSet.is_empty n then None + else Some (Names n) + +let filter_or f1 f2 = match f1, f2 with + | Unfiltered, f | f, Unfiltered -> Unfiltered + | Names n1, Names n2 -> Names (NSet.union n1 n2) + +let in_filter_ref gr = function + | Unfiltered -> true + | Names ns -> NSet.mem (Globnames.TrueGlobal gr) ns + type 'a object_declaration = { object_name : string; cache_function : object_name * 'a -> unit; load_function : int -> object_name * 'a -> unit; - open_function : int -> object_name * 'a -> unit; + open_function : open_filter -> int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : Mod_subst.substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; @@ -32,7 +57,7 @@ let default_object s = { object_name = s; cache_function = (fun _ -> ()); load_function = (fun _ _ -> ()); - open_function = (fun _ _ -> ()); + open_function = (fun _ _ _ -> ()); subst_function = (fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!")); classify_function = (fun atomic_obj -> Keep atomic_obj); @@ -75,7 +100,7 @@ and t = | ModuleTypeObject of substitutive_objects | IncludeObject of algebraic_objects | KeepObject of objects - | ExportObject of { mpl : ModPath.t list } + | ExportObject of { mpl : (open_filter * ModPath.t) list } | AtomicObject of obj and objects = (Names.Id.t * t) list @@ -105,9 +130,9 @@ let load_object i (sp, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in decl.load_function i (sp, v) -let open_object i (sp, Dyn.Dyn (tag, v)) = +let open_object f i (sp, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in - decl.open_function i (sp, v) + decl.open_function f i (sp, v) let subst_object (subs, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in @@ -147,7 +172,7 @@ let global_object_nodischarge s ~cache ~subst = let import i o = if Int.equal i 1 then cache o in { (default_object s) with cache_function = cache; - open_function = import; + open_function = simple_open import; subst_function = (match subst with | None -> fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!") | Some subst -> subst; diff --git a/library/libobject.mli b/library/libobject.mli index 24cadc2223..1c82349bb6 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -72,16 +72,28 @@ type 'a substitutivity = type object_name = full_path * Names.KerName.t +type open_filter = Unfiltered | Names of Globnames.ExtRefSet.t + type 'a object_declaration = { object_name : string; cache_function : object_name * 'a -> unit; load_function : int -> object_name * 'a -> unit; - open_function : int -> object_name * 'a -> unit; + open_function : open_filter -> int -> object_name * 'a -> unit; classify_function : 'a -> 'a substitutivity; subst_function : substitution * 'a -> 'a; discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } +val simple_open : (int -> object_name * 'a -> unit) -> open_filter -> int -> object_name * 'a -> unit +(** Combinator for making objects which are only opened by unfiltered Import *) + +val filter_and : open_filter -> open_filter -> open_filter option +(** Returns [None] when the intersection is empty. *) + +val filter_or : open_filter -> open_filter -> open_filter + +val in_filter_ref : Names.GlobRef.t -> open_filter -> bool + (** The default object is a "Keep" object with empty methods. Object creators are advised to use the construction [{(default_object "MY_OBJECT") with @@ -114,7 +126,7 @@ and t = | ModuleTypeObject of substitutive_objects | IncludeObject of algebraic_objects | KeepObject of objects - | ExportObject of { mpl : Names.ModPath.t list } + | ExportObject of { mpl : (open_filter * Names.ModPath.t) list } | AtomicObject of obj and objects = (Names.Id.t * t) list @@ -129,7 +141,7 @@ val declare_object : val cache_object : object_name * obj -> unit val load_object : int -> object_name * obj -> unit -val open_object : int -> object_name * obj -> unit +val open_object : open_filter -> int -> object_name * obj -> unit val subst_object : substitution * obj -> obj val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option diff --git a/library/nametab.ml b/library/nametab.ml index 523fe8af50..d9b4dc9122 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -352,10 +352,8 @@ let the_univtab = Summary.ref ~name:"univtab" (UnivTab.empty : univtab) (* Reversed name tables ***************************************************) (* This table translates extended_global_references back to section paths *) -module Globrevtab = HMap.Make(ExtRefOrdered) - -type globrevtab = full_path Globrevtab.t -let the_globrevtab = Summary.ref ~name:"globrevtab" (Globrevtab.empty : globrevtab) +type globrevtab = full_path ExtRefMap.t +let the_globrevtab = Summary.ref ~name:"globrevtab" (ExtRefMap.empty : globrevtab) type mprevtab = DirPath.t MPmap.t @@ -386,7 +384,7 @@ let push_xref visibility sp xref = match visibility with | Until _ -> the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; - the_globrevtab := Globrevtab.add xref sp !the_globrevtab + the_globrevtab := ExtRefMap.add xref sp !the_globrevtab | _ -> begin if ExtRefTab.exists sp !the_ccitab then @@ -520,7 +518,7 @@ let path_of_global ref = let open GlobRef in match ref with | VarRef id -> make_path DirPath.empty id - | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab + | _ -> ExtRefMap.find (TrueGlobal ref) !the_globrevtab let dirpath_of_global ref = fst (repr_path (path_of_global ref)) @@ -529,7 +527,7 @@ let basename_of_global ref = snd (repr_path (path_of_global ref)) let path_of_syndef kn = - Globrevtab.find (SynDef kn) !the_globrevtab + ExtRefMap.find (SynDef kn) !the_globrevtab let dirpath_of_module mp = MPmap.find mp !the_modrevtab @@ -547,7 +545,7 @@ let shortest_qualid_of_global ?loc ctx ref = match ref with | VarRef id -> make_qualid ?loc DirPath.empty id | _ -> - let sp = Globrevtab.find (TrueGlobal ref) !the_globrevtab in + let sp = ExtRefMap.find (TrueGlobal ref) !the_globrevtab in ExtRefTab.shortest_qualid ?loc ctx sp !the_ccitab let shortest_qualid_of_syndef ?loc ctx kn = diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index dca69f06ca..f09b35a6d1 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -42,6 +42,6 @@ let start_deriving f suchthat name : Lemmas.t = let info = Lemmas.Info.make ~proof_ending:(Lemmas.Proof_ending.(End_derive {f; name})) ~kind () in let lemma = Lemmas.start_dependent_lemma ~name ~poly ~info goals in - Lemmas.pf_map (Proof_global.map_proof begin fun p -> + Lemmas.pf_map (Declare.Proof.map_proof begin fun p -> Util.pi1 @@ Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p end) lemma diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 3a90d24c97..02383799a9 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -728,13 +728,13 @@ let extract_and_compile l = (* Show the extraction of the current ongoing proof *) let show_extraction ~pstate = init ~inner:true false false; - let prf = Proof_global.get_proof pstate in - let sigma, env = Pfedit.get_current_context pstate in + let prf = Declare.Proof.get_proof pstate in + let sigma, env = Declare.get_current_context pstate in let trms = Proof.partial_proof prf in let extr_term t = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in - let l = Label.of_id (Proof_global.get_proof_name pstate) in + let l = Label.of_id (Declare.Proof.get_proof_name pstate) in let fake_ref = GlobRef.ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index edbc1f5ea7..06cc475200 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -40,4 +40,4 @@ val structure_for_compute : (* Show the extraction of the current ongoing proof *) -val show_extraction : pstate:Proof_global.t -> unit +val show_extraction : pstate:Declare.Proof.t -> unit diff --git a/plugins/funind/.ocamlformat b/plugins/funind/.ocamlformat new file mode 100644 index 0000000000..a22a2ff88c --- /dev/null +++ b/plugins/funind/.ocamlformat @@ -0,0 +1 @@ +disable=false diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 9749af1e66..7b2ce671a3 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -15,280 +15,265 @@ open Tactics open Indfun_common open Libnames open Context.Rel.Declaration - module RelDecl = Context.Rel.Declaration -let list_chop ?(msg="") n l = - try - List.chop n l - with Failure (msg') -> - failwith (msg ^ msg') +let list_chop ?(msg = "") n l = + try List.chop n l with Failure msg' -> failwith (msg ^ msg') let pop t = Vars.lift (-1) t -let make_refl_eq constructor type_of_t t = -(* let refl_equal_term = Lazy.force refl_equal in *) - mkApp(constructor,[|type_of_t;t|]) - +let make_refl_eq constructor type_of_t t = + (* let refl_equal_term = Lazy.force refl_equal in *) + mkApp (constructor, [|type_of_t; t|]) type pte_info = - { - proving_tac : (Id.t list -> Tacmach.tactic); - is_valid : constr -> bool - } + {proving_tac : Id.t list -> Tacmach.tactic; is_valid : constr -> bool} type ptes_info = pte_info Id.Map.t type 'a dynamic_info = - { - nb_rec_hyps : int; - rec_hyps : Id.t list ; - eq_hyps : Id.t list; - info : 'a - } + {nb_rec_hyps : int; rec_hyps : Id.t list; eq_hyps : Id.t list; info : 'a} type body_info = constr dynamic_info let observe_tac s = observe_tac (fun _ _ -> Pp.str s) let finish_proof dynamic_infos g = - observe_tac "finish" - (Proofview.V82.of_tactic assumption) - g - + observe_tac "finish" (Proofview.V82.of_tactic assumption) g let refine c = Refiner.refiner ~check:true EConstr.Unsafe.(to_constr c) - let thin l = Proofview.V82.of_tactic (Tactics.clear l) - let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v let is_trivial_eq sigma t = - let res = try - begin + let res = + try match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - eq_constr sigma t1 t2 - | App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ()) -> - eq_constr sigma t1 t2 && eq_constr sigma a1 a2 - | _ -> false - end - with e when CErrors.noncritical e -> false + | App (f, [|_; t1; t2|]) when eq_constr sigma f (Lazy.force eq) -> + eq_constr sigma t1 t2 + | App (f, [|t1; a1; t2; a2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma t1 t2 && eq_constr sigma a1 a2 + | _ -> false + with e when CErrors.noncritical e -> false in -(* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) + (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res let rec incompatible_constructor_terms sigma t1 t2 = - let c1,arg1 = decompose_app sigma t1 - and c2,arg2 = decompose_app sigma t2 - in - (not (eq_constr sigma t1 t2)) && - isConstruct sigma c1 && isConstruct sigma c2 && - ( - not (eq_constr sigma c1 c2) || - List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 - ) + let c1, arg1 = decompose_app sigma t1 and c2, arg2 = decompose_app sigma t2 in + (not (eq_constr sigma t1 t2)) + && isConstruct sigma c1 && isConstruct sigma c2 + && ( (not (eq_constr sigma c1 c2)) + || List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) let is_incompatible_eq env sigma t = let res = try match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - incompatible_constructor_terms sigma t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) -> - (eq_constr sigma u1 u2 && - incompatible_constructor_terms sigma t1 t2) - | _ -> false + | App (f, [|_; t1; t2|]) when eq_constr sigma f (Lazy.force eq) -> + incompatible_constructor_terms sigma t1 t2 + | App (f, [|u1; t1; u2; t2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma u1 u2 && incompatible_constructor_terms sigma t1 t2 + | _ -> false with e when CErrors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in - tclTHENS - ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) - [tclTHENLIST - [ - (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); - (* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id])) - ]] g + fun g -> + let prov_id = pf_get_new_id hyp_id g in + tclTHENS + ((* observe_tac msg *) Proofview.V82.of_tactic + (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) + [ tclTHENLIST + [ (* observe_tac "change_hyp_with_using thin" *) + thin [hyp_id] + ; (* observe_tac "change_hyp_with_using rename " *) + Proofview.V82.of_tactic (rename_hyp [(prov_id, hyp_id)]) ] ] + g exception TOREMOVE - -let prove_trivial_eq h_id context (constructor,type_of_term,term) = +let prove_trivial_eq h_id context (constructor, type_of_term, term) = let nb_intros = List.length context in tclTHENLIST - [ - tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *) + [ tclDO nb_intros (Proofview.V82.of_tactic intro) + ; (* introducing context *) (fun g -> - let context_hyps = - fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - (mkApp(constructor,[|type_of_term;term|])):: - (List.map mkVar context_hyps) - in - let to_refine = applist(mkVar h_id,List.rev context_hyps') in - refine to_refine g - ) - ] - - + let context_hyps = + fst + (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) + in + let context_hyps' = + mkApp (constructor, [|type_of_term; term|]) + :: List.map mkVar context_hyps + in + let to_refine = applist (mkVar h_id, List.rev context_hyps') in + refine to_refine g) ] let find_rectype env sigma c = - let (t, l) = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in + let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in match EConstr.kind sigma t with | Ind ind -> (t, l) - | Construct _ -> (t,l) + | Construct _ -> (t, l) | _ -> raise Not_found - -let isAppConstruct ?(env=Global.env ()) sigma t = +let isAppConstruct ?(env = Global.env ()) sigma t = try - let t',l = find_rectype env sigma t in - observe (str "isAppConstruct : " ++ Printer.pr_leconstr_env env sigma t ++ str " -> " ++ - Printer.pr_leconstr_env env sigma (applist (t',l))); + let t', l = find_rectype env sigma t in + observe + ( str "isAppConstruct : " + ++ Printer.pr_leconstr_env env sigma t + ++ str " -> " + ++ Printer.pr_leconstr_env env sigma (applist (t', l)) ); true with Not_found -> false exception NoChange -let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = - let nochange ?t' msg = - begin - observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr_env env sigma t ++ str " " ++ - match t' with None -> str "" | Some t -> Printer.pr_leconstr_env env sigma t ); - raise NoChange; - end +let change_eq env sigma hyp_id (context : rel_context) x t end_of_type = + let nochange ?t' msg = + observe + ( str ("Not treating ( " ^ msg ^ " )") + ++ pr_leconstr_env env sigma t + ++ str " " + ++ + match t' with + | None -> str "" + | Some t -> Printer.pr_leconstr_env env sigma t ); + raise NoChange 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"; - let f_eq,args = destApp sigma t in - let constructor,t1,t2,t1_typ = + 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"; + let f_eq, args = destApp sigma t in + let constructor, t1, t2, t1_typ = + try + if eq_constr f_eq (Lazy.force eq) then + let t1 = (args.(1), args.(0)) + and t2 = (args.(2), args.(0)) + and t1_typ = args.(0) in + (Lazy.force refl_equal, t1, t2, t1_typ) + else if eq_constr f_eq (jmeq ()) then + (jmeq_refl (), (args.(1), args.(0)), (args.(3), args.(2)), args.(0)) + else nochange "not an equality" + with e when CErrors.noncritical e -> nochange "not an equality" + in + if not (closed0 sigma (fst t1) && closed0 sigma (snd t1)) then + nochange "not a closed lhs"; + let rec compute_substitution sub t1 t2 = + (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) + if isRel sigma t2 then ( + let t2 = destRel sigma t2 in try - if (eq_constr f_eq (Lazy.force eq)) - then - let t1 = (args.(1),args.(0)) - and t2 = (args.(2),args.(0)) - and t1_typ = args.(0) - in - (Lazy.force refl_equal,t1,t2,t1_typ) - else - if (eq_constr f_eq (jmeq ())) - then - (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) - else nochange "not an equality" - with e when CErrors.noncritical e -> nochange "not an equality" - in - if not ((closed0 sigma (fst t1)) && (closed0 sigma (snd t1)))then nochange "not a closed lhs"; - let rec compute_substitution sub t1 t2 = -(* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel sigma t2 - then - let t2 = destRel sigma t2 in - begin - try - let t1' = Int.Map.find t2 sub in - if not (eq_constr t1 t1') then nochange "twice bound variable"; - sub - with Not_found -> - assert (closed0 sigma t1); - Int.Map.add t2 t1 sub - end - else if isAppConstruct sigma t1 && isAppConstruct sigma t2 - then - begin - let c1,args1 = find_rectype env sigma t1 - and c2,args2 = find_rectype env sigma t2 - in - if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; - List.fold_left2 compute_substitution sub args1 args2 - end - else - if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) "cannot solve (diff)" - in - let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in - let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) - let new_end_of_type = - (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 - Can be safely replaced by the next comment for Ocaml >= 3.08.4 - *) - let sub = Int.Map.bindings sub in - List.fold_left (fun end_of_type (i,t) -> liftn 1 i (substnl [t] (i-1) end_of_type)) - end_of_type_with_pop + let t1' = Int.Map.find t2 sub in + if not (eq_constr t1 t1') then nochange "twice bound variable"; sub - in - let old_context_length = List.length context + 1 in - let witness_fun = - mkLetIn(make_annot Anonymous Sorts.Relevant,make_refl_eq constructor t1_typ (fst t1),t, - mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) - ) - in - let new_type_of_hyp,ctxt_size,witness_fun = - List.fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) decl -> - try - let witness = Int.Map.find i sub in - if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_annot decl, - witness, RelDecl.get_type decl, witness_fun)) - with Not_found -> - (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) - ) - 1 - (new_end_of_type,0,witness_fun) - context - in - let new_type_of_hyp = - Reductionops.nf_betaiota env sigma new_type_of_hyp in - let new_ctxt,new_end_of_type = - decompose_prod_n_assum sigma ctxt_size new_type_of_hyp - in - let prove_new_hyp : tactic = - tclTHEN - (tclDO ctxt_size (Proofview.V82.of_tactic intro)) - (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids,_ = list_chop ctxt_size all_ids in - let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.type_of g to_refine in - tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g - ) - in - let simpl_eq_tac = - change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp - in -(* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) -(* str "removing an equation " ++ fnl ()++ *) -(* str "old_typ_of_hyp :=" ++ *) -(* Printer.pr_lconstr_env *) -(* env *) -(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) -(* ++ fnl () ++ *) -(* str "new_typ_of_hyp := "++ *) -(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) -(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) -(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) -(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) -(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) -(* ); *) - new_ctxt,new_end_of_type,simpl_eq_tac - - -let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = - if isApp sigma t_x - then - let pte,args = destApp sigma t_x in - if isVar sigma pte && Array.for_all (closed0 sigma) args - then + with Not_found -> + assert (closed0 sigma t1); + Int.Map.add t2 t1 sub ) + else if isAppConstruct sigma t1 && isAppConstruct sigma t2 then begin + let c1, args1 = find_rectype env sigma t1 + and c2, args2 = find_rectype env sigma t2 in + if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; + List.fold_left2 compute_substitution sub args1 args2 + end + else if eq_constr t1 t2 then sub + else + nochange + ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) + "cannot solve (diff)" + in + let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in + let sub = compute_substitution sub (fst t1) (fst t2) in + let end_of_type_with_pop = pop end_of_type in + (*the equation will be removed *) + let new_end_of_type = + (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 + Can be safely replaced by the next comment for Ocaml >= 3.08.4 + *) + let sub = Int.Map.bindings sub in + List.fold_left + (fun end_of_type (i, t) -> liftn 1 i (substnl [t] (i - 1) end_of_type)) + end_of_type_with_pop sub + in + let old_context_length = List.length context + 1 in + let witness_fun = + mkLetIn + ( make_annot Anonymous Sorts.Relevant + , make_refl_eq constructor t1_typ (fst t1) + , t + , mkApp + ( mkVar hyp_id + , Array.init old_context_length (fun i -> + mkRel (old_context_length - i)) ) ) + in + let new_type_of_hyp, ctxt_size, witness_fun = + List.fold_left_i + (fun i (end_of_type, ctxt_size, witness_fun) decl -> + try + let witness = Int.Map.find i sub in + if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); + ( pop end_of_type + , ctxt_size + , mkLetIn + ( RelDecl.get_annot decl + , witness + , RelDecl.get_type decl + , witness_fun ) ) + with Not_found -> + ( mkProd_or_LetIn decl end_of_type + , ctxt_size + 1 + , mkLambda_or_LetIn decl witness_fun )) + 1 + (new_end_of_type, 0, witness_fun) + context + in + let new_type_of_hyp = Reductionops.nf_betaiota env sigma new_type_of_hyp in + let new_ctxt, new_end_of_type = + decompose_prod_n_assum sigma ctxt_size new_type_of_hyp + in + let prove_new_hyp : tactic = + tclTHEN + (tclDO ctxt_size (Proofview.V82.of_tactic intro)) + (fun g -> + let all_ids = pf_ids_of_hyps g in + let new_ids, _ = list_chop ctxt_size all_ids in + let to_refine = applist (witness_fun, List.rev_map mkVar new_ids) in + let evm, _ = pf_apply Typing.type_of g to_refine in + tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g) + in + let simpl_eq_tac = + change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp + prove_new_hyp + in + (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) + (* str "removing an equation " ++ fnl ()++ *) + (* str "old_typ_of_hyp :=" ++ *) + (* Printer.pr_lconstr_env *) + (* env *) + (* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) + (* ++ fnl () ++ *) + (* str "new_typ_of_hyp := "++ *) + (* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) + (* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) + (* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) + (* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) + (* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) + (* ); *) + (new_ctxt, new_end_of_type, simpl_eq_tac) + +let is_property sigma (ptes_info : ptes_info) t_x full_type_of_hyp = + if isApp sigma t_x then + let pte, args = destApp sigma t_x in + if isVar sigma pte && Array.for_all (closed0 sigma) args then try let info = Id.Map.find (destVar sigma pte) ptes_info in info.is_valid full_type_of_hyp @@ -297,19 +282,13 @@ let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = else false let isLetIn sigma t = - match EConstr.kind sigma t with - | LetIn _ -> true - | _ -> false - + match EConstr.kind sigma t with LetIn _ -> true | _ -> false let h_reduce_with_zeta cl = - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) cl) - - + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + cl) let rewrite_until_var arg_num eq_ids : tactic = (* tests if the declares recursive argument is neither a Constructor nor @@ -318,268 +297,247 @@ let rewrite_until_var arg_num eq_ids : tactic = *) let test_var g = let sigma = project g in - let _,args = destApp sigma (pf_concl g) in - not ((isConstruct sigma args.(arg_num)) || isAppConstruct sigma args.(arg_num)) + let _, args = destApp sigma (pf_concl g) in + not (isConstruct sigma args.(arg_num) || isAppConstruct sigma args.(arg_num)) in - let rec do_rewrite eq_ids g = - if test_var g - then tclIDTAC g + let rec do_rewrite eq_ids g = + if test_var g then tclIDTAC g else match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property."); - | eq_id::eq_ids -> - tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) - (do_rewrite eq_ids) - g + | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property.") + | eq_id :: eq_ids -> + tclTHEN + (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) + (do_rewrite eq_ids) g in do_rewrite eq_ids - let rec_pte_id = Id.of_string "Hrec" + let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type") in - let coq_True = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.type") in - let coq_I = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in - let rec scan_type context type_of_hyp : tactic = + let coq_False = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type") + in + let coq_True = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.type") + in + let coq_I = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") + in + let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in - let reduced_type_of_hyp = Reductionops.nf_betaiotazeta env sigma real_type_of_hyp in + let reduced_type_of_hyp = + Reductionops.nf_betaiotazeta env sigma real_type_of_hyp + in (* length of context didn't change ? *) - let new_context,new_typ_of_hyp = - decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp + let new_context, new_typ_of_hyp = + decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp in + tclTHENLIST + [ h_reduce_with_zeta (Locusops.onHyp hyp_id) + ; scan_type new_context new_typ_of_hyp ] + else if isProd sigma type_of_hyp then + let x, t_x, t' = destProd sigma type_of_hyp in + let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in + if is_property sigma ptes_infos t_x actual_real_type_of_hyp then + let pte, pte_args = destApp sigma t_x in + let (* fix_info *) prove_rec_hyp = + (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac + in + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let prove_new_type_of_hyp = + let context_length = List.length context in + tclTHENLIST + [ tclDO context_length (Proofview.V82.of_tactic intro) + ; (fun g -> + let context_hyps_ids = + fst + (list_chop ~msg:"rec hyp : context_hyps" context_length + (pf_ids_of_hyps g)) + in + let rec_pte_id = pf_get_new_id rec_pte_id g in + let to_refine = + applist + ( mkVar hyp_id + , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) + in + (* observe_tac "rec hyp " *) + (tclTHENS + (Proofview.V82.of_tactic + (assert_before (Name rec_pte_id) t_x)) + [ (* observe_tac "prove rec hyp" *) + prove_rec_hyp eq_hyps + ; (* observe_tac "prove rec hyp" *) + refine to_refine ]) + g) ] + in tclTHENLIST - [ h_reduce_with_zeta (Locusops.onHyp hyp_id); - scan_type new_context new_typ_of_hyp ] - else if isProd sigma type_of_hyp - then - begin - let (x,t_x,t') = destProd sigma type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in - if is_property sigma ptes_infos t_x actual_real_type_of_hyp then - begin - let pte,pte_args = (destApp sigma t_x) in - let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in - let prove_new_type_of_hyp = - let context_length = List.length context in - tclTHENLIST - [ - tclDO context_length (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps_ids = - fst (list_chop ~msg:"rec hyp : context_hyps" - context_length (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist(mkVar hyp_id, - List.rev_map mkVar (rec_pte_id::context_hyps_ids) - ) - in -(* observe_tac "rec hyp " *) - (tclTHENS - (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) - [ - (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); -(* observe_tac "prove rec hyp" *) - (refine to_refine) - ]) - g - ) - ] - in - tclTHENLIST - [ -(* observe_tac "hyp rec" *) - (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); - scan_type context popped_t' - ] - end - else if eq_constr sigma t_x coq_False then - begin -(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) -(* str " since it has False in its preconds " *) -(* ); *) - raise TOREMOVE; (* False -> .. useless *) - end - else if is_incompatible_eq env sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) - then -(* observe (str "In "++Ppconstr.pr_id hyp_id++ *) -(* str " removing useless precond True" *) -(* ); *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let prove_trivial = - let nb_intro = List.length context in - tclTHENLIST [ - tclDO nb_intro (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps = - fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) - in - let to_refine = - applist (mkVar hyp_id, - List.rev (coq_I::List.map mkVar context_hyps) - ) - in - refine to_refine g - ) - ] - in - tclTHENLIST[ - change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp - ((* observe_tac "prove_trivial" *) prove_trivial); - scan_type context popped_t' - ] - else if is_trivial_eq sigma t_x - then (* t_x := t = t => we remove this precond *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let hd,args = destApp sigma t_x in - let get_args hd args = - if eq_constr sigma hd (Lazy.force eq) - then (Lazy.force refl_equal,args.(0),args.(1)) - else (jmeq_refl (),args.(0),args.(1)) - in + [ (* observe_tac "hyp rec" *) + change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp + prove_new_type_of_hyp + ; scan_type context popped_t' ] + else if eq_constr sigma t_x coq_False then + (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) + (* str " since it has False in its preconds " *) + (* ); *) + raise TOREMOVE (* False -> .. useless *) + else if is_incompatible_eq env sigma t_x then raise TOREMOVE + (* t_x := C1 ... = C2 ... *) + else if + eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) + then + (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) + (* str " removing useless precond True" *) + (* ); *) + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let prove_trivial = + let nb_intro = List.length context in tclTHENLIST - [ - change_hyp_with_using - "prove_trivial_eq" - hyp_id - real_type_of_hyp - ((* observe_tac "prove_trivial_eq" *) - (prove_trivial_eq hyp_id context (get_args hd args))); - scan_type context popped_t' - ] - else - begin - try - let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in - tclTHEN - tac - (scan_type new_context new_t') - with NoChange -> - (* Last thing todo : push the rel in the context and continue *) - scan_type (LocalAssum (x,t_x) :: context) t' - end - end - else - tclIDTAC - in - try - scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id] - with TOREMOVE -> - thin [hyp_id],[] - - -let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) = - fun g -> - let env = pf_env g - and sigma = project g - in - let tac,new_hyps = - List.fold_left ( - fun (hyps_tac,new_hyps) hyp_id -> - let hyp_tac,new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + [ tclDO nb_intro (Proofview.V82.of_tactic intro) + ; (fun g -> + let context_hyps = + fst + (list_chop ~msg:"removing True : context_hyps " nb_intro + (pf_ids_of_hyps g)) + in + let to_refine = + applist + ( mkVar hyp_id + , List.rev (coq_I :: List.map mkVar context_hyps) ) + in + refine to_refine g) ] + in + tclTHENLIST + [ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp + (* observe_tac "prove_trivial" *) prove_trivial + ; scan_type context popped_t' ] + else if is_trivial_eq sigma t_x then + (* t_x := t = t => we remove this precond *) + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let hd, args = destApp sigma t_x in + let get_args hd args = + if eq_constr sigma hd (Lazy.force eq) then + (Lazy.force refl_equal, args.(0), args.(1)) + else (jmeq_refl (), args.(0), args.(1)) + in + tclTHENLIST + [ change_hyp_with_using "prove_trivial_eq" hyp_id real_type_of_hyp + ((* observe_tac "prove_trivial_eq" *) + prove_trivial_eq hyp_id context (get_args hd args)) + ; scan_type context popped_t' ] + else + try + let new_context, new_t', tac = + change_eq env sigma hyp_id context x t_x t' in - (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps - ) - (tclIDTAC,[]) - dyn_infos.rec_hyps - in - let new_infos = - { dyn_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in - tclTHENLIST - [ - tac ; - (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) - ] - g + tclTHEN tac (scan_type new_context new_t') + with NoChange -> + (* Last thing todo : push the rel in the context and continue *) + scan_type (LocalAssum (x, t_x) :: context) t' + else tclIDTAC + in + try (scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id]) + with TOREMOVE -> (thin [hyp_id], []) + +let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) g = + let env = pf_env g and sigma = project g in + let tac, new_hyps = + List.fold_left + (fun (hyps_tac, new_hyps) hyp_id -> + let hyp_tac, new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) + (tclIDTAC, []) dyn_infos.rec_hyps + in + let new_infos = + {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} + in + tclTHENLIST + [tac; (* observe_tac "clean_hyp_with_heq continue" *) continue_tac new_infos] + g let heq_id = Id.of_string "Heq" -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = - fun g -> - let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in - tclTHENLIST - [ - (* We first introduce the variables *) - tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))); - (* Then the equation itself *) - Proofview.V82.of_tactic (intro_using heq_id); - onLastHypId (fun heq_id -> tclTHENLIST [ - (* Then the new hypothesis *) - tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; - observe_tac "after_introduction" (fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_get_hyp_typ g' heq_id in - (* compute the new value of the body *) - let new_term_value = - match EConstr.kind (project g') new_term_value_eq with - | App(f,[| _;_;args2 |]) -> args2 - | _ -> - observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_leconstr_env (pf_env g') (project g') new_term_value_eq - ); - anomaly (Pp.str "cannot compute new term value.") - in - let g', termtyp = tac_type_of g' term in - let fun_body = - mkLambda(make_annot Anonymous Sorts.Relevant, - termtyp, - Termops.replace_term (project g') term (mkRel 1) dyn_infos.info - ) - in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with - info = new_body; - eq_hyps = heq_id::dyn_infos.eq_hyps - } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g' - )]) - ] - g - +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos g = + let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in + tclTHENLIST + [ (* We first introduce the variables *) + tclDO nb_first_intro + (Proofview.V82.of_tactic + (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))) + ; (* Then the equation itself *) + Proofview.V82.of_tactic (intro_using heq_id) + ; onLastHypId (fun heq_id -> + tclTHENLIST + [ (* Then the new hypothesis *) + tclMAP + (fun id -> Proofview.V82.of_tactic (introduction id)) + dyn_infos.rec_hyps + ; observe_tac "after_introduction" (fun g' -> + (* We get infos on the equations introduced*) + let new_term_value_eq = pf_get_hyp_typ g' heq_id in + (* compute the new value of the body *) + let new_term_value = + match EConstr.kind (project g') new_term_value_eq with + | App (f, [|_; _; args2|]) -> args2 + | _ -> + observe + ( str "cannot compute new term value : " + ++ pr_gls g' ++ fnl () ++ str "last hyp is" + ++ pr_leconstr_env (pf_env g') (project g') + new_term_value_eq ); + anomaly (Pp.str "cannot compute new term value.") + in + let g', termtyp = tac_type_of g' term in + let fun_body = + mkLambda + ( make_annot Anonymous Sorts.Relevant + , termtyp + , Termops.replace_term (project g') term (mkRel 1) + dyn_infos.info ) + in + let new_body = + pf_nf_betaiota g' (mkApp (fun_body, [|new_term_value|])) + in + let new_infos = + { dyn_infos with + info = new_body + ; eq_hyps = heq_id :: dyn_infos.eq_hyps } + in + clean_goal_with_heq ptes_infos continue_tac new_infos g') ]) + ] + g let my_orelse tac1 tac2 g = - try - tac1 g + try tac1 g with e when CErrors.noncritical e -> -(* observe (str "using snd tac since : " ++ CErrors.print e); *) + (* observe (str "using snd tac since : " ++ CErrors.print e); *) tac2 g -let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = - let args = Array.of_list (List.map mkVar args_id) in +let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = + let args = Array.of_list (List.map mkVar args_id) in let instantiate_one_hyp hid = my_orelse - ( (* we instantiate the hyp if possible *) - fun g -> - let prov_hid = pf_get_new_id hid g in - let c = mkApp(mkVar hid,args) in - let evm, _ = pf_apply Typing.type_of g c in - tclTHENLIST[ - Refiner.tclEVARS evm; - Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); - thin [hid]; - Proofview.V82.of_tactic (rename_hyp [prov_hid,hid]) - ] g - ) - ( (* + (fun (* we instantiate the hyp if possible *) + g -> + let prov_hid = pf_get_new_id hid g in + let c = mkApp (mkVar hid, args) in + let evm, _ = pf_apply Typing.type_of g c in + tclTHENLIST + [ Refiner.tclEVARS evm + ; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c) + ; thin [hid] + ; Proofview.V82.of_tactic (rename_hyp [(prov_hid, hid)]) ] + g) + (fun (* if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. @@ -587,350 +545,314 @@ let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = principle so that we can trash it *) - (fun g -> -(* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) - thin [hid] g - ) - ) + g -> + (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) + thin [hid] g) in - if List.is_empty args_id - then - tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - do_prove hyps - ] + if List.is_empty args_id then + tclTHENLIST + [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps + ; do_prove hyps ] else tclTHENLIST - [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - tclMAP instantiate_one_hyp hyps; - (fun g -> - let all_g_hyps_id = - List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty - in - let remaining_hyps = - List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g - ) - ] + [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps + ; tclMAP instantiate_one_hyp hyps + ; (fun g -> + let all_g_hyps_id = + List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty + in + let remaining_hyps = + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps g) ] -let build_proof - (interactive_proof:bool) - (fnames:Constant.t list) - ptes_infos - dyn_infos - : tactic = +let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos + dyn_infos : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> - let env = pf_env g in - let sigma = project g in -(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match EConstr.kind sigma dyn_infos.info with - | Case(ci,ct,t,cb) -> - let do_finalize_t dyn_info' = - fun g -> - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = - mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (project g) (pf_concl g) in - let g, type_of_term = tac_type_of g t in - let term_eq = - make_refl_eq (Lazy.force refl_equal) type_of_term t - in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); - thin dyn_infos.rec_hyps; - Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); - (fun g -> observe_tac "toto" ( - tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); - (fun g' -> - let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instantiate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case - ptes_infos - nb_instantiate_partial - (build_proof do_finalize) - t - dyn_infos) - g' - ) - - ]) g - ) - ] - g - in - build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda(n,t,b) -> - begin - match EConstr.kind sigma (pf_concl g) with - | Prod _ -> - tclTHEN - (Proofview.V82.of_tactic intro) - (fun g' -> - let open Context.Named.Declaration in - let id = pf_last_hyp g' |> get_id in - let new_term = - pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) - in - let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize - {new_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in -(* observe_tac "Lambda" *) (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' - (* build_proof do_finalize new_infos g' *) - ) g - | _ -> - do_finalize dyn_infos g - end - | Cast(t,_,_) -> - build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> - do_finalize dyn_infos g - | App(_,_) -> - let f,args = decompose_app sigma dyn_infos.info in - begin - match EConstr.kind sigma f with - | Int _ -> user_err Pp.(str "integer cannot be applied") - | Float _ -> user_err Pp.(str "float cannot be applied") - | App _ -> assert false (* we have collected all the app in decompose_app *) - | Proj _ -> assert false (*FIXME*) - | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in - build_proof_args env sigma do_finalize new_infos g - | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in -(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args env sigma do_finalize new_infos g - | Const _ -> - do_finalize dyn_infos g - | Lambda _ -> - let new_term = - Reductionops.nf_beta env sigma dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} - g - | LetIn _ -> - let new_infos = - { dyn_infos with info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> - h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos - ] - g - | Cast(b,_,_) -> - build_proof do_finalize {dyn_infos with info = b } g - | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = - { dyn_infos with - info = dyn_infos.info,args - } - in - build_proof_args env sigma do_finalize new_infos - in - build_proof new_finalize {dyn_infos with info = f } g - end - | Fix _ | CoFix _ -> - user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) - - - | Proj _ -> user_err Pp.(str "Prod") - | Prod _ -> do_finalize dyn_infos g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info - } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos - ] g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - and build_proof do_finalize dyn_infos g = -(* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - Indfun_common.observe_tac (fun env sigma -> - str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g - and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = - fun g -> - let (f_args',args) = dyn_infos.info in - let tac : tactic = - fun g -> - match args with - | [] -> - do_finalize {dyn_infos with info = f_args'} g - | arg::args -> - (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) - (* fnl () ++ *) - (* pr_goal (Tacmach.sig_it g) *) - (* ); *) - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - (* tclTRYD *) - (build_proof_args env sigma - do_finalize - {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} - ) - in + fun g -> + let env = pf_env g in + let sigma = project g in + (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) + match EConstr.kind sigma dyn_infos.info with + | Case (ci, ct, t, cb) -> + let do_finalize_t dyn_info' g = + let t = dyn_info'.info in + let dyn_infos = {dyn_info' with info = mkCase (ci, ct, t, cb)} in + let g_nb_prod = nb_prod (project g) (pf_concl g) in + let g, type_of_term = tac_type_of g t in + let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in + tclTHENLIST + [ Proofview.V82.of_tactic + (generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps)) + ; thin dyn_infos.rec_hyps + ; Proofview.V82.of_tactic + (pattern_option [(Locus.AllOccurrencesBut [1], t)] None) + ; (fun g -> + observe_tac "toto" + (tclTHENLIST + [ Proofview.V82.of_tactic (Simple.case t) + ; (fun g' -> + let g'_nb_prod = nb_prod (project g') (pf_concl g') in + let nb_instantiate_partial = g'_nb_prod - g_nb_prod in + observe_tac "treat_new_case" + (treat_new_case ptes_infos nb_instantiate_partial + (build_proof do_finalize) t dyn_infos) + g') ]) + g) ] + g + in + build_proof do_finalize_t {dyn_infos with info = t} g + | Lambda (n, t, b) -> ( + match EConstr.kind sigma (pf_concl g) with + | Prod _ -> + tclTHEN + (Proofview.V82.of_tactic intro) + (fun g' -> + let open Context.Named.Declaration in + let id = pf_last_hyp g' |> get_id in + let new_term = + pf_nf_betaiota g' (mkApp (dyn_infos.info, [|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = build_proof do_finalize - {dyn_infos with info = arg } - g + { new_infos with + rec_hyps = new_hyps + ; nb_rec_hyps = List.length new_hyps } + in + (* observe_tac "Lambda" *) + (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' + (* build_proof do_finalize new_infos g' *)) + g + | _ -> do_finalize dyn_infos g ) + | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ + |Float _ -> + do_finalize dyn_infos g + | App (_, _) -> ( + let f, args = decompose_app sigma dyn_infos.info in + match EConstr.kind sigma f with + | Int _ -> user_err Pp.(str "integer cannot be applied") + | Float _ -> user_err Pp.(str "float cannot be applied") + | App _ -> + assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ + -> + let new_infos = {dyn_infos with info = (f, args)} in + build_proof_args env sigma do_finalize new_infos g + | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + let new_infos = {dyn_infos with info = (f, args)} in + (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + build_proof_args env sigma do_finalize new_infos g + | Const _ -> do_finalize dyn_infos g + | Lambda _ -> + let new_term = Reductionops.nf_beta env sigma dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} g + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } + in + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + g + | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} g + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in + build_proof_args env sigma do_finalize new_infos + in + build_proof new_finalize {dyn_infos with info = f} g ) + | Fix _ | CoFix _ -> + user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos g + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in - (* observe_tac "build_proof_args" *) (tac ) g + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + g + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + and build_proof do_finalize dyn_infos g = + (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) + Indfun_common.observe_tac + (fun env sigma -> + str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info) + (build_proof_aux do_finalize dyn_infos) + g + and build_proof_args env sigma do_finalize dyn_infos : tactic = + (* f_args' args *) + fun g -> + let f_args', args = dyn_infos.info in + let tac : tactic = + fun g -> + match args with + | [] -> do_finalize {dyn_infos with info = f_args'} g + | arg :: args -> + (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) + (* fnl () ++ *) + (* pr_goal (Tacmach.sig_it g) *) + (* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) + build_proof_args env sigma do_finalize + {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + in + build_proof do_finalize {dyn_infos with info = arg} g + in + (* observe_tac "build_proof_args" *) tac g in let do_finish_proof dyn_infos = - (* tclTRYD *) (clean_goal_with_heq - ptes_infos - finish_proof dyn_infos) + (* tclTRYD *) clean_goal_with_heq ptes_infos finish_proof dyn_infos in - (* observe_tac "build_proof" *) + (* observe_tac "build_proof" *) fun g -> build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g - (* Proof of principles from structural functions *) type static_fix_info = - { - idx : int; - name : Id.t; - types : types; - offset : int; - nb_realargs : int; - body_with_param : constr; - num_in_block : int - } - - - -let prove_rec_hyp_for_struct fix_info = - (fun eq_hyps -> tclTHEN - (rewrite_until_var (fix_info.idx) eq_hyps) - (fun g -> - let _,pte_args = destApp (project g) (pf_concl g) in - let rec_hyp_proof = - mkApp(mkVar fix_info.name,array_get_start pte_args) - in - refine rec_hyp_proof g - )) + { idx : int + ; name : Id.t + ; types : types + ; offset : int + ; nb_realargs : int + ; body_with_param : constr + ; num_in_block : int } + +let prove_rec_hyp_for_struct fix_info eq_hyps = + tclTHEN (rewrite_until_var fix_info.idx eq_hyps) (fun g -> + let _, pte_args = destApp (project g) (pf_concl g) in + let rec_hyp_proof = + mkApp (mkVar fix_info.name, array_get_start pte_args) + in + refine rec_hyp_proof g) -let prove_rec_hyp fix_info = - { proving_tac = prove_rec_hyp_for_struct fix_info - ; - is_valid = fun _ -> true - } +let prove_rec_hyp fix_info = + {proving_tac = prove_rec_hyp_for_struct fix_info; is_valid = (fun _ -> true)} let generalize_non_dep hyp g = -(* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) + (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in let hyp_typ = pf_get_hyp_typ g hyp in - let to_revert,_ = + let to_revert, _ = let open Context.Named.Declaration in - Environ.fold_named_context_reverse (fun (clear,keep) decl -> - let decl = map_named_decl EConstr.of_constr decl in - let hyp = get_id decl in - if Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep - || Termops.occur_var env (project g) hyp hyp_typ - || Termops.is_section_variable hyp (* should be dangerous *) - then (clear,decl::keep) - else (hyp::clear,keep)) - ~init:([],[]) (pf_env g) + Environ.fold_named_context_reverse + (fun (clear, keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in + let hyp = get_id decl in + if + Id.List.mem hyp hyps + || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep + || Termops.occur_var env (project g) hyp hyp_typ + || Termops.is_section_variable hyp + (* should be dangerous *) + then (clear, decl :: keep) + else (hyp :: clear, keep)) + ~init:([], []) (pf_env g) in -(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) + (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map mkVar to_revert) ))) - ((* observe_tac "thin" *) (thin to_revert)) + ((* observe_tac "h_generalize" *) Proofview.V82.of_tactic + (generalize (List.map mkVar to_revert))) + ((* observe_tac "thin" *) thin to_revert) g let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id let var_of_decl = id_of_decl %> mkVar + let revert idl = - tclTHEN - (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) - (thin idl) + tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) (thin idl) -let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = -(* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) -(* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) -(* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) +let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num + = + (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) + (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) + (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) let f_def = Global.lookup_constant (fst (destConst evd f)) in - let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in - let (f_body, _, _) = Option.get (Global.body_of_constant_body Library.indirect_accessor f_def) in + let eq_lhs = + mkApp + ( f + , Array.init (nb_params + nb_args) (fun i -> + mkRel (nb_params + nb_args - i)) ) + in + let f_body, _, _ = + Option.get (Global.body_of_constant_body Library.indirect_accessor f_def) + in let f_body = EConstr.of_constr f_body in - let params,f_body_with_params = decompose_lam_n evd nb_params f_body in - let (_,num),(_,_,bodies) = destFix evd f_body_with_params in + let params, f_body_with_params = decompose_lam_n evd nb_params f_body in + let (_, num), (_, _, bodies) = destFix evd f_body_with_params in let fnames_with_params = - let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in - let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in + let params = Array.init nb_params (fun i -> mkRel (nb_params - i)) in + let fnames = + List.rev (Array.to_list (Array.map (fun f -> mkApp (f, params)) fnames)) + in fnames in -(* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) -(* observe (str "body " ++ pr_lconstr bodies.(num)); *) - let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in -(* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) - let eq_rhs = Reductionops.nf_betaiotazeta (Global.env ()) evd (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in + (* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) + (* observe (str "body " ++ pr_lconstr bodies.(num)); *) + let f_body_with_params_and_other_fun = + substl fnames_with_params bodies.(num) + in + (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) + let eq_rhs = + Reductionops.nf_betaiotazeta (Global.env ()) evd + (mkApp + ( compose_lam params f_body_with_params_and_other_fun + , Array.init (nb_params + nb_args) (fun i -> + mkRel (nb_params + nb_args - i)) )) + in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) - let (type_ctxt,type_of_f),evd = - let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f - in - decompose_prod_n_assum evd - (nb_params + nb_args) t,evd + let (type_ctxt, type_of_f), evd = + let evd, t = Typing.type_of ~refresh:true (Global.env ()) evd f in + (decompose_prod_n_assum evd (nb_params + nb_args) t, evd) in - let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in + let eqn = mkApp (Lazy.force eq, [|type_of_f; eq_lhs; eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) let f_id = Label.to_id (Constant.label (fst (destConst evd f))) in let prove_replacement = tclTHENLIST - [ - tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro); - observe_tac "" (fun g -> - let rec_id = pf_nth_hyp_id g 1 in - tclTHENLIST - [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); - observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); - (Proofview.V82.of_tactic intros_reflexivity)] g - ) - ] + [ tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro) + ; observe_tac "" (fun g -> + let rec_id = pf_nth_hyp_id g 1 in + tclTHENLIST + [ observe_tac "generalize_non_dep in generate_equation_lemma" + (generalize_non_dep rec_id) + ; observe_tac "h_case" + (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))) + ; Proofview.V82.of_tactic intros_reflexivity ] + g) ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) - let lemma = Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type in - let lemma,_ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let lemma = + Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type + in + let lemma, _ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None + in evd -let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = +let do_replace (evd : Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num + all_funs g = let equation_lemma = try let finfos = @@ -939,376 +861,366 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a | Some finfos -> finfos in mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone as e) -> + with (Not_found | Option.IsNone) as e -> let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) - let equation_lemma_id = (mk_equation_id f_id) in - evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + let equation_lemma_id = mk_equation_id f_id in + evd := + generate_equation_lemma !evd all_funs f fun_num (List.length params) + (List.length rev_args_id) rec_arg_num; let _ = match e with - | Option.IsNone -> - let finfos = match find_Function_infos (fst (destConst !evd f)) with - | None -> raise Not_found - | Some finfos -> finfos - in - update_Function - {finfos with - equation_lemma = Some ( - match Nametab.locate (qualid_of_ident equation_lemma_id) with - | GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) - } - | _ -> () + | Option.IsNone -> + let finfos = + match find_Function_infos (fst (destConst !evd f)) with + | None -> raise Not_found + | Some finfos -> finfos + in + update_Function + { finfos with + equation_lemma = + Some + ( match Nametab.locate (qualid_of_ident equation_lemma_id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } + | _ -> () in (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) - let evd',res = - Evd.fresh_global - (Global.env ()) !evd + let evd', res = + Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in - evd:=evd'; + evd := evd'; let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in evd := sigma; res in let nb_intro_to_do = nb_prod (project g) (pf_concl g) in - tclTHEN - (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) - ( - fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in - let open Context.Named.Declaration in - let just_introduced_id = List.map get_id just_introduced in - tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) - (revert just_introduced_id) g' - ) - g + tclTHEN + (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) + (fun g' -> + let just_introduced = nLastDecls nb_intro_to_do g' in + let open Context.Named.Declaration in + let just_introduced_id = List.map get_id just_introduced in + tclTHEN + (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) + (revert just_introduced_id) + g') + g -let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnames all_funs _nparams : tactic = - fun g -> +let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num + fnames all_funs _nparams : tactic = + fun g -> let princ_type = pf_concl g in (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) (* Pp.msgnl (str "all_funs "); *) (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig (project g) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - (fun na -> - let new_id = - match na with - Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" - in - avoid := new_id :: !avoid; - (Name new_id) - ) - in - let fresh_decl = RelDecl.map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } - in - let get_body const = - match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in - Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env - sigma - (EConstr.of_constr body) - | None -> user_err Pp.(str "Cannot define a principle over an axiom ") - in - let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam (project g) fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params,princ_params,fbody_with_full_params = - if diff_params > 0 - then - let princ_params,full_params = - list_chop diff_params princ_info.params - in - (full_params, (* real params *) - princ_params, (* the params of the principle which are not params of the function *) - substl (* function instantiated with real params *) - (List.map var_of_decl full_params) - f_body - ) - else - let f_ctxt_other,f_ctxt_params = - list_chop (- diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in - (princ_info.params, (* real params *) - [],(* all params are full params *) - substl (* function instantiated with real params *) - (List.map var_of_decl princ_info.params) - f_body - ) - in - observe (str "full_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - full_params - ); - observe (str "princ_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - princ_params - ); - observe (str "fbody_with_full_params := " ++ - pr_leconstr_env (Global.env ()) !evd fbody_with_full_params - ); - let all_funs_with_full_params = - Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs - in - let fix_offset = List.length princ_params in - let ptes_to_fix,infos = - match EConstr.kind (project g) fbody_with_full_params with - | Fix((idxs,i),(names,typess,bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, - List.rev_map var_of_decl princ_params)) - ) - bodies + let princ_info = compute_elim_sig (project g) princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps g) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id + in + let fresh_decl = RelDecl.map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } + in + let get_body const = + match Global.body_of_constant Library.indirect_accessor const with + | Some (body, _, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + env sigma (EConstr.of_constr body) + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") + in + let fbody = get_body fnames.(fun_num) in + let f_ctxt, f_body = decompose_lam (project g) fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params, princ_params, fbody_with_full_params = + if diff_params > 0 then + let princ_params, full_params = list_chop diff_params princ_info.params in + ( full_params + , (* real params *) + princ_params + , (* the params of the principle which are not params of the function *) + substl (* function instantiated with real params *) + (List.map var_of_decl full_params) + f_body ) + else + let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + ( princ_info.params + , (* real params *) + [] + , (* all params are full params *) + substl (* function instantiated with real params *) + (List.map var_of_decl princ_info.params) + f_body ) + in + observe + ( str "full_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + full_params ); + observe + ( str "princ_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + princ_params ); + observe + ( str "fbody_with_full_params := " + ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); + let all_funs_with_full_params = + Array.map + (fun f -> applist (f, List.rev_map var_of_decl full_params)) + all_funs + in + let fix_offset = List.length princ_params in + let ptes_to_fix, infos = + match EConstr.kind (project g) fbody_with_full_params with + | Fix ((idxs, i), (names, typess, bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> + Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + body + , List.rev_map var_of_decl princ_params ))) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = + prod_applist (project g) types + (List.rev_map var_of_decl princ_params) in - let info_array = - Array.mapi - (fun i types -> - let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in - { idx = idxs.(i) - fix_offset; - name = Nameops.Name.get_id (fresh_id names.(i).binder_name); - types = types; - offset = fix_offset; - nb_realargs = - List.length - (fst (decompose_lam (project g) bodies.(i))) - fix_offset; - body_with_param = bodies_with_all_params.(i); - num_in_block = i - } - ) - typess + { idx = idxs.(i) - fix_offset + ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) + ; types + ; offset = fix_offset + ; nb_realargs = + List.length (fst (decompose_lam (project g) bodies.(i))) + - fix_offset + ; body_with_param = bodies_with_all_params.(i) + ; num_in_block = i }) + typess + in + let pte_to_fix, rev_info = + List.fold_left_i + (fun i (acc_map, acc_info) decl -> + let pte = RelDecl.get_name decl in + let infos = info_array.(i) in + let type_args, _ = decompose_prod (project g) infos.types in + let nargs = List.length type_args in + let f = + applist + (mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let pte_to_fix,rev_info = - List.fold_left_i - (fun i (acc_map,acc_info) decl -> - let pte = RelDecl.get_name decl in - let infos = info_array.(i) in - let type_args,_ = decompose_prod (project g) infos.types in - let nargs = List.length type_args in - let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in - let app_f = mkApp(f,first_args) in - let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in - let body_with_param,num = - let body = get_body fnames.(i) in - let body_with_full_params = - Reductionops.nf_betaiota (pf_env g) (project g) ( - applist(body,List.rev_map var_of_decl full_params)) - in - match EConstr.kind (project g) body_with_full_params with - | Fix((_,num),(_,_,bs)) -> - Reductionops.nf_betaiota (pf_env g) (project g) - ( - (applist - (substl - (List.rev - (Array.to_list all_funs_with_full_params)) - bs.(num), - List.rev_map var_of_decl princ_params)) - ),num - | _ -> user_err Pp.(str "Not a mutual block") - in - let info = - {infos with - types = compose_prod type_args app_pte; - body_with_param = body_with_param; - num_in_block = num - } - in -(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) -(* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info) - ) - 0 - (Id.Map.empty,[]) - (List.rev princ_info.predicates) + let first_args = Array.init nargs (fun i -> mkRel (nargs - i)) in + let app_f = mkApp (f, first_args) in + let pte_args = Array.to_list first_args @ [app_f] in + let app_pte = applist (mkVar (Nameops.Name.get_id pte), pte_args) in + let body_with_param, num = + let body = get_body fnames.(i) in + let body_with_full_params = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist (body, List.rev_map var_of_decl full_params)) + in + match EConstr.kind (project g) body_with_full_params with + | Fix ((_, num), (_, _, bs)) -> + ( Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + bs.(num) + , List.rev_map var_of_decl princ_params )) + , num ) + | _ -> user_err Pp.(str "Not a mutual block") in - pte_to_fix,List.rev rev_info - | _ -> - Id.Map.empty,[] - in - let mk_fixes : tactic = - let pre_info,infos = list_chop fun_num infos in - match pre_info,infos with - | _,[] -> tclIDTAC - | _, this_fix_info::others_infos -> - let other_fix_infos = - List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) - (pre_info@others_infos) + let info = + { infos with + types = compose_prod type_args app_pte + ; body_with_param + ; num_in_block = num } in - if List.is_empty other_fix_infos - then - if this_fix_info.idx + 1 = 0 - then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) - else - Indfun_common.observe_tac (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx +1)) - (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) - else - Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos 0) - in - let first_tac : tactic = (* every operations until fix creations *) + (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) + (* str " to " ++ Ppconstr.pr_id info.name); *) + (Id.Map.add (Nameops.Name.get_id pte) info acc_map, info :: acc_info)) + 0 (Id.Map.empty, []) + (List.rev princ_info.predicates) + in + (pte_to_fix, List.rev rev_info) + | _ -> (Id.Map.empty, []) + in + let mk_fixes : tactic = + let pre_info, infos = list_chop fun_num infos in + match (pre_info, infos) with + | _, [] -> tclIDTAC + | _, this_fix_info :: others_infos -> + let other_fix_infos = + List.map + (fun fi -> (fi.name, fi.idx + 1, fi.types)) + (pre_info @ others_infos) + in + if List.is_empty other_fix_infos then + if this_fix_info.idx + 1 = 0 then tclIDTAC + (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) + else + Indfun_common.observe_tac + (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) + (Proofview.V82.of_tactic + (fix this_fix_info.name (this_fix_info.idx + 1))) + else + Proofview.V82.of_tactic + (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos 0) + in + let first_tac : tactic = + (* every operations until fix creations *) + tclTHENLIST + [ observe_tac "introducing params" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.params))) + ; observe_tac "introducing predictes" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.predicates))) + ; observe_tac "introducing branches" + (Proofview.V82.of_tactic + (intros_using (List.rev_map id_of_decl princ_info.branches))) + ; observe_tac "building fixes" mk_fixes ] + in + let intros_after_fixes : tactic = + fun gl -> + let ctxt, pte_app = decompose_prod_assum (project gl) (pf_concl gl) in + let pte, pte_args = decompose_app (project gl) pte_app in + try + let pte = + try destVar (project gl) pte + with DestKO -> anomaly (Pp.str "Property is not a variable.") + in + let fix_info = Id.Map.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in tclTHENLIST - [ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params))); - observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates))); - observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches))); - observe_tac "building fixes" mk_fixes; - ] - in - let intros_after_fixes : tactic = - fun gl -> - let ctxt,pte_app = (decompose_prod_assum (project gl) (pf_concl gl)) in - let pte,pte_args = (decompose_app (project gl) pte_app) in - try - let pte = - try destVar (project gl) pte - with DestKO -> anomaly (Pp.str "Property is not a variable.") - in - let fix_info = Id.Map.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in - tclTHENLIST - [ - (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro)); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let fix_body = fix_info.body_with_param in -(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fix_body,List.rev_map mkVar args_id)); - eq_hyps = [] - } + [ (* observe_tac ("introducing args") *) + tclDO nb_args (Proofview.V82.of_tactic intro) + ; (fun g -> + (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let fix_body = fix_info.body_with_param in + (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist (fix_body, List.rev_map mkVar args_id)) + ; eq_hyps = [] } + in + tclTHENLIST + [ observe_tac "do_replace" + (do_replace evd full_params + (fix_info.idx + List.length princ_params) + ( args_id + @ List.map + (RelDecl.get_name %> Nameops.Name.get_id) + princ_params ) + all_funs.(fix_info.num_in_block) + fix_info.num_in_block all_funs) + ; (let do_prove = + build_proof interactive_proof (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) in - tclTHENLIST - [ - observe_tac "do_replace" - (do_replace evd - full_params - (fix_info.idx + List.length princ_params) - (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params)) - (all_funs.(fix_info.num_in_block)) - fix_info.num_in_block - all_funs - ); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - observe_tac "cleaning" (clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos) - in -(* observe (str "branches := " ++ *) -(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) -(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - -(* ); *) - (* observe_tac "instancing" *) (instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) - ] - g - ); - ] gl - with Not_found -> - let nb_args = min (princ_info.nargs) (List.length ctxt) in - tclTHENLIST - [ - tclDO nb_args (Proofview.V82.of_tactic intro); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fbody_with_full_params, - (List.rev_map var_of_decl princ_params)@ - (List.rev_map mkVar args_id) - )); - eq_hyps = [] - } + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + observe_tac "cleaning" + (clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos) in - let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in - tclTHENLIST - [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos - in - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id) - ] - g - ) - ] - gl - in - tclTHEN - first_tac - intros_after_fixes - g - - - - - + (* observe (str "branches := " ++ *) + (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) + (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + + (* ); *) + (* observe_tac "instancing" *) + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ] + g) ] + gl + with Not_found -> + let nb_args = min princ_info.nargs (List.length ctxt) in + tclTHENLIST + [ tclDO nb_args (Proofview.V82.of_tactic intro) + ; (fun g -> + (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (pf_env g) (project g) + (applist + ( fbody_with_full_params + , List.rev_map var_of_decl princ_params + @ List.rev_map mkVar args_id )) + ; eq_hyps = [] } + in + let fname = + destConst (project g) + (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) + in + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]) + ; (let do_prove = + build_proof interactive_proof (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos + in + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ] + g) ] + gl + in + tclTHEN first_tac intros_after_fixes g (* Proof of principles of general functions *) (* let hrec_id = Recdef.hrec_id *) @@ -1319,132 +1231,119 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* and list_rewrite = Recdef.list_rewrite *) (* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) - - - - let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with | Undefined -> anomaly (Pp.str "No tcc proof !!") | Value lemma -> - fun gls -> -(* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) -(* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENLIST - [ -(* generalize [lemma]; *) -(* h_intro hid; *) -(* Elim.h_decompose_and (mkVar hid); *) - tclTRY(list_rewrite true eqs); -(* (fun g -> *) -(* let ids' = pf_ids_of_hyps g in *) -(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) -(* rewrite *) -(* ) *) - Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) - ] - gls + fun gls -> + (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) + (* let ids = hid::pf_ids_of_hyps gls in *) + tclTHENLIST + [ (* generalize [lemma]; *) + (* h_intro hid; *) + (* Elim.h_decompose_and (mkVar hid); *) + tclTRY (list_rewrite true eqs) + ; (* (fun g -> *) + (* let ids' = pf_ids_of_hyps g in *) + (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) + (* rewrite *) + (* ) *) + Proofview.V82.of_tactic (Eauto.gen_eauto (false, 5) [] (Some [])) ] + gls | Not_needed -> tclIDTAC let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = - tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) - in - let _,hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in - let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in - let f = (fst (destApp (project gls) f_app)) in - let rec backtrack : tactic = - fun g -> - let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in - match EConstr.kind (project g) f_app with - | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g - | _ -> tclTHEN rewrite backtrack g - in - backtrack gls - + fun gls -> + let eqs = List.map mkVar eqs in + let rewrite = + tclFIRST + (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs) + in + let _, hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in + let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in + let f = fst (destApp (project gls) f_app) in + let rec backtrack : tactic = + fun g -> + let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in + match EConstr.kind (project g) f_app with + | App (f', _) when eq_constr (project g) f' f -> tclIDTAC g + | _ -> tclTHEN rewrite backtrack g + in + backtrack gls let rec rewrite_eqs_in_eqs eqs = match eqs with - | [] -> tclIDTAC - | eq::eqs -> - - tclTHEN - (tclMAP - (fun id gl -> - observe_tac - (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) - (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences - true (* dep proofs also: *) true id (mkVar eq) false))) - gl - ) - eqs - ) - (rewrite_eqs_in_eqs eqs) + | [] -> tclIDTAC + | eq :: eqs -> + tclTHEN + (tclMAP + (fun id gl -> + observe_tac + (Format.sprintf "rewrite %s in %s " (Id.to_string eq) + (Id.to_string id)) + (tclTRY + (Proofview.V82.of_tactic + (Equality.general_rewrite_in true Locus.AllOccurrences true + (* dep proofs also: *) true id (mkVar eq) false))) + gl) + eqs) + (rewrite_eqs_in_eqs eqs) let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = - fun gls -> - (tclTHENLIST - [ - backtrack_eqs_until_hrec hrec eqs; - (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) - (tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) - [ tclTHENLIST - [ - (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); - (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); - (fun g -> - if is_mes - then - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g - else tclIDTAC g - ); - observe_tac "rew_and_finish" - (tclTHENLIST - [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs)); - observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); - (observe_tac "finishing using" - ( - tclCOMPLETE( - Proofview.V82.of_tactic @@ - Eauto.eauto_with_bases - (true,5) + fun gls -> + (tclTHENLIST + [ backtrack_eqs_until_hrec hrec eqs + ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) + tclTHENS (* We must have exactly ONE subgoal !*) + (Proofview.V82.of_tactic (apply (mkVar hrec))) + [ tclTHENLIST + [ Proofview.V82.of_tactic (keep (tcc_hyps @ eqs)) + ; Proofview.V82.of_tactic (apply (Lazy.force acc_inv)) + ; (fun g -> + if is_mes then + Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference + (delayed_force ltof_ref) ) ]) + g + else tclIDTAC g) + ; observe_tac "rew_and_finish" + (tclTHENLIST + [ tclTRY + (list_rewrite false + (List.map (fun v -> (mkVar v, true)) eqs)) + ; observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs) + ; observe_tac "finishing using" + (tclCOMPLETE + ( Proofview.V82.of_tactic + @@ Eauto.eauto_with_bases (true, 5) [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [Hints.Hint_db.empty TransparentState.empty false] - ) - ) - ) - ] - ) - ] - ]) - ]) - gls - + [ Hints.Hint_db.empty TransparentState.empty + false ] )) ]) ] ] ]) + gls let is_valid_hypothesis sigma predicates_name = - let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in + let predicates_name = + List.fold_right Id.Set.add predicates_name Id.Set.empty + in let is_pte typ = - if isApp sigma typ - then - let pte,_ = destApp sigma typ in - if isVar sigma pte - then Id.Set.mem (destVar sigma pte) predicates_name + if isApp sigma typ then + let pte, _ = destApp sigma typ in + if isVar sigma pte then Id.Set.mem (destVar sigma pte) predicates_name else false else false in let rec is_valid_hypothesis typ = - is_pte typ || - match EConstr.kind sigma typ with - | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' - | _ -> false + is_pte typ + || + match EConstr.kind sigma typ with + | Prod (_, pte, typ') -> is_pte pte && is_valid_hypothesis typ' + | _ -> false in is_valid_hypothesis -let prove_principle_for_gen - (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes +let prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in let princ_info = compute_elim_sig (project gl) princ_type in @@ -1452,9 +1351,9 @@ let prove_principle_for_gen let avoid = ref (pf_ids_of_hyps gl) in fun na -> let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; Name new_id @@ -1462,200 +1361,182 @@ let prove_principle_for_gen let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } in let wf_tac = - if is_mes - then - (fun b -> - Proofview.V82.of_tactic @@ - Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None) + if is_mes then fun b -> + Proofview.V82.of_tactic + @@ Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None else fun _ -> prove_with_tcc tcc_lemma_ref [] in let real_rec_arg_num = rec_arg_num - princ_info.nparams in let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in -(* observe ( *) -(* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) -(* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - -(* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) -(* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) -(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) -(* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let (post_rec_arg,pre_rec_arg) = + (* observe ( *) + (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) + (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) + + (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) + (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) + (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) + (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) + let post_rec_arg, pre_rec_arg = Util.List.chop npost_rec_arg princ_info.args in let rec_arg_id = match List.rev post_rec_arg with - | (LocalAssum ({binder_name=Name id},_) | LocalDef ({binder_name=Name id},_,_)) :: _ -> id - | _ -> assert false + | ( LocalAssum ({binder_name = Name id}, _) + | LocalDef ({binder_name = Name id}, _, _) ) + :: _ -> + id + | _ -> assert false + in + (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) + let subst_constrs = + List.map + (get_name %> Nameops.Name.get_id %> mkVar) + (pre_rec_arg @ princ_info.params) in -(* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (get_name %> Nameops.Name.get_id %> mkVar) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in let acc_rec_arg_id = - Nameops.Name.get_id (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) + Nameops.Name.get_id + (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) in let revert l = - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) + tclTHEN + (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) + (Proofview.V82.of_tactic (clear l)) in let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = - ((* observe_tac "prove_rec_arg_acc" *) - (tclCOMPLETE - (tclTHEN - (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) - ( - (* observe_tac *) -(* "apply wf_thm" *) - Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) - ) - ) - ) - ) + ((* observe_tac "prove_rec_arg_acc" *) + tclCOMPLETE + (tclTHEN + (Proofview.V82.of_tactic + (assert_by (Name wf_thm_id) + (mkApp (delayed_force well_founded, [|input_type; relation|])) + (Proofview.V82.tactic (fun g -> + (* observe_tac "prove wf" *) + (tclCOMPLETE (wf_tac is_mes)) g)))) + ((* observe_tac *) + (* "apply wf_thm" *) + Proofview.V82.of_tactic + (Tactics.Simple.apply + (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))))) g in let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in let lemma = match !tcc_lemma_ref with - | Undefined -> user_err Pp.(str "No tcc proof !!") - | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") + | Undefined -> user_err Pp.(str "No tcc proof !!") + | Value lemma -> EConstr.of_constr lemma + | Not_needed -> + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in -(* let rec list_diff del_list check_list = *) -(* match del_list with *) -(* [] -> *) -(* [] *) -(* | f::r -> *) -(* if List.mem f check_list then *) -(* list_diff r check_list *) -(* else *) -(* f::(list_diff r check_list) *) -(* in *) + (* let rec list_diff del_list check_list = *) + (* match del_list with *) + (* [] -> *) + (* [] *) + (* | f::r -> *) + (* if List.mem f check_list then *) + (* list_diff r check_list *) + (* else *) + (* f::(list_diff r check_list) *) + (* in *) let tcc_list = ref [] in let start_tac gls = let hyps = pf_ids_of_hyps gls in - let hid = - next_ident_away_in_goal - (Id.of_string "prov") - (Id.Set.of_list hyps) - in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize [lemma]); - Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); - (fun g -> - let new_hyps = pf_ids_of_hyps g in - tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); - if List.is_empty !tcc_list - then - begin - tcc_list := [hid]; - tclIDTAC g - end - else thin [hid] g - ) - ] - gls + let hid = + next_ident_away_in_goal (Id.of_string "prov") (Id.Set.of_list hyps) + in + tclTHENLIST + [ Proofview.V82.of_tactic (generalize [lemma]) + ; Proofview.V82.of_tactic (Simple.intro hid) + ; Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)) + ; (fun g -> + let new_hyps = pf_ids_of_hyps g in + tcc_list := List.rev (List.subtract Id.equal new_hyps (hid :: hyps)); + if List.is_empty !tcc_list then begin + tcc_list := [hid]; + tclIDTAC g + end + else thin [hid] g) ] + gls in tclTHENLIST - [ - observe_tac "start_tac" start_tac; - h_intros - (List.rev_map (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) - ); - Proofview.V82.of_tactic - (assert_by - (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc)); - (revert (List.rev (acc_rec_arg_id::args_ids))); - (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); - h_intros (List.rev (acc_rec_arg_id::args_ids)); - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); - (fun gl' -> - let body = - let _,args = destApp (project gl') (pf_concl gl') in - Array.last args - in - let body_info rec_hyps = - { - nb_rec_hyps = List.length rec_hyps; - rec_hyps = rec_hyps; - eq_hyps = []; - info = body - } - in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in - let predicates_names = - List.map (get_name %> Nameops.Name.get_id) princ_info.predicates - in - let pte_info = - { proving_tac = - (fun eqs -> -(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) -(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) -(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) -(* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) -(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) - - (* observe_tac "new_prove_with_tcc" *) - (new_prove_with_tcc - is_mes acc_inv fix_id - - (!tcc_list@(List.map - (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.params) - )@ ([acc_rec_arg_id])) eqs - ) - - ); - is_valid = is_valid_hypothesis (project gl') predicates_names - } - in - let ptes_info : pte_info Id.Map.t = - List.fold_left - (fun map pte_id -> - Id.Map.add pte_id - pte_info - map - ) - Id.Map.empty - predicates_names - in - let make_proof rec_hyps = - build_proof - false - [f_ref] - ptes_info - (body_info rec_hyps) - in - (* observe_tac "instantiate_hyps_with_args" *) - (instantiate_hyps_with_args - make_proof - (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) - (List.rev args_ids) - ) - gl' - ) - - ] + [ observe_tac "start_tac" start_tac + ; h_intros + (List.rev_map + (get_name %> Nameops.Name.get_id) + ( princ_info.args @ princ_info.branches @ princ_info.predicates + @ princ_info.params )) + ; Proofview.V82.of_tactic + (assert_by (Name acc_rec_arg_id) + (mkApp + (delayed_force acc_rel, [|input_type; relation; mkVar rec_arg_id|])) + (Proofview.V82.tactic prove_rec_arg_acc)) + ; revert (List.rev (acc_rec_arg_id :: args_ids)) + ; Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1)) + ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) + ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)) + ; (fun gl' -> + let body = + let _, args = destApp (project gl') (pf_concl gl') in + Array.last args + in + let body_info rec_hyps = + { nb_rec_hyps = List.length rec_hyps + ; rec_hyps + ; eq_hyps = [] + ; info = body } + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + let acc_inv = + lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) + in + let predicates_names = + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> + (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) + (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) + (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) + (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) + (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) + + (* observe_tac "new_prove_with_tcc" *) + new_prove_with_tcc is_mes acc_inv fix_id + ( !tcc_list + @ List.map + (get_name %> Nameops.Name.get_id) + (princ_info.args @ princ_info.params) + @ [acc_rec_arg_id] ) + eqs) + ; is_valid = is_valid_hypothesis (project gl') predicates_names } + in + let ptes_info : pte_info Id.Map.t = + List.fold_left + (fun map pte_id -> Id.Map.add pte_id pte_info map) + Id.Map.empty predicates_names + in + let make_proof rec_hyps = + build_proof false [f_ref] ptes_info (body_info rec_hyps) + in + (* observe_tac "instantiate_hyps_with_args" *) + (instantiate_hyps_with_args make_proof + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) + (List.rev args_ids)) + gl') ] gl diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 64fbfaeedf..52089ca7fb 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -1,19 +1,27 @@ open Names val prove_princ_for_struct : - Evd.evar_map ref -> - bool -> - int -> Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic - + Evd.evar_map ref + -> bool + -> int + -> Constant.t array + -> EConstr.constr array + -> int + -> Tacmach.tactic val prove_principle_for_gen : - Constant.t * Constant.t * Constant.t -> (* name of the function, the functional and the fixpoint equation *) - Indfun_common.tcc_lemma_value ref -> (* a pointer to the obligation proofs lemma *) - bool -> (* is that function uses measure *) - int -> (* the number of recursive argument *) - EConstr.types -> (* the type of the recursive argument *) - EConstr.constr -> (* the wf relation used to prove the function *) - Tacmach.tactic - + Constant.t * Constant.t * Constant.t + -> (* name of the function, the functional and the fixpoint equation *) + Indfun_common.tcc_lemma_value ref + -> (* a pointer to the obligation proofs lemma *) + bool + -> (* is that function uses measure *) + int + -> (* the number of recursive argument *) + EConstr.types + -> (* the type of the recursive argument *) + EConstr.constr + -> (* the wf relation used to prove the function *) + Tacmach.tactic (* val is_pte : rel_declaration -> bool *) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 163645b719..1ab747ca09 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -20,16 +20,12 @@ open Pp open Tactics open Context.Rel.Declaration open Indfun_common - module RelDecl = Context.Rel.Declaration -exception Toberemoved_with_rel of int*constr +exception Toberemoved_with_rel of int * constr exception Toberemoved -let observe s = - if do_observe () - then Feedback.msg_debug s - +let observe s = if do_observe () then Feedback.msg_debug s let pop t = Vars.lift (-1) t (* @@ -42,203 +38,211 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env = Global.env () in let env_with_params = EConstr.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:Id.t list) (predicates:EConstr.rel_context) : EConstr.rel_context = + let rec change_predicates_names (avoid : Id.t list) + (predicates : EConstr.rel_context) : EConstr.rel_context = match predicates with | [] -> [] - | decl :: predicates -> - (match Context.Rel.Declaration.get_name decl with - | Name x -> - let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in - Hashtbl.add tbl id x; - RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates - | Anonymous -> anomaly (Pp.str "Anonymous property binder.")) + | decl :: predicates -> ( + match Context.Rel.Declaration.get_name decl with + | Name x -> + let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in + Hashtbl.add tbl id x; + RelDecl.set_name (Name id) decl + :: change_predicates_names (id :: avoid) predicates + | Anonymous -> anomaly (Pp.str "Anonymous property binder.") ) in - let avoid = (Termops.ids_of_context env_with_params ) in + let avoid = Termops.ids_of_context env_with_params in let princ_type_info = { princ_type_info with - predicates = change_predicates_names avoid princ_type_info.predicates - } + predicates = change_predicates_names avoid princ_type_info.predicates } in -(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) -(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) + (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) + (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod_assum (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in + let args, _ = + decompose_prod_assum (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) + in let real_args = - if princ_type_info.indarg_in_concl - then List.tl args - else args + if princ_type_info.indarg_in_concl then List.tl args else args in - Context.Named.Declaration.LocalAssum (map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl), - Term.it_mkProd_or_LetIn (mkSort new_sort) real_args) + Context.Named.Declaration.LocalAssum + ( map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl) + , Term.it_mkProd_or_LetIn (mkSort new_sort) real_args ) in let new_predicates = - List.map_i - change_predicate_sort - 0 - princ_type_info.predicates + List.map_i change_predicate_sort 0 princ_type_info.predicates + in + let env_with_params_and_predicates = + List.fold_right Environ.push_named new_predicates env_with_params in - let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = - fst (match princ_type_info.indref with - | Some (GlobRef.IndRef ind) -> ind - | _ -> user_err Pp.(str "Not a valid predicate") - ) + fst + ( match princ_type_info.indref with + | Some (GlobRef.IndRef ind) -> ind + | _ -> user_err Pp.(str "Not a valid predicate") ) in let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in let is_pte = let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in - fun t -> - match Constr.kind t with - | Var id -> Id.Set.mem id set - | _ -> false + fun t -> match Constr.kind t with Var id -> Id.Set.mem id set | _ -> false in let pre_princ = let open EConstr in it_mkProd_or_LetIn (it_mkProd_or_LetIn - (Option.fold_right - mkProd_or_LetIn - princ_type_info.indarg - princ_type_info.concl - ) - princ_type_info.args - ) + (Option.fold_right mkProd_or_LetIn princ_type_info.indarg + princ_type_info.concl) + princ_type_info.args) princ_type_info.branches in let pre_princ = EConstr.Unsafe.to_constr pre_princ in let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match Constr.kind c with - | Ind((u,_),_) -> MutInd.equal u rel_as_kn - | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn - | _ -> false + | Ind ((u, _), _) -> MutInd.equal u rel_as_kn + | Construct (((u, _), _), _) -> MutInd.equal u rel_as_kn + | _ -> false in let get_fun_num c = match Constr.kind c with - | Ind((_,num),_) -> num - | Construct(((_,num),_),_) -> num - | _ -> assert false + | Ind ((_, num), _) -> num + | Construct (((_, num), _), _) -> num + | _ -> assert false in let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in - observe (str "replacing " ++ - pr_lconstr_env env Evd.empty c ++ str " by " ++ - pr_lconstr_env env Evd.empty res); + let res = mkApp (rel_to_fun.(i), Array.map pop (array_get_start args)) in + observe + ( str "replacing " + ++ pr_lconstr_env env Evd.empty c + ++ str " by " + ++ pr_lconstr_env env Evd.empty res ); res in - let rec compute_new_princ_type remove env pre_princ : types*(constr list) = - let (new_princ_type,_) as res = + let rec compute_new_princ_type remove env pre_princ : types * constr list = + let ((new_princ_type, _) as res) = match Constr.kind pre_princ with - | Rel n -> - begin - try match Environ.lookup_rel n env with - | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved - | _ -> pre_princ,[] - with Not_found -> assert false - end - | Prod(x,t,b) -> - compute_new_princ_type_for_binder remove mkProd env x t b - | Lambda(x,t,b) -> - compute_new_princ_type_for_binder remove mkLambda env x t b - | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved - | App(f,args) when is_dom f -> - let var_to_be_removed = destRel (Array.last args) in - let num = get_fun_num f in - raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) - | App(f,args) -> - let args = - if is_pte f && remove - then array_get_start args - else args - in - let new_args,binders_to_remove = - Array.fold_right (compute_new_princ_type_with_acc remove env) - args - ([],[]) - in - let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in - applistc new_f new_args, - list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove - | LetIn(x,v,t,b) -> - compute_new_princ_type_for_letin remove env x v t b - | _ -> pre_princ,[] + | Rel n -> ( + try + match Environ.lookup_rel n env with + | (LocalAssum (_, t) | LocalDef (_, _, t)) when is_dom t -> + raise Toberemoved + | _ -> (pre_princ, []) + with Not_found -> assert false ) + | Prod (x, t, b) -> + compute_new_princ_type_for_binder remove mkProd env x t b + | Lambda (x, t, b) -> + compute_new_princ_type_for_binder remove mkLambda env x t b + | (Ind _ | Construct _) when is_dom pre_princ -> raise Toberemoved + | App (f, args) when is_dom f -> + let var_to_be_removed = destRel (Array.last args) in + let num = get_fun_num f in + raise + (Toberemoved_with_rel + (var_to_be_removed, mk_replacement pre_princ num args)) + | App (f, args) -> + let args = if is_pte f && remove then array_get_start args else args in + let new_args, binders_to_remove = + Array.fold_right + (compute_new_princ_type_with_acc remove env) + args ([], []) + in + let new_f, binders_to_remove_from_f = + compute_new_princ_type remove env f + in + ( applistc new_f new_args + , list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove + ) + | LetIn (x, v, t, b) -> + compute_new_princ_type_for_letin remove env x v t b + | _ -> (pre_princ, []) in -(* let _ = match Constr.kind pre_princ with *) -(* | Prod _ -> *) -(* observe(str "compute_new_princ_type for "++ *) -(* pr_lconstr_env env pre_princ ++ *) -(* str" is "++ *) -(* pr_lconstr_env env new_princ_type ++ fnl ()) *) -(* | _ -> () in *) + (* let _ = match Constr.kind pre_princ with *) + (* | Prod _ -> *) + (* observe(str "compute_new_princ_type for "++ *) + (* pr_lconstr_env env pre_princ ++ *) + (* str" is "++ *) + (* pr_lconstr_env env new_princ_type ++ fnl ()) *) + (* | _ -> () in *) res - and compute_new_princ_type_for_binder remove bind_fun env x t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x = map_annot (get_name (Termops.ids_of_context env)) x in - let new_env = Environ.push_rel (LocalAssum (x,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b), filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( - bind_fun(new_x,new_t,new_b), - list_union_eq - Constr.equal - binders_to_remove_from_t - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) - end + try + let new_t, binders_to_remove_from_t = + compute_new_princ_type remove env t + in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalAssum (x, t)) env in + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove new_env b + in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then + ( pop new_b + , filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b ) + else + ( bind_fun (new_x, new_t, new_b) + , list_union_eq Constr.equal binders_to_remove_from_t + (List.map pop binders_to_remove_from_b) ) + with + | Toberemoved -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [dummy_var] 1 b) + in + (new_b, List.map pop binders_to_remove_from_b) + | Toberemoved_with_rel (n, c) -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [c] n b) + in + ( new_b + , list_add_set_eq Constr.equal (mkRel n) + (List.map pop binders_to_remove_from_b) ) and compute_new_princ_type_for_letin remove env x v t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in - let new_x = map_annot (get_name (Termops.ids_of_context env)) x in - let new_env = Environ.push_rel (LocalDef (x,v,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( - mkLetIn(new_x,new_v,new_t,new_b), - list_union_eq - Constr.equal - (list_union_eq Constr.equal binders_to_remove_from_t binders_to_remove_from_v) - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) - end - and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = - let new_e,to_remove_from_e = compute_new_princ_type remove env e - in - new_e::c_acc,list_union_eq Constr.equal to_remove_from_e to_remove_acc + try + let new_t, binders_to_remove_from_t = + compute_new_princ_type remove env t + in + let new_v, binders_to_remove_from_v = + compute_new_princ_type remove env v + in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalDef (x, v, t)) env in + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove new_env b + in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then + ( pop new_b + , filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b ) + else + ( mkLetIn (new_x, new_v, new_t, new_b) + , list_union_eq Constr.equal + (list_union_eq Constr.equal binders_to_remove_from_t + binders_to_remove_from_v) + (List.map pop binders_to_remove_from_b) ) + with + | Toberemoved -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [dummy_var] 1 b) + in + (new_b, List.map pop binders_to_remove_from_b) + | Toberemoved_with_rel (n, c) -> + (* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b, binders_to_remove_from_b = + compute_new_princ_type remove env (substnl [c] n b) + in + ( new_b + , list_add_set_eq Constr.equal (mkRel n) + (List.map pop binders_to_remove_from_b) ) + and compute_new_princ_type_with_acc remove env e (c_acc, to_remove_acc) = + let new_e, to_remove_from_e = compute_new_princ_type remove env e in + (new_e :: c_acc, list_union_eq Constr.equal to_remove_from_e to_remove_acc) in -(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) - let pre_res,_ = - compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ + (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) + let pre_res, _ = + compute_new_princ_type princ_type_info.indarg_in_concl + env_with_params_and_predicates pre_princ in let pre_res = replace_vars @@ -246,12 +250,18 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (lift (List.length ptes_vars) pre_res) in it_mkProd_or_LetIn - (it_mkProd_or_LetIn - pre_res (List.map (function - | Context.Named.Declaration.LocalAssum (id,b) -> - LocalAssum (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) - | Context.Named.Declaration.LocalDef (id,t,b) -> - LocalDef (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, t, b)) - new_predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) + (it_mkProd_or_LetIn pre_res + (List.map + (function + | Context.Named.Declaration.LocalAssum (id, b) -> + LocalAssum + (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) + | Context.Named.Declaration.LocalDef (id, t, b) -> + LocalDef + ( map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id + , t + , b )) + new_predicates)) + (List.map + (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) + princ_type_info.params) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index c870603a43..4bbb7180f0 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -8,8 +8,5 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val compute_new_princ_type_from_rel - : Constr.constr array - -> Sorts.t array - -> Constr.t - -> Constr.types +val compute_new_princ_type_from_rel : + Constr.constr array -> Sorts.t array -> Constr.t -> Constr.types diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index d38c3c869b..55e659d487 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -10,9 +10,7 @@ open Util open Names - open Indfun_common - module RelDecl = Context.Rel.Declaration let observe_tac s = observe_tac (fun _ _ -> Pp.str s) @@ -23,73 +21,92 @@ let observe_tac s = observe_tac (fun _ _ -> Pp.str s) *) let rec abstract_glob_constr c = function | [] -> c - | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) - | Constrexpr.CLocalAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl + | Constrexpr.CLocalDef (x, b, t) :: bl -> + Constrexpr_ops.mkLetInC (x, b, t, abstract_glob_constr c bl) + | Constrexpr.CLocalAssum (idl, k, t) :: bl -> + List.fold_right + (fun x b -> Constrexpr_ops.mkLambdaC ([x], k, t, b)) + idl (abstract_glob_constr c bl) - | Constrexpr.CLocalPattern _::bl -> assert false + | Constrexpr.CLocalPattern _ :: bl -> assert false -let interp_casted_constr_with_implicits env sigma impls c = +let interp_casted_constr_with_implicits env sigma impls c = Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c let build_newrecursive lnameargsardef = - let env0 = Global.env() in + let env0 = Global.env () in let sigma = Evd.from_env env0 in - let (rec_sign,rec_impls) = + let rec_sign, rec_impls = List.fold_left - (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> - let arityc = Constrexpr_ops.mkCProdN binders rtype in - let arity,_ctx = Constrintern.interp_type env0 sigma arityc in - let evd = Evd.from_env env0 in - let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in - let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in - let open Context.Named.Declaration in - let r = Sorts.Relevant in (* TODO relevance *) - (EConstr.push_named (LocalAssum (Context.make_annot recname r,arity)) env, Id.Map.add recname impl impls)) - (env0,Constrintern.empty_internalization_env) lnameargsardef in + (fun (env, impls) {Vernacexpr.fname = {CAst.v = recname}; binders; rtype} -> + let arityc = Constrexpr_ops.mkCProdN binders rtype in + let arity, _ctx = Constrintern.interp_type env0 sigma arityc in + let evd = Evd.from_env env0 in + let evd, (_, (_, impls')) = + Constrintern.interp_context_evars ~program_mode:false env evd binders + in + let impl = + Constrintern.compute_internalization_data env0 evd recname + Constrintern.Recursive arity impls' + in + let open Context.Named.Declaration in + let r = Sorts.Relevant in + (* TODO relevance *) + ( EConstr.push_named + (LocalAssum (Context.make_annot recname r, arity)) + env + , Id.Map.add recname impl impls )) + (env0, Constrintern.empty_internalization_env) + lnameargsardef + in let recdef = (* Declare local notations *) - let f { Vernacexpr.binders; body_def } = + let f {Vernacexpr.binders; body_def} = match body_def with | Some body_def -> let def = abstract_glob_constr body_def binders in - interp_casted_constr_with_implicits - rec_sign sigma rec_impls def - | None -> CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") + interp_casted_constr_with_implicits rec_sign sigma rec_impls def + | None -> + CErrors.user_err ~hdr:"Function" + (Pp.str "Body of Function must be given") in States.with_state_protection (List.map f) lnameargsardef in - recdef,rec_impls + (recdef, rec_impls) (* Checks whether or not the mutual bloc is recursive *) let is_rec names = let open Glob_term in let names = List.fold_right Id.Set.add names Id.Set.empty in - let check_id id names = Id.Set.mem id names in - let rec lookup names gt = match DAst.get gt with - | GVar(id) -> check_id id names - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> false - | GCast(b,_) -> lookup names b + let check_id id names = Id.Set.mem id names in + let rec lookup names gt = + match DAst.get gt with + | GVar id -> check_id id names + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> + false + | GCast (b, _) -> lookup names b | GRec _ -> CErrors.user_err (Pp.str "GRec not handled") - | GIf(b,_,lhs,rhs) -> - (lookup names b) || (lookup names lhs) || (lookup names rhs) - | GProd(na,_,t,b) | GLambda(na,_,t,b) -> - lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b - | GLetIn(na,b,t,c) -> - lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c - | GLetTuple(nal,_,t,b) -> lookup names t || - lookup - (List.fold_left - (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) - names - nal - ) - b - | GApp(f,args) -> List.exists (lookup names) (f::args) - | GCases(_,_,el,brl) -> - List.exists (fun (e,_) -> lookup names e) el || - List.exists (lookup_br names) brl - and lookup_br names {CAst.v=(idl,_,rt)} = + | GIf (b, _, lhs, rhs) -> + lookup names b || lookup names lhs || lookup names rhs + | GProd (na, _, t, b) | GLambda (na, _, t, b) -> + lookup names t + || lookup (Nameops.Name.fold_right Id.Set.remove na names) b + | GLetIn (na, b, t, c) -> + lookup names b + || Option.cata (lookup names) true t + || lookup (Nameops.Name.fold_right Id.Set.remove na names) c + | GLetTuple (nal, _, t, b) -> + lookup names t + || lookup + (List.fold_left + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) + names nal) + b + | GApp (f, args) -> List.exists (lookup names) (f :: args) + | GCases (_, _, el, brl) -> + List.exists (fun (e, _) -> lookup names e) el + || List.exists (lookup_br names) brl + and lookup_br names {CAst.v = idl, _, rt} = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in @@ -97,114 +114,138 @@ let is_rec names = let rec rebuild_bl aux bl typ = let open Constrexpr in - match bl,typ with - | [], _ -> List.rev aux,typ - | (CLocalAssum(nal,bk,_))::bl',typ -> - rebuild_nal aux bk bl' nal typ - | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> - rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) - bl' typ' + match (bl, typ) with + | [], _ -> (List.rev aux, typ) + | CLocalAssum (nal, bk, _) :: bl', typ -> rebuild_nal aux bk bl' nal typ + | CLocalDef (na, _, _) :: bl', {CAst.v = CLetIn (_, nat, ty, typ')} -> + rebuild_bl (Constrexpr.CLocalDef (na, nat, ty) :: aux) bl' typ' | _ -> assert false + and rebuild_nal aux bk bl' nal typ = let open Constrexpr in - match nal,typ with - | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ + match (nal, typ) with + | _, {CAst.v = CProdN ([], typ)} -> rebuild_nal aux bk bl' nal typ | [], _ -> rebuild_bl aux bl' typ - | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> - if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) - then - let assum = CLocalAssum([na],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - nal - (CAst.make @@ CProdN(new_rest,typ')) + | ( na :: nal + , {CAst.v = CProdN (CLocalAssum (na' :: nal', bk', nal't) :: rest, typ')} ) + -> + if Name.equal na.CAst.v na'.CAst.v || Name.is_anonymous na'.CAst.v then + let assum = CLocalAssum ([na], bk, nal't) in + let new_rest = + if nal' = [] then rest else CLocalAssum (nal', bk', nal't) :: rest + in + rebuild_nal (assum :: aux) bk bl' nal + (CAst.make @@ CProdN (new_rest, typ')) else - let assum = CLocalAssum([na'],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - (na::nal) - (CAst.make @@ CProdN(new_rest,typ')) - | _ -> - assert false + let assum = CLocalAssum ([na'], bk, nal't) in + let new_rest = + if nal' = [] then rest else CLocalAssum (nal', bk', nal't) :: rest + in + rebuild_nal (assum :: aux) bk bl' (na :: nal) + (CAst.make @@ CProdN (new_rest, typ')) + | _ -> assert false let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list fixpoint_exprl = let fixl = - List.map (fun fix -> Vernacexpr.{ - fix - with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in - let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in + List.map + (fun fix -> + Vernacexpr. + { fix with + rec_order = + ComFixpoint.adjust_rec_order ~structonly:false fix.binders + fix.rec_order }) + fixpoint_exprl + in + let (_, _, _, typel), _, ctx, _ = + ComFixpoint.interp_fixpoint ~cofix:false fixl + in let constr_expr_typel = - with_full_print (List.map (fun c -> Constrextern.extern_constr (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in + with_full_print + (List.map (fun c -> + Constrextern.extern_constr (Global.env ()) (Evd.from_ctx ctx) + (EConstr.of_constr c))) + typel + in let fixpoint_exprl_with_new_bl = - List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> + List.map2 + (fun ({Vernacexpr.binders} as fp) fix_typ -> let binders, rtype = rebuild_bl [] binders fix_typ in - { fp with Vernacexpr.binders; rtype } - ) fixpoint_exprl constr_expr_typel + {fp with Vernacexpr.binders; rtype}) + fixpoint_exprl constr_expr_typel in fixpoint_exprl_with_new_bl let rec local_binders_length = function (* Assume that no `{ ... } contexts occur *) | [] -> 0 - | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl - | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl - | Constrexpr.CLocalPattern _::bl -> assert false + | Constrexpr.CLocalDef _ :: bl -> 1 + local_binders_length bl + | Constrexpr.CLocalAssum (idl, _, _) :: bl -> + List.length idl + local_binders_length bl + | Constrexpr.CLocalPattern _ :: bl -> assert false -let prepare_body { Vernacexpr.binders } rt = +let prepare_body {Vernacexpr.binders} rt = let n = local_binders_length binders in (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) - let fun_args,rt' = chop_rlambda_n n rt in - (fun_args,rt') + let fun_args, rt' = chop_rlambda_n n rt in + (fun_args, rt') -let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = +let build_functional_principle ?(opaque = Declare.Transparent) + (evd : Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = (* First we get the type of the old graph principle *) - let mutr_nparams = (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)).Tactics.nparams in + let mutr_nparams = + (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)) + .Tactics.nparams + in (* let time1 = System.get_time () in *) let new_principle_type = Functional_principles_types.compute_new_princ_type_from_rel (Array.map Constr.mkConstU funs) - sorts - old_princ_type + sorts old_princ_type in (* let time2 = System.get_time () in *) (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) let new_princ_name = - Namegen.next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty + Namegen.next_ident_away_in_goal + (Id.of_string "___________princ_________") + Id.Set.empty + in + let sigma, _ = + Typing.type_of ~refresh:true (Global.env ()) !evd + (EConstr.of_constr new_principle_type) in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in evd := sigma; let hook = DeclareDef.Hook.make (hook new_principle_type) in let lemma = - Lemmas.start_lemma - ~name:new_princ_name - ~poly:false - !evd + Lemmas.start_lemma ~name:new_princ_name ~poly:false !evd (EConstr.of_constr new_principle_type) in (* let _tim1 = System.get_time () in *) let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in + let lemma, _ = + Lemmas.by + (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) + lemma + in (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - - let open Proof_global in - let { entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false) lemma in + let {Declare.entries} = + Lemmas.pf_fold + (Declare.close_proof ~opaque ~keep_body_ucst_separate:false) + lemma + in match entries with - | [entry] -> - entry, hook + | [entry] -> (entry, hook) | _ -> - CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") + CErrors.anomaly + Pp.( + str + "[build_functional_principle] close_proof returned more than one \ + proof term") let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in @@ -212,207 +253,221 @@ let change_property_sort evd toSort princ princName = let princ_info = Tactics.compute_elim_sig evd princ in let change_sort_in_predicate decl = LocalAssum - (get_annot decl, - let args,ty = Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in - let s = Constr.destSort ty in - Global.add_constraints (Univ.enforce_leq (Sorts.univ_of_sort toSort) (Sorts.univ_of_sort s) Univ.Constraint.empty); - Term.compose_prod args (Constr.mkSort toSort) - ) + ( get_annot decl + , let args, ty = + Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) + in + let s = Constr.destSort ty in + Global.add_constraints + (Univ.enforce_leq + (Sorts.univ_of_sort toSort) + (Sorts.univ_of_sort s) Univ.Constraint.empty); + Term.compose_prod args (Constr.mkSort toSort) ) + in + let evd, princName_as_constr = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in - let evd,princName_as_constr = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in let init = - let nargs = (princ_info.Tactics.nparams + (List.length princ_info.Tactics.predicates)) in - Constr.mkApp(EConstr.Unsafe.to_constr princName_as_constr, - Array.init nargs - (fun i -> Constr.mkRel (nargs - i ))) + let nargs = + princ_info.Tactics.nparams + List.length princ_info.Tactics.predicates + in + Constr.mkApp + ( EConstr.Unsafe.to_constr princName_as_constr + , Array.init nargs (fun i -> Constr.mkRel (nargs - i)) ) in - evd, Term.it_mkLambda_or_LetIn - (Term.it_mkLambda_or_LetIn init - (List.map change_sort_in_predicate princ_info.Tactics.predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) - -let generate_functional_principle (evd: Evd.evar_map ref) - old_princ_type sorts new_princ_name funs i proof_tac - = + ( evd + , Term.it_mkLambda_or_LetIn + (Term.it_mkLambda_or_LetIn init + (List.map change_sort_in_predicate princ_info.Tactics.predicates)) + (List.map + (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) + princ_info.Tactics.params) ) + +let generate_functional_principle (evd : Evd.evar_map ref) old_princ_type sorts + new_princ_name funs i proof_tac = try - - let f = funs.(i) in - let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in - evd := sigma; - let new_sorts = - match sorts with - | None -> Array.make (Array.length funs) (type_sort) + let f = funs.(i) in + let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in + evd := sigma; + let new_sorts = + match sorts with + | None -> Array.make (Array.length funs) type_sort | Some a -> a - in - let base_new_princ_name,new_princ_name = - match new_princ_name with - | Some (id) -> id,id + in + let base_new_princ_name, new_princ_name = + match new_princ_name with + | Some id -> (id, id) | None -> - let id_of_f = Label.to_id (Constant.label (fst f)) in - id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) - in - let names = ref [new_princ_name] in - let hook = - fun new_principle_type _ -> - if Option.is_empty sorts - then - (* let id_of_f = Label.to_id (con_label f) in *) - let register_with_sort fam_sort = - let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family evd' fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let univs = Evd.univ_entry ~poly:false evd' in - let ce = Declare.definition_entry ~univs value in - ignore( - Declare.declare_constant - ~name - ~kind:Decls.(IsDefinition Scheme) - (Declare.DefinitionEntry ce) - ); - Declare.definition_message name; - names := name :: !names - in - register_with_sort Sorts.InProp; - register_with_sort Sorts.InSet - in - let entry, hook = - build_functional_principle evd old_princ_type new_sorts funs i - proof_tac hook + let id_of_f = Label.to_id (Constant.label (fst f)) in + (id_of_f, Indrec.make_elimination_ident id_of_f (Sorts.family type_sort)) + in + let names = ref [new_princ_name] in + let hook new_principle_type _ = + if Option.is_empty sorts then ( + (* let id_of_f = Label.to_id (con_label f) in *) + let register_with_sort fam_sort = + let evd' = Evd.from_env (Global.env ()) in + let evd', s = Evd.fresh_sort_in_family evd' fam_sort in + let name = + Indrec.make_elimination_ident base_new_princ_name fam_sort + in + let evd', value = + change_property_sort evd' s new_principle_type new_princ_name + in + let evd' = + fst + (Typing.type_of ~refresh:true (Global.env ()) evd' + (EConstr.of_constr value)) + in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let univs = Evd.univ_entry ~poly:false evd' in + let ce = Declare.definition_entry ~univs value in + ignore + (Declare.declare_constant ~name + ~kind:Decls.(IsDefinition Scheme) + (Declare.DefinitionEntry ce)); + Declare.definition_message name; + names := name :: !names + in + register_with_sort Sorts.InProp; + register_with_sort Sorts.InSet ) + in + let entry, hook = + build_functional_principle evd old_princ_type new_sorts funs i proof_tac + hook + in + (* Pr 1278 : + Don't forget to close the goal if an error is raised !!!! + *) + let uctx = Evd.evar_universe_context sigma in + let (_ : Names.GlobRef.t) = + DeclareDef.declare_entry ~name:new_princ_name ~hook + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.(IsProof Theorem) + ~impargs:[] ~uctx entry + in + () + with e when CErrors.noncritical e -> raise (Defining_principle e) + +let generate_principle (evd : Evd.evar_map ref) pconstants on_error is_general + do_built fix_rec_l recdefs + (continue_proof : + int + -> Names.Constant.t array + -> EConstr.constr array + -> int + -> Tacmach.tactic) : unit = + let names = + List.map (function {Vernacexpr.fname = {CAst.v = name}} -> name) fix_rec_l in - (* Pr 1278 : - Don't forget to close the goal if an error is raised !!!! - *) - let uctx = Evd.evar_universe_context sigma in - let _ : Names.GlobRef.t = DeclareDef.declare_entry - ~name:new_princ_name ~hook - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsProof Theorem) - ~impargs:[] - ~uctx entry in - () - with e when CErrors.noncritical e -> - raise (Defining_principle e) - -let generate_principle (evd:Evd.evar_map ref) pconstants on_error - is_general do_built fix_rec_l recdefs - (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> - Tacmach.tactic) : unit = - let names = List.map (function { Vernacexpr.fname = {CAst.v=name} } -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in - let funs_types = List.map (function { Vernacexpr.rtype } -> rtype) fix_rec_l in + let funs_types = + List.map (function {Vernacexpr.rtype} -> rtype) fix_rec_l + in try (* We then register the Inductive graphs of the functions *) - Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; - if do_built - then - begin - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : do_built - i*) - let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in - let ind_kn = - fst (locate_with_msg - Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") - locate_ind - f_R_mut) - in - let fname_kn { Vernacexpr.fname } = - let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in - locate_with_msg - Pp.(Libnames.pr_qualid f_ref++str ": Not an inductive type!") - locate_constant - f_ref - in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = - List.map_i - (fun i _x -> - let env = Global.env () in - let princ = Indrec.lookup_eliminator env (ind_kn,i) (Sorts.InProp) in - let evd = ref (Evd.from_env env) in - let evd',uprinc = Evd.fresh_global env !evd princ in - let _ = evd := evd' in - let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in - evd := sigma; - let princ_type = EConstr.Unsafe.to_constr princ_type in - generate_functional_principle - evd - princ_type - None - None - (Array.of_list pconstants) - (* funs_kn *) - i - (continue_proof 0 [|funs_kn.(i)|]) - ) - 0 - fix_rec_l - in - Array.iter (add_Function is_general) funs_kn; - () - end - with e when CErrors.noncritical e -> - on_error names e + Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types + recdefs; + if do_built then begin + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : do_built + i*) + let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in + let ind_kn = + fst + (locate_with_msg + Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") + locate_ind f_R_mut) + in + let fname_kn {Vernacexpr.fname} = + let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in + locate_with_msg + Pp.(Libnames.pr_qualid f_ref ++ str ": Not an inductive type!") + locate_constant f_ref + in + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = + List.map_i + (fun i _x -> + let env = Global.env () in + let princ = Indrec.lookup_eliminator env (ind_kn, i) Sorts.InProp in + let evd = ref (Evd.from_env env) in + let evd', uprinc = Evd.fresh_global env !evd princ in + let _ = evd := evd' in + let sigma, princ_type = + Typing.type_of ~refresh:true env !evd uprinc + in + evd := sigma; + let princ_type = EConstr.Unsafe.to_constr princ_type in + generate_functional_principle evd princ_type None None + (Array.of_list pconstants) (* funs_kn *) + i + (continue_proof 0 [|funs_kn.(i)|])) + 0 fix_rec_l + in + Array.iter (add_Function is_general) funs_kn; + () + end + with e when CErrors.noncritical e -> on_error names e let register_struct is_rec fixpoint_exprl = let open EConstr in match fixpoint_exprl with - | [{ Vernacexpr.fname; univs; binders; rtype; body_def }] when not is_rec -> + | [{Vernacexpr.fname; univs; binders; rtype; body_def}] when not is_rec -> let body = match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in - ComDefinition.do_definition - ~name:fname.CAst.v - ~poly:false + CErrors.user_err ~hdr:"Function" + Pp.(str "Body of Function must be given") + in + ComDefinition.do_definition ~name:fname.CAst.v ~poly:false ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.Definition univs - binders None body (Some rtype); - let evd,rev_pconstants = + ~kind:Decls.Definition univs binders None body (Some rtype); + let evd, rev_pconstants = List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) + (fun (evd, l) {Vernacexpr.fname} -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident fname.CAst.v)) + in + let cst, u = destConst evd c in + let u = EInstance.kind evd u in + (evd, (cst, u) :: l)) + (Evd.from_env (Global.env ()), []) fixpoint_exprl in - None, evd,List.rev rev_pconstants + (None, evd, List.rev rev_pconstants) | _ -> - ComFixpoint.do_fixpoint ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; - let evd,rev_pconstants = + ComFixpoint.do_fixpoint + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false + fixpoint_exprl; + let evd, rev_pconstants = List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) + (fun (evd, l) {Vernacexpr.fname} -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident fname.CAst.v)) + in + let cst, u = destConst evd c in + let u = EInstance.kind evd u in + (evd, (cst, u) :: l)) + (Evd.from_env (Global.env ()), []) fixpoint_exprl in - None,evd,List.rev rev_pconstants + (None, evd, List.rev rev_pconstants) -let generate_correction_proof_wf f_ref tcc_lemma_ref - is_mes functional_ref eq_ref rec_arg_num rec_arg_type relation - (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = +let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref + eq_ref rec_arg_num rec_arg_type relation (_ : int) + (_ : Names.Constant.t array) (_ : EConstr.constr array) (_ : int) : + Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen - (f_ref,functional_ref,eq_ref) - tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation + (f_ref, functional_ref, eq_ref) + tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. @@ -431,34 +486,38 @@ let generate_type evd g_to_f f graph = let open EConstr in let open EConstr.Vars in (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let evd',graph = - Evd.fresh_global (Global.env ()) !evd (GlobRef.IndRef (fst (destInd !evd graph))) + let evd', graph = + Evd.fresh_global (Global.env ()) !evd + (GlobRef.IndRef (fst (destInd !evd graph))) in - evd:=evd'; + evd := evd'; let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in evd := sigma; - let ctxt,_ = decompose_prod_assum !evd graph_arity in - let fun_ctxt,res_type = + let ctxt, _ = decompose_prod_assum !evd graph_arity in + let fun_ctxt, res_type = match ctxt with | [] | [_] -> CErrors.anomaly (Pp.str "Not a valid context.") - | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl + | decl :: fun_ctxt -> (fun_ctxt, RelDecl.get_type decl) in let rec args_from_decl i accu = function | [] -> accu - | LocalDef _ :: l -> - args_from_decl (succ i) accu l + | LocalDef _ :: l -> args_from_decl (succ i) accu l | _ :: l -> let t = mkRel i in args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let filter = fun decl -> match RelDecl.get_name decl with - | Name id -> Some id - | Anonymous -> None + let filter decl = + match RelDecl.get_name decl with Name id -> Some id | Anonymous -> None in let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in - let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in - let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in + let res_id = + Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt + in + let fv_id = + Namegen.next_ident_away_in_goal (Id.of_string "fv") + (Id.Set.add res_id named_ctxt) + in (*i we can then type the argument to be applied to the function [f] i*) let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in (*i @@ -467,7 +526,7 @@ let generate_type evd g_to_f f graph = i*) let make_eq = make_eq () in let res_eq_f_of_args = - mkApp(make_eq ,[|lift 2 res_type;mkRel 1;mkRel 2|]) + mkApp (make_eq, [|lift 2 res_type; mkRel 1; mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed @@ -475,18 +534,29 @@ let generate_type evd g_to_f f graph = i*) let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in - let graph_applied = mkApp(graph, args_and_res_as_rels) in + let graph_applied = mkApp (graph, args_and_res_as_rels) in (*i The [pre_context] is the defined to be the context corresponding to \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: - LocalDef (Context.make_annot (Name fv_id) Sorts.Relevant, mkApp (f,args_as_rels), res_type) :: fun_ctxt + LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) + :: LocalDef + ( Context.make_annot (Name fv_id) Sorts.Relevant + , mkApp (f, args_as_rels) + , res_type ) + :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) - if g_to_f - then LocalAssum (Context.make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else LocalAssum (Context.make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + if g_to_f then + ( LocalAssum (Context.make_annot Anonymous Sorts.Relevant, graph_applied) + :: pre_ctxt + , lift 1 res_eq_f_of_args + , graph ) + else + ( LocalAssum (Context.make_annot Anonymous Sorts.Relevant, res_eq_f_of_args) + :: pre_ctxt + , lift 1 graph_applied + , graph ) (** [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] @@ -494,21 +564,25 @@ let generate_type evd g_to_f f graph = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = - let f_as_constant, _u = match EConstr.kind !evd f with + let f_as_constant, _u = + match EConstr.kind !evd f with | Constr.Const c' -> c' | _ -> CErrors.user_err Pp.(str "Must be used with a function") in match find_Function_infos f_as_constant with - | None -> - raise Not_found - | Some infos -> + | None -> raise Not_found + | Some infos -> ( match infos.rect_lemma with | None -> raise Not_found | Some rect_lemma -> - let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in - let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in - evd:=evd'; - rect_lemma,typ + let evd', rect_lemma = + Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) + in + let evd', typ = + Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma + in + evd := evd'; + (rect_lemma, typ) ) (* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -535,13 +609,13 @@ let find_induction_principle evd f = *) let rec generate_fresh_id x avoid i = - if i == 0 - then [] + if i == 0 then [] else let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in - id::(generate_fresh_id x (id::avoid) (pred i)) + id :: generate_fresh_id x (id :: avoid) (pred i) -let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : + Tacmach.tactic = let open Constr in let open EConstr in let open Context.Rel.Declaration in @@ -554,22 +628,25 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) (* we the get the definition of the graphs block *) - let graph_ind,u = destInd evd graphs_constr.(i) in + let graph_ind, u = destInd evd graphs_constr.(i) in let kn = fst graph_ind in - let mib,_ = Global.lookup_inductive graph_ind in + let mib, _ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) - let f_principle,princ_type = schemes.(i) in + let f_principle, princ_type = schemes.(i) in let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in + let ids = args_names @ pf_ids_of_hyps g in (* Since we cannot ensure that the functional principle is defined in the environment and due to the bug #1174, we will need to pose the principle using a name *) - let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in + let principle_id = + Namegen.next_ident_away_in_goal (Id.of_string "princ") + (Id.Set.of_list ids) + in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.Tactics.branches in @@ -577,28 +654,28 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t let intro_pats = List.map (fun decl -> - List.map - (fun id -> CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) - ) + List.map + (fun id -> + CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids + (List.length + (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) branches in (* before building the full intro pattern for the principle *) let eq_ind = make_eq () in let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 - and min_constr_number = ref 0 in + let ind_number = ref 0 and min_constr_number = ref 0 in (* The tactic to prove the ith branch of the principle *) let prove_branche i g = (* We get the identifiers of this branch *) let pre_args = List.fold_right - (fun {CAst.v=pat} acc -> - match pat with - | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id::acc - | _ -> CErrors.anomaly (Pp.str "Not an identifier.") - ) + (fun {CAst.v = pat} acc -> + match pat with + | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc + | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) (List.nth intro_pats (pred i)) [] in @@ -613,32 +690,35 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t let constructor_args g = List.fold_right (fun hid acc -> - let type_of_hid = pf_get_hyp_typ g hid in - let sigma = project g in - match EConstr.kind sigma type_of_hid with - | Prod(_,_,t') -> - begin - match EConstr.kind sigma t' with - | Prod(_,t'',t''') -> - begin - match EConstr.kind sigma t'',EConstr.kind sigma t''' with - | App(eq,args), App(graph',_) - when - (EConstr.eq_constr sigma eq eq_ind) && - Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> - (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::acc) - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - ) pre_args [] + let type_of_hid = pf_get_hyp_typ g hid in + let sigma = project g in + match EConstr.kind sigma type_of_hid with + | Prod (_, _, t') -> ( + match EConstr.kind sigma t' with + | Prod (_, t'', t''') -> ( + match (EConstr.kind sigma t'', EConstr.kind sigma t''') with + | App (eq, args), App (graph', _) + when EConstr.eq_constr sigma eq eq_ind + && Array.exists + (EConstr.eq_constr_nounivs sigma graph') + graphs_constr -> + args.(2) + :: mkApp + ( mkVar hid + , [| args.(2) + ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) + :: acc + | _ -> mkVar hid :: acc ) + | _ -> mkVar hid :: acc ) + | _ -> mkVar hid :: acc) + pre_args [] in (* in fact we must also add the parameters to the constructor args *) let constructor_args g = - let params_id = fst (List.chop princ_infos.Tactics.nparams args_names) in - (List.map mkVar params_id)@((constructor_args g)) + let params_id = + fst (List.chop princ_infos.Tactics.nparams args_names) + in + List.map mkVar params_id @ constructor_args g in (* We then get the constructor corresponding to this branch and modifies the references has needed i.e. @@ -648,120 +728,136 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.t *) let constructor = let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then - begin - (kn,!ind_number),constructor_num - end - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length ; - (kn,!ind_number),1 - end + let length = + Array.length + mib.Declarations.mind_packets.(!ind_number) + .Declarations.mind_consnames + in + if constructor_num <= length then ((kn, !ind_number), constructor_num) + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + ((kn, !ind_number), 1) + end in (* we can then build the final proof term *) - let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in + let app_constructor g = + applist (mkConstructU (constructor, u), constructor_args g) + in (* an apply the tactic *) - let res,hres = - match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with - | [res;hres] -> res,hres + let res, hres = + match + generate_fresh_id (Id.of_string "z") ids (* @this_branche_ids *) 2 + with + | [res; hres] -> (res, hres) | _ -> assert false in (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) - ( - tclTHENLIST - [ - observe_tac ("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)); - (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false ; - Genredexpr.rConst = [] - } - ) - Locusops.onConcl); - observe_tac ("toto ") tclIDTAC; - - (* introducing the result of the graph and the equality hypothesis *) - observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); - (* replacing [res] with its value *) - observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); - (* Conclusion *) - observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) - ] - ) + (tclTHENLIST + [ observe_tac "h_intro_patterns " + (let l = List.nth intro_pats (pred i) in + match l with + | [] -> tclIDTAC + | _ -> Proofview.V82.of_tactic (intro_patterns false l)) + ; (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false + ; Genredexpr.rConst = [] }) + Locusops.onConcl) + ; observe_tac "toto " tclIDTAC + ; (* introducing the result of the graph and the equality hypothesis *) + observe_tac "introducing" + (tclMAP + (fun x -> Proofview.V82.of_tactic (Simple.intro x)) + [res; hres]) + ; (* replacing [res] with its value *) + observe_tac "rewriting res value" + (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))) + ; (* Conclusion *) + observe_tac "exact" (fun g -> + Proofview.V82.of_tactic (exact_check (app_constructor g)) g) ]) g in (* end of branche proof *) let lemmas = Array.map - (fun ((_,(ctxt,concl))) -> - match ctxt with - | [] | [_] | [_;_] -> CErrors.anomaly (Pp.str "bad context.") - | hres::res::decl::ctxt -> - let res = EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) :: ctxt) - in - res) + (fun (_, (ctxt, concl)) -> + match ctxt with + | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") + | hres :: res :: decl :: ctxt -> + let res = + EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres; res]) + ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) + :: ctxt ) + in + res) lemmas_types_infos in let param_names = fst (List.chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in - let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in + let lemmas = + Array.to_list (Array.map (fun c -> applist (c, params)) lemmas) + in (* The bindings of the principle that is the params of the principle and the different lemma types *) let bindings = - let params_bindings,avoid = + let params_bindings, avoid = List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - p::bindings,id::avoid - ) - ([],pf_ids_of_hyps g) - princ_infos.params - (List.rev params) + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + (p :: bindings, id :: avoid)) + ([], pf_ids_of_hyps g) + princ_infos.params (List.rev params) in let lemmas_bindings = - List.rev (fst (List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) - ([],avoid) - princ_infos.predicates - (lemmas))) + List.rev + (fst + (List.fold_left2 + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + ( Reductionops.nf_zeta (pf_env g) (project g) p :: bindings + , id :: avoid )) + ([], avoid) princ_infos.predicates lemmas)) in - (params_bindings@lemmas_bindings) + params_bindings @ lemmas_bindings in tclTHENLIST - [ - observe_tac "principle" (Proofview.V82.of_tactic (assert_by - (Name principle_id) - princ_type - (exact_check f_principle))); - observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); - (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) - observe_tac "idtac" tclIDTAC; - tclTHEN_i - (observe_tac - "functional_induction" ( - (fun gl -> - let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in - Proofview.V82.of_tactic (apply term) gl') - )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) - ] + [ observe_tac "principle" + (Proofview.V82.of_tactic + (assert_by (Name principle_id) princ_type + (exact_check f_principle))) + ; observe_tac "intro args_names" + (tclMAP + (fun id -> Proofview.V82.of_tactic (Simple.intro id)) + args_names) + ; (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC + ; tclTHEN_i + (observe_tac "functional_induction" (fun gl -> + let term = mkApp (mkVar principle_id, Array.of_list bindings) in + let gl', _ty = + pf_eapply (Typing.type_of ~refresh:true) gl term + in + Proofview.V82.of_tactic (apply term) gl')) + (fun i g -> + observe_tac + ("proving branche " ^ string_of_int i) + (prove_branche i) g) ] g (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] @@ -798,13 +894,12 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl *) let tauto = let open Ltac_plugin in - let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in + let dp = List.map Id.of_string ["Tauto"; "Init"; "Coq"] in let mp = ModPath.MPfile (DirPath.make dp) in let kn = KerName.make mp (Label.make "tauto") in - Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> - let body = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic body - end + Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> + let body = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic body) (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] @@ -815,16 +910,18 @@ let generalize_dependent_of x hyp g = let open Tacticals in tclMAP (function - | LocalAssum ({Context.binder_name=id},t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x t) -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (thin [id]) - | _ -> tclIDTAC - ) - (pf_hyps g) - g + | LocalAssum ({Context.binder_name = id}, t) + when (not (Id.equal id hyp)) + && Termops.occur_var (pf_env g) (project g) x t -> + tclTHEN + (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) + (thin [id]) + | _ -> tclIDTAC) + (pf_hyps g) g let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g + and intros_with_rewrite_aux : Tacmach.tactic = let open Constr in let open EConstr in @@ -835,88 +932,111 @@ and intros_with_rewrite_aux : Tacmach.tactic = let eq_ind = make_eq () in let sigma = project g in match EConstr.kind sigma (pf_concl g) with - | Prod(_,t,t') -> - begin - match EConstr.kind sigma t with - | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(1) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(1)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] - g - else if isVar sigma args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(2)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); - intros_with_rewrite - ] - g - else - begin - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST[ - Proofview.V82.of_tactic (Simple.intro id); - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] g - end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> - Proofview.V82.of_tactic tauto g - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - intros_with_rewrite - ] g - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g - end + | Prod (_, t, t') -> ( + match EConstr.kind sigma t with + | App (eq, args) when EConstr.eq_constr sigma eq eq_ind -> + if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; thin [id] + ; intros_with_rewrite ] + g + else if + isVar sigma args.(1) + && Environ.evaluable_named (destVar sigma args.(1)) (pf_env g) + then + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ]) + ; tclMAP + (fun id -> + tclTRY + (Proofview.V82.of_tactic + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + (destVar sigma args.(1), Locus.InHyp)))) + (pf_ids_of_hyps g) + ; intros_with_rewrite ] + g + else if + isVar sigma args.(2) + && Environ.evaluable_named (destVar sigma args.(2)) (pf_env g) + then + tclTHENLIST + [ Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ]) + ; tclMAP + (fun id -> + tclTRY + (Proofview.V82.of_tactic + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + (destVar sigma args.(2), Locus.InHyp)))) + (pf_ids_of_hyps g) + ; intros_with_rewrite ] + g + else if isVar sigma args.(1) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; generalize_dependent_of (destVar sigma args.(1)) id + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) + ; intros_with_rewrite ] + g + else if isVar sigma args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; generalize_dependent_of (destVar sigma args.(2)) id + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))) + ; intros_with_rewrite ] + g + else + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Proofview.V82.of_tactic (Simple.intro id) + ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) + ; intros_with_rewrite ] + g + | Ind _ + when EConstr.eq_constr sigma t + (EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.False.type" )) -> + Proofview.V82.of_tactic tauto g + | Case (_, _, v, _) -> + tclTHENLIST + [Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite] + g + | LetIn _ -> + tclTHENLIST + [ Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; intros_with_rewrite ] + g + | _ -> + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [Proofview.V82.of_tactic (Simple.intro id); intros_with_rewrite] + g ) | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g + tclTHENLIST + [ Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; intros_with_rewrite ] + g | _ -> tclIDTAC g let rec reflexivity_with_destruct_cases g = @@ -927,52 +1047,66 @@ let rec reflexivity_with_destruct_cases g = let open Tacticals in let destruct_case () = try - match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - Proofview.V82.of_tactic intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases - ] + match + EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) + with + | Case (_, _, v, _) -> + tclTHENLIST + [ Proofview.V82.of_tactic (simplest_case v) + ; Proofview.V82.of_tactic intros + ; observe_tac "reflexivity_with_destruct_cases" + reflexivity_with_destruct_cases ] | _ -> Proofview.V82.of_tactic reflexivity with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in let eq_ind = make_eq () in - let my_inj_flags = Some { - Equality.keep_proof_equalities = false; - injection_in_context = false; (* for compatibility, necessary *) - injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) - } in + let my_inj_flags = + Some + { Equality.keep_proof_equalities = false + ; injection_in_context = false + ; (* for compatibility, necessary *) + injection_pattern_l2r_order = + false (* probably does not matter; except maybe with dependent hyps *) + } + in let discr_inject = - Tacticals.onAllHypsAndConcl ( - fun sc g -> + Tacticals.onAllHypsAndConcl (fun sc g -> match sc with - None -> tclIDTAC g - | Some id -> + | None -> tclIDTAC g + | Some id -> ( match EConstr.kind (project g) (pf_get_hyp_typ g id) with - | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 - then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g + | App (eq, [|_; t1; t2|]) when EConstr.eq_constr (project g) eq eq_ind + -> + if Equality.discriminable (pf_env g) (project g) t1 t2 then + Proofview.V82.of_tactic (Equality.discrHyp id) g + else if + Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then + tclTHENLIST + [ Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id) + ; thin [id] + ; intros_with_rewrite ] + g else tclIDTAC g - | _ -> tclIDTAC g - ) + | _ -> tclIDTAC g )) in (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); - observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); - (* We reach this point ONLY if - the same value is matched (at least) two times - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" + (Proofview.V82.of_tactic reflexivity) + ; observe_tac "reflexivity_with_destruct_cases : destruct_case" + (destruct_case ()) + ; (* We reach this point ONLY if + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing *) - observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) - ]) + observe_tac "reflexivity_with_destruct_cases : others" + (tclTHEN (tclPROGRESS discr_inject) reflexivity_with_destruct_cases) ]) g -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : + Tacmach.tactic = let open EConstr in let open Tacmach in let open Tactics in @@ -983,12 +1117,17 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn concl ctxt)) + (fun (_, (ctxt, concl)) -> + Reductionops.nf_zeta (pf_env g) (project g) + (EConstr.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in + let graph_principle = + Reductionops.nf_zeta (pf_env g) (project g) + (EConstr.of_constr schemes.(i)) + in let g, princ_type = tac_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function @@ -996,24 +1135,24 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in + let ids = args_names @ pf_ids_of_hyps g in (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res,hres,graph_principle_id = + let res, hres, graph_principle_id = match generate_fresh_id (Id.of_string "z") ids 3 with - | [res;hres;graph_principle_id] -> res,hres,graph_principle_id + | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) | _ -> assert false in - let ids = res::hres::graph_principle_id::ids in + let ids = res :: hres :: graph_principle_id :: ids in (* we also compute fresh names for each hyptohesis of each branch of the principle *) let branches = List.rev princ_infos.branches in let intro_pats = List.map (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (Termops.nb_prod (project g) (RelDecl.get_type decl))) - ) + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids + (Termops.nb_prod (project g) (RelDecl.get_type decl)))) branches in (* We will need to change the function by its body @@ -1022,34 +1161,38 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let rewrite_tac j ids : Tacmach.tactic = let graph_def = graphs.(j) in - let infos = match find_Function_infos (fst (destConst (project g) funcs.(j))) with - | None -> - CErrors.user_err Pp.(str "No graph found") + let infos = + match find_Function_infos (fst (destConst (project g) funcs.(j))) with + | None -> CErrors.user_err Pp.(str "No graph found") | Some infos -> infos in - if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.Declarations.mind_recargs + if + infos.is_general + || Rtree.is_infinite Declareops.eq_recarg + graph_def.Declarations.mind_recargs then let eq_lemma = - try Option.get (infos).equation_lemma - with Option.IsNone -> CErrors.anomaly (Pp.str "Cannot find equation lemma.") + try Option.get infos.equation_lemma + with Option.IsNone -> + CErrors.anomaly (Pp.str "Cannot find equation lemma.") in - tclTHENLIST[ - tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); - (* Don't forget to $\zeta$ normlize the term since the principles - have been $\zeta$-normalized *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - Proofview.V82.of_tactic (generalize (List.map mkVar ids)); - thin ids - ] + tclTHENLIST + [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids + ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)) + ; (* Don't forget to $\zeta$ normlize the term since the principles + have been $\zeta$-normalized *) + Proofview.V82.of_tactic + (reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl) + ; Proofview.V82.of_tactic (generalize (List.map mkVar ids)) + ; thin ids ] else - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) + Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef (fst (destConst (project g) f)) ) ]) in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -1058,40 +1201,49 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti (* we fist compute the inductive corresponding to the branch *) let this_ind_number = let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then !ind_number - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end + let length = + Array.length graphs.(!ind_number).Declarations.mind_consnames + in + if constructor_num <= length then !ind_number + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end in let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENLIST[ - (* we expand the definition of the function *) - observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); - (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite (all)" intros_with_rewrite; - (* The proof is (almost) complete *) - observe_tac "reflexivity" (reflexivity_with_destruct_cases) - ] + tclTHENLIST + [ (* we expand the definition of the function *) + observe_tac "rewrite_tac" + (rewrite_tac this_ind_number this_branche_ids) + ; (* introduce hypothesis with some rewrite *) + observe_tac "intros_with_rewrite (all)" intros_with_rewrite + ; (* The proof is (almost) complete *) + observe_tac "reflexivity" reflexivity_with_destruct_cases ] g in let params_names = fst (List.chop princ_infos.nparams args_names) in let open EConstr in let params = List.map mkVar params_names in tclTHENLIST - [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); - observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); - Proofview.V82.of_tactic (Simple.intro graph_principle_id); - observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres, Tactypes.NoBindings) - (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) - ] + [ tclMAP + (fun id -> Proofview.V82.of_tactic (Simple.intro id)) + (args_names @ [res; hres]) + ; observe_tac "h_generalize" + (Proofview.V82.of_tactic + (generalize + [ mkApp + ( applist (graph_principle, params) + , Array.map (fun c -> applist (c, params)) lemmas ) ])) + ; Proofview.V82.of_tactic (Simple.intro graph_principle_id) + ; observe_tac "" + (tclTHEN_i + (observe_tac "elim" + (Proofview.V82.of_tactic + (elim false None + (mkVar hres, Tactypes.NoBindings) + (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) + (fun i g -> observe_tac "prove_branche" (prove_branche i) g)) ] g exception No_graph_found @@ -1099,35 +1251,35 @@ exception No_graph_found let get_funs_constant mp = let open Constr in let exception Not_Rec in - let get_funs_constant const e : (Names.Constant.t*int) array = + let get_funs_constant const e : (Names.Constant.t * int) array = match Constr.kind (Term.strip_lam e) with - | Fix((_,(na,_,_))) -> + | Fix (_, (na, _, _)) -> Array.mapi (fun i na -> - match na.Context.binder_name with - | Name id -> - let const = Constant.make2 mp (Label.of_id id) in - const,i - | Anonymous -> - CErrors.anomaly (Pp.str "Anonymous fix.") - ) + match na.Context.binder_name with + | Name id -> + let const = Constant.make2 mp (Label.of_id id) in + (const, i) + | Anonymous -> CErrors.anomaly (Pp.str "Anonymous fix.")) na - | _ -> [|const,0|] + | _ -> [|(const, 0)|] in - function const -> + function + | const -> let find_constant_body const = match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let body = Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.from_env (Global.env ())) - (EConstr.of_constr body) - in - let body = EConstr.Unsafe.to_constr body in - body - | None -> - CErrors.user_err Pp.(str ( "Cannot define a principle over an axiom ")) + | Some (body, _, _) -> + let body = + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + (Global.env ()) + (Evd.from_env (Global.env ())) + (EConstr.of_constr body) + in + let body = EConstr.Unsafe.to_constr body in + body + | None -> + CErrors.user_err Pp.(str "Cannot define a principle over an axiom ") in let f = find_constant_body const in let l_const = get_funs_constant const f in @@ -1135,17 +1287,24 @@ let get_funs_constant mp = We need to check that all the functions found are in the same block to prevent Reset strange thing *) - let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params, _l_fixes = List.split (List.map Term.decompose_lam l_bodies) in + let l_bodies = + List.map find_constant_body (Array.to_list (Array.map fst l_const)) + in + let l_params, _l_fixes = + List.split (List.map Term.decompose_lam l_bodies) + in (* all the parameters must be equal*) let _check_params = - let first_params = List.hd l_params in + let first_params = List.hd l_params in List.iter (fun params -> - if not (List.equal (fun (n1, c1) (n2, c2) -> - Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) - then CErrors.user_err Pp.(str "Not a mutal recursive block") - ) + if + not + (List.equal + (fun (n1, c1) (n2, c2) -> + Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) + first_params params) + then CErrors.user_err Pp.(str "Not a mutal recursive block")) l_params in (* The bodies has to be very similar *) @@ -1153,27 +1312,30 @@ let get_funs_constant mp = try let extract_info is_first body = match Constr.kind body with - | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && Int.equal (List.length l_bodies) 1 - then raise Not_Rec - else CErrors.user_err Pp.(str "Not a mutal recursive block") + | Fix ((idxs, _), (na, ta, ca)) -> (idxs, na, ta, ca) + | _ -> + if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec + else CErrors.user_err Pp.(str "Not a mutal recursive block") in let first_infos = extract_info true (List.hd l_bodies) in - let check body = (* Hope this is correct *) + let check body = + (* Hope this is correct *) let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = - Array.equal Int.equal ia1 ia2 && Array.equal (Context.eq_annot Name.equal) na1 na2 && - Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 + Array.equal Int.equal ia1 ia2 + && Array.equal (Context.eq_annot Name.equal) na1 na2 + && Array.equal Constr.equal ta1 ta2 + && Array.equal Constr.equal ca1 ca2 in - if not (eq_infos first_infos (extract_info false body)) - then CErrors.user_err Pp.(str "Not a mutal recursive block") + if not (eq_infos first_infos (extract_info false body)) then + CErrors.user_err Pp.(str "Not a mutal recursive block") in List.iter check l_bodies with Not_Rec -> () in l_const -let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_effects Declare.proof_entry list = +let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : + Evd.side_effects Declare.proof_entry list = let exception Found_type of int in let env = Global.env () in let funs = List.map fst fas in @@ -1185,42 +1347,47 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef | Some finfos -> fst finfos.graph_ind in let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in - let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in + let this_block_funs = + Array.map (fun (c, _) -> (c, snd first_fun)) this_block_funs_indexes + in let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map - (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) + (function + | cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) funs in let ind_list = List.map - (fun (idx) -> - let ind = first_fun_kn,idx in - (ind,snd first_fun),true,prop_sort - ) + (fun idx -> + let ind = (first_fun_kn, idx) in + ((ind, snd first_fun), true, prop_sort)) funs_indexes in - let sigma, schemes = - Indrec.build_mutual_induction_scheme env !evd ind_list - in + let sigma, schemes = Indrec.build_mutual_induction_scheme env !evd ind_list in let _ = evd := sigma in let l_schemes = - List.map (EConstr.of_constr %> Retyping.get_type_of env sigma %> EConstr.Unsafe.to_constr) schemes + List.map + ( EConstr.of_constr + %> Retyping.get_type_of env sigma + %> EConstr.Unsafe.to_constr ) + schemes in let i = ref (-1) in let sorts = - List.rev_map (fun (_,x) -> + List.rev_map + (fun (_, x) -> let sigma, fs = Evd.fresh_sort_in_family !evd x in - evd := sigma; fs - ) + evd := sigma; + fs) fas in (* We create the first principle by tactic *) - let first_type,other_princ_types = + let first_type, other_princ_types = match l_schemes with - s::l_schemes -> s,l_schemes - | _ -> CErrors.anomaly (Pp.str "") + | s :: l_schemes -> (s, l_schemes) + | _ -> CErrors.anomaly (Pp.str "") in let opaque = let finfos = @@ -1228,280 +1395,298 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef | None -> raise Not_found | Some finfos -> finfos in - let open Proof_global in + let open Declare in match finfos.equation_lemma with | None -> Transparent (* non recursive definition *) | Some equation -> - if Declareops.is_opaque (Global.lookup_constant equation) then Opaque else Transparent + if Declareops.is_opaque (Global.lookup_constant equation) then Opaque + else Transparent in let entry, _hook = try - build_functional_principle ~opaque evd - first_type - (Array.of_list sorts) - this_block_funs - 0 - (Functional_principles_proofs.prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) + build_functional_principle ~opaque evd first_type (Array.of_list sorts) + this_block_funs 0 + (Functional_principles_proofs.prove_princ_for_struct evd false 0 + (Array.of_list (List.map fst funs))) (fun _ _ -> ()) - with e when CErrors.noncritical e -> - raise (Defining_principle e) - + with e when CErrors.noncritical e -> raise (Defining_principle e) in incr i; (* The others are just deduced *) - if List.is_empty other_princ_types - then [entry] + if List.is_empty other_princ_types then [entry] else let other_fun_princ_types = let funs = Array.map Constr.mkConstU this_block_funs in let sorts = Array.of_list sorts in - List.map (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types + List.map + (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) + other_princ_types in let first_princ_body = entry.Declare.proof_entry_body in - let ctxt,fix = Term.decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) - let (idxs,_),(_,ta,_ as decl) = Constr.destFix fix in + let ctxt, fix = + Term.decompose_lam_assum (fst (fst (Future.force first_princ_body))) + in + (* the principle has for forall ...., fix .*) + let (idxs, _), ((_, ta, _) as decl) = Constr.destFix fix in let other_result = List.map (* we can now compute the other principles *) (fun scheme_type -> - incr i; - observe (Printer.pr_lconstr_env env sigma scheme_type); - let type_concl = (Term.strip_prod_assum scheme_type) in - let applied_f = List.hd (List.rev (snd (Constr.decompose_app type_concl))) in - let f = fst (Constr.decompose_app applied_f) in - try (* we search the number of the function in the fix block (name of the function) *) - Array.iteri - (fun j t -> - let t = (Term.strip_prod_assum t) in - let applied_g = List.hd (List.rev (snd (Constr.decompose_app t))) in + incr i; + observe (Printer.pr_lconstr_env env sigma scheme_type); + let type_concl = Term.strip_prod_assum scheme_type in + let applied_f = + List.hd (List.rev (snd (Constr.decompose_app type_concl))) + in + let f = fst (Constr.decompose_app applied_f) in + try + (* we search the number of the function in the fix block (name of the function) *) + Array.iteri + (fun j t -> + let t = Term.strip_prod_assum t in + let applied_g = + List.hd (List.rev (snd (Constr.decompose_app t))) + in let g = fst (Constr.decompose_app applied_g) in - if Constr.equal f g - then raise (Found_type j); - observe Pp.(Printer.pr_lconstr_env env sigma f ++ str " <> " ++ - Printer.pr_lconstr_env env sigma g) - - ) - ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method - *) - let entry, _hook = - build_functional_principle - evd - (List.nth other_princ_types (!i - 1)) - (Array.of_list sorts) - this_block_funs - !i - (Functional_principles_proofs.prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) - (fun _ _ -> ()) - in - entry - with Found_type i -> - let princ_body = - Termops.it_mkLambda_or_LetIn (Constr.mkFix((idxs,i),decl)) ctxt - in - Declare.definition_entry ~types:scheme_type princ_body - ) - other_fun_princ_types + if Constr.equal f g then raise (Found_type j); + observe + Pp.( + Printer.pr_lconstr_env env sigma f + ++ str " <> " + ++ Printer.pr_lconstr_env env sigma g)) + ta; + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method + *) + let entry, _hook = + build_functional_principle evd + (List.nth other_princ_types (!i - 1)) + (Array.of_list sorts) this_block_funs !i + (Functional_principles_proofs.prove_princ_for_struct evd false + !i + (Array.of_list (List.map fst funs))) + (fun _ _ -> ()) + in + entry + with Found_type i -> + let princ_body = + Termops.it_mkLambda_or_LetIn (Constr.mkFix ((idxs, i), decl)) ctxt + in + Declare.definition_entry ~types:scheme_type princ_body) + other_fun_princ_types in - entry::other_result + entry :: other_result (* [derive_correctness funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] *) -let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = +let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) + = let open EConstr in assert (funs <> []); assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in let map (c, u) = mkConstU (c, EInstance.make u) in - let funs_constr = Array.map map funs in + let funs_constr = Array.map map funs in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> - let env = Global.env () in - let evd = ref (Evd.from_env env) in - let graphs_constr = Array.map mkInd graphs in - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd false f_constr graph - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in - evd := sigma; - let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in - observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - let schemes = - (* The functional induction schemes are computed and not saved if there is more that one function - if the block contains only one function we can safely reuse [f_rect] - *) - try - if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; - [| find_induction_principle evd funs_constr.(0) |] - with Not_found -> - ( - - Array.of_list - (List.map - (fun entry -> - (EConstr.of_constr (fst (fst (Future.force entry.Declare.proof_entry_body))), - EConstr.of_constr (Option.get entry.Declare.proof_entry_type )) - ) - (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) - ) - ) - in - let proving_tac = - prove_fun_correct !evd graphs_constr schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_correct_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_correct_id f_id in - let (typ,_) = lemmas_types_infos.(i) in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (proving_tac i)) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = - match find_Function_infos (fst f_as_constant) with - | None -> raise Not_found - | Some finfo -> finfo + let env = Global.env () in + let evd = ref (Evd.from_env env) in + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let type_of_lemma_ctxt, type_of_lemma_concl, graph = + generate_type evd false f_constr graph in - (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = EConstr.destConst !evd lem_cst_constr in - update_Function {finfo with correctness_lemma = Some lem_cst}; - - ) - funs; - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd true f_constr graph - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = - EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt - in - let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in - observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - - let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in - let mib, _mip = Global.lookup_inductive graph_ind in - let sigma, scheme = - (Indrec.build_mutual_induction_scheme (Global.env ()) !evd - (Array.to_list - (Array.mapi - (fun i _ -> ((kn,i), EInstance.kind !evd u),true, Sorts.InType) - mib.Declarations.mind_packets - ) - ) - ) - in - let schemes = - Array.of_list scheme - in - let proving_tac = - prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_complete_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_complete_id f_id in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false sigma (fst lemmas_types_infos.(i)) in - let lemma = fst (Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i))) lemma) in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = - match find_Function_infos (fst f_as_constant) with - | None -> raise Not_found - | Some finfo -> finfo + let type_info = (type_of_lemma_ctxt, type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with completeness_lemma = Some lem_cst} - ) - funs) + let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in + evd := sigma; + let type_of_lemma = + Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma + in + observe + Pp.( + str "type_of_lemma := " + ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); + (type_of_lemma, type_info)) + funs_constr graphs_constr + in + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function + if the block contains only one function we can safely reuse [f_rect] + *) + try + if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; + [|find_induction_principle evd funs_constr.(0)|] + with Not_found -> + Array.of_list + (List.map + (fun entry -> + ( EConstr.of_constr + (fst (fst (Future.force entry.Declare.proof_entry_body))) + , EConstr.of_constr (Option.get entry.Declare.proof_entry_type) + )) + (make_scheme evd + (Array.map_to_list (fun const -> (const, Sorts.InType)) funs))) + in + let proving_tac = + prove_fun_correct !evd graphs_constr schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_correct_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_correct_id f_id in + let typ, _ = lemmas_types_infos.(i) in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in + let lemma = + fst @@ Lemmas.by (Proofview.V82.tactic (proving_tac i)) lemma + in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + ~idopt:None + in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) + let _, lem_cst_constr = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) + in + let lem_cst, _ = EConstr.destConst !evd lem_cst_constr in + update_Function {finfo with correctness_lemma = Some lem_cst}) + funs; + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let type_of_lemma_ctxt, type_of_lemma_concl, graph = + generate_type evd true f_constr graph + in + let type_info = (type_of_lemma_ctxt, type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + in + let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in + observe + Pp.( + str "type_of_lemma := " + ++ Printer.pr_leconstr_env env !evd type_of_lemma); + (type_of_lemma, type_info)) + funs_constr graphs_constr + in + let ((kn, _) as graph_ind), u = destInd !evd graphs_constr.(0) in + let mib, _mip = Global.lookup_inductive graph_ind in + let sigma, scheme = + Indrec.build_mutual_induction_scheme (Global.env ()) !evd + (Array.to_list + (Array.mapi + (fun i _ -> + (((kn, i), EInstance.kind !evd u), true, Sorts.InType)) + mib.Declarations.mind_packets)) + in + let schemes = Array.of_list scheme in + let proving_tac = + prove_fun_complete funs_constr mib.Declarations.mind_packets schemes + lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_complete_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_complete_id f_id in + let lemma = + Lemmas.start_lemma ~name:lem_id ~poly:false sigma + (fst lemmas_types_infos.(i)) + in + let lemma = + fst + (Lemmas.by + (Proofview.V82.tactic + (observe_tac + ("prove completeness (" ^ Id.to_string f_id ^ ")") + (proving_tac i))) + lemma) + in + let () = + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent + ~idopt:None + in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + let _, lem_cst_constr = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) + in + let lem_cst, _ = destConst !evd lem_cst_constr in + update_Function {finfo with completeness_lemma = Some lem_cst}) + funs) () let warn_funind_cannot_build_inversion = CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" - Pp.(fun e' -> strbrk "Cannot build inversion information" ++ - if do_observe () then (fnl() ++ CErrors.print e') else mt ()) + Pp.( + fun e' -> + strbrk "Cannot build inversion information" + ++ if do_observe () then fnl () ++ CErrors.print e' else mt ()) let derive_inversion fix_names = try let evd' = Evd.from_env (Global.env ()) in (* we first transform the fix_names identifier into their corresponding constant *) - let evd',fix_names_as_constant = + let evd', fix_names_as_constant = List.fold_right - (fun id (evd,l) -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - let (cst, u) = EConstr.destConst evd c in - evd, (cst, EConstr.EInstance.kind evd u) :: l - ) - fix_names - (evd',[]) + (fun id (evd, l) -> + let evd, c = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident id)) + in + let cst, u = EConstr.destConst evd c in + (evd, (cst, EConstr.EInstance.kind evd u) :: l)) + fix_names (evd', []) in (* Then we check that the graphs have been defined If one of the graphs haven't been defined we do nothing *) - List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; + List.iter + (fun c -> ignore (find_Function_infos (fst c))) + fix_names_as_constant; try let _evd', lind = List.fold_right - (fun id (evd,l) -> - let evd,id = - Evd.fresh_global - (Global.env ()) evd - (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) - in - evd,(fst (EConstr.destInd evd id))::l - ) - fix_names - (evd',[]) + (fun id (evd, l) -> + let evd, id = + Evd.fresh_global (Global.env ()) evd + (Constrintern.locate_reference + (Libnames.qualid_of_ident (mk_rel_id id))) + in + (evd, fst (EConstr.destInd evd id) :: l)) + fix_names (evd', []) in - derive_correctness - fix_names_as_constant - lind; - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - -let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body - pre_hook - = + derive_correctness fix_names_as_constant lind + with e when CErrors.noncritical e -> warn_funind_cannot_build_inversion e + with e when CErrors.noncritical e -> warn_funind_cannot_build_inversion e + +let register_wf interactive_proof ?(is_mes = false) fname rec_impls wf_rel_expr + wf_arg using_lemmas args ret_type body pre_hook = let type_of_f = Constrexpr_ops.mkCProdN args ret_type in let rec_arg_num = let names = @@ -1513,226 +1698,233 @@ let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf in let unbounded_eq = let f_app_args = - CAst.make @@ Constrexpr.CAppExpl( - (None, Libnames.qualid_of_ident fname,None) , - (List.map - (function - | {CAst.v=Anonymous} -> assert false - | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) - ) - (Constrexpr_ops.names_of_local_assums args) - ) - ) + CAst.make + @@ Constrexpr.CAppExpl + ( (None, Libnames.qualid_of_ident fname, None) + , List.map + (function + | {CAst.v = Anonymous} -> assert false + | {CAst.v = Name e} -> Constrexpr_ops.mkIdentC e) + (Constrexpr_ops.names_of_local_assums args) ) in - CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")), - [(f_app_args,None);(body,None)]) + CAst.make + @@ Constrexpr.CApp + ( (None, Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")) + , [(f_app_args, None); (body, None)] ) in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in - let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type - _nb_args relation = + let hook ((f_ref, _) as fconst) tcc_lemma_ref (functional_ref, _) (eq_ref, _) + rec_arg_num rec_arg_type _nb_args relation = try pre_hook [fconst] - (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes - functional_ref eq_ref rec_arg_num rec_arg_type relation - ); + (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref + eq_ref rec_arg_num rec_arg_type relation); derive_inversion [fname] - with e when CErrors.noncritical e -> - (* No proof done *) - () + with e when CErrors.noncritical e -> (* No proof done *) + () in - Recdef.recursive_definition ~interactive_proof - ~is_mes fname rec_impls - type_of_f - wf_rel_expr - rec_arg_num - eq - hook - using_lemmas - -let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = - let wf_arg_type,wf_arg = + Recdef.recursive_definition ~interactive_proof ~is_mes fname rec_impls + type_of_f wf_rel_expr rec_arg_num eq hook using_lemmas + +let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt + wf_arg using_lemmas args ret_type body = + let wf_arg_type, wf_arg = match wf_arg with - | None -> - begin - match args with - | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],_k,t)] -> t,x - | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") - end - | Some wf_args -> + | None -> ( + match args with + | [Constrexpr.CLocalAssum ([{CAst.v = Name x}], _k, t)] -> (t, x) + | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") ) + | Some wf_args -> ( try match List.find (function - | Constrexpr.CLocalAssum(l,_k,t) -> + | Constrexpr.CLocalAssum (l, _k, t) -> List.exists - (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) + (function + | {CAst.v = Name id} -> Id.equal id wf_args | _ -> false) l - | _ -> false - ) + | _ -> false) args with - | Constrexpr.CLocalAssum(_,_k,t) -> t,wf_args + | Constrexpr.CLocalAssum (_, _k, t) -> (t, wf_args) | _ -> assert false - with Not_found -> assert false + with Not_found -> assert false ) in - let wf_rel_from_mes,is_mes = + let wf_rel_from_mes, is_mes = match wf_rel_expr_opt with | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) + (Libnames.make_path + (make_dir ["Arith"; "Wf_nat"]) + (Id.of_string "ltof")) in let fun_from_mes = let applied_mes = - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in - Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) + Constrexpr_ops.mkAppC (wf_mes_expr, [Constrexpr_ops.mkIdentC wf_arg]) + in + Constrexpr_ops.mkLambdaC + ( [CAst.make @@ Name wf_arg] + , Constrexpr_ops.default_binder_kind + , wf_arg_type + , applied_mes ) in let wf_rel_from_mes = - Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) + Constrexpr_ops.mkAppC + (Constrexpr_ops.mkRefC ltof, [wf_arg_type; fun_from_mes]) in - wf_rel_from_mes,true + (wf_rel_from_mes, true) | Some wf_rel_expr -> let wf_rel_with_mes = let a = Names.Id.of_string "___a" in let b = Names.Id.of_string "___b" in - Constrexpr_ops.mkLambdaC( - [CAst.make @@ Name a; CAst.make @@ Name b], - Constrexpr.Default Glob_term.Explicit, - wf_arg_type, - Constrexpr_ops.mkAppC(wf_rel_expr, - [ - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) - ]) - ) + Constrexpr_ops.mkLambdaC + ( [CAst.make @@ Name a; CAst.make @@ Name b] + , Constrexpr.Default Glob_term.Explicit + , wf_arg_type + , Constrexpr_ops.mkAppC + ( wf_rel_expr + , [ Constrexpr_ops.mkAppC + (wf_mes_expr, [Constrexpr_ops.mkIdentC a]) + ; Constrexpr_ops.mkAppC + (wf_mes_expr, [Constrexpr_ops.mkIdentC b]) ] ) ) in - wf_rel_with_mes,false + (wf_rel_with_mes, false) in - register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg + register_wf interactive_proof ~is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body -let do_generate_principle_aux pconstants on_error register_built interactive_proof fixpoint_exprl : Lemmas.t option = - List.iter (fun { Vernacexpr.notations } -> - if not (List.is_empty notations) - then CErrors.user_err (Pp.str "Function does not support notations for now")) fixpoint_exprl; +let do_generate_principle_aux pconstants on_error register_built + interactive_proof fixpoint_exprl : Lemmas.t option = + List.iter + (fun {Vernacexpr.notations} -> + if not (List.is_empty notations) then + CErrors.user_err (Pp.str "Function does not support notations for now")) + fixpoint_exprl; let lemma, _is_struct = match fixpoint_exprl with - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs = _; binders; rtype; body_def } as fixpoint_expr = + | [ ( { Vernacexpr.rec_order = + Some {CAst.v = Constrexpr.CWfRec (wf_x, wf_rel)} } as + fixpoint_expr ) ] -> + let ( {Vernacexpr.fname; univs = _; binders; rtype; body_def} as + fixpoint_expr ) = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let body = match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let body = + match body_def with + | Some body -> body + | None -> + CErrors.user_err ~hdr:"Function" + (Pp.str "Body of Function must be given") + in + let recdefs, rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs + pconstants on_error true register_built fixpoint_exprl recdefs in - if register_built - then register_wf interactive_proof fname.CAst.v rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false - else None, false - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs = _; binders; rtype; body_def} as fixpoint_expr = + if register_built then + ( register_wf interactive_proof fname.CAst.v rec_impls wf_rel + wf_x.CAst.v using_lemmas binders rtype body pre_hook + , false ) + else (None, false) + | [ ( { Vernacexpr.rec_order = + Some {CAst.v = Constrexpr.CMeasureRec (wf_x, wf_mes, wf_rel_opt)} + } as fixpoint_expr ) ] -> + let ( {Vernacexpr.fname; univs = _; binders; rtype; body_def} as + fixpoint_expr ) = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false in let fixpoint_exprl = [fixpoint_expr] in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let recdefs, rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let body = match body_def with + let body = + match body_def with | Some body -> body | None -> - CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in + CErrors.user_err ~hdr:"Function" + Pp.(str "Body of Function must be given") + in let pre_hook pconstants = generate_principle (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs + pconstants on_error true register_built fixpoint_exprl recdefs in - if register_built - then register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt - (Option.map (fun x -> x.CAst.v) wf_x) using_lemmas binders rtype body pre_hook, true - else None, true + if register_built then + ( register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt + (Option.map (fun x -> x.CAst.v) wf_x) + using_lemmas binders rtype body pre_hook + , true ) + else (None, true) | _ -> - List.iter (function { Vernacexpr.rec_order } -> - match rec_order with - | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> - CErrors.user_err - (Pp.str "Cannot use mutual definition with well-founded recursion or measure") - | _ -> () - ) + List.iter + (function + | {Vernacexpr.rec_order} -> ( + match rec_order with + | Some {CAst.v = Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _} -> + CErrors.user_err + (Pp.str + "Cannot use mutual definition with well-founded recursion \ + or measure") + | _ -> () )) fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in - let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in + let fix_names = + List.map (function {Vernacexpr.fname} -> fname.CAst.v) fixpoint_exprl + in (* ok all the expressions are structural *) let recdefs, _rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in - let lemma,evd,pconstants = - if register_built - then register_struct is_rec fixpoint_exprl - else None, Evd.from_env (Global.env ()), pconstants + let lemma, evd, pconstants = + if register_built then register_struct is_rec fixpoint_exprl + else (None, Evd.from_env (Global.env ()), pconstants) in let evd = ref evd in - generate_principle - (ref !evd) - pconstants - on_error - false - register_built - fixpoint_exprl - recdefs - (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); - if register_built then - begin derive_inversion fix_names; end; - lemma, true + generate_principle (ref !evd) pconstants on_error false register_built + fixpoint_exprl recdefs + (Functional_principles_proofs.prove_princ_for_struct evd + interactive_proof); + if register_built then derive_inversion fix_names; + (lemma, true) in lemma let warn_cannot_define_graph = CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" - (fun (names,error) -> - Pp.(strbrk "Cannot define graph(s) for " ++ - h 1 names ++ error)) + (fun (names, error) -> + Pp.(strbrk "Cannot define graph(s) for " ++ h 1 names ++ error)) let warn_cannot_define_principle = CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" - (fun (names,error) -> - Pp.(strbrk "Cannot define induction principle(s) for "++ - h 1 names ++ error)) + (fun (names, error) -> + Pp.( + strbrk "Cannot define induction principle(s) for " ++ h 1 names ++ error)) let warning_error names e = let e_explain e = match e with - | ToShow e -> - Pp.(spc () ++ CErrors.print e) - | _ -> - if do_observe () - then Pp.(spc () ++ CErrors.print e) - else Pp.mt () + | ToShow e -> Pp.(spc () ++ CErrors.print e) + | _ -> if do_observe () then Pp.(spc () ++ CErrors.print e) else Pp.mt () in match e with | Building_graph e -> - let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in - warn_cannot_define_graph (names,e_explain e) + let names = + Pp.(prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + in + warn_cannot_define_graph (names, e_explain e) | Defining_principle e -> - let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in - warn_cannot_define_principle (names,e_explain e) + let names = + Pp.(prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + in + warn_cannot_define_principle (names, e_explain e) | _ -> raise e let error_error names e = @@ -1744,9 +1936,11 @@ let error_error names e = match e with | Building_graph e -> CErrors.user_err - Pp.(str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - e_explain e) + Pp.( + str "Cannot define graph(s) for " + ++ h 1 + (prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) + ++ e_explain e) | _ -> raise e (* [chop_n_arrow n t] chops the [n] first arrows in [t] @@ -1755,272 +1949,307 @@ let error_error names e = let rec chop_n_arrow n t = let exception Stop of Constrexpr.constr_expr in let open Constrexpr in - if n <= 0 - then t (* If we have already removed all the arrows then return the type *) - else (* If not we check the form of [t] *) + if n <= 0 then t + (* If we have already removed all the arrows then return the type *) + else + (* If not we check the form of [t] *) match t.CAst.v with - | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible : - either we need to discard more than the number of arrows contained - in this product declaration then we just recall [chop_n_arrow] on - the remaining number of arrow to chop and [t'] we discard it and - recall [chop_n_arrow], either this product contains more arrows - than the number we need to chop and then we return the new type - *) - begin - try - let new_n = - let rec aux (n:int) = function - [] -> n - | CLocalAssum(nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in - if n >= nal_l - then - aux (n - nal_l) nal_ta' - else - let new_t' = CAst.make @@ - Constrexpr.CProdN( - CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') - in - raise (Stop new_t') - | _ -> CErrors.anomaly (Pp.str "Not enough products.") - in - aux n nal_ta' + | Constrexpr.CProdN (nal_ta', t') -> ( + try + (* If we have a forall, two results are possible : + either we need to discard more than the number of arrows contained + in this product declaration then we just recall [chop_n_arrow] on + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows + than the number we need to chop and then we return the new type + *) + let new_n = + let rec aux (n : int) = function + | [] -> n + | CLocalAssum (nal, k, t'') :: nal_ta' -> + let nal_l = List.length nal in + if n >= nal_l then aux (n - nal_l) nal_ta' + else + let new_t' = + CAst.make + @@ Constrexpr.CProdN + ( CLocalAssum (snd (List.chop n nal), k, t'') :: nal_ta' + , t' ) + in + raise (Stop new_t') + | _ -> CErrors.anomaly (Pp.str "Not enough products.") in - chop_n_arrow new_n t' - with Stop t -> t - end + aux n nal_ta' + in + chop_n_arrow new_n t' + with Stop t -> t ) | _ -> CErrors.anomaly (Pp.str "Not enough products.") let rec add_args id new_args = let open Libnames in let open Constrexpr in CAst.map (function - | CRef (qid,_) as b -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((None,qid,None),new_args) - else b - | CFix _ | CCoFix _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "todo.") - | CProdN(nal,b1) -> - CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> - CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLambdaN(nal,b1) -> - CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> - CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLetIn(na,b1,t,b2) -> - CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) - | CAppExpl((pf,qid,us),exprl) -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) - else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) - | CApp((pf,b),bl) -> - CApp((pf,add_args id new_args b), - List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(sty,b_option,cel,cal) -> - CCases(sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,na,b_option) -> - add_args id new_args b, - na, b_option) cel, - List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal - ) - | CLetTuple(nal,(na,b_option),b1,b2) -> - CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), - add_args id new_args b1, - add_args id new_args b2 - ) - - | CIf(b1,(na,b_option),b2,b3) -> - CIf(add_args id new_args b1, - (na,Option.map (add_args id new_args) b_option), - add_args id new_args b2, - add_args id new_args b3 - ) - | CHole _ - | CPatVar _ - | CEvar _ - | CPrim _ - | CSort _ as b -> b - | CCast(b1,b2) -> - CCast(add_args id new_args b1, - Glob_ops.map_cast_type (add_args id new_args) b2) - | CRecord pars -> - CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) - | CNotation _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") - | CGeneralization _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") - | CDelimiters _ -> - CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.") - ) - -let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = + | CRef (qid, _) as b -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl ((None, qid, None), new_args) + else b + | CFix _ | CCoFix _ -> CErrors.anomaly ~label:"add_args " (Pp.str "todo.") + | CProdN (nal, b1) -> + CProdN + ( List.map + (function + | CLocalAssum (nal, k, b2) -> + CLocalAssum (nal, k, add_args id new_args b2) + | CLocalDef (na, b1, t) -> + CLocalDef + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t ) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) + nal + , add_args id new_args b1 ) + | CLambdaN (nal, b1) -> + CLambdaN + ( List.map + (function + | CLocalAssum (nal, k, b2) -> + CLocalAssum (nal, k, add_args id new_args b2) + | CLocalDef (na, b1, t) -> + CLocalDef + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t ) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) + nal + , add_args id new_args b1 ) + | CLetIn (na, b1, t, b2) -> + CLetIn + ( na + , add_args id new_args b1 + , Option.map (add_args id new_args) t + , add_args id new_args b2 ) + | CAppExpl ((pf, qid, us), exprl) -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl + ((pf, qid, us), new_args @ List.map (add_args id new_args) exprl) + else CAppExpl ((pf, qid, us), List.map (add_args id new_args) exprl) + | CApp ((pf, b), bl) -> + CApp + ( (pf, add_args id new_args b) + , List.map (fun (e, o) -> (add_args id new_args e, o)) bl ) + | CCases (sty, b_option, cel, cal) -> + CCases + ( sty + , Option.map (add_args id new_args) b_option + , List.map + (fun (b, na, b_option) -> (add_args id new_args b, na, b_option)) + cel + , List.map + CAst.(map (fun (cpl, e) -> (cpl, add_args id new_args e))) + cal ) + | CLetTuple (nal, (na, b_option), b1, b2) -> + CLetTuple + ( nal + , (na, Option.map (add_args id new_args) b_option) + , add_args id new_args b1 + , add_args id new_args b2 ) + | CIf (b1, (na, b_option), b2, b3) -> + CIf + ( add_args id new_args b1 + , (na, Option.map (add_args id new_args) b_option) + , add_args id new_args b2 + , add_args id new_args b3 ) + | (CHole _ | CPatVar _ | CEvar _ | CPrim _ | CSort _) as b -> b + | CCast (b1, b2) -> + CCast + ( add_args id new_args b1 + , Glob_ops.map_cast_type (add_args id new_args) b2 ) + | CRecord pars -> + CRecord (List.map (fun (e, o) -> (e, add_args id new_args o)) pars) + | CNotation _ -> CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") + | CGeneralization _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") + | CDelimiters _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.")) + +let rec get_args b t : + Constrexpr.local_binder_expr list + * Constrexpr.constr_expr + * Constrexpr.constr_expr = let open Constrexpr in match b.CAst.v with - | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> - begin - let n = List.length nal in - let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in - d :: nal_tas, b'',t'' - end - | Constrexpr.CLambdaN ([], b) -> [],b,t - | _ -> [],b,t + | Constrexpr.CLambdaN ((CLocalAssum (nal, k, ta) as d) :: rest, b') -> + let n = List.length nal in + let nal_tas, b'', t'' = + get_args + (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest, b')) + (chop_n_arrow n t) + in + (d :: nal_tas, b'', t'') + | Constrexpr.CLambdaN ([], b) -> ([], b, t) + | _ -> ([], b, t) let make_graph (f_ref : GlobRef.t) = let open Constrexpr in - let env = Global.env() in + let env = Global.env () in let sigma = Evd.from_env env in - let c,c_body = + let c, c_body = match f_ref with - | GlobRef.ConstRef c -> - begin - try c,Global.lookup_constant c - with Not_found -> - CErrors.user_err Pp.(str "Cannot find " ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) - end - | _ -> - CErrors.user_err Pp.(str "Not a function reference") + | GlobRef.ConstRef c -> ( + try (c, Global.lookup_constant c) + with Not_found -> + CErrors.user_err + Pp.( + str "Cannot find " + ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) ) + | _ -> CErrors.user_err Pp.(str "Not a function reference") in - (match Global.body_of_constant_body Library.indirect_accessor c_body with - | None -> - CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") - | Some (body, _, _) -> - let env = Global.env () in - let extern_body,extern_type = - with_full_print (fun () -> - (Constrextern.extern_constr env sigma (EConstr.of_constr body), - Constrextern.extern_type env sigma - (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) - ) - ) - () - in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,recexp,bl,t,b) -> - let { CAst.loc; v=rec_id } = match Option.get recexp with - | { CAst.v = CStructRec id } -> id - | { CAst.v = CWfRec (id,_) } -> id - | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid - in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - { Vernacexpr.fname=id; univs=None - ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) - ; binders = nal_tas@bl; rtype=t; body_def=Some b'; notations = []} - ) - fixexprl - in - l - | _ -> - let fname = CAst.make (Label.to_id (Constant.label c)) in - [{ Vernacexpr.fname; univs=None; rec_order = None; binders=nal_tas; rtype=t; body_def=Some b; notations=[]}] - in - let mp = Constant.modpath c in - let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in - assert (Option.is_empty pstate); - (* We register the infos *) - List.iter - (fun { Vernacexpr.fname= {CAst.v=id} } -> - add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) + match Global.body_of_constant_body Library.indirect_accessor c_body with + | None -> CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") + | Some (body, _, _) -> + let env = Global.env () in + let extern_body, extern_type = + with_full_print + (fun () -> + ( Constrextern.extern_constr env sigma (EConstr.of_constr body) + , Constrextern.extern_type env sigma + (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) )) + () + in + let nal_tas, b, t = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix (l_id, fixexprl) -> + let l = + List.map + (fun (id, recexp, bl, t, b) -> + let {CAst.loc; v = rec_id} = + match Option.get recexp with + | {CAst.v = CStructRec id} -> id + | {CAst.v = CWfRec (id, _)} -> id + | {CAst.v = CMeasureRec (oid, _, _)} -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na, _, _) -> [] + | Constrexpr.CLocalAssum (nal, _, _) -> + List.map + (fun {CAst.loc; v = n} -> + CAst.make ?loc + @@ CRef + ( Libnames.qualid_of_ident ?loc + @@ Nameops.Name.get_id n + , None )) + nal + | Constrexpr.CLocalPattern _ -> assert false) + nal_tas) + in + let b' = add_args id.CAst.v new_args b in + { Vernacexpr.fname = id + ; univs = None + ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) + ; binders = nal_tas @ bl + ; rtype = t + ; body_def = Some b' + ; notations = [] }) + fixexprl + in + l + | _ -> + let fname = CAst.make (Label.to_id (Constant.label c)) in + [ { Vernacexpr.fname + ; univs = None + ; rec_order = None + ; binders = nal_tas + ; rtype = t + ; body_def = Some b + ; notations = [] } ] + in + let mp = Constant.modpath c in + let pstate = + do_generate_principle_aux [(c, Univ.Instance.empty)] error_error false + false expr_list + in + assert (Option.is_empty pstate); + (* We register the infos *) + List.iter + (fun {Vernacexpr.fname = {CAst.v = id}} -> + add_Function false (Constant.make2 mp (Label.of_id id))) + expr_list (* *************** statically typed entrypoints ************************* *) let do_generate_principle_interactive fixl : Lemmas.t = - match - do_generate_principle_aux [] warning_error true true fixl - with + match do_generate_principle_aux [] warning_error true true fixl with | Some lemma -> lemma | None -> - CErrors.anomaly - (Pp.str"indfun: leaving no open proof in interactive mode") + CErrors.anomaly (Pp.str "indfun: leaving no open proof in interactive mode") let do_generate_principle fixl : unit = - match do_generate_principle_aux [] warning_error true false fixl with + match do_generate_principle_aux [] warning_error true false fixl with | Some _lemma -> CErrors.anomaly - (Pp.str"indfun: leaving a goal open in non-interactive mode") + (Pp.str "indfun: leaving a goal open in non-interactive mode") | None -> () - let build_scheme fas = - let evd = (ref (Evd.from_env (Global.env ()))) in - let pconstants = (List.map - (fun (_,f,sort) -> - let f_as_constant = - try - Smartlocate.global_with_alias f - with Not_found -> - CErrors.user_err ~hdr:"FunInd.build_scheme" - Pp.(str "Cannot find " ++ Libnames.pr_qualid f) - in - let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in - let _ = evd := evd' in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in - evd := sigma; - let c, u = - try EConstr.destConst !evd f - with Constr.DestKO -> - CErrors.user_err Pp.(Printer.pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") - in - (c, EConstr.EInstance.kind !evd u), sort - ) - fas - ) in + let evd = ref (Evd.from_env (Global.env ())) in + let pconstants = + List.map + (fun (_, f, sort) -> + let f_as_constant = + try Smartlocate.global_with_alias f + with Not_found -> + CErrors.user_err ~hdr:"FunInd.build_scheme" + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let evd', f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let _ = evd := evd' in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in + evd := sigma; + let c, u = + try EConstr.destConst !evd f + with Constr.DestKO -> + CErrors.user_err + Pp.( + Printer.pr_econstr_env (Global.env ()) !evd f + ++ spc () + ++ str "should be the named of a globally defined function") + in + ((c, EConstr.EInstance.kind !evd u), sort)) + fas + in let bodies_types = make_scheme evd pconstants in - List.iter2 - (fun (princ_id,_,_) def_entry -> - ignore - (Declare.declare_constant - ~name:princ_id - ~kind:Decls.(IsProof Theorem) - (Declare.DefinitionEntry def_entry)); - Declare.definition_message princ_id - ) - fas - bodies_types + (fun (princ_id, _, _) def_entry -> + ignore + (Declare.declare_constant ~name:princ_id + ~kind:Decls.(IsProof Theorem) + (Declare.DefinitionEntry def_entry)); + Declare.definition_message princ_id) + fas bodies_types let build_case_scheme fa = - let env = Global.env () - and sigma = (Evd.from_env (Global.env ())) in -(* let id_to_constr id = *) -(* Constrintern.global_reference id *) -(* in *) + let env = Global.env () and sigma = Evd.from_env (Global.env ()) in + (* let id_to_constr id = *) + (* Constrintern.global_reference id *) + (* in *) let funs = - let (_,f,_) = fa in - try (let open GlobRef in - match Smartlocate.global_with_alias f with - | ConstRef c -> c - | IndRef _ | ConstructRef _ | VarRef _ -> assert false) + let _, f, _ = fa in + try + let open GlobRef in + match Smartlocate.global_with_alias f with + | ConstRef c -> c + | IndRef _ | ConstructRef _ | VarRef _ -> assert false with Not_found -> CErrors.user_err ~hdr:"FunInd.build_case_scheme" - Pp.(str "Cannot find " ++ Libnames.pr_qualid f) in - let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let sigma, (_, u) = Evd.fresh_constant_instance env sigma funs in let first_fun = funs in let funs_mp = Constant.modpath first_fun in let first_fun_kn = @@ -2029,39 +2258,39 @@ let build_case_scheme fa = | Some finfos -> fst finfos.graph_ind in let this_block_funs_indexes = get_funs_constant funs_mp first_fun in - let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in + let this_block_funs = + Array.map (fun (c, _) -> (c, u)) this_block_funs_indexes + in let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc_f Constant.equal funs this_block_funs_indexes in - let (ind, sf) = - let ind = first_fun_kn,funs_indexes in - (ind,Univ.Instance.empty)(*FIXME*),prop_sort + let ind, sf = + let ind = (first_fun_kn, funs_indexes) in + ((ind, Univ.Instance.empty) (*FIXME*), prop_sort) in - let (sigma, scheme) = - Indrec.build_case_analysis_scheme_default env sigma ind sf + let sigma, scheme = + Indrec.build_case_analysis_scheme_default env sigma ind sf in - let scheme_type = EConstr.Unsafe.to_constr ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in - let sorts = - (fun (_,_,x) -> - fst @@ UnivGen.fresh_sort_in_family x - ) - fa + let scheme_type = + EConstr.Unsafe.to_constr + ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in - let princ_name = (fun (x,_,_) -> x) fa in - let _ : unit = - (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ - pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs - ); - *) + let sorts = (fun (_, _, x) -> fst @@ UnivGen.fresh_sort_in_family x) fa in + let princ_name = (fun (x, _, _) -> x) fa in + let (_ : unit) = + (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ + pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs + ); + *) generate_functional_principle (ref (Evd.from_env (Global.env ()))) scheme_type - (Some ([|sorts|])) - (Some princ_name) - this_block_funs - 0 - (Functional_principles_proofs.prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) + (Some [|sorts|]) + (Some princ_name) this_block_funs 0 + (Functional_principles_proofs.prove_princ_for_struct + (ref (Evd.from_env (Global.env ()))) + false 0 [|funs|]) in () diff --git a/plugins/funind/gen_principle.mli b/plugins/funind/gen_principle.mli index 6313a2b16e..3c04d6cb7d 100644 --- a/plugins/funind/gen_principle.mli +++ b/plugins/funind/gen_principle.mli @@ -11,13 +11,14 @@ val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit -val do_generate_principle_interactive : Vernacexpr.fixpoint_expr list -> Lemmas.t -val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit +val do_generate_principle_interactive : + Vernacexpr.fixpoint_expr list -> Lemmas.t +val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit val make_graph : Names.GlobRef.t -> unit (* Can be thrown by build_{,case}_scheme *) exception No_graph_found val build_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) list -> unit -val build_case_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) -> unit +val build_case_scheme : Names.Id.t * Libnames.qualid * Sorts.family -> unit diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index e08ad9af3a..11e4fa0ac7 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -10,34 +10,27 @@ open Indfun_common open CErrors open Util open Glob_termops - module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () +let observe strm = if do_observe () then Feedback.msg_debug strm else () + (*let observennl strm = if do_observe () then Pp.msg strm else ()*) - -type binder_type = - | Lambda of Name.t - | Prod of Name.t - | LetIn of Name.t - -type glob_context = (binder_type*glob_constr) list - +type binder_type = Lambda of Name.t | Prod of Name.t | LetIn of Name.t +type glob_context = (binder_type * glob_constr) list let rec solve_trivial_holes pat_as_term e = - match DAst.get pat_as_term, DAst.get e with - | GHole _,_ -> e - | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe -> - DAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) - | _,_ -> pat_as_term + match (DAst.get pat_as_term, DAst.get e) with + | GHole _, _ -> e + | GApp (fp, argsp), GApp (fe, argse) when glob_constr_eq fp fe -> + DAst.make + (GApp + (solve_trivial_holes fp fe, List.map2 solve_trivial_holes argsp argse)) + | _, _ -> pat_as_term (* compose_glob_context [(bt_1,n_1,t_1);......] rt returns @@ -45,31 +38,26 @@ let rec solve_trivial_holes pat_as_term e = binders corresponding to the bt_i's *) let compose_glob_context = - let compose_binder (bt,t) acc = + let compose_binder (bt, t) acc = match bt with - | Lambda n -> mkGLambda(n,t,acc) - | Prod n -> mkGProd(n,t,acc) - | LetIn n -> mkGLetIn(n,t,None,acc) + | Lambda n -> mkGLambda (n, t, acc) + | Prod n -> mkGProd (n, t, acc) + | LetIn n -> mkGLetIn (n, t, None, acc) in List.fold_right compose_binder - (* The main part deals with building a list of globalized constructor expressions from the rhs of a fixpoint equation. *) type 'a build_entry_pre_return = - { - context : glob_context; (* the binding context of the result *) - value : 'a; (* The value *) - } + { context : glob_context + ; (* the binding context of the result *) + value : 'a (* The value *) } type 'a build_entry_return = - { - result : 'a build_entry_pre_return list; - to_avoid : Id.t list - } + {result : 'a build_entry_pre_return list; to_avoid : Id.t list} (* [combine_results combine_fun res1 res2] combine two results [res1] and [res2] @@ -81,64 +69,55 @@ type 'a build_entry_return = *) let combine_results - (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> - 'c build_entry_pre_return - ) - (res1: 'a build_entry_return) - (res2 : 'b build_entry_return) - : 'c build_entry_return - = - let pre_result = List.map - ( fun res1 -> (* for each result in arg_res *) - List.map (* we add it in each args_res *) - (fun res2 -> - combine_fun res1 res2 - ) - res2.result - ) + (combine_fun : + 'a build_entry_pre_return + -> 'b build_entry_pre_return + -> 'c build_entry_pre_return) (res1 : 'a build_entry_return) + (res2 : 'b build_entry_return) : 'c build_entry_return = + let pre_result = + List.map + (fun res1 -> + (* for each result in arg_res *) + List.map (* we add it in each args_res *) + (fun res2 -> combine_fun res1 res2) + res2.result) res1.result - in (* and then we flatten the map *) - { - result = List.concat pre_result; - to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid - } - + in + (* and then we flatten the map *) + { result = List.concat pre_result + ; to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid } (* The combination function for an argument with a list of argument *) let combine_args arg args = - { - context = arg.context@args.context; - (* Note that the binding context of [arg] MUST be placed before the one of + { context = arg.context @ args.context + ; (* Note that the binding context of [arg] MUST be placed before the one of [args] in order to preserve possible type dependencies *) - value = arg.value::args.value; - } + value = arg.value :: args.value } - -let ids_of_binder = function +let ids_of_binder = function | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> Id.Set.empty - | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id + | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id let rec change_vars_in_binder mapping = function - [] -> [] - | (bt,t)::l -> - let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in - (bt,change_vars mapping t):: - (if Id.Map.is_empty new_mapping - then l - else change_vars_in_binder new_mapping l - ) + | [] -> [] + | (bt, t) :: l -> + let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in + (bt, change_vars mapping t) + :: + ( if Id.Map.is_empty new_mapping then l + else change_vars_in_binder new_mapping l ) let rec replace_var_by_term_in_binder x_id term = function | [] -> [] - | (bt,t)::l -> - (bt,replace_var_by_term x_id term t):: - if Id.Set.mem x_id (ids_of_binder bt) - then l - else replace_var_by_term_in_binder x_id term l + | (bt, t) :: l -> + (bt, replace_var_by_term x_id term t) + :: + ( if Id.Set.mem x_id (ids_of_binder bt) then l + else replace_var_by_term_in_binder x_id term l ) let add_bt_names bt = Id.Set.union (ids_of_binder bt) @@ -146,128 +125,116 @@ let apply_args ctxt body args = let need_convert_id avoid id = List.exists (is_free_in id) args || Id.Set.mem id avoid in - let need_convert avoid bt = + let need_convert avoid bt = Id.Set.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.Set.t) = + let next_name_away (na : Name.t) (mapping : Id.t Id.Map.t) (avoid : Id.Set.t) + = match na with - | Name id when Id.Set.mem id avoid -> - let new_id = Namegen.next_ident_away id avoid in - Name new_id,Id.Map.add id new_id mapping,Id.Set.add new_id avoid - | _ -> na,mapping,avoid + | Name id when Id.Set.mem id avoid -> + let new_id = Namegen.next_ident_away id avoid in + (Name new_id, Id.Map.add id new_id mapping, Id.Set.add new_id avoid) + | _ -> (na, mapping, avoid) in - let next_bt_away bt (avoid:Id.Set.t) = + let next_bt_away bt (avoid : Id.Set.t) = match bt with - | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - LetIn new_na,mapping,new_avoid - | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Prod new_na,mapping,new_avoid - | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Lambda new_na,mapping,new_avoid + | LetIn na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (LetIn new_na, mapping, new_avoid) + | Prod na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (Prod new_na, mapping, new_avoid) + | Lambda na -> + let new_na, mapping, new_avoid = next_name_away na Id.Map.empty avoid in + (Lambda new_na, mapping, new_avoid) in let rec do_apply avoid ctxt body args = - match ctxt,args with - | _,[] -> (* No more args *) - (ctxt,body) - | [],_ -> (* no more fun *) - let f,args' = glob_decompose_app body in - (ctxt,mkGApp(f,args'@args)) - | (Lambda Anonymous,t)::ctxt',arg::args' -> - do_apply avoid ctxt' body args' - | (Lambda (Name id),t)::ctxt',arg::args' -> - let new_avoid,new_ctxt',new_body,new_id = - if need_convert_id avoid id - then - let new_avoid = Id.Set.add id avoid in - let new_id = Namegen.next_ident_away id new_avoid in - let new_avoid' = Id.Set.add new_id new_avoid in - let mapping = Id.Map.add id new_id Id.Map.empty in - let new_ctxt' = change_vars_in_binder mapping ctxt' in - let new_body = change_vars mapping body in - new_avoid',new_ctxt',new_body,new_id - else - Id.Set.add id avoid,ctxt',body,id - in - let new_body = replace_var_by_term new_id arg new_body in - let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in - do_apply avoid new_ctxt' new_body args' - | (bt,t)::ctxt',_ -> - let new_avoid,new_ctxt',new_body,new_bt = - let new_avoid = add_bt_names bt avoid in - if need_convert avoid bt - then - let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in - ( - new_avoid, - change_vars_in_binder mapping ctxt', - change_vars mapping body, - new_bt - ) - else new_avoid,ctxt',body,bt - in - let new_ctxt',new_body = - do_apply new_avoid new_ctxt' new_body args - in - (new_bt,t)::new_ctxt',new_body + match (ctxt, args) with + | _, [] -> + (* No more args *) + (ctxt, body) + | [], _ -> + (* no more fun *) + let f, args' = glob_decompose_app body in + (ctxt, mkGApp (f, args' @ args)) + | (Lambda Anonymous, t) :: ctxt', arg :: args' -> + do_apply avoid ctxt' body args' + | (Lambda (Name id), t) :: ctxt', arg :: args' -> + let new_avoid, new_ctxt', new_body, new_id = + if need_convert_id avoid id then + let new_avoid = Id.Set.add id avoid in + let new_id = Namegen.next_ident_away id new_avoid in + let new_avoid' = Id.Set.add new_id new_avoid in + let mapping = Id.Map.add id new_id Id.Map.empty in + let new_ctxt' = change_vars_in_binder mapping ctxt' in + let new_body = change_vars mapping body in + (new_avoid', new_ctxt', new_body, new_id) + else (Id.Set.add id avoid, ctxt', body, id) + in + let new_body = replace_var_by_term new_id arg new_body in + let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in + do_apply avoid new_ctxt' new_body args' + | (bt, t) :: ctxt', _ -> + let new_avoid, new_ctxt', new_body, new_bt = + let new_avoid = add_bt_names bt avoid in + if need_convert avoid bt then + let new_bt, mapping, new_avoid = next_bt_away bt new_avoid in + ( new_avoid + , change_vars_in_binder mapping ctxt' + , change_vars mapping body + , new_bt ) + else (new_avoid, ctxt', body, bt) + in + let new_ctxt', new_body = do_apply new_avoid new_ctxt' new_body args in + ((new_bt, t) :: new_ctxt', new_body) in do_apply Id.Set.empty ctxt body args - let combine_app f args = - let new_ctxt,new_value = apply_args f.context f.value args.value in - { - (* Note that the binding context of [args] MUST be placed before the one of + let new_ctxt, new_value = apply_args f.context f.value args.value in + { (* Note that the binding context of [args] MUST be placed before the one of the applied value in order to preserve possible type dependencies *) - context = args.context@new_ctxt; - value = new_value; - } + context = args.context @ new_ctxt + ; value = new_value } let combine_lam n t b = - { - context = []; - value = mkGLambda(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) - } + { context = [] + ; value = + mkGLambda + ( n + , compose_glob_context t.context t.value + , compose_glob_context b.context b.value ) } let combine_prod2 n t b = - { - context = []; - value = mkGProd(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) - } + { context = [] + ; value = + mkGProd + ( n + , compose_glob_context t.context t.value + , compose_glob_context b.context b.value ) } let combine_prod n t b = - { context = t.context@((Prod n,t.value)::b.context); value = b.value} + {context = t.context @ ((Prod n, t.value) :: b.context); value = b.value} let combine_letin n t b = - { context = t.context@((LetIn n,t.value)::b.context); value = b.value} - + {context = t.context @ ((LetIn n, t.value) :: b.context); value = b.value} let mk_result ctxt value avoid = - { - result = - [{context = ctxt; - value = value}] - ; - to_avoid = avoid - } + {result = [{context = ctxt; value}]; to_avoid = avoid} + (************************************************* Some functions to deal with overlapping patterns **************************************************) -let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") +let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") let coq_False_ref = lazy (Coqlib.lib_ref "core.False.type") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with (the list of expressions on which we will do the matching) *) -let make_discr_match_el = - List.map (fun e -> (e,(Anonymous,None))) +let make_discr_match_el = List.map (fun e -> (e, (Anonymous, None))) (* [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. @@ -283,23 +250,21 @@ let make_discr_match_el = *) let make_discr_match_brl i = List.map_i - (fun j {CAst.v=(idl,patl,_)} -> CAst.make @@ - if Int.equal j i - then (idl,patl, mkGRef (Lazy.force coq_True_ref)) - else (idl,patl, mkGRef (Lazy.force coq_False_ref)) - ) + (fun j {CAst.v = idl, patl, _} -> + CAst.make + @@ + if Int.equal j i then (idl, patl, mkGRef (Lazy.force coq_True_ref)) + else (idl, patl, mkGRef (Lazy.force coq_False_ref))) 0 + (* [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff brl_{i} is the first branch matched by [el] Used when we want to simulate the coq pattern matching algorithm *) -let make_discr_match brl = - fun el i -> - mkGCases(None, - make_discr_match_el el, - make_discr_match_brl i brl) +let make_discr_match brl el i = + mkGCases (None, make_discr_match_el el, make_discr_match_brl i brl) (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) @@ -307,140 +272,159 @@ let make_discr_match brl = (* [build_constructors_of_type] construct the array of pattern of its inductive argument*) let build_constructors_of_type ind' argl = - let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in + let mib, ind = Inductive.lookup_mind_specif (Global.env ()) ind' in let npar = mib.Declarations.mind_nparams in - Array.mapi (fun i _ -> - let construct = ind',i+1 in - let constructref = GlobRef.ConstructRef(construct) in - let _implicit_positions_of_cst = - Impargs.implicits_of_global constructref - in - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - construct - in - let argl = - if List.is_empty argl then - List.make cst_narg (mkGHole ()) - else - List.make npar (mkGHole ()) @ argl - in - let pat_as_term = - mkGApp(mkGRef (GlobRef.ConstructRef(ind',i+1)),argl) - in - cases_pattern_of_glob_constr (Global.env()) Anonymous pat_as_term - ) + Array.mapi + (fun i _ -> + let construct = (ind', i + 1) in + let constructref = GlobRef.ConstructRef construct in + let _implicit_positions_of_cst = + Impargs.implicits_of_global constructref + in + let cst_narg = + Inductiveops.constructor_nallargs (Global.env ()) construct + in + let argl = + if List.is_empty argl then List.make cst_narg (mkGHole ()) + else List.make npar (mkGHole ()) @ argl + in + let pat_as_term = + mkGApp (mkGRef (GlobRef.ConstructRef (ind', i + 1)), argl) + in + cases_pattern_of_glob_constr (Global.env ()) Anonymous pat_as_term) ind.Declarations.mind_consnames (******************) (* Main functions *) (******************) - - -let raw_push_named (na,raw_value,raw_typ) env = +let raw_push_named (na, raw_value, raw_typ) env = match na with - | Anonymous -> env - | Name id -> - let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in - let na = make_annot id Sorts.Relevant in (* TODO relevance *) - (match raw_value with - | None -> - EConstr.push_named (NamedDecl.LocalAssum (na,typ)) env - | Some value -> - EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env) - + | Anonymous -> env + | Name id -> ( + let typ, _ = + Pretyping.understand env (Evd.from_env env) + ~expected_type:Pretyping.IsType raw_typ + in + let na = make_annot id Sorts.Relevant in + (* TODO relevance *) + match raw_value with + | None -> EConstr.push_named (NamedDecl.LocalAssum (na, typ)) env + | Some value -> EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env + ) let add_pat_variables sigma pat typ env : Environ.env = - let rec add_pat_variables env pat typ : Environ.env = - observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); - + let rec add_pat_variables env pat typ : Environ.env = + observe + (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match DAst.get pat with - | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (make_annot na Sorts.Relevant,typ)) env - | PatCstr(c,patl,na) -> - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) - with Not_found -> assert false - in - let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in - List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + | PatVar na -> + Environ.push_rel + (RelDecl.LocalAssum (make_annot na Sorts.Relevant, typ)) + env + | PatCstr (c, patl, na) -> + let (Inductiveops.IndType (indf, indargs)) = + try + Inductiveops.find_rectype env (Evd.from_env env) + (EConstr.of_constr typ) + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = + List.find + (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) + (Array.to_list constructors) + in + let cs_args_types : types list = + List.map RelDecl.get_type constructor.Inductiveops.cs_args + in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = - fst ( - Context.Rel.fold_outside - (fun decl (env,ctxt) -> + fst + (Context.Rel.fold_outside + (fun decl (env, ctxt) -> let open Context.Rel.Declaration in match decl with - | LocalAssum ({binder_name=Anonymous},_) | LocalDef ({binder_name=Anonymous},_,_) -> assert false - | LocalAssum ({binder_name=Name id} as na, t) -> - let na = {na with binder_name=id} in - let new_t = substl ctxt t in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () - ); + | LocalAssum ({binder_name = Anonymous}, _) + |LocalDef ({binder_name = Anonymous}, _, _) -> + assert false + | LocalAssum (({binder_name = Name id} as na), t) -> + let na = {na with binder_name = id} in + let new_t = substl ctxt t in + observe + ( str "for variable " ++ Ppconstr.pr_id id ++ fnl () + ++ str "old type := " + ++ Printer.pr_lconstr_env env sigma t + ++ fnl () ++ str "new type := " + ++ Printer.pr_lconstr_env env sigma new_t + ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalAssum (na,new_t)) env,mkVar id::ctxt) - | LocalDef ({binder_name=Name id} as na, v, t) -> - let na = {na with binder_name=id} in - let new_t = substl ctxt t in + (Environ.push_named (LocalAssum (na, new_t)) env, mkVar id :: ctxt) + | LocalDef (({binder_name = Name id} as na), v, t) -> + let na = {na with binder_name = id} in + let new_t = substl ctxt t in let new_v = substl ctxt v in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () ++ - str "old value := " ++ Printer.pr_lconstr_env env sigma v ++ fnl () ++ - str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl () - ); + observe + ( str "for variable " ++ Ppconstr.pr_id id ++ fnl () + ++ str "old type := " + ++ Printer.pr_lconstr_env env sigma t + ++ fnl () ++ str "new type := " + ++ Printer.pr_lconstr_env env sigma new_t + ++ fnl () ++ str "old value := " + ++ Printer.pr_lconstr_env env sigma v + ++ fnl () ++ str "new value := " + ++ Printer.pr_lconstr_env env sigma new_v + ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalDef (na,new_v,new_t)) env,mkVar id::ctxt) - ) - (Environ.rel_context new_env) - ~init:(env,[]) - ) + ( Environ.push_named (LocalDef (na, new_v, new_t)) env + , mkVar id :: ctxt )) + (Environ.rel_context new_env) + ~init:(env, [])) in - observe (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); + observe + (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); res - - - -let rec pattern_to_term_and_type env typ = DAst.with_val (function - | PatVar Anonymous -> assert false - | PatVar (Name id) -> - mkGVar id - | PatCstr(constr,patternl,_) -> - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - constr - in - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) +let rec pattern_to_term_and_type env typ = + DAst.with_val (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id + | PatCstr (constr, patternl, _) -> + let cst_narg = Inductiveops.constructor_nallargs (Global.env ()) constr in + let (Inductiveops.IndType (indf, indargs)) = + try + Inductiveops.find_rectype env (Evd.from_env env) + (EConstr.of_constr typ) with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in - let _,cstl = Inductiveops.dest_ind_family indf in + let constructor = + List.find + (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) + (Array.to_list constructors) + in + let cs_args_types : types list = + List.map RelDecl.get_type constructor.Inductiveops.cs_args + in + let _, cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr csta.(i))) - ) + (fun i -> + Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) + (EConstr.of_constr csta.(i)))) in let patl_as_term = - List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl + List.map2 + (pattern_to_term_and_type env) + (List.rev cs_args_types) patternl in - mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) - ) + mkGApp (mkGRef (GlobRef.ConstructRef constr), implicit_args @ patl_as_term)) (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the @@ -473,448 +457,427 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function but only the value of the function *) - -let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_return = +let rec build_entry_lc env sigma funnames avoid rt : + glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> - (* do nothing (except changing type of course) *) - mk_result [] rt avoid - | GApp(_,_) -> - let f,args = glob_decompose_app rt in - let args_res : (glob_constr list) build_entry_return = - List.fold_right (* create the arguments lists of constructors and combine them *) - (fun arg ctxt_argsl -> - let arg_res = build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in - combine_results combine_args arg_res ctxt_argsl - ) - args - (mk_result [] [] avoid) - in - begin - match DAst.get f with - | GLambda _ -> - let rec aux t l = - match l with - | [] -> t - | u::l -> DAst.make @@ - match DAst.get t with - | GLambda(na,_,nat,b) -> - GLetIn(na,u,None,aux b l) - | _ -> - GApp(t,l) - in - build_entry_lc env sigma funnames avoid (aux f args) - | GVar id when Id.Set.mem id funnames -> - (* if we have [f t1 ... tn] with [f]$\in$[fnames] - then we create a fresh variable [res], - add [res] and its "value" (i.e. [res v1 ... vn]) to each - pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and - a pseudo value "v1 ... vn". - The "value" of this branch is then simply [res] - *) - (* XXX here and other [understand] calls drop the ctx *) - let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in - let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in - let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in - let res = fresh_id args_res.to_avoid "_res" in - let new_avoid = res::args_res.to_avoid in - let res_rt = mkGVar res in - let new_result = - List.map - (fun arg_res -> - let new_hyps = - [Prod (Name res),res_raw_type; - Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)] - in - {context = arg_res.context@new_hyps; value = res_rt } - ) - args_res.result - in - { result = new_result; to_avoid = new_avoid } - | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> - (* if have [g t1 ... tn] with [g] not appearing in [funnames] - then - foreach [ctxt,v1 ... vn] in [args_res] we return - [ctxt, g v1 .... vn] - *) - { - args_res with - result = - List.map - (fun args_res -> - {args_res with value = mkGApp(f,args_res.value)}) - args_res.result - } - | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) - | GLetIn(n,v,t,b) -> - (* if we have [(let x := v in b) t1 ... tn] , - we discard our work and compute the list of constructor for - [let x = v in (b t1 ... tn)] up to alpha conversion - *) - let new_n,new_b,new_avoid = - match n with - | Name id when List.exists (is_free_in id) args -> - (* need to alpha-convert the name *) - let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in - let new_avoid = id:: avoid in - let new_b = - replace_var_by_term - id - (DAst.make @@ GVar id) - b - in - (Name new_id,new_b,new_avoid) - | _ -> n,b,avoid - in - build_entry_lc - env - sigma - funnames - avoid - (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) - | GCases _ | GIf _ | GLetTuple _ -> - (* we have [(match e1, ...., en with ..... end) t1 tn] - we first compute the result from the case and - then combine each of them with each of args one - *) - let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in - combine_results combine_app f_res args_res - | GCast(b,_) -> - (* for an applied cast we just trash the cast part - and restart the work. - - WARNING: We need to restart since [b] itself should be an application term - *) - build_entry_lc env sigma funnames avoid (mkGApp(b,args)) - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GProd _ -> user_err Pp.(str "Cannot apply a type") - | GInt _ -> user_err Pp.(str "Cannot apply an integer") - | GFloat _ -> user_err Pp.(str "Cannot apply a float") - end (* end of the application treatement *) - - | GLambda(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env sigma funnames avoid t in - let new_n = - match n with - | Name _ -> n - | Anonymous -> Name (Indfun_common.fresh_id [] "_x") - in - let new_env = raw_push_named (new_n,None,t) env in - let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_lam new_n) t_res b_res - | GProd(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env sigma funnames avoid t in - let new_env = raw_push_named (n,None,t) env in - let b_res = build_entry_lc new_env sigma funnames avoid b in - if List.length t_res.result = 1 && List.length b_res.result = 1 - then combine_results (combine_prod2 n) t_res b_res - else combine_results (combine_prod n) t_res b_res - | GLetIn(n,v,typ,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the value [t] - and combine the two result - *) - let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let v_res = build_entry_lc env sigma funnames avoid v in - let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in - let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in - let v_r = Sorts.Relevant in (* TODO relevance *) - let new_env = - match n with - Anonymous -> env - | Name id -> EConstr.push_named (NamedDecl.LocalDef (make_annot id v_r,v_as_constr,v_type)) env - in - let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_letin n) v_res b_res - | GCases(_,_,el,brl) -> - (* we create the discrimination function - and treat the case itself - *) - let make_discr = make_discr_match brl in - build_entry_lc_from_case env sigma funnames make_discr el brl avoid - | GIf(b,(na,e_option),lhs,rhs) -> - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr_env env b ++ str " in " ++ - Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type (fst ind) [] in - assert (Int.equal (Array.length case_pats) 2); - let brl = - List.map_i - (fun i x -> CAst.make ([],[case_pats.(i)],x)) - 0 - [lhs;rhs] - in - let match_expr = - mkGCases(None,[(b,(Anonymous,None))],brl) - in - (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) - build_entry_lc env sigma funnames avoid match_expr - | GLetTuple(nal,_,b,e) -> - begin - let nal_as_glob_constr = - List.map - (function - Name id -> mkGVar id - | Anonymous -> mkGHole () - ) - nal - in - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr_env env b ++ str " in " ++ - Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ + |GFloat _ -> + (* do nothing (except changing type of course) *) + mk_result [] rt avoid + | GApp (_, _) -> ( + let f, args = glob_decompose_app rt in + let args_res : glob_constr list build_entry_return = + List.fold_right + (* create the arguments lists of constructors and combine them *) + (fun arg ctxt_argsl -> + let arg_res = + build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in - let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in - assert (Int.equal (Array.length case_pats) 1); - let br = CAst.make ([],[case_pats.(0)],e) in - let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc env sigma funnames avoid match_expr - - end + combine_results combine_args arg_res ctxt_argsl) + args (mk_result [] [] avoid) + in + match DAst.get f with + | GLambda _ -> + let rec aux t l = + match l with + | [] -> t + | u :: l -> ( + DAst.make + @@ + match DAst.get t with + | GLambda (na, _, nat, b) -> GLetIn (na, u, None, aux b l) + | _ -> GApp (t, l) ) + in + build_entry_lc env sigma funnames avoid (aux f args) + | GVar id when Id.Set.mem id funnames -> + (* if we have [f t1 ... tn] with [f]$\in$[fnames] + then we create a fresh variable [res], + add [res] and its "value" (i.e. [res v1 ... vn]) to each + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". + The "value" of this branch is then simply [res] + *) + (* XXX here and other [understand] calls drop the ctx *) + let rt_as_constr, ctx = Pretyping.understand env (Evd.from_env env) rt in + let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in + let res_raw_type = + Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) + rt_typ + in + let res = fresh_id args_res.to_avoid "_res" in + let new_avoid = res :: args_res.to_avoid in + let res_rt = mkGVar res in + let new_result = + List.map + (fun arg_res -> + let new_hyps = + [ (Prod (Name res), res_raw_type) + ; (Prod Anonymous, mkGApp (res_rt, mkGVar id :: arg_res.value)) ] + in + {context = arg_res.context @ new_hyps; value = res_rt}) + args_res.result + in + {result = new_result; to_avoid = new_avoid} + | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> + (* if have [g t1 ... tn] with [g] not appearing in [funnames] + then + foreach [ctxt,v1 ... vn] in [args_res] we return + [ctxt, g v1 .... vn] + *) + { args_res with + result = + List.map + (fun args_res -> {args_res with value = mkGApp (f, args_res.value)}) + args_res.result } + | GApp _ -> + assert false (* we have collected all the app in [glob_decompose_app] *) + | GLetIn (n, v, t, b) -> + (* if we have [(let x := v in b) t1 ... tn] , + we discard our work and compute the list of constructor for + [let x = v in (b t1 ... tn)] up to alpha conversion + *) + let new_n, new_b, new_avoid = + match n with + | Name id when List.exists (is_free_in id) args -> + (* need to alpha-convert the name *) + let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in + let new_avoid = id :: avoid in + let new_b = replace_var_by_term id (DAst.make @@ GVar id) b in + (Name new_id, new_b, new_avoid) + | _ -> (n, b, avoid) + in + build_entry_lc env sigma funnames avoid + (mkGLetIn (new_n, v, t, mkGApp (new_b, args))) + | GCases _ | GIf _ | GLetTuple _ -> + (* we have [(match e1, ...., en with ..... end) t1 tn] + we first compute the result from the case and + then combine each of them with each of args one + *) + let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in + combine_results combine_app f_res args_res + | GCast (b, _) -> + (* for an applied cast we just trash the cast part + and restart the work. + + WARNING: We need to restart since [b] itself should be an application term + *) + build_entry_lc env sigma funnames avoid (mkGApp (b, args)) | GRec _ -> user_err Pp.(str "Not handled GRec") - | GCast(b,_) -> - build_entry_lc env sigma funnames avoid b -and build_entry_lc_from_case env sigma funname make_discr - (el:tomatch_tuples) - (brl:Glob_term.cases_clauses) avoid : - glob_constr build_entry_return = + | GProd _ -> user_err Pp.(str "Cannot apply a type") + | GInt _ -> user_err Pp.(str "Cannot apply an integer") + | GFloat _ -> user_err Pp.(str "Cannot apply a float") + (* end of the application treatement *) ) + | GLambda (n, _, t, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env sigma funnames avoid t in + let new_n = + match n with + | Name _ -> n + | Anonymous -> Name (Indfun_common.fresh_id [] "_x") + in + let new_env = raw_push_named (new_n, None, t) env in + let b_res = build_entry_lc new_env sigma funnames avoid b in + combine_results (combine_lam new_n) t_res b_res + | GProd (n, _, t, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env sigma funnames avoid t in + let new_env = raw_push_named (n, None, t) env in + let b_res = build_entry_lc new_env sigma funnames avoid b in + if List.length t_res.result = 1 && List.length b_res.result = 1 then + combine_results (combine_prod2 n) t_res b_res + else combine_results (combine_prod n) t_res b_res + | GLetIn (n, v, typ, b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the value [t] + and combine the two result + *) + let v = + match typ with + | None -> v + | Some t -> DAst.make ?loc:rt.loc @@ GCast (v, CastConv t) + in + let v_res = build_entry_lc env sigma funnames avoid v in + let v_as_constr, ctx = Pretyping.understand env (Evd.from_env env) v in + let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in + let v_r = Sorts.Relevant in + (* TODO relevance *) + let new_env = + match n with + | Anonymous -> env + | Name id -> + EConstr.push_named + (NamedDecl.LocalDef (make_annot id v_r, v_as_constr, v_type)) + env + in + let b_res = build_entry_lc new_env sigma funnames avoid b in + combine_results (combine_letin n) v_res b_res + | GCases (_, _, el, brl) -> + (* we create the discrimination function + and treat the case itself + *) + let make_discr = make_discr_match brl in + build_entry_lc_from_case env sigma funnames make_discr el brl avoid + | GIf (b, (na, e_option), lhs, rhs) -> + let b_as_constr, ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in + let ind, _ = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err + ( str "Cannot find the inductive associated to " + ++ Printer.pr_glob_constr_env env b + ++ str " in " + ++ Printer.pr_glob_constr_env env rt + ++ str ". try again with a cast" ) + in + let case_pats = build_constructors_of_type (fst ind) [] in + assert (Int.equal (Array.length case_pats) 2); + let brl = + List.map_i (fun i x -> CAst.make ([], [case_pats.(i)], x)) 0 [lhs; rhs] + in + let match_expr = mkGCases (None, [(b, (Anonymous, None))], brl) in + (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) + build_entry_lc env sigma funnames avoid match_expr + | GLetTuple (nal, _, b, e) -> + let nal_as_glob_constr = + List.map (function Name id -> mkGVar id | Anonymous -> mkGHole ()) nal + in + let b_as_constr, ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in + let ind, _ = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err + ( str "Cannot find the inductive associated to " + ++ Printer.pr_glob_constr_env env b + ++ str " in " + ++ Printer.pr_glob_constr_env env rt + ++ str ". try again with a cast" ) + in + let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in + assert (Int.equal (Array.length case_pats) 1); + let br = CAst.make ([], [case_pats.(0)], e) in + let match_expr = mkGCases (None, [(b, (Anonymous, None))], [br]) in + build_entry_lc env sigma funnames avoid match_expr + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast (b, _) -> build_entry_lc env sigma funnames avoid b + +and build_entry_lc_from_case env sigma funname make_discr (el : tomatch_tuples) + (brl : Glob_term.cases_clauses) avoid : glob_constr build_entry_return = match el with - | [] -> assert false (* this case correspond to match <nothing> with .... !*) - | el -> - (* this case correspond to - match el with brl end - we first compute the list of lists corresponding to [el] and - combine them . - Then for each element of the combinations, - we compute the result we compute one list per branch in [brl] and - finally we just concatenate those list - *) - let case_resl = - List.fold_right - (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg in - combine_results combine_args arg_res ctxt_argsl - ) - el - (mk_result [] [] avoid) - in - let types = - List.map (fun (case_arg,_) -> - let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - EConstr.Unsafe.to_constr (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr) - ) el - in - (****** The next works only if the match is not dependent ****) - let results = - List.map - (fun ca -> - let res = build_entry_lc_from_case_term - env sigma types - funname (make_discr) - [] brl - case_resl.to_avoid - ca - in - res - ) - case_resl.result - in - { - result = List.concat (List.map (fun r -> r.result) results); - to_avoid = - List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid) - [] results - } - -and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to_prevent brl avoid - matched_expr = + | [] -> assert false (* this case correspond to match <nothing> with .... !*) + | el -> + (* this case correspond to + match el with brl end + we first compute the list of lists corresponding to [el] and + combine them . + Then for each element of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list + *) + let case_resl = + List.fold_right + (fun (case_arg, _) ctxt_argsl -> + let arg_res = + build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg + in + combine_results combine_args arg_res ctxt_argsl) + el (mk_result [] [] avoid) + in + let types = + List.map + (fun (case_arg, _) -> + let case_arg_as_constr, ctx = + Pretyping.understand env (Evd.from_env env) case_arg + in + EConstr.Unsafe.to_constr + (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr)) + el + in + (****** The next works only if the match is not dependent ****) + let results = + List.map + (fun ca -> + let res = + build_entry_lc_from_case_term env sigma types funname make_discr [] + brl case_resl.to_avoid ca + in + res) + case_resl.result + in + { result = List.concat (List.map (fun r -> r.result) results) + ; to_avoid = + List.fold_left + (fun acc r -> List.union Id.equal acc r.to_avoid) + [] results } + +and build_entry_lc_from_case_term env sigma types funname make_discr + patterns_to_prevent brl avoid matched_expr = match brl with - | [] -> (* computed_branches *) {result = [];to_avoid = avoid} - | br::brl' -> - (* alpha conversion to prevent name clashes *) - let {CAst.v=(idl,patl,return)} = alpha_br avoid br in - let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) - (* building a list of precondition stating that we are not in this branch - (will be used in the following recursive calls) - *) - let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in - let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = - List.map2 - (fun pat typ -> - fun avoid pat'_as_term -> - let renamed_pat,_,_ = alpha_pat avoid pat in - let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables sigma pat typ new_env in - List.fold_right - (fun id acc -> - let typ_of_id = Typing.type_of_variable env_with_pat_ids id in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty - env_with_pat_ids (Evd.from_env env) typ_of_id - in - mkGProd (Name id,raw_typ_of_id,acc)) - pat_ids - (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) - ) - patl - types - in - (* Checking if we can be in this branch - (will be used in the following recursive calls) - *) - let unify_with_those_patterns : (cases_pattern -> bool*bool) list = - List.map - (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') - patl - in - (* + | [] -> (* computed_branches *) {result = []; to_avoid = avoid} + | br :: brl' -> + (* alpha conversion to prevent name clashes *) + let {CAst.v = idl, patl, return} = alpha_br avoid br in + let new_avoid = idl @ avoid in + (* for now we can no more use idl as an identifier *) + (* building a list of precondition stating that we are not in this branch + (will be used in the following recursive calls) + *) + let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in + let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = + List.map2 + (fun pat typ avoid pat'_as_term -> + let renamed_pat, _, _ = alpha_pat avoid pat in + let pat_ids = get_pattern_id renamed_pat in + let env_with_pat_ids = add_pat_variables sigma pat typ new_env in + List.fold_right + (fun id acc -> + let typ_of_id = Typing.type_of_variable env_with_pat_ids id in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty env_with_pat_ids + (Evd.from_env env) typ_of_id + in + mkGProd (Name id, raw_typ_of_id, acc)) + pat_ids + (glob_make_neq pat'_as_term (pattern_to_term renamed_pat))) + patl types + in + (* Checking if we can be in this branch + (will be used in the following recursive calls) + *) + let unify_with_those_patterns : (cases_pattern -> bool * bool) list = + List.map + (fun pat pat' -> (are_unifiable pat pat', eq_cases_pattern pat pat')) + patl + in + (* we first compute the other branch result (in ordrer to keep the order of the matching as much as possible) *) - let brl'_res = - build_entry_lc_from_case_term - env - sigma - types - funname - make_discr - ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) - brl' - avoid - matched_expr - in - (* We now create the precondition of this branch i.e. - 1- the list of variable appearing in the different patterns of this branch and - the list of equation stating than el = patl (List.flatten ...) - 2- If there exists a previous branch which pattern unify with the one of this branch - then a discrimination precond stating that we are not in a previous branch (if List.exists ...) - *) - let those_pattern_preconds = - (List.flatten - ( - List.map3 - (fun pat e typ_as_constr -> - let this_pat_ids = ids_of_pat pat in - let typ_as_constr = EConstr.of_constr typ_as_constr in - let typ = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_as_constr in - let pat_as_term = pattern_to_term pat in - (* removing trivial holes *) - let pat_as_term = solve_trivial_holes pat_as_term e in - (* observe (str "those_pattern_preconds" ++ spc () ++ *) - (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) - (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) - (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) - List.fold_right - (fun id acc -> - if Id.Set.mem id this_pat_ids - then (Prod (Name id), - let typ_of_id = Typing.type_of_variable new_env id in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id - in - raw_typ_of_id - )::acc - else acc - ) - idl - [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] - ) - patl - matched_expr.value - types - ) - ) - @ - (if List.exists (function (unifl,_) -> - let (unif,_) = - List.split (List.map2 (fun x y -> x y) unifl patl) - in - List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in - let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in - [(Prod Anonymous,make_discr pats_as_constr i )] - else - [] - ) - in - (* We compute the result of the value returned by the branch*) - let return_res = build_entry_lc new_env sigma funname new_avoid return in - (* and combine it with the preconds computed for this branch *) - let this_branch_res = - List.map - (fun res -> - { context = matched_expr.context@those_pattern_preconds@res.context ; - value = res.value} - ) - return_res.result + let brl'_res = + build_entry_lc_from_case_term env sigma types funname make_discr + ((unify_with_those_patterns, not_those_patterns) :: patterns_to_prevent) + brl' avoid matched_expr + in + (* We now create the precondition of this branch i.e. + 1- the list of variable appearing in the different patterns of this branch and + the list of equation stating than el = patl (List.flatten ...) + 2- If there exists a previous branch which pattern unify with the one of this branch + then a discrimination precond stating that we are not in a previous branch (if List.exists ...) + *) + let those_pattern_preconds = + List.flatten + (List.map3 + (fun pat e typ_as_constr -> + let this_pat_ids = ids_of_pat pat in + let typ_as_constr = EConstr.of_constr typ_as_constr in + let typ = + Detyping.detype Detyping.Now false Id.Set.empty new_env + (Evd.from_env env) typ_as_constr + in + let pat_as_term = pattern_to_term pat in + (* removing trivial holes *) + let pat_as_term = solve_trivial_holes pat_as_term e in + (* observe (str "those_pattern_preconds" ++ spc () ++ *) + (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) + (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) + (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) + List.fold_right + (fun id acc -> + if Id.Set.mem id this_pat_ids then + ( Prod (Name id) + , let typ_of_id = Typing.type_of_variable new_env id in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty new_env + (Evd.from_env env) typ_of_id + in + raw_typ_of_id ) + :: acc + else acc) + idl + [(Prod Anonymous, glob_make_eq ~typ pat_as_term e)]) + patl matched_expr.value types) + @ + if + List.exists + (function + | unifl, _ -> + let unif, _ = + List.split (List.map2 (fun x y -> x y) unifl patl) + in + List.for_all (fun x -> x) unif) + patterns_to_prevent + then + let i = List.length patterns_to_prevent in + let pats_as_constr = + List.map2 (pattern_to_term_and_type new_env) types patl in - { brl'_res with result = this_branch_res@brl'_res.result } - + [(Prod Anonymous, make_discr pats_as_constr i)] + else [] + in + (* We compute the result of the value returned by the branch*) + let return_res = build_entry_lc new_env sigma funname new_avoid return in + (* and combine it with the preconds computed for this branch *) + let this_branch_res = + List.map + (fun res -> + { context = matched_expr.context @ those_pattern_preconds @ res.context + ; value = res.value }) + return_res.result + in + {brl'_res with result = this_branch_res @ brl'_res.result} -let is_res r = match DAst.get r with -| GVar id -> - begin try - String.equal (String.sub (Id.to_string id) 0 4) "_res" - with Invalid_argument _ -> false end -| _ -> false +let is_res r = + match DAst.get r with + | GVar id -> ( + try String.equal (String.sub (Id.to_string id) 0 4) "_res" + with Invalid_argument _ -> false ) + | _ -> false -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false +let is_gr c gr = + match DAst.get c with GRef (r, _) -> GlobRef.equal r gr | _ -> false -let is_gvar c = match DAst.get c with -| GVar id -> true -| _ -> false +let is_gvar c = match DAst.get c with GVar id -> true | _ -> false let same_raw_term rt1 rt2 = - match DAst.get rt1, DAst.get rt2 with - | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 - | GHole _, GHole _ -> true - | _ -> false + match (DAst.get rt1, DAst.get rt2) with + | GRef (r1, _), GRef (r2, _) -> GlobRef.equal r1 r2 + | GHole _, GHole _ -> true + | _ -> false + let decompose_raw_eq env lhs rhs = let rec decompose_raw_eq lhs rhs acc = - observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs); - let (rhd,lrhs) = glob_decompose_app rhs in - let (lhd,llhs) = glob_decompose_app lhs in + observe + ( str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " + ++ pr_glob_constr_env env rhs ); + let rhd, lrhs = glob_decompose_app rhs in + let lhd, llhs = glob_decompose_app lhs in observe (str "lhd := " ++ pr_glob_constr_env env lhd); observe (str "rhd := " ++ pr_glob_constr_env env rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); let sllhs = List.length llhs in let slrhs = List.length lrhs in - if same_raw_term lhd rhd && Int.equal sllhs slrhs - then + if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) - List.fold_right2 decompose_raw_eq llhs lrhs acc - else (lhs,rhs)::acc + List.fold_right2 decompose_raw_eq llhs lrhs acc + else (lhs, rhs) :: acc in decompose_raw_eq lhs rhs [] exception Continue + (* The second phase which reconstruct the real type of the constructor. rebuild the globalized constructors expression. @@ -925,304 +888,283 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let open Context.Rel.Declaration in let open CAst in match DAst.get rt with - | GProd(n,k,t,b) -> - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t::crossed_types in - begin - match DAst.get t with - | GApp(res_rt ,args') when is_res res_rt -> - begin - let arg = List.hd args' in - match DAst.get arg with - | GVar this_relname -> - (*i The next call to mk_rel_id is - valid since we are constructing the graph - Ensures by: obvious - i*) - - let new_t = - mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt]) - in - let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - mkGProd(n,new_t,new_b), - Id.Set.filter not_free_in_t id_to_exclude - | _ -> (* the first args is the name of the function! *) - assert false - end - | GApp(eq_as_ref,[ty; id ;rt]) - when is_gvar id && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> - let loc1 = rt.CAst.loc in - let loc2 = eq_as_ref.CAst.loc in - let loc3 = id.CAst.loc in - let id = match DAst.get id with GVar id -> id | _ -> assert false in - begin - try - observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); - let t' = - try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) - with e when CErrors.noncritical e -> raise Continue - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = List.map (replace_var_by_term id rt) args in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,t,new_b),id_to_exclude - with Continue -> - let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in - let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in - let ind,args' = Inductiveops.find_inductive env Evd.(from_env env) ty' in - let mib,_ = Global.lookup_inductive (fst ind) in - let nparam = mib.Declarations.mind_nparams in - let params,arg' = - ((Util.List.chop nparam args')) - in - let rt_typ = DAst.make @@ - GApp(DAst.make @@ GRef (GlobRef.IndRef (fst ind),None), - (List.map - (fun p -> Detyping.detype Detyping.Now false Id.Set.empty - env (Evd.from_env env) - (EConstr.of_constr p)) params)@(Array.to_list - (Array.make - (List.length args' - nparam) - (mkGHole ())))) - in - let eq' = - DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) - in - observe (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); - let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in - observe (str " computing new type for jmeq : done") ; - let sigma = Evd.(from_env env) in - let new_args = - match EConstr.kind sigma eq'_as_constr with - | App(_,[|_;_;ty;_|]) -> - let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in - let ty' = snd (Util.List.chop nparam ty) in - List.fold_left2 - (fun acc var_as_constr arg -> - if isRel var_as_constr - then - let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in - match na with - | Anonymous -> acc - | Name id' -> - (id',Detyping.detype Detyping.Now false Id.Set.empty - env - (Evd.from_env env) - arg)::acc - else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype Detyping.Now false Id.Set.empty - env - (Evd.from_env env) - arg)::acc - else acc - ) - [] - arg' - ty' - | _ -> assert false - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = - List.fold_left - (fun args (id,rt) -> - List.map (replace_var_by_term id rt) args - ) - args - ((id,rt)::new_args) - in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let new_env = - let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in - let r = Sorts.Relevant in (* TODO relevance *) - EConstr.push_rel (LocalAssum (make_annot n r,t')) env - in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,eq',new_b),id_to_exclude - end - (* J.F:. keep this comment it explain how to remove some meaningless equalities - if keep_eq then - mkGProd(n,t,new_b),id_to_exclude - else new_b, Id.Set.add id id_to_exclude - *) - | GApp(eq_as_ref,[ty;rt1;rt2]) - when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> - begin - try - let l = decompose_raw_eq env rt1 rt2 in - if List.length l > 1 - then - let new_rt = - List.fold_left - (fun acc (lhs,rhs) -> - mkGProd(Anonymous, - mkGApp(mkGRef Coqlib.(lib_ref "core.eq.type"),[mkGHole ();lhs;rhs]),acc) - ) - b - l - in - rebuild_cons env nb_args relname args crossed_types depth new_rt - else raise Continue - with Continue -> - observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end - | _ -> - observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end - | GLambda(n,k,t,b) -> - begin - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t :: crossed_types in - observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - match n with - | Name id -> - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - (args@[mkGVar id])new_crossed_types - (depth + 1 ) b - in - if Id.Set.mem id id_to_exclude && depth >= nb_args - then - new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - else - DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - | _ -> anomaly (Pp.str "Should not have an anonymous function here.") - (* We have renamed all the anonymous functions during alpha_renaming phase *) - - end - | GLetIn(n,v,t,b) -> - begin - let t = match t with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let not_free_in_t id = not (is_free_in id t) in - let evd = (Evd.from_env env) in - let t',ctx = Pretyping.understand env evd t in - let evd = Evd.from_ctx ctx in - let type_t' = Retyping.get_type_of env evd t' in - let t' = EConstr.Unsafe.to_constr t' in - let type_t' = EConstr.Unsafe.to_constr type_t' in - let new_env = Environ.push_rel (LocalDef (make_annot n Sorts.Relevant,t',type_t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1 ) b in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) - Id.Set.filter not_free_in_t id_to_exclude - end - | GLetTuple(nal,(na,rto),t,b) -> - assert (Option.is_empty rto); - begin - let not_free_in_t id = not (is_free_in id t) in - let new_t,id_to_exclude' = - rebuild_cons env - nb_args - relname - args (crossed_types) - depth t - in - let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let r = Sorts.Relevant in (* TODO relevance *) - let new_env = EConstr.push_rel (LocalAssum (make_annot na r,t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1) b + | GProd (n, k, t, b) -> ( + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in + match DAst.get t with + | GApp (res_rt, args') when is_res res_rt -> ( + let arg = List.hd args' in + match DAst.get arg with + | GVar this_relname -> + (*i The next call to mk_rel_id is + valid since we are constructing the graph + Ensures by: obvious + i*) + let new_t = + mkGApp (mkGVar (mk_rel_id this_relname), List.tl args' @ [res_rt]) + in + let t', ctx = Pretyping.understand env (Evd.from_env env) new_t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types + (depth + 1) b + in + (mkGProd (n, new_t, new_b), Id.Set.filter not_free_in_t id_to_exclude) + | _ -> + (* the first args is the name of the function! *) + assert false ) + | GApp (eq_as_ref, [ty; id; rt]) + when is_gvar id + && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") + && n == Anonymous -> ( + let loc1 = rt.CAst.loc in + let loc2 = eq_as_ref.CAst.loc in + let loc3 = id.CAst.loc in + let id = match DAst.get id with GVar id -> id | _ -> assert false in + try + observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); + let t' = + try fst (Pretyping.understand env (Evd.from_env env) t) (*FIXME*) + with e when CErrors.noncritical e -> raise Continue + in + let is_in_b = is_free_in id b in + let _keep_eq = + (not (List.exists (is_free_in id) args)) + || is_in_b + || List.exists (is_free_in id) crossed_types + in + let new_args = List.map (replace_var_by_term id rt) args in + let subst_b = if is_in_b then b else replace_var_by_term id rt b in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types + (depth + 1) subst_b + in + (mkGProd (n, t, new_b), id_to_exclude) + with Continue -> + let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in + let ty', ctx = Pretyping.understand env (Evd.from_env env) ty in + let ind, args' = + Inductiveops.find_inductive env Evd.(from_env env) ty' + in + let mib, _ = Global.lookup_inductive (fst ind) in + let nparam = mib.Declarations.mind_nparams in + let params, arg' = Util.List.chop nparam args' in + let rt_typ = + DAst.make + @@ GApp + ( DAst.make @@ GRef (GlobRef.IndRef (fst ind), None) + , List.map + (fun p -> + Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) (EConstr.of_constr p)) + params + @ Array.to_list + (Array.make (List.length args' - nparam) (mkGHole ())) ) + in + let eq' = + DAst.make ?loc:loc1 + @@ GApp + ( DAst.make ?loc:loc2 @@ GRef (jmeq, None) + , [ty; DAst.make ?loc:loc3 @@ GVar id; rt_typ; rt] ) + in + observe + (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); + let eq'_as_constr, ctx = + Pretyping.understand env (Evd.from_env env) eq' + in + observe (str " computing new type for jmeq : done"); + let sigma = Evd.(from_env env) in + let new_args = + match EConstr.kind sigma eq'_as_constr with + | App (_, [|_; _; ty; _|]) -> + let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in + let ty' = snd (Util.List.chop nparam ty) in + List.fold_left2 + (fun acc var_as_constr arg -> + if isRel var_as_constr then + let na = + RelDecl.get_name + (Environ.lookup_rel (destRel var_as_constr) env) + in + match na with + | Anonymous -> acc + | Name id' -> + ( id' + , Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) arg ) + :: acc + else if isVar var_as_constr then + ( destVar var_as_constr + , Detyping.detype Detyping.Now false Id.Set.empty env + (Evd.from_env env) arg ) + :: acc + else acc) + [] arg' ty' + | _ -> assert false + in + let is_in_b = is_free_in id b in + let _keep_eq = + (not (List.exists (is_free_in id) args)) + || is_in_b + || List.exists (is_free_in id) crossed_types + in + let new_args = + List.fold_left + (fun args (id, rt) -> List.map (replace_var_by_term id rt) args) + args ((id, rt) :: new_args) + in + let subst_b = if is_in_b then b else replace_var_by_term id rt b in + let new_env = + let t', ctx = Pretyping.understand env (Evd.from_env env) eq' in + let r = Sorts.Relevant in + (* TODO relevance *) + EConstr.push_rel (LocalAssum (make_annot n r, t')) env + in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types + (depth + 1) subst_b + in + (mkGProd (n, eq', new_b), id_to_exclude) + (* J.F:. keep this comment it explain how to remove some meaningless equalities + if keep_eq then + mkGProd(n,t,new_b),id_to_exclude + else new_b, Id.Set.add id id_to_exclude + *) ) + | GApp (eq_as_ref, [ty; rt1; rt2]) + when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous + -> ( + try + let l = decompose_raw_eq env rt1 rt2 in + if List.length l > 1 then + let new_rt = + List.fold_left + (fun acc (lhs, rhs) -> + mkGProd + ( Anonymous + , mkGApp + ( mkGRef Coqlib.(lib_ref "core.eq.type") + , [mkGHole (); lhs; rhs] ) + , acc )) + b l in -(* match n with *) -(* | Name id when Id.Set.mem id id_to_exclude -> *) -(* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) -(* | _ -> *) - DAst.make @@ GLetTuple(nal,(na,None),t,new_b), - Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') - - end - - | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty - + rebuild_cons env nb_args relname args crossed_types depth new_rt + else raise Continue + with Continue -> ( + observe + (str "computing new type for prod : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> (mkGProd (n, t, new_b), Id.Set.filter not_free_in_t id_to_exclude) ) + ) + | _ -> ( + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) + b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> (mkGProd (n, t, new_b), Id.Set.filter not_free_in_t id_to_exclude) + ) ) + | GLambda (n, k, t, b) -> ( + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in + observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); + let t', ctx = Pretyping.understand env (Evd.from_env env) t in + match n with + | Name id -> + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname + (args @ [mkGVar id]) + new_crossed_types (depth + 1) b + in + if Id.Set.mem id id_to_exclude && depth >= nb_args then + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + else + ( DAst.make @@ GProd (n, k, t, new_b) + , Id.Set.filter not_free_in_t id_to_exclude ) + | _ -> anomaly (Pp.str "Should not have an anonymous function here.") + (* We have renamed all the anonymous functions during alpha_renaming phase *) + ) + | GLetIn (n, v, t, b) -> ( + let t = + match t with + | None -> v + | Some t -> DAst.make ?loc:rt.loc @@ GCast (v, CastConv t) + in + let not_free_in_t id = not (is_free_in id t) in + let evd = Evd.from_env env in + let t', ctx = Pretyping.understand env evd t in + let evd = Evd.from_ctx ctx in + let type_t' = Retyping.get_type_of env evd t' in + let t' = EConstr.Unsafe.to_constr t' in + let type_t' = EConstr.Unsafe.to_constr type_t' in + let new_env = + Environ.push_rel (LocalDef (make_annot n Sorts.Relevant, t', type_t')) env + in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args (t :: crossed_types) (depth + 1) + b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + (new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)) + | _ -> + ( DAst.make @@ GLetIn (n, t, None, new_b) + , (* HOPING IT WOULD WORK *) + Id.Set.filter not_free_in_t id_to_exclude ) ) + | GLetTuple (nal, (na, rto), t, b) -> + assert (Option.is_empty rto); + let not_free_in_t id = not (is_free_in id t) in + let new_t, id_to_exclude' = + rebuild_cons env nb_args relname args crossed_types depth t + in + let t', ctx = Pretyping.understand env (Evd.from_env env) new_t in + let r = Sorts.Relevant in + (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot na r, t')) env in + let new_b, id_to_exclude = + rebuild_cons new_env nb_args relname args (t :: crossed_types) (depth + 1) + b + in + (* match n with *) + (* | Name id when Id.Set.mem id id_to_exclude -> *) + (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) + (* | _ -> *) + ( DAst.make @@ GLetTuple (nal, (na, None), t, new_b) + , Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') ) + | _ -> (mkGApp (mkGVar relname, args @ [rt]), Id.Set.empty) (* debugging wrapper *) let rebuild_cons env nb_args relname args crossed_types rt = -(* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) -(* str "nb_args := " ++ str (string_of_int nb_args)); *) - let res = - rebuild_cons env nb_args relname args crossed_types 0 rt - in -(* observe (str " leads to "++ pr_glob_constr (fst res)); *) + (* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) + (* str "nb_args := " ++ str (string_of_int nb_args)); *) + let res = rebuild_cons env nb_args relname args crossed_types 0 rt in + (* observe (str " leads to "++ pr_glob_constr (fst res)); *) res - (* naive implementation of parameter detection. A parameter is an argument which is only preceded by parameters and whose @@ -1230,92 +1172,103 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params gt = DAst.with_val (function - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ -> params - | GApp(f,args) -> - begin match DAst.get f with - | GVar relname' when Id.Set.mem relname' relnames -> - compute_cst_params_from_app [] (params,args) - | _ -> - List.fold_left (compute_cst_params relnames) params (f::args) - end - | GLambda(_,_,t,b) | GProd(_,_,t,b) | GLetTuple(_,_,t,b) -> - let t_params = compute_cst_params relnames params t in - compute_cst_params relnames t_params b - | GLetIn(_,v,t,b) -> - let v_params = compute_cst_params relnames params v in - let t_params = Option.fold_left (compute_cst_params relnames) v_params t in - compute_cst_params relnames t_params b - | GCases _ -> - params (* If there is still cases at this point they can only be - discrimination ones *) - | GSort _ -> params - | GHole _ -> params - | GIf _ | GRec _ | GCast _ -> - CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case") - ) gt -and compute_cst_params_from_app acc (params,rtl) = - let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in - match params,rtl with - | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,None) as param)::params', c::rtl' when is_gid id c -> - compute_cst_params_from_app (param::acc) (params',rtl') - | _ -> List.rev acc - -let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) csts = +let rec compute_cst_params relnames params gt = + DAst.with_val + (function + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ -> params + | GApp (f, args) -> ( + match DAst.get f with + | GVar relname' when Id.Set.mem relname' relnames -> + compute_cst_params_from_app [] (params, args) + | _ -> List.fold_left (compute_cst_params relnames) params (f :: args) ) + | GLambda (_, _, t, b) | GProd (_, _, t, b) | GLetTuple (_, _, t, b) -> + let t_params = compute_cst_params relnames params t in + compute_cst_params relnames t_params b + | GLetIn (_, v, t, b) -> + let v_params = compute_cst_params relnames params v in + let t_params = + Option.fold_left (compute_cst_params relnames) v_params t + in + compute_cst_params relnames t_params b + | GCases _ -> + params + (* If there is still cases at this point they can only be + discrimination ones *) + | GSort _ -> params + | GHole _ -> params + | GIf _ | GRec _ | GCast _ -> + CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case")) + gt + +and compute_cst_params_from_app acc (params, rtl) = + let is_gid id c = + match DAst.get c with GVar id' -> Id.equal id id' | _ -> false + in + match (params, rtl) with + | _ :: _, [] -> assert false (* the rel has at least nargs + 1 arguments ! *) + | ((Name id, _, None) as param) :: params', c :: rtl' when is_gid id c -> + compute_cst_params_from_app (param :: acc) (params', rtl') + | _ -> List.rev acc + +let compute_params_name relnames + (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) + csts = let rels_params = Array.mapi (fun i args -> - List.fold_left - (fun params (_,cst) -> compute_cst_params relnames params cst) - args - csts.(i) - ) + List.fold_left + (fun params (_, cst) -> compute_cst_params relnames params cst) + args csts.(i)) args in let l = ref [] in let _ = try List.iteri - (fun i ((n,nt,typ) as param) -> - if Array.for_all - (fun l -> - let (n',nt',typ') = List.nth l i in - Name.equal n n' && glob_constr_eq nt nt' && Option.equal glob_constr_eq typ typ') - rels_params - then - l := param::!l - ) + (fun i ((n, nt, typ) as param) -> + if + Array.for_all + (fun l -> + let n', nt', typ' = List.nth l i in + Name.equal n n' && glob_constr_eq nt nt' + && Option.equal glob_constr_eq typ typ') + rels_params + then l := param :: !l) rels_params.(0) - with e when CErrors.noncritical e -> - () + with e when CErrors.noncritical e -> () in List.rev !l let rec rebuild_return_type rt = let loc = rt.CAst.loc in match rt.CAst.v with - | Constrexpr.CProdN(n,t') -> - CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t') - | Constrexpr.CLetIn(na,v,t,t') -> - CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') - | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([CAst.make Anonymous], - Constrexpr.Default Explicit, rt)], - CAst.make @@ Constrexpr.CSort(UAnonymous {rigid=true})) - -let do_build_inductive - evd (funconstants: pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list) - returned_types - (rtl:glob_constr list) = + | Constrexpr.CProdN (n, t') -> + CAst.make ?loc @@ Constrexpr.CProdN (n, rebuild_return_type t') + | Constrexpr.CLetIn (na, v, t, t') -> + CAst.make ?loc @@ Constrexpr.CLetIn (na, v, t, rebuild_return_type t') + | _ -> + CAst.make ?loc + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ([CAst.make Anonymous], Constrexpr.Default Explicit, rt) ] + , CAst.make @@ Constrexpr.CSort (UAnonymous {rigid = true}) ) + +let do_build_inductive evd (funconstants : pconstant list) + (funsargs : (Name.t * glob_constr * glob_constr option) list list) + returned_types (rtl : glob_constr list) = let _time1 = System.get_time () in - let funnames = List.map (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) funconstants in + let funnames = + List.map + (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) + funconstants + in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in (* alpha_renaming of the body to prevent variable capture during manipulation *) - let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in + let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in let rta = Array.of_list rtl_alpha in (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious @@ -1324,46 +1277,64 @@ let do_build_inductive let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) let open Context.Named.Declaration in - let evd,env = + let evd, env = Array.fold_right2 - (fun id (c, u) (evd,env) -> - let u = EConstr.EInstance.make u in - let evd,t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in - let t = EConstr.Unsafe.to_constr t in - evd, - Environ.push_named (LocalAssum (make_annot id Sorts.Relevant,t)) - env - ) + (fun id (c, u) (evd, env) -> + let u = EConstr.EInstance.make u in + let evd, t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in + let t = EConstr.Unsafe.to_constr t in + ( evd + , Environ.push_named (LocalAssum (make_annot id Sorts.Relevant, t)) env + )) funnames (Array.of_list funconstants) - (evd,Global.env ()) + (evd, Global.env ()) in (* we solve and replace the implicits *) let rta = - Array.mapi (fun i rt -> - let _,t = Typing.type_of env evd (EConstr.of_constr (mkConstU ((Array.of_list funconstants).(i)))) in - resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env evd rt - ) rta + Array.mapi + (fun i rt -> + let _, t = + Typing.type_of env evd + (EConstr.of_constr (mkConstU (Array.of_list funconstants).(i))) + in + resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env + evd rt) + rta in let resa = Array.map (build_entry_lc env evd funnames_as_set []) rta in let env_with_graphs = - let rel_arity i funargs = (* Rebuilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = + let rel_arity i funargs = + (* Rebuilding arities (with parameters) *) + let rel_first_args : + (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list = funargs in List.fold_right - (fun (n,t,typ) acc -> + (fun (n, t, typ) acc -> match typ with | Some typ -> - CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) + CAst.make + @@ Constrexpr.CLetIn + ( CAst.make n + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) + , acc ) | None -> - CAst.make @@ Constrexpr.CProdN - ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) - ) + CAst.make + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t ) ] + , acc )) rel_first_args (rebuild_return_type returned_types.(i)) in @@ -1372,67 +1343,87 @@ let do_build_inductive Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - Util.Array.fold_left2 (fun env rel_name rel_ar -> - let rex = fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) in + Util.Array.fold_left2 + (fun env rel_name rel_ar -> + let rex = + fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) + in let rex = EConstr.Unsafe.to_constr rex in - let r = Sorts.Relevant in (* TODO relevance *) - Environ.push_named (LocalAssum (make_annot rel_name r,rex)) env) env relnames rel_arities + let r = Sorts.Relevant in + (* TODO relevance *) + Environ.push_named (LocalAssum (make_annot rel_name r, rex)) env) + env relnames rel_arities in (* and of the real constructors*) let constr i res = List.map - (function result (* (args',concl') *) -> - let rt = compose_glob_context result.context result.value in - let nb_args = List.length funsargs.(i) in - (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) - fst ( - rebuild_cons env_with_graphs nb_args relnames.(i) - [] - [] - rt - ) - ) + (function + | result (* (args',concl') *) -> + let rt = compose_glob_context result.context result.value in + let nb_args = List.length funsargs.(i) in + (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) + fst (rebuild_cons env_with_graphs nb_args relnames.(i) [] [] rt)) res.result in (* adding names to constructors *) - let next_constructor_id = ref (-1) in + let next_constructor_id = ref (-1) in let mk_constructor_id i = incr next_constructor_id; (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) - Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) + Id.of_string + ( Id.to_string (mk_rel_id funnames.(i)) + ^ "_" + ^ string_of_int !next_constructor_id ) in - let rel_constructors i rt : (Id.t*glob_constr) list = - next_constructor_id := (-1); - List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) + let rel_constructors i rt : (Id.t * glob_constr) list = + next_constructor_id := -1; + List.map (fun constr -> (mk_constructor_id i, constr)) (constr i rt) in let rel_constructors = Array.mapi rel_constructors resa in (* Computing the set of parameters if asked *) - let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in + let rels_params = + compute_params_name relnames_as_set funsargs rel_constructors + in let nrel_params = List.length rels_params in - let rel_constructors = (* Taking into account the parameters in constructors *) - Array.map (List.map - (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) - rel_constructors + let rel_constructors = + (* Taking into account the parameters in constructors *) + Array.map + (List.map (fun (id, rt) -> (id, snd (chop_rprod_n nrel_params rt)))) + rel_constructors in - let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = - (snd (List.chop nrel_params funargs)) + let rel_arity i funargs = + (* Reduilding arities (with parameters) *) + let rel_first_args : + (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list = + snd (List.chop nrel_params funargs) in List.fold_right - (fun (n,t,typ) acc -> - match typ with - | Some typ -> - CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) - | None -> - CAst.make @@ Constrexpr.CProdN - ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) - ) + (fun (n, t, typ) acc -> + match typ with + | Some typ -> + CAst.make + @@ Constrexpr.CLetIn + ( CAst.make n + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) + , acc ) + | None -> + CAst.make + @@ Constrexpr.CProdN + ( [ Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + t ) ] + , acc )) rel_first_args (rebuild_return_type returned_types.(i)) in @@ -1443,103 +1434,123 @@ let do_build_inductive let rel_arities = Array.mapi rel_arity funsargs in let rel_params_ids = List.fold_left - (fun acc (na,_,_) -> - match na with - Anonymous -> acc - | Name id -> id::acc - ) - [] - rels_params + (fun acc (na, _, _) -> + match na with Anonymous -> acc | Name id -> id :: acc) + [] rels_params in let rel_params = List.map - (fun (n,t,typ) -> - match typ with - | Some typ -> - Constrexpr.CLocalDef((CAst.make n), Constrextern.extern_glob_constr Id.Set.empty t, - Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ)) - | None -> - Constrexpr.CLocalAssum - ([(CAst.make n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) - ) + (fun (n, t, typ) -> + match typ with + | Some typ -> + Constrexpr.CLocalDef + ( CAst.make n + , Constrextern.extern_glob_constr Id.Set.empty t + , Some + (with_full_print + (Constrextern.extern_glob_constr Id.Set.empty) + typ) ) + | None -> + Constrexpr.CLocalAssum + ( [CAst.make n] + , Constrexpr_ops.default_binder_kind + , Constrextern.extern_glob_constr Id.Set.empty t )) rels_params in let ext_rels_constructors = - Array.map (List.map - (fun (id,t) -> - false,((CAst.make id), - with_full_print - (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) - ) - )) - (rel_constructors) + Array.map + (List.map (fun (id, t) -> + ( false + , ( CAst.make id + , with_full_print + (Constrextern.extern_glob_type Id.Set.empty) + ((* zeta_normalize *) alpha_rt rel_params_ids t) ) ))) + rel_constructors in let rel_ind i ext_rel_constructors = - ((CAst.make @@ relnames.(i)), - (rel_params,None), - Some rel_arities.(i), - ext_rel_constructors),[] + ( ( CAst.make @@ relnames.(i) + , (rel_params, None) + , Some rel_arities.(i) + , ext_rel_constructors ) + , [] ) in - let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in + let ext_rel_constructors = Array.mapi rel_ind ext_rels_constructors in let rel_inds = Array.to_list ext_rel_constructors in -(* let _ = *) -(* Pp.msgnl (\* observe *\) ( *) -(* str "Inductive" ++ spc () ++ *) -(* prlist_with_sep *) -(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) -(* (function ((_,id),_,params,ar,constr) -> *) -(* Ppconstr.pr_id id ++ spc () ++ *) -(* Ppconstr.pr_binders params ++ spc () ++ *) -(* str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) -(* prlist_with_sep *) -(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) -(* (function (_,((_,id),t)) -> *) -(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr t) *) -(* constr *) -(* ) *) -(* rel_inds *) -(* ) *) -(* in *) + (* let _ = *) + (* Pp.msgnl (\* observe *\) ( *) + (* str "Inductive" ++ spc () ++ *) + (* prlist_with_sep *) + (* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) + (* (function ((_,id),_,params,ar,constr) -> *) + (* Ppconstr.pr_id id ++ spc () ++ *) + (* Ppconstr.pr_binders params ++ spc () ++ *) + (* str ":" ++ spc () ++ *) + (* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) + (* prlist_with_sep *) + (* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) + (* (function (_,((_,id),t)) -> *) + (* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) + (* Ppconstr.pr_lconstr_expr t) *) + (* constr *) + (* ) *) + (* rel_inds *) + (* ) *) + (* in *) let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds ~cumulative:false ~poly:false ~private_ind:false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently + (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds + ~cumulative:false ~poly:false ~private_ind:false + ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with - | UserError(s,msg) as e -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) - ++ fnl () ++ - msg - in - observe (msg); - raise e - | reraise -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) - ++ fnl () ++ - CErrors.print reraise - in - observe msg; - raise reraise - - + | UserError (s, msg) as e -> + let _time3 = System.get_time () in + (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map + (fun ((a, b, c, l), ntn) -> + (((false, (a, None)), b, c, Vernacexpr.Constructors l), ntn)) + rel_inds + in + let msg = + str "while trying to define" + ++ spc () + ++ Ppvernac.pr_vernac + (CAst.make + Vernacexpr. + { control = [] + ; attrs = [] + ; expr = + VernacInductive (Vernacexpr.Inductive_kw, repacked_rel_inds) + }) + ++ fnl () ++ msg + in + observe msg; raise e + | reraise -> + let _time3 = System.get_time () in + (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map + (fun ((a, b, c, l), ntn) -> + (((false, (a, None)), b, c, Vernacexpr.Constructors l), ntn)) + rel_inds + in + let msg = + str "while trying to define" + ++ spc () + ++ Ppvernac.pr_vernac + ( CAst.make + @@ Vernacexpr. + { control = [] + ; attrs = [] + ; expr = + VernacInductive (Vernacexpr.Inductive_kw, repacked_rel_inds) + } ) + ++ fnl () ++ CErrors.print reraise + in + observe msg; raise reraise let build_inductive evd funconstants funsargs returned_types rtl = let pu = !Detyping.print_universes in diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index a29e5dff23..8dfeafe7c9 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -7,13 +7,15 @@ open Names *) val build_inductive : -(* (ModPath.t * DirPath.t) option -> - Id.t list -> (* The list of function name *) - *) - Evd.evar_map -> - Constr.pconstant list -> - (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list list -> (* The list of function args *) - Constrexpr.constr_expr list -> (* The list of function returned type *) - Glob_term.glob_constr list -> (* the list of body *) - unit - + (* (ModPath.t * DirPath.t) option -> + Id.t list -> (* The list of function name *) + *) + Evd.evar_map + -> Constr.pconstant list + -> (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list list + -> (* The list of function args *) + Constrexpr.constr_expr list + -> (* The list of function returned type *) + Glob_term.glob_constr list + -> (* the list of body *) + unit diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 9fa72919ce..5026120849 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -18,14 +18,17 @@ open Names Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) -let mkGRef ref = DAst.make @@ GRef(ref,None) -let mkGVar id = DAst.make @@ GVar(id) -let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) -let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) -let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) -let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) -let mkGCases(rto,l,brl) = DAst.make @@ GCases(RegularStyle,rto,l,brl) -let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) +let mkGRef ref = DAst.make @@ GRef (ref, None) +let mkGVar id = DAst.make @@ GVar id +let mkGApp (rt, rtl) = DAst.make @@ GApp (rt, rtl) +let mkGLambda (n, t, b) = DAst.make @@ GLambda (n, Explicit, t, b) +let mkGProd (n, t, b) = DAst.make @@ GProd (n, Explicit, t, b) +let mkGLetIn (n, b, t, c) = DAst.make @@ GLetIn (n, b, t, c) +let mkGCases (rto, l, brl) = DAst.make @@ GCases (RegularStyle, rto, l, brl) + +let mkGHole () = + DAst.make + @@ GHole (Evar_kinds.BinderType Anonymous, Namegen.IntroAnonymous, None) (* Some basic functions to decompose glob_constrs @@ -33,532 +36,483 @@ let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Nam *) let glob_decompose_app = let rec decompose_rapp acc rt = -(* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) + (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) match DAst.get rt with - | GApp(rt,rtl) -> - decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt - | _ -> rt,List.rev acc + | GApp (rt, rtl) -> + decompose_rapp (List.fold_left (fun y x -> x :: y) acc rtl) rt + | _ -> (rt, List.rev acc) in decompose_rapp [] - - - (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) -let glob_make_eq ?(typ= mkGHole ()) t1 t2 = - mkGApp(mkGRef (Coqlib.lib_ref "core.eq.type"),[typ;t2;t1]) +let glob_make_eq ?(typ = mkGHole ()) t1 t2 = + mkGApp (mkGRef (Coqlib.lib_ref "core.eq.type"), [typ; t2; t1]) (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) let glob_make_neq t1 t2 = - mkGApp(mkGRef (Coqlib.lib_ref "core.not.type"),[glob_make_eq t1 t2]) + mkGApp (mkGRef (Coqlib.lib_ref "core.not.type"), [glob_make_eq t1 t2]) let remove_name_from_mapping mapping na = - match na with - | Anonymous -> mapping - | Name id -> Id.Map.remove id mapping + match na with Anonymous -> mapping | Name id -> Id.Map.remove id mapping let change_vars = let rec change_vars mapping rt = - DAst.map_with_loc (fun ?loc -> function - | GRef _ as x -> x - | GVar id -> - let new_id = - try - Id.Map.find id mapping - with Not_found -> id + DAst.map_with_loc + (fun ?loc -> function GRef _ as x -> x + | GVar id -> + let new_id = try Id.Map.find id mapping with Not_found -> id in + GVar new_id | GEvar _ as x -> x | GPatVar _ as x -> x + | GApp (rt', rtl) -> + GApp (change_vars mapping rt', List.map (change_vars mapping) rtl) + | GLambda (name, k, t, b) -> + GLambda + ( name + , k + , change_vars mapping t + , change_vars (remove_name_from_mapping mapping name) b ) + | GProd (name, k, t, b) -> + GProd + ( name + , k + , change_vars mapping t + , change_vars (remove_name_from_mapping mapping name) b ) + | GLetIn (name, def, typ, b) -> + GLetIn + ( name + , change_vars mapping def + , Option.map (change_vars mapping) typ + , change_vars (remove_name_from_mapping mapping name) b ) + | GLetTuple (nal, (na, rto), b, e) -> + let new_mapping = + List.fold_left remove_name_from_mapping mapping nal in - GVar(new_id) - | GEvar _ as x -> x - | GPatVar _ as x -> x - | GApp(rt',rtl) -> - GApp(change_vars mapping rt', - List.map (change_vars mapping) rtl - ) - | GLambda(name,k,t,b) -> - GLambda(name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | GProd(name,k,t,b) -> - GProd( name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | GLetIn(name,def,typ,b) -> - GLetIn(name, - change_vars mapping def, - Option.map (change_vars mapping) typ, - change_vars (remove_name_from_mapping mapping name) b - ) - | GLetTuple(nal,(na,rto),b,e) -> - let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - GLetTuple(nal, - (na, Option.map (change_vars mapping) rto), - change_vars mapping b, - change_vars new_mapping e - ) - | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (change_vars mapping e,x)) el, - List.map (change_vars_br mapping) brl - ) - | GIf(b,(na,e_option),lhs,rhs) -> - GIf(change_vars mapping b, - (na,Option.map (change_vars mapping) e_option), - change_vars mapping lhs, - change_vars mapping rhs - ) - | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") - | GSort _ as x -> x - | GHole _ as x -> x - | GInt _ as x -> x - | GFloat _ as x -> x - | GCast(b,c) -> - GCast(change_vars mapping b, - Glob_ops.map_cast_type (change_vars mapping) c) - ) rt - and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = + GLetTuple + ( nal + , (na, Option.map (change_vars mapping) rto) + , change_vars mapping b + , change_vars new_mapping e ) + | GCases (sty, infos, el, brl) -> + GCases + ( sty + , infos + , List.map (fun (e, x) -> (change_vars mapping e, x)) el + , List.map (change_vars_br mapping) brl ) + | GIf (b, (na, e_option), lhs, rhs) -> + GIf + ( change_vars mapping b + , (na, Option.map (change_vars mapping) e_option) + , change_vars mapping lhs + , change_vars mapping rhs ) + | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") + | GSort _ as x -> x | GHole _ as x -> x | GInt _ as x -> x + | GFloat _ as x -> x + | GCast (b, c) -> + GCast + ( change_vars mapping b + , Glob_ops.map_cast_type (change_vars mapping) c )) + rt + and change_vars_br mapping ({CAst.loc; v = idl, patl, res} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in - if Id.Map.is_empty new_mapping - then br - else CAst.make ?loc (idl,patl,change_vars new_mapping res) + if Id.Map.is_empty new_mapping then br + else CAst.make ?loc (idl, patl, change_vars new_mapping res) in change_vars - - let rec alpha_pat excluded pat = let loc = pat.CAst.loc in match DAst.get pat with - | PatVar Anonymous -> - let new_id = Indfun_common.fresh_id excluded "_x" in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty - | PatVar(Name id) -> - if Id.List.mem id excluded - then - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), - (Id.Map.add id new_id Id.Map.empty) - else pat, excluded,Id.Map.empty - | PatCstr(constr,patl,na) -> - let new_na,new_excluded,map = - match na with - | Name id when Id.List.mem id excluded -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty - | _ -> na,excluded,Id.Map.empty - in - let new_patl,new_excluded,new_map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) - ) - ([],new_excluded,map) - patl - in - (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map - -let alpha_patl excluded patl = - let patl,new_excluded,map = + | PatVar Anonymous -> + let new_id = Indfun_common.fresh_id excluded "_x" in + (DAst.make ?loc @@ PatVar (Name new_id), new_id :: excluded, Id.Map.empty) + | PatVar (Name id) -> + if Id.List.mem id excluded then + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + ( DAst.make ?loc @@ PatVar (Name new_id) + , new_id :: excluded + , Id.Map.add id new_id Id.Map.empty ) + else (pat, excluded, Id.Map.empty) + | PatCstr (constr, patl, na) -> + let new_na, new_excluded, map = + match na with + | Name id when Id.List.mem id excluded -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + (Name new_id, new_id :: excluded, Id.Map.add id new_id Id.Map.empty) + | _ -> (na, excluded, Id.Map.empty) + in + let new_patl, new_excluded, new_map = + List.fold_left + (fun (patl, excluded, map) pat -> + let new_pat, new_excluded, new_map = alpha_pat excluded pat in + (new_pat :: patl, new_excluded, Id.Map.fold Id.Map.add new_map map)) + ([], new_excluded, map) patl + in + ( DAst.make ?loc @@ PatCstr (constr, List.rev new_patl, new_na) + , new_excluded + , new_map ) + +let alpha_patl excluded patl = + let patl, new_excluded, map = List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) - ) - ([],excluded,Id.Map.empty) + (fun (patl, excluded, map) pat -> + let new_pat, new_excluded, new_map = alpha_pat excluded pat in + (new_pat :: patl, new_excluded, Id.Map.fold Id.Map.add new_map map)) + ([], excluded, Id.Map.empty) patl in - (List.rev patl,new_excluded,map) - - - + (List.rev patl, new_excluded, map) let raw_get_pattern_id pat acc = let rec get_pattern_id pat = match DAst.get pat with - | PatVar(Anonymous) -> assert false - | PatVar(Name id) -> - [id] - | PatCstr(constr,patternl,_) -> - List.fold_right - (fun pat idl -> - let idl' = get_pattern_id pat in - idl'@idl - ) - patternl - [] + | PatVar Anonymous -> assert false + | PatVar (Name id) -> [id] + | PatCstr (constr, patternl, _) -> + List.fold_right + (fun pat idl -> + let idl' = get_pattern_id pat in + idl' @ idl) + patternl [] in - (get_pattern_id pat)@acc + get_pattern_id pat @ acc let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = let loc = rt.CAst.loc in - let new_rt = DAst.make ?loc @@ + let new_rt = + DAst.make ?loc + @@ match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt - | GLambda(Anonymous,k,t,b) -> - let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in - let new_excluded = new_id :: excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) - | GProd(Anonymous,k,t,b) -> - let new_t = alpha_rt excluded t in - let new_b = alpha_rt excluded b in - GProd(Anonymous,k,new_t,new_b) - | GLetIn(Anonymous,b,t,c) -> - let new_b = alpha_rt excluded b in - let new_t = Option.map (alpha_rt excluded) t in - let new_c = alpha_rt excluded c in - GLetIn(Anonymous,new_b,new_t,new_c) - | GLambda(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let t,b = - if Id.equal new_id id - then t, b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) - | GProd(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let new_excluded = new_id::excluded in - let t,b = - if Id.equal new_id id - then t,b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GProd(Name new_id,k,new_t,new_b) - | GLetIn(Name id,b,t,c) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let c = - if Id.equal new_id id then c - else change_vars (Id.Map.add id new_id Id.Map.empty) c - in - let new_excluded = new_id::excluded in - let new_b = alpha_rt new_excluded b in - let new_t = Option.map (alpha_rt new_excluded) t in - let new_c = alpha_rt new_excluded c in - GLetIn(Name new_id,new_b,new_t,new_c) - - | GLetTuple(nal,(na,rto),t,b) -> - let rev_new_nal,new_excluded,mapping = - List.fold_left - (fun (nal,excluded,mapping) na -> - match na with - | Anonymous -> (na::nal,excluded,mapping) - | Name id -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - if Id.equal new_id id - then - na::nal,id::excluded,mapping - else - (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) - ) - ([],excluded,Id.Map.empty) - nal - in - let new_nal = List.rev rev_new_nal in - let new_rto,new_t,new_b = - if Id.Map.is_empty mapping - then rto,t,b - else let replace = change_vars mapping in - (Option.map replace rto, t,replace b) - in - let new_t = alpha_rt new_excluded new_t in - let new_b = alpha_rt new_excluded new_b in - let new_rto = Option.map (alpha_rt new_excluded) new_rto in - GLetTuple(new_nal,(na,new_rto),new_t,new_b) - | GCases(sty,infos,el,brl) -> - let new_el = - List.map (function (rt,i) -> alpha_rt excluded rt, i) el - in - GCases(sty,infos,new_el,List.map (alpha_br excluded) brl) - | GIf(b,(na,e_o),lhs,rhs) -> - GIf(alpha_rt excluded b, - (na,Option.map (alpha_rt excluded) e_o), - alpha_rt excluded lhs, - alpha_rt excluded rhs - ) + | (GRef _ | GVar _ | GEvar _ | GPatVar _) as rt -> rt + | GLambda (Anonymous, k, t, b) -> + let new_id = + Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) + in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda (Name new_id, k, new_t, new_b) + | GProd (Anonymous, k, t, b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in + GProd (Anonymous, k, new_t, new_b) + | GLetIn (Anonymous, b, t, c) -> + let new_b = alpha_rt excluded b in + let new_t = Option.map (alpha_rt excluded) t in + let new_c = alpha_rt excluded c in + GLetIn (Anonymous, new_b, new_t, new_c) + | GLambda (Name id, k, t, b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let t, b = + if Id.equal new_id id then (t, b) + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t, replace b) + in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda (Name new_id, k, new_t, new_b) + | GProd (Name id, k, t, b) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let new_excluded = new_id :: excluded in + let t, b = + if Id.equal new_id id then (t, b) + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t, replace b) + in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GProd (Name new_id, k, new_t, new_b) + | GLetIn (Name id, b, t, c) -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let c = + if Id.equal new_id id then c + else change_vars (Id.Map.add id new_id Id.Map.empty) c + in + let new_excluded = new_id :: excluded in + let new_b = alpha_rt new_excluded b in + let new_t = Option.map (alpha_rt new_excluded) t in + let new_c = alpha_rt new_excluded c in + GLetIn (Name new_id, new_b, new_t, new_c) + | GLetTuple (nal, (na, rto), t, b) -> + let rev_new_nal, new_excluded, mapping = + List.fold_left + (fun (nal, excluded, mapping) na -> + match na with + | Anonymous -> (na :: nal, excluded, mapping) + | Name id -> + let new_id = + Namegen.next_ident_away id (Id.Set.of_list excluded) + in + if Id.equal new_id id then (na :: nal, id :: excluded, mapping) + else + ( Name new_id :: nal + , id :: excluded + , Id.Map.add id new_id mapping )) + ([], excluded, Id.Map.empty) + nal + in + let new_nal = List.rev rev_new_nal in + let new_rto, new_t, new_b = + if Id.Map.is_empty mapping then (rto, t, b) + else + let replace = change_vars mapping in + (Option.map replace rto, t, replace b) + in + let new_t = alpha_rt new_excluded new_t in + let new_b = alpha_rt new_excluded new_b in + let new_rto = Option.map (alpha_rt new_excluded) new_rto in + GLetTuple (new_nal, (na, new_rto), new_t, new_b) + | GCases (sty, infos, el, brl) -> + let new_el = + List.map (function rt, i -> (alpha_rt excluded rt, i)) el + in + GCases (sty, infos, new_el, List.map (alpha_br excluded) brl) + | GIf (b, (na, e_o), lhs, rhs) -> + GIf + ( alpha_rt excluded b + , (na, Option.map (alpha_rt excluded) e_o) + , alpha_rt excluded lhs + , alpha_rt excluded rhs ) | GRec _ -> user_err Pp.(str "Not handled GRec") - | GSort _ - | GInt _ - | GFloat _ - | GHole _ as rt -> rt - | GCast (b,c) -> - GCast(alpha_rt excluded b, - Glob_ops.map_cast_type (alpha_rt excluded) c) - | GApp(f,args) -> - GApp(alpha_rt excluded f, - List.map (alpha_rt excluded) args - ) + | (GSort _ | GInt _ | GFloat _ | GHole _) as rt -> rt + | GCast (b, c) -> + GCast (alpha_rt excluded b, Glob_ops.map_cast_type (alpha_rt excluded) c) + | GApp (f, args) -> + GApp (alpha_rt excluded f, List.map (alpha_rt excluded) args) in new_rt -and alpha_br excluded {CAst.loc;v=(ids,patl,res)} = - let new_patl,new_excluded,mapping = alpha_patl excluded patl in +and alpha_br excluded {CAst.loc; v = ids, patl, res} = + let new_patl, new_excluded, mapping = alpha_patl excluded patl in let new_ids = List.fold_right raw_get_pattern_id new_patl [] in - let new_excluded = new_ids@excluded in + let new_excluded = new_ids @ excluded in let renamed_res = change_vars mapping res in let new_res = alpha_rt new_excluded renamed_res in - CAst.make ?loc (new_ids,new_patl,new_res) + CAst.make ?loc (new_ids, new_patl, new_res) (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = - let rec is_free_in x = DAst.with_loc_val (fun ?loc -> function - | GRef _ -> false - | GVar id' -> Id.compare id' id == 0 - | GEvar _ -> false - | GPatVar _ -> false - | GApp(rt,rtl) -> List.exists is_free_in (rt::rtl) - | GLambda(n,_,t,b) | GProd(n,_,t,b) -> - let check_in_b = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in t || (check_in_b && is_free_in b) - | GLetIn(n,b,t,c) -> - let check_in_c = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c) - | GCases(_,_,el,brl) -> - (List.exists (fun (e,_) -> is_free_in e) el) || - List.exists is_free_in_br brl - | GLetTuple(nal,_,b,t) -> - let check_in_nal = - not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) - in - is_free_in t || (check_in_nal && is_free_in b) - - | GIf(cond,_,br1,br2) -> - is_free_in cond || is_free_in br1 || is_free_in br2 - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GSort _ -> false - | GHole _ -> false - | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t - | GCast (b,CastCoerce) -> is_free_in b - | GInt _ | GFloat _ -> false - ) x - and is_free_in_br {CAst.v=(ids,_,rt)} = + let rec is_free_in x = + DAst.with_loc_val + (fun ?loc -> function GRef _ -> false | GVar id' -> Id.compare id' id == 0 + | GEvar _ -> false | GPatVar _ -> false + | GApp (rt, rtl) -> List.exists is_free_in (rt :: rtl) + | GLambda (n, _, t, b) | GProd (n, _, t, b) -> + let check_in_b = + match n with Name id' -> not (Id.equal id' id) | _ -> true + in + is_free_in t || (check_in_b && is_free_in b) + | GLetIn (n, b, t, c) -> + let check_in_c = + match n with Name id' -> not (Id.equal id' id) | _ -> true + in + is_free_in b + || Option.cata is_free_in true t + || (check_in_c && is_free_in c) + | GCases (_, _, el, brl) -> + List.exists (fun (e, _) -> is_free_in e) el + || List.exists is_free_in_br brl + | GLetTuple (nal, _, b, t) -> + let check_in_nal = + not + (List.exists + (function Name id' -> Id.equal id' id | _ -> false) + nal) + in + is_free_in t || (check_in_nal && is_free_in b) + | GIf (cond, _, br1, br2) -> + is_free_in cond || is_free_in br1 || is_free_in br2 + | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ -> false + | GHole _ -> false + | GCast (b, (CastConv t | CastVM t | CastNative t)) -> + is_free_in b || is_free_in t | GCast (b, CastCoerce) -> is_free_in b + | GInt _ | GFloat _ -> false) + x + and is_free_in_br {CAst.v = ids, _, rt} = (not (Id.List.mem id ids)) && is_free_in rt in is_free_in - - -let rec pattern_to_term pt = DAst.with_val (function - | PatVar Anonymous -> assert false - | PatVar(Name id) -> - mkGVar id - | PatCstr(constr,patternl,_) -> - let cst_narg = - Inductiveops.constructor_nallargs - (Global.env ()) - constr - in - let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun _ -> mkGHole ()) - ) - in - let patl_as_term = - List.map pattern_to_term patternl - in - mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) - ) pt - +let rec pattern_to_term pt = + DAst.with_val + (function + | PatVar Anonymous -> assert false + | PatVar (Name id) -> mkGVar id + | PatCstr (constr, patternl, _) -> + let cst_narg = + Inductiveops.constructor_nallargs (Global.env ()) constr + in + let implicit_args = + Array.to_list + (Array.init (cst_narg - List.length patternl) (fun _ -> mkGHole ())) + in + let patl_as_term = List.map pattern_to_term patternl in + mkGApp + (mkGRef (GlobRef.ConstructRef constr), implicit_args @ patl_as_term)) + pt let replace_var_by_term x_id term = - let rec replace_var_by_pattern x = DAst.map (function - | GVar id when Id.compare id x_id == 0 -> DAst.get term - | GRef _ - | GVar _ - | GEvar _ - | GPatVar _ as rt -> rt - | GApp(rt',rtl) -> - GApp(replace_var_by_pattern rt', - List.map replace_var_by_pattern rtl - ) - | GLambda(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GLambda(name,k,t,b) -> - GLambda(name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | GProd(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GProd(name,k,t,b) -> - GProd( name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | GLetIn(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt - | GLetIn(name,def,typ,b) -> - GLetIn(name, - replace_var_by_pattern def, - Option.map (replace_var_by_pattern) typ, - replace_var_by_pattern b - ) - | GLetTuple(nal,_,_,_) as rt - when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> + let rec replace_var_by_pattern x = + DAst.map + (function + | GVar id when Id.compare id x_id == 0 -> DAst.get term + | (GRef _ | GVar _ | GEvar _ | GPatVar _) as rt -> rt + | GApp (rt', rtl) -> + GApp (replace_var_by_pattern rt', List.map replace_var_by_pattern rtl) + | GLambda (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GLambda (name, k, t, b) -> + GLambda (name, k, replace_var_by_pattern t, replace_var_by_pattern b) + | GProd (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GProd (name, k, t, b) -> + GProd (name, k, replace_var_by_pattern t, replace_var_by_pattern b) + | GLetIn (Name id, _, _, _) as rt when Id.compare id x_id == 0 -> rt + | GLetIn (name, def, typ, b) -> + GLetIn + ( name + , replace_var_by_pattern def + , Option.map replace_var_by_pattern typ + , replace_var_by_pattern b ) + | GLetTuple (nal, _, _, _) as rt + when List.exists + (function Name id -> Id.equal id x_id | _ -> false) + nal -> rt - | GLetTuple(nal,(na,rto),def,b) -> - GLetTuple(nal, - (na,Option.map replace_var_by_pattern rto), - replace_var_by_pattern def, - replace_var_by_pattern b - ) - | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, - List.map replace_var_by_pattern_br brl - ) - | GIf(b,(na,e_option),lhs,rhs) -> - GIf(replace_var_by_pattern b, - (na,Option.map replace_var_by_pattern e_option), - replace_var_by_pattern lhs, - replace_var_by_pattern rhs - ) - | GRec _ -> - CErrors.user_err (Pp.str "Not handled GRec") - | GSort _ - | GHole _ as rt -> rt - | GInt _ as rt -> rt - | GFloat _ as rt -> rt - | GCast(b,c) -> - GCast(replace_var_by_pattern b, - Glob_ops.map_cast_type replace_var_by_pattern c) - ) x - and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) = - if List.exists (fun id -> Id.compare id x_id == 0) idl - then br - else CAst.make ?loc (idl,patl,replace_var_by_pattern res) + | GLetTuple (nal, (na, rto), def, b) -> + GLetTuple + ( nal + , (na, Option.map replace_var_by_pattern rto) + , replace_var_by_pattern def + , replace_var_by_pattern b ) + | GCases (sty, infos, el, brl) -> + GCases + ( sty + , infos + , List.map (fun (e, x) -> (replace_var_by_pattern e, x)) el + , List.map replace_var_by_pattern_br brl ) + | GIf (b, (na, e_option), lhs, rhs) -> + GIf + ( replace_var_by_pattern b + , (na, Option.map replace_var_by_pattern e_option) + , replace_var_by_pattern lhs + , replace_var_by_pattern rhs ) + | GRec _ -> CErrors.user_err (Pp.str "Not handled GRec") + | (GSort _ | GHole _) as rt -> rt + | GInt _ as rt -> rt + | GFloat _ as rt -> rt + | GCast (b, c) -> + GCast + ( replace_var_by_pattern b + , Glob_ops.map_cast_type replace_var_by_pattern c )) + x + and replace_var_by_pattern_br ({CAst.loc; v = idl, patl, res} as br) = + if List.exists (fun id -> Id.compare id x_id == 0) idl then br + else CAst.make ?loc (idl, patl, replace_var_by_pattern res) in replace_var_by_pattern - - - (* checking unifiability of patterns *) exception NotUnifiable -let rec are_unifiable_aux = function +let rec are_unifiable_aux = function | [] -> () - | (l, r) ::eqs -> - match DAst.get l, DAst.get r with - | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") - in - are_unifiable_aux eqs' + | (l, r) :: eqs -> ( + match (DAst.get l, DAst.get r) with + | PatVar _, _ | _, PatVar _ -> are_unifiable_aux eqs + | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + else + let eqs' = + try List.combine cpl1 cpl2 @ eqs + with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") + in + are_unifiable_aux eqs' ) let are_unifiable pat1 pat2 = try - are_unifiable_aux [pat1,pat2]; + are_unifiable_aux [(pat1, pat2)]; true with NotUnifiable -> false - -let rec eq_cases_pattern_aux = function +let rec eq_cases_pattern_aux = function | [] -> () - | (l, r) ::eqs -> - match DAst.get l, DAst.get r with - | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") - in - eq_cases_pattern_aux eqs' - | _ -> raise NotUnifiable + | (l, r) :: eqs -> ( + match (DAst.get l, DAst.get r) with + | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> + if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + else + let eqs' = + try List.combine cpl1 cpl2 @ eqs + with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") + in + eq_cases_pattern_aux eqs' + | _ -> raise NotUnifiable ) let eq_cases_pattern pat1 pat2 = try - eq_cases_pattern_aux [pat1,pat2]; + eq_cases_pattern_aux [(pat1, pat2)]; true with NotUnifiable -> false - - let ids_of_pat = - let rec ids_of_pat ids = DAst.with_val (function - | PatVar Anonymous -> ids - | PatVar(Name id) -> Id.Set.add id ids - | PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl - ) + let rec ids_of_pat ids = + DAst.with_val (function + | PatVar Anonymous -> ids + | PatVar (Name id) -> Id.Set.add id ids + | PatCstr (_, patl, _) -> List.fold_left ids_of_pat ids patl) in ids_of_pat Id.Set.empty let expand_as = - let rec add_as map rt = match DAst.get rt with - | PatVar _ -> map - | PatCstr(_,patl,Name id) -> - Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) - | PatCstr(_,patl,_) -> List.fold_left add_as map patl + | PatVar _ -> map + | PatCstr (_, patl, Name id) -> + Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) + | PatCstr (_, patl, _) -> List.fold_left add_as map patl in - let rec expand_as map = DAst.map (function - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ as rt -> rt - | GVar id as rt -> - begin - try - DAst.get (Id.Map.find id map) - with Not_found -> rt - end - | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args) - | GLambda(na,k,t,b) -> GLambda(na,k,expand_as map t, expand_as map b) - | GProd(na,k,t,b) -> GProd(na,k,expand_as map t, expand_as map b) - | GLetIn(na,v,typ,b) -> GLetIn(na, expand_as map v,Option.map (expand_as map) typ,expand_as map b) - | GLetTuple(nal,(na,po),v,b) -> - GLetTuple(nal,(na,Option.map (expand_as map) po), - expand_as map v, expand_as map b) - | GIf(e,(na,po),br1,br2) -> - GIf(expand_as map e,(na,Option.map (expand_as map) po), - expand_as map br1, expand_as map br2) - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GCast(b,c) -> - GCast(expand_as map b, - Glob_ops.map_cast_type (expand_as map) c) - | GCases(sty,po,el,brl) -> - GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, - List.map (expand_as_br map) brl) - ) - and expand_as_br map {CAst.loc; v=(idl,cpl,rt)} = - CAst.make ?loc (idl,cpl, expand_as (List.fold_left add_as map cpl) rt) + let rec expand_as map = + DAst.map (function + | (GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _) + as rt -> + rt + | GVar id as rt -> ( + try DAst.get (Id.Map.find id map) with Not_found -> rt ) + | GApp (f, args) -> GApp (expand_as map f, List.map (expand_as map) args) + | GLambda (na, k, t, b) -> + GLambda (na, k, expand_as map t, expand_as map b) + | GProd (na, k, t, b) -> GProd (na, k, expand_as map t, expand_as map b) + | GLetIn (na, v, typ, b) -> + GLetIn + (na, expand_as map v, Option.map (expand_as map) typ, expand_as map b) + | GLetTuple (nal, (na, po), v, b) -> + GLetTuple + ( nal + , (na, Option.map (expand_as map) po) + , expand_as map v + , expand_as map b ) + | GIf (e, (na, po), br1, br2) -> + GIf + ( expand_as map e + , (na, Option.map (expand_as map) po) + , expand_as map br1 + , expand_as map br2 ) + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GCast (b, c) -> + GCast (expand_as map b, Glob_ops.map_cast_type (expand_as map) c) + | GCases (sty, po, el, brl) -> + GCases + ( sty + , Option.map (expand_as map) po + , List.map (fun (rt, t) -> (expand_as map rt, t)) el + , List.map (expand_as_br map) brl )) + and expand_as_br map {CAst.loc; v = idl, cpl, rt} = + CAst.make ?loc (idl, cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Id.Map.empty @@ -566,65 +520,75 @@ let expand_as = *) exception Found of Evd.evar_info -let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expected_type=Pretyping.WithoutTypeConstraint) env sigma rt = + +let resolve_and_replace_implicits ?(flags = Pretyping.all_and_fail_flags) + ?(expected_type = Pretyping.WithoutTypeConstraint) env sigma rt = let open Evd in let open Evar_kinds in (* we first (pseudo) understand [rt] and get back the computed evar_map *) (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. -If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) - let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in + If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) + let ctx, _, _ = + Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type + rt + in let ctx = Evd.minimize_universes ctx in - let f c = EConstr.of_constr (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) in - + let f c = + EConstr.of_constr + (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) + in (* then we map [rt] to replace the implicit holes by their values *) let rec change rt = match DAst.get rt with - | GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *) - ( - try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) - Evd.fold (* to simulate an iter *) - (fun _ evi _ -> - match evi.evar_source with - | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) -> - if GlobRef.equal grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi - then raise (Found evi) - | _ -> () - ) - ctx - (); - (* the hole was not solved : we do nothing *) - rt - with Found evi -> (* we found the evar corresponding to this hole *) - match evi.evar_body with - | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) - | Evar_empty -> rt (* the hole was not solved : we do nothing *) - ) - | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) - ( - let res = - try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) - Evd.fold (* to simulate an iter *) - (fun _ evi _ -> - match evi.evar_source with - | (loc_evi,BinderType na') -> - if Name.equal na na' && rt.CAst.loc = loc_evi then raise (Found evi) - | _ -> () - ) - ctx - (); - (* the hole was not solved : we do nothing *) - rt - with Found evi -> (* we found the evar corresponding to this hole *) - match evi.evar_body with - | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) - | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) - in - res - ) + | GHole (ImplicitArg (grk, pk, bk), _, _) -> ( + try + (* we only want to deal with implicit arguments *) + + (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | loc_evi, ImplicitArg (gr_evi, p_evi, b_evi) -> + if + GlobRef.equal grk gr_evi && pk = p_evi && bk = b_evi + && rt.CAst.loc = loc_evi + then raise (Found evi) + | _ -> ()) + ctx (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> ( + (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) + | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) ) + | GHole (BinderType na, _, _) -> + (* we only want to deal with implicit arguments *) + let res = + try + (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) + Evd.fold (* to simulate an iter *) + (fun _ evi _ -> + match evi.evar_source with + | loc_evi, BinderType na' -> + if Name.equal na na' && rt.CAst.loc = loc_evi then + raise (Found evi) + | _ -> ()) + ctx (); + (* the hole was not solved : we do nothing *) + rt + with Found evi -> ( + (* we found the evar corresponding to this hole *) + match evi.evar_body with + | Evar_defined c -> + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) + | Evar_empty -> rt ) + (* the hole was not solved : we d when falseo nothing *) + in + res | _ -> Glob_ops.map_glob_constr change rt in change rt diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index c55fdc017c..8eff7926da 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -25,33 +25,37 @@ val pattern_to_term : cases_pattern -> glob_constr *) val mkGRef : GlobRef.t -> glob_constr val mkGVar : Id.t -> glob_constr -val mkGApp : glob_constr*(glob_constr list) -> glob_constr +val mkGApp : glob_constr * glob_constr list -> glob_constr val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr -val mkGLetIn : Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr -val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr -val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) + +val mkGLetIn : + Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr + +val mkGCases : + glob_constr option * tomatch_tuples * cases_clauses -> glob_constr + +val mkGHole : unit -> glob_constr + +(* we only build Evd.BinderType Anonymous holes *) + (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) - +val glob_decompose_app : glob_constr -> glob_constr * glob_constr list (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) -val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr +val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr + (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) -val glob_make_neq : glob_constr -> glob_constr -> glob_constr +val glob_make_neq : glob_constr -> glob_constr -> glob_constr (* alpha_conversion functions *) - - (* Replace the var mapped in the glob_constr/context *) val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr - - (* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. the result does not share variables with [avoid]. This function create a fresh variable for each occurrence of the anonymous pattern. @@ -59,11 +63,10 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr Also returns a mapping from old variables to new ones and the concatenation of [avoid] with the variables appearing in the result. *) - val alpha_pat : - Id.Map.key list -> - Glob_term.cases_pattern -> - Glob_term.cases_pattern * Id.Map.key list * - Id.t Id.Map.t +val alpha_pat : + Id.Map.key list + -> Glob_term.cases_pattern + -> Glob_term.cases_pattern * Id.Map.key list * Id.t Id.Map.t (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result respects barendregt conventions and does not share bound variables with avoid @@ -71,38 +74,35 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr val alpha_rt : Id.t list -> glob_constr -> glob_constr (* same as alpha_rt but for case branches *) -val alpha_br : Id.t list -> - Glob_term.cases_clause -> - Glob_term.cases_clause +val alpha_br : Id.t list -> Glob_term.cases_clause -> Glob_term.cases_clause (* Reduction function *) -val replace_var_by_term : - Id.t -> - Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr - - +val replace_var_by_term : + Id.t + -> Glob_term.glob_constr + -> Glob_term.glob_constr + -> Glob_term.glob_constr (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) val is_free_in : Id.t -> glob_constr -> bool - - val are_unifiable : cases_pattern -> cases_pattern -> bool val eq_cases_pattern : cases_pattern -> cases_pattern -> bool - - (* ids_of_pat : cases_pattern -> Id.Set.t returns the set of variables appearing in a pattern *) -val ids_of_pat : cases_pattern -> Id.Set.t - +val ids_of_pat : cases_pattern -> Id.Set.t val expand_as : glob_constr -> glob_constr (* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution *) val resolve_and_replace_implicits : - ?flags:Pretyping.inference_flags -> - ?expected_type:Pretyping.typing_constraint -> Environ.env -> Evd.evar_map -> glob_constr -> glob_constr + ?flags:Pretyping.inference_flags + -> ?expected_type:Pretyping.typing_constraint + -> Environ.env + -> Evd.evar_map + -> glob_constr + -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 1f2f56ec34..4e0e2dc501 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -15,48 +15,49 @@ open Names open Sorts open Constr open EConstr - open Tacmach.New open Tacticals.New open Tactics - open Indfun_common - module RelDecl = Context.Rel.Declaration let is_rec_info sigma scheme_info = let test_branche min acc decl = - acc || ( - let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in - let free_rels_in_br = Termops.free_rels sigma new_branche in - let max = min + scheme_info.Tactics.npredicates in - Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br - ) + acc + || + let new_branche = + it_mkProd_or_LetIn mkProp + (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) + in + let free_rels_in_br = Termops.free_rels sigma new_branche in + let max = min + scheme_info.Tactics.npredicates in + Int.Set.exists (fun i -> i >= min && i < max) free_rels_in_br in List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) let choose_dest_or_ind scheme_info args = Proofview.tclBIND Proofview.tclEVARMAP (fun sigma -> - Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) + Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) let functional_induction with_clean c princl pat = let open Proofview.Notations in Proofview.Goal.enter_one (fun gl -> - let sigma = project gl in - let f,args = decompose_app sigma c in - match princl with - | None -> (* No principle is given let's find the good one *) - begin + let sigma = project gl in + let f, args = decompose_app sigma c in + match princl with + | None -> ( + (* No principle is given let's find the good one *) match EConstr.kind sigma f with - | Const (c',u) -> + | Const (c', u) -> let princ_option = - let finfo = (* we first try to find out a graph on f *) + let finfo = + (* we first try to find out a graph on f *) match find_Function_infos c' with | Some finfo -> finfo | None -> - user_err (str "Cannot find induction information on "++ - Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + user_err + ( str "Cannot find induction information on " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in match elimination_sort_of_goal gl with | InSProp -> finfo.sprop_lemma @@ -64,7 +65,8 @@ let functional_induction with_clean c princl pat = | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in - let sigma, princ = (* then we get the principle *) + let sigma, princ = + (* then we get the principle *) match princ_option with | Some princ -> Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) @@ -79,66 +81,74 @@ let functional_induction with_clean c princl pat = in let princ_ref = try - Constrintern.locate_reference (Libnames.qualid_of_ident princ_name) - with - | Not_found -> - user_err (str "Cannot find induction principle for " - ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + Constrintern.locate_reference + (Libnames.qualid_of_ident princ_name) + with Not_found -> + user_err + ( str "Cannot find induction principle for " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in Evd.fresh_global (pf_env gl) (project gl) princ_ref in let princt = Retyping.get_type_of (pf_env gl) sigma princ in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) + Proofview.Unsafe.tclEVARS sigma + <*> Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) | _ -> - CErrors.user_err (str "functional induction must be used with a function" ) - end - | Some ((princ,binding)) -> - let sigma, princt = pf_type_of gl princ in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclUNIT (princ, binding, princt, args) - ) >>= fun (princ, bindings, princ_type, args) -> + CErrors.user_err + (str "functional induction must be used with a function") ) + | Some (princ, binding) -> + let sigma, princt = pf_type_of gl princ in + Proofview.Unsafe.tclEVARS sigma + <*> Proofview.tclUNIT (princ, binding, princt, args)) + >>= fun (princ, bindings, princ_type, args) -> Proofview.Goal.enter (fun gl -> - let sigma = project gl in - let princ_infos = compute_elim_sig (project gl) princ_type in - let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] - in - if List.length args + List.length c_list = 0 - then user_err Pp.(str "Cannot recognize a valid functional scheme" ); - let encoded_pat_as_patlist = - List.make (List.length args + List.length c_list - 1) None @ [pat] - in - List.map2 - (fun c pat -> - ((None, ElimOnConstr (fun env sigma -> (sigma,(c,Tactypes.NoBindings)))), - (None,pat), None)) - (args@c_list) - encoded_pat_as_patlist - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) - args - Id.Set.empty - in - let old_idl = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in - let old_idl = Id.Set.diff old_idl princ_vars in - let subst_and_reduce gl = - if with_clean - then - let idl = List.filter (fun id -> not (Id.Set.mem id old_idl))(pf_ids_of_hyps gl) in - let flag = Genredexpr.Cbv { Redops.all_flags with Genredexpr.rDelta = false } in + let sigma = project gl in + let princ_infos = compute_elim_sig (project gl) princ_type in + let args_as_induction_constr = + let c_list = if princ_infos.Tactics.farg_in_concl then [c] else [] in + if List.length args + List.length c_list = 0 then + user_err Pp.(str "Cannot recognize a valid functional scheme"); + let encoded_pat_as_patlist = + List.make (List.length args + List.length c_list - 1) None @ [pat] + in + List.map2 + (fun c pat -> + ( ( None + , ElimOnConstr + (fun env sigma -> (sigma, (c, Tactypes.NoBindings))) ) + , (None, pat) + , None )) + (args @ c_list) encoded_pat_as_patlist + in + let princ' = Some (princ, bindings) in + let princ_vars = + List.fold_right + (fun a acc -> + try Id.Set.add (destVar sigma a) acc with DestKO -> acc) + args Id.Set.empty + in + let old_idl = + List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty + in + let old_idl = Id.Set.diff old_idl princ_vars in + let subst_and_reduce gl = + if with_clean then + let idl = + List.filter + (fun id -> not (Id.Set.mem id old_idl)) + (pf_ids_of_hyps gl) + in + let flag = + Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false} + in + tclTHEN + (tclMAP + (fun id -> + tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) + idl) + (reduce flag Locusops.allHypsAndConcl) + else tclIDTAC + in tclTHEN - (tclMAP (fun id -> tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl) - (reduce flag Locusops.allHypsAndConcl) - else tclIDTAC - in - tclTHEN - (choose_dest_or_ind - princ_infos - (args_as_induction_constr,princ')) - (Proofview.Goal.enter subst_and_reduce)) + (choose_dest_or_ind princ_infos (args_as_induction_constr, princ')) + (Proofview.Goal.enter subst_and_reduce)) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 4f3d4a1587..daabc4e7c6 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val functional_induction - : bool +val functional_induction : + bool -> EConstr.constr -> (EConstr.constr * EConstr.constr Tactypes.bindings) option -> Ltac_plugin.Tacexpr.or_and_intro_pattern option diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index ec23355ce1..e83fe56cc9 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -4,112 +4,96 @@ open Constr open Libnames open Refiner -let mk_prefix pre id = Id.of_string (pre^(Id.to_string id)) +let mk_prefix pre id = Id.of_string (pre ^ Id.to_string id) let mk_rel_id = mk_prefix "R_" let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" -let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) +let fresh_id avoid s = + Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) let fresh_name avoid s = Name (fresh_id avoid s) -let get_name avoid ?(default="H") = function +let get_name avoid ?(default = "H") = function | Anonymous -> fresh_name avoid default | Name n -> Name n -let array_get_start a = - Array.init - (Array.length a - 1) - (fun i -> a.(i)) - +let array_get_start a = Array.init (Array.length a - 1) (fun i -> a.(i)) let locate qid = Nametab.locate qid let locate_ind ref = - match locate ref with - | GlobRef.IndRef x -> x - | _ -> raise Not_found + match locate ref with GlobRef.IndRef x -> x | _ -> raise Not_found let locate_constant ref = - match locate ref with - | GlobRef.ConstRef x -> x - | _ -> raise Not_found - - -let locate_with_msg msg f x = - try f x - with - | Not_found -> - CErrors.user_err msg + match locate ref with GlobRef.ConstRef x -> x | _ -> raise Not_found +let locate_with_msg msg f x = try f x with Not_found -> CErrors.user_err msg let filter_map filter f = let rec it = function | [] -> [] - | e::l -> - if filter e - then - (f e) :: it l - else it l + | e :: l -> if filter e then f e :: it l else it l in it - -let chop_rlambda_n = +let chop_rlambda_n = let rec chop_lambda_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match DAst.get rt with - | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b - | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b - | _ -> - CErrors.user_err ~hdr:"chop_rlambda_n" (str "chop_rlambda_n: Not enough Lambdas") + if n == 0 then (List.rev acc, rt) + else + match DAst.get rt with + | Glob_term.GLambda (name, k, t, b) -> + chop_lambda_n ((name, t, None) :: acc) (n - 1) b + | Glob_term.GLetIn (name, v, t, b) -> + chop_lambda_n ((name, v, t) :: acc) (n - 1) b + | _ -> + CErrors.user_err ~hdr:"chop_rlambda_n" + (str "chop_rlambda_n: Not enough Lambdas") in chop_lambda_n [] -let chop_rprod_n = +let chop_rprod_n = let rec chop_prod_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match DAst.get rt with - | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> - CErrors.user_err ~hdr:"chop_rprod_n" (str "chop_rprod_n: Not enough products") + if n == 0 then (List.rev acc, rt) + else + match DAst.get rt with + | Glob_term.GProd (name, k, t, b) -> + chop_prod_n ((name, t) :: acc) (n - 1) b + | _ -> + CErrors.user_err ~hdr:"chop_rprod_n" + (str "chop_rprod_n: Not enough products") in chop_prod_n [] - - let list_union_eq eq_fun l1 l2 = let rec urec = function | [] -> l2 - | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l + | a :: l -> if List.exists (eq_fun a) l2 then urec l else a :: urec l in urec l1 -let list_add_set_eq eq_fun x l = - if List.exists (eq_fun x) l then l else x::l - -let coq_constant s = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s;; +let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x :: l +let coq_constant s = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in Nametab.locate (make_qualid dp (Id.of_string s)) -let eq = lazy(EConstr.of_constr (coq_constant "core.eq.type")) -let refl_equal = lazy(EConstr.of_constr (coq_constant "core.eq.refl")) +let eq = lazy (EConstr.of_constr (coq_constant "core.eq.type")) +let refl_equal = lazy (EConstr.of_constr (coq_constant "core.eq.refl")) let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () - and old_strict_implicit_args = Impargs.is_strict_implicit_args () + and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in let old_printuniverses = !Constrextern.print_universes in - let old_printallowmatchdefaultclause = Detyping.print_allow_match_default_clause () in + let old_printallowmatchdefaultclause = + Detyping.print_allow_match_default_clause () + in Constrextern.print_universes := true; - Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name false; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + false; Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; @@ -122,47 +106,41 @@ let with_full_print f a = Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Constrextern.print_universes := old_printuniverses; - Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name old_printallowmatchdefaultclause; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + old_printallowmatchdefaultclause; Dumpglob.continue (); res - with - | reraise -> - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Flags.raw_print := old_rawprint; - Constrextern.print_universes := old_printuniverses; - Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name old_printallowmatchdefaultclause; - Dumpglob.continue (); - raise reraise - - - - - + with reraise -> + Impargs.make_implicit_args old_implicit_args; + Impargs.make_strict_implicit_args old_strict_implicit_args; + Impargs.make_contextual_implicit_args old_contextual_implicit_args; + Flags.raw_print := old_rawprint; + Constrextern.print_universes := old_printuniverses; + Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name + old_printallowmatchdefaultclause; + Dumpglob.continue (); + raise reraise (**********************) type function_info = - { - function_constant : Constant.t; - graph_ind : inductive; - equation_lemma : Constant.t option; - correctness_lemma : Constant.t option; - completeness_lemma : Constant.t option; - rect_lemma : Constant.t option; - rec_lemma : Constant.t option; - prop_lemma : Constant.t option; - sprop_lemma : Constant.t option; - is_general : bool; (* Has this function been defined using general recursive definition *) - } - + { function_constant : Constant.t + ; graph_ind : inductive + ; equation_lemma : Constant.t option + ; correctness_lemma : Constant.t option + ; completeness_lemma : Constant.t option + ; rect_lemma : Constant.t option + ; rec_lemma : Constant.t option + ; prop_lemma : Constant.t option + ; sprop_lemma : Constant.t option + ; is_general : bool + (* Has this function been defined using general recursive definition *) + } (* type function_db = function_info list *) (* let function_table = ref ([] : function_db) *) - let from_function = Summary.ref Cmap_env.empty ~name:"functions_db_fn" let from_graph = Summary.ref Indmap.empty ~name:"functions_db_gr" @@ -187,91 +165,105 @@ let cache_Function (_,(finfos)) = then function_table := new_tbl *) -let cache_Function (_,finfos) = +let cache_Function (_, finfos) = from_function := Cmap_env.add finfos.function_constant finfos !from_function; from_graph := Indmap.add finfos.graph_ind finfos !from_graph - -let subst_Function (subst,finfos) = +let subst_Function (subst, finfos) = let do_subst_con c = Mod_subst.subst_constant subst c - and do_subst_ind i = Mod_subst.subst_ind subst i - in + and do_subst_ind i = Mod_subst.subst_ind subst i in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in let equation_lemma' = Option.Smart.map do_subst_con finfos.equation_lemma in - let correctness_lemma' = Option.Smart.map do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Option.Smart.map do_subst_con finfos.completeness_lemma in + let correctness_lemma' = + Option.Smart.map do_subst_con finfos.correctness_lemma + in + let completeness_lemma' = + Option.Smart.map do_subst_con finfos.completeness_lemma + in let rect_lemma' = Option.Smart.map do_subst_con finfos.rect_lemma in let rec_lemma' = Option.Smart.map do_subst_con finfos.rec_lemma in - let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in + let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in let sprop_lemma' = Option.Smart.map do_subst_con finfos.sprop_lemma in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && - equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma && - sprop_lemma' == finfos.sprop_lemma + if + function_constant' == finfos.function_constant + && graph_ind' == finfos.graph_ind + && equation_lemma' == finfos.equation_lemma + && correctness_lemma' == finfos.correctness_lemma + && completeness_lemma' == finfos.completeness_lemma + && rect_lemma' == finfos.rect_lemma + && rec_lemma' == finfos.rec_lemma + && prop_lemma' == finfos.prop_lemma + && sprop_lemma' == finfos.sprop_lemma then finfos else - { function_constant = function_constant'; - graph_ind = graph_ind'; - equation_lemma = equation_lemma' ; - correctness_lemma = correctness_lemma' ; - completeness_lemma = completeness_lemma' ; - rect_lemma = rect_lemma' ; - rec_lemma = rec_lemma'; - prop_lemma = prop_lemma'; - sprop_lemma = sprop_lemma'; - is_general = finfos.is_general - } - -let discharge_Function (_,finfos) = Some finfos + { function_constant = function_constant' + ; graph_ind = graph_ind' + ; equation_lemma = equation_lemma' + ; correctness_lemma = correctness_lemma' + ; completeness_lemma = completeness_lemma' + ; rect_lemma = rect_lemma' + ; rec_lemma = rec_lemma' + ; prop_lemma = prop_lemma' + ; sprop_lemma = sprop_lemma' + ; is_general = finfos.is_general } + +let discharge_Function (_, finfos) = Some finfos let pr_ocst env sigma c = - Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ()) + Option.fold_right + (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) + c (mt ()) let pr_info env sigma f_info = - str "function_constant := " ++ - Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++ - str "function_constant_type := " ++ - (try - Printer.pr_lconstr_env env sigma - (fst (Typeops.type_of_global_in_context env (GlobRef.ConstRef f_info.function_constant))) - with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ - str "equation_lemma := " ++ pr_ocst env sigma f_info.equation_lemma ++ fnl () ++ - str "completeness_lemma :=" ++ pr_ocst env sigma f_info.completeness_lemma ++ fnl () ++ - str "correctness_lemma := " ++ pr_ocst env sigma f_info.correctness_lemma ++ fnl () ++ - str "rect_lemma := " ++ pr_ocst env sigma f_info.rect_lemma ++ fnl () ++ - str "rec_lemma := " ++ pr_ocst env sigma f_info.rec_lemma ++ fnl () ++ - str "prop_lemma := " ++ pr_ocst env sigma f_info.prop_lemma ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl () + str "function_constant := " + ++ Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant) + ++ fnl () + ++ str "function_constant_type := " + ++ ( try + Printer.pr_lconstr_env env sigma + (fst + (Typeops.type_of_global_in_context env + (GlobRef.ConstRef f_info.function_constant))) + with e when CErrors.noncritical e -> mt () ) + ++ fnl () ++ str "equation_lemma := " + ++ pr_ocst env sigma f_info.equation_lemma + ++ fnl () + ++ str "completeness_lemma :=" + ++ pr_ocst env sigma f_info.completeness_lemma + ++ fnl () + ++ str "correctness_lemma := " + ++ pr_ocst env sigma f_info.correctness_lemma + ++ fnl () ++ str "rect_lemma := " + ++ pr_ocst env sigma f_info.rect_lemma + ++ fnl () ++ str "rec_lemma := " + ++ pr_ocst env sigma f_info.rec_lemma + ++ fnl () ++ str "prop_lemma := " + ++ pr_ocst env sigma f_info.prop_lemma + ++ fnl () ++ str "graph_ind := " + ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) + ++ fnl () let pr_table env sigma tb = - let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in + let l = Cmap_env.fold (fun k v acc -> v :: acc) tb [] in Pp.prlist_with_sep fnl (pr_info env sigma) l let in_Function : function_info -> Libobject.obj = let open Libobject in - declare_object @@ superglobal_object "FUNCTIONS_DB" - ~cache:cache_Function - ~subst:(Some subst_Function) - ~discharge:discharge_Function - + declare_object + @@ superglobal_object "FUNCTIONS_DB" ~cache:cache_Function + ~subst:(Some subst_Function) ~discharge:discharge_Function let find_or_none id = - try Some - (match Nametab.locate (qualid_of_ident id) with GlobRef.ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) + try + Some + ( match Nametab.locate (qualid_of_ident id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) with Not_found -> None -let find_Function_infos f = - Cmap_env.find_opt f !from_function - -let find_Function_of_graph ind = - Indmap.find_opt ind !from_graph +let find_Function_infos f = Cmap_env.find_opt f !from_function +let find_Function_of_graph ind = Indmap.find_opt ind !from_graph let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) @@ -287,113 +279,101 @@ let add_Function is_general f = and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") and sprop_lemma = find_or_none (Nameops.add_suffix f_id "_sind") and graph_ind = - match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) - with | GlobRef.IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") + match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) with + | GlobRef.IndRef ind -> ind + | _ -> CErrors.anomaly (Pp.str "Not an inductive.") in let finfos = - { function_constant = f; - equation_lemma = equation_lemma; - completeness_lemma = completeness_lemma; - correctness_lemma = correctness_lemma; - rect_lemma = rect_lemma; - rec_lemma = rec_lemma; - prop_lemma = prop_lemma; - sprop_lemma = sprop_lemma; - graph_ind = graph_ind; - is_general = is_general - - } + { function_constant = f + ; equation_lemma + ; completeness_lemma + ; correctness_lemma + ; rect_lemma + ; rec_lemma + ; prop_lemma + ; sprop_lemma + ; graph_ind + ; is_general } in update_Function finfos let pr_table env sigma = pr_table env sigma !from_function + (*********************************) (* Debugging *) let do_rewrite_dependent = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Functional";"Induction";"Rewrite";"Dependent"] + Goptions.declare_bool_option_and_ref ~depr:false + ~key:["Functional"; "Induction"; "Rewrite"; "Dependent"] ~value:true let do_observe = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Function_debug"] + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Function_debug"] ~value:false -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () - +let observe strm = if do_observe () then Feedback.msg_debug strm else () let debug_queue = Stack.create () let print_debug_queue b e = - if not (Stack.is_empty debug_queue) - then - let lmsg,goal = Stack.pop debug_queue in - (if b then - Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) - else - Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)) - (* print_debug_queue false e; *) - ) + if not (Stack.is_empty debug_queue) then + let lmsg, goal = Stack.pop debug_queue in + if b then + Feedback.msg_debug + (hov 1 + ( lmsg + ++ (str " raised exception " ++ CErrors.print e) + ++ str " on goal" ++ fnl () ++ goal )) + else + Feedback.msg_debug + (hov 1 (str " from " ++ lmsg ++ str " on goal" ++ fnl () ++ goal)) + +(* print_debug_queue false e; *) let do_observe_tac s tac g = let goal = Printer.pr_goal g in let s = s (pf_env g) (project g) in - let lmsg = (str "observation : ") ++ s in - Stack.push (lmsg,goal) debug_queue; + let lmsg = str "observation : " ++ s in + Stack.push (lmsg, goal) debug_queue; try let v = tac g in - ignore(Stack.pop debug_queue); + ignore (Stack.pop debug_queue); v with reraise -> let reraise = Exninfo.capture reraise in - if not (Stack.is_empty debug_queue) - then print_debug_queue true (fst reraise); + if not (Stack.is_empty debug_queue) then + print_debug_queue true (fst reraise); Exninfo.iraise reraise let observe_tac s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g + if do_observe () then do_observe_tac s tac g else tac g module New = struct - -let do_observe_tac ~header s tac = - let open Proofview.Notations in - let open Proofview in - Goal.enter begin fun gl -> - let goal = Printer.pr_goal (Goal.print gl) in - let env, sigma = Goal.env gl, Goal.sigma gl in - let s = s env sigma in - let lmsg = seq [header; str " : " ++ s] in - tclLIFT (NonLogical.make (fun () -> - Feedback.msg_debug (s++fnl()))) >>= fun () -> - tclOR ( - Stack.push (lmsg, goal) debug_queue; - tac >>= fun v -> - ignore(Stack.pop debug_queue); - Proofview.tclUNIT v) - (fun (exn, info) -> - if not (Stack.is_empty debug_queue) - then print_debug_queue true exn; - tclZERO ~info exn) - end - -let observe_tac ~header s tac = - if do_observe () - then do_observe_tac ~header s tac - else tac - + let do_observe_tac ~header s tac = + let open Proofview.Notations in + let open Proofview in + Goal.enter (fun gl -> + let goal = Printer.pr_goal (Goal.print gl) in + let env, sigma = (Goal.env gl, Goal.sigma gl) in + let s = s env sigma in + let lmsg = seq [header; str " : " ++ s] in + tclLIFT (NonLogical.make (fun () -> Feedback.msg_debug (s ++ fnl ()))) + >>= fun () -> + tclOR + ( Stack.push (lmsg, goal) debug_queue; + tac + >>= fun v -> + ignore (Stack.pop debug_queue); + Proofview.tclUNIT v ) + (fun (exn, info) -> + if not (Stack.is_empty debug_queue) then print_debug_queue true exn; + tclZERO ~info exn)) + + let observe_tac ~header s tac = + if do_observe () then do_observe_tac ~header s tac else tac end let is_strict_tcc = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Function_raw_tcc"] + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Function_raw_tcc"] ~value:false exception Building_graph of exn @@ -403,17 +383,15 @@ exception ToShow of exn let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr @@ - UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref "core.JMeq.type" + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.JMeq.type" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - EConstr.of_constr @@ - UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref "core.JMeq.refl" + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -421,49 +399,67 @@ let h_intros l = let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" -let well_founded = function () -> EConstr.of_constr (coq_constant "core.wf.well_founded") + +let well_founded = function + | () -> EConstr.of_constr (coq_constant "core.wf.well_founded") + let acc_rel = function () -> EConstr.of_constr (coq_constant "core.wf.acc") -let acc_inv_id = function () -> EConstr.of_constr (coq_constant "core.wf.acc_inv") -let well_founded_ltof () = EConstr.of_constr (coq_constant "num.nat.well_founded_ltof") +let acc_inv_id = function + | () -> EConstr.of_constr (coq_constant "core.wf.acc_inv") -let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") +let well_founded_ltof () = + EConstr.of_constr (coq_constant "num.nat.well_founded_ltof") + +let ltof_ref = function () -> find_reference ["Coq"; "Arith"; "Wf_nat"] "ltof" let make_eq () = - try EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) + try + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) with _ -> assert false -let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) +let evaluable_of_global_reference r = + (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with - GlobRef.ConstRef sp -> EvalConstRef sp - | GlobRef.VarRef id -> EvalVarRef id - | _ -> assert false;; + | GlobRef.ConstRef sp -> EvalConstRef sp + | GlobRef.VarRef id -> EvalVarRef id + | _ -> assert false -let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) = +let list_rewrite (rev : bool) (eqs : (EConstr.constr * bool) list) = tclREPEAT (List.fold_right - (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) - (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; + (fun (eq, b) i -> + tclORELSE + (Proofview.V82.of_tactic + ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) + i) + (if rev then List.rev eqs else eqs) + (tclFAIL 0 (mt ()))) let decompose_lam_n sigma n = - if n < 0 then CErrors.user_err Pp.(str "decompose_lam_n: integer parameter must be positive"); + if n < 0 then + CErrors.user_err + Pp.(str "decompose_lam_n: integer parameter must be positive"); let rec lamdec_rec l n c = - if Int.equal n 0 then l,c - else match EConstr.kind sigma c with - | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c - | Cast (c,_,_) -> lamdec_rec l n c - | _ -> CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") + if Int.equal n 0 then (l, c) + else + match EConstr.kind sigma c with + | Lambda (x, t, c) -> lamdec_rec ((x, t) :: l) (n - 1) c + | Cast (c, _, _) -> lamdec_rec l n c + | _ -> + CErrors.user_err Pp.(str "decompose_lam_n: not enough abstractions") in lamdec_rec [] n let lamn n env b = let open EConstr in let rec lamrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) + | 0, env, b -> b + | n, (v, t) :: l, b -> lamrec (n - 1, l, mkLambda (v, t, b)) | _ -> assert false in - lamrec (n,env,b) + lamrec (n, env, b) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) let compose_lam l b = lamn (List.length l) l b @@ -472,19 +468,16 @@ let compose_lam l b = lamn (List.length l) l b let prodn n env b = let open EConstr in let rec prodrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | 0, env, b -> b + | n, (v, t) :: l, b -> prodrec (n - 1, l, mkProd (v, t, b)) | _ -> assert false in - prodrec (n,env,b) + prodrec (n, env, b) (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) let compose_prod l b = prodn (List.length l) l b -type tcc_lemma_value = - | Undefined - | Value of constr - | Not_needed +type tcc_lemma_value = Undefined | Value of constr | Not_needed (* We only "purify" on exceptions. XXX: What is this doing here? *) let funind_purify f x = @@ -497,4 +490,4 @@ let funind_purify f x = let tac_type_of g c = let sigma, t = Tacmach.pf_type_of g c in - {g with Evd.sigma}, t + ({g with Evd.sigma}, t) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index bd8b34088b..396db55458 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -8,30 +8,27 @@ val mk_rel_id : Id.t -> Id.t val mk_correct_id : Id.t -> Id.t val mk_complete_id : Id.t -> Id.t val mk_equation_id : Id.t -> Id.t - val fresh_id : Id.t list -> string -> Id.t val fresh_name : Id.t list -> string -> Name.t val get_name : Id.t list -> ?default:string -> Name.t -> Name.t - val array_get_start : 'a array -> 'a array - val locate_ind : Libnames.qualid -> inductive val locate_constant : Libnames.qualid -> Constant.t -val locate_with_msg : - Pp.t -> (Libnames.qualid -> 'a) -> - Libnames.qualid -> 'a - +val locate_with_msg : Pp.t -> (Libnames.qualid -> 'a) -> Libnames.qualid -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list -val list_union_eq : - ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list -val list_add_set_eq : - ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list +val list_union_eq : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list -val chop_rlambda_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list * Glob_term.glob_constr +val chop_rlambda_n : + int + -> Glob_term.glob_constr + -> (Name.t * Glob_term.glob_constr * Glob_term.glob_constr option) list + * Glob_term.glob_constr -val chop_rprod_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr +val chop_rprod_n : + int + -> Glob_term.glob_constr + -> (Name.t * Glob_term.glob_constr) list * Glob_term.glob_constr val eq : EConstr.constr Lazy.t val refl_equal : EConstr.constr Lazy.t @@ -45,44 +42,41 @@ val make_eq : unit -> EConstr.constr *) val with_full_print : ('a -> 'b) -> 'a -> 'b - (*****************) type function_info = - { - function_constant : Constant.t; - graph_ind : inductive; - equation_lemma : Constant.t option; - correctness_lemma : Constant.t option; - completeness_lemma : Constant.t option; - rect_lemma : Constant.t option; - rec_lemma : Constant.t option; - prop_lemma : Constant.t option; - sprop_lemma : Constant.t option; - is_general : bool; - } + { function_constant : Constant.t + ; graph_ind : inductive + ; equation_lemma : Constant.t option + ; correctness_lemma : Constant.t option + ; completeness_lemma : Constant.t option + ; rect_lemma : Constant.t option + ; rec_lemma : Constant.t option + ; prop_lemma : Constant.t option + ; sprop_lemma : Constant.t option + ; is_general : bool } val find_Function_infos : Constant.t -> function_info option val find_Function_of_graph : inductive -> function_info option + (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> Constant.t -> unit val update_Function : function_info -> unit (** debugging *) val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t + val pr_table : Environ.env -> Evd.evar_map -> Pp.t -val observe_tac - : (Environ.env -> Evd.evar_map -> Pp.t) - -> Tacmach.tactic -> Tacmach.tactic +val observe_tac : + (Environ.env -> Evd.evar_map -> Pp.t) -> Tacmach.tactic -> Tacmach.tactic module New : sig - - val observe_tac - : header:Pp.t + val observe_tac : + header:Pp.t -> (Environ.env -> Evd.evar_map -> Pp.t) - -> unit Proofview.tactic -> unit Proofview.tactic - + -> unit Proofview.tactic + -> unit Proofview.tactic end (* val function_debug : bool ref *) @@ -96,28 +90,35 @@ exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool - -val h_intros: Names.Id.t list -> Tacmach.tactic -val h_id : Names.Id.t -val hrec_id : Names.Id.t -val acc_inv_id : EConstr.constr Util.delayed +val h_intros : Names.Id.t list -> Tacmach.tactic +val h_id : Names.Id.t +val hrec_id : Names.Id.t +val acc_inv_id : EConstr.constr Util.delayed val ltof_ref : GlobRef.t Util.delayed val well_founded_ltof : EConstr.constr Util.delayed val acc_rel : EConstr.constr Util.delayed val well_founded : EConstr.constr Util.delayed -val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference -val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic -val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> - (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t -val compose_lam : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t -val compose_prod : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t +val evaluable_of_global_reference : + GlobRef.t -> Names.evaluable_global_reference + +val list_rewrite : bool -> (EConstr.constr * bool) list -> Tacmach.tactic + +val decompose_lam_n : + Evd.evar_map + -> int + -> EConstr.t + -> (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t + +val compose_lam : + (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t + +val compose_prod : + (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t -type tcc_lemma_value = - | Undefined - | Value of Constr.t - | Not_needed +type tcc_lemma_value = Undefined | Value of Constr.t | Not_needed -val funind_purify : ('a -> 'b) -> ('a -> 'b) +val funind_purify : ('a -> 'b) -> 'a -> 'b -val tac_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types +val tac_type_of : + Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 44d2cb4a3d..5d631aac84 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -15,7 +15,6 @@ open EConstr open Tacmach.New open Tactics open Tacticals.New - open Indfun_common (***********************************************) @@ -26,36 +25,40 @@ open Indfun_common if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) -let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> - let sigma = project gl in - let typ = pf_get_hyp_typ hid gl in - match EConstr.kind sigma typ with - | App(i,args) when isInd sigma i -> - let ((kn',num) as ind'),u = destInd sigma i in - if MutInd.equal kn kn' - then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = match find_Function_of_graph ind' with - | Some info -> info - | None -> - (* The graphs are mutually recursive but we cannot find one of them !*) - CErrors.anomaly (Pp.str "Cannot retrieve infos about a mutual block.") - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing - *) - match info.completeness_lemma with - | None -> tclIDTAC - | Some f_complete -> - let f_args,res = Array.chop (Array.length args - 1) args in - tclTHENLIST - [ generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])] - ; clear [hid] - ; Simple.intro hid - ; post_tac hid - ] - else tclIDTAC - | _ -> tclIDTAC - ) +let revert_graph kn post_tac hid = + Proofview.Goal.enter (fun gl -> + let sigma = project gl in + let typ = pf_get_hyp_typ hid gl in + match EConstr.kind sigma typ with + | App (i, args) when isInd sigma i -> + let ((kn', num) as ind'), u = destInd sigma i in + if MutInd.equal kn kn' then + (* We have generated a graph hypothesis so that we must change it if we can *) + let info = + match find_Function_of_graph ind' with + | Some info -> info + | None -> + (* The graphs are mutually recursive but we cannot find one of them !*) + CErrors.anomaly + (Pp.str "Cannot retrieve infos about a mutual block.") + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing + *) + match info.completeness_lemma with + | None -> tclIDTAC + | Some f_complete -> + let f_args, res = Array.chop (Array.length args - 1) args in + tclTHENLIST + [ generalize + [ applist + ( mkConst f_complete + , Array.to_list f_args @ [res.(0); mkVar hid] ) ] + ; clear [hid] + ; Simple.intro hid + ; post_tac hid ] + else tclIDTAC + | _ -> tclIDTAC) (* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] @@ -74,52 +77,55 @@ let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> \end{enumerate} *) -let functional_inversion kn hid fconst f_correct = Proofview.Goal.enter (fun gl -> - let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in - let sigma = project gl in - let type_of_h = pf_get_hyp_typ hid gl in - match EConstr.kind sigma type_of_h with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - let pre_tac,f_args,res = - match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with - | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> - ((fun hid -> intros_symmetry (Locusops.onHyp hid))),f_args,args.(2) - |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) - | _ -> (fun hid -> tclFAIL 1 Pp.(mt ())),[||],args.(2) - in - tclTHENLIST - [ pre_tac hid - ; generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])] - ; clear [hid] - ; Simple.intro hid - ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) - ; Proofview.Goal.enter (fun gl -> - let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps gl) in - tclMAP (revert_graph kn pre_tac) (hid::new_ids) - ) - ] - | _ -> tclFAIL 1 Pp.(mt ()) - ) +let functional_inversion kn hid fconst f_correct = + Proofview.Goal.enter (fun gl -> + let old_ids = + List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty + in + let sigma = project gl in + let type_of_h = pf_get_hyp_typ hid gl in + match EConstr.kind sigma type_of_h with + | App (eq, args) when EConstr.eq_constr sigma eq (make_eq ()) -> + let pre_tac, f_args, res = + match (EConstr.kind sigma args.(1), EConstr.kind sigma args.(2)) with + | App (f, f_args), _ when EConstr.eq_constr sigma f fconst -> + ((fun hid -> intros_symmetry (Locusops.onHyp hid)), f_args, args.(2)) + | _, App (f, f_args) when EConstr.eq_constr sigma f fconst -> + ((fun hid -> tclIDTAC), f_args, args.(1)) + | _ -> ((fun hid -> tclFAIL 1 Pp.(mt ())), [||], args.(2)) + in + tclTHENLIST + [ pre_tac hid + ; generalize + [applist (f_correct, Array.to_list f_args @ [res; mkVar hid])] + ; clear [hid] + ; Simple.intro hid + ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) + ; Proofview.Goal.enter (fun gl -> + let new_ids = + List.filter + (fun id -> not (Id.Set.mem id old_ids)) + (pf_ids_of_hyps gl) + in + tclMAP (revert_graph kn pre_tac) (hid :: new_ids)) ] + | _ -> tclFAIL 1 Pp.(mt ())) -let invfun qhyp f = +let invfun qhyp f = let f = match f with | GlobRef.ConstRef f -> f - | _ -> - CErrors.user_err Pp.(str "Not a function") + | _ -> CErrors.user_err Pp.(str "Not a function") in match find_Function_infos f with - | None -> - CErrors.user_err (Pp.str "No graph found") - | Some finfos -> + | None -> CErrors.user_err (Pp.str "No graph found") + | Some finfos -> ( match finfos.correctness_lemma with - | None -> - CErrors.user_err (Pp.str "Cannot use equivalence with graph!") + | None -> CErrors.user_err (Pp.str "Cannot use equivalence with graph!") | Some f_correct -> - let f_correct = mkConst f_correct - and kn = fst finfos.graph_ind in - Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + let f_correct = mkConst f_correct and kn = fst finfos.graph_ind in + Tactics.try_intros_until + (fun hid -> functional_inversion kn hid (mkConst f) f_correct) + qhyp ) let invfun qhyp f = let exception NoFunction in @@ -128,41 +134,55 @@ let invfun qhyp f = | None -> let tac_action hid gl = let sigma = project gl in - let hyp_typ = pf_get_hyp_typ hid gl in + let hyp_typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma hyp_typ with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - begin - let f1,_ = decompose_app sigma args.(1) in - try - if not (isConst sigma f1) then raise NoFunction; - let finfos = Option.get (find_Function_infos (fst (destConst sigma f1))) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f1 f_correct - with - | NoFunction | Option.IsNone -> - let f2,_ = decompose_app sigma args.(2) in - if isConst sigma f2 then - match find_Function_infos (fst (destConst sigma f2)) with + | App (eq, args) when EConstr.eq_constr sigma eq (make_eq ()) -> ( + let f1, _ = decompose_app sigma args.(1) in + try + if not (isConst sigma f1) then raise NoFunction; + let finfos = + Option.get (find_Function_infos (fst (destConst sigma f1))) + in + let f_correct = mkConst (Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind in + functional_inversion kn hid f1 f_correct + with NoFunction | Option.IsNone -> + let f2, _ = decompose_app sigma args.(2) in + if isConst sigma f2 then + match find_Function_infos (fst (destConst sigma f2)) with + | None -> + if do_observe () then + CErrors.user_err + (Pp.str "No graph found for any side of equality") + else + CErrors.user_err + Pp.( + str "Cannot find inversion information for hypothesis " + ++ Ppconstr.pr_id hid) + | Some finfos -> ( + match finfos.correctness_lemma with | None -> - if do_observe () - then CErrors.user_err (Pp.str "No graph found for any side of equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Some finfos -> - match finfos.correctness_lemma with - | None -> - if do_observe () - then CErrors.user_err (Pp.str "Cannot use equivalence with graph for any side of the equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Some f_correct -> - let f_correct = mkConst f_correct - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f2 f_correct - else (* NoFunction *) - CErrors.user_err Pp.(str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") - end - | _ -> CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") + if do_observe () then + CErrors.user_err + (Pp.str + "Cannot use equivalence with graph for any side of the \ + equality") + else + CErrors.user_err + Pp.( + str "Cannot find inversion information for hypothesis " + ++ Ppconstr.pr_id hid) + | Some f_correct -> + let f_correct = mkConst f_correct + and kn = fst finfos.graph_ind in + functional_inversion kn hid f2 f_correct ) + else + (* NoFunction *) + CErrors.user_err + Pp.( + str "Hypothesis " ++ Ppconstr.pr_id hid + ++ str " must contain at least one Function") ) + | _ -> + CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") in try_intros_until (tac_action %> Proofview.Goal.enter) qhyp diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli index 41dbe1437c..a117df32df 100644 --- a/plugins/funind/invfun.mli +++ b/plugins/funind/invfun.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val invfun - : Tactypes.quantified_hypothesis +val invfun : + Tactypes.quantified_hypothesis -> Names.GlobRef.t option -> unit Proofview.tactic diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 19a762d33d..ffb9a7e69b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -8,9 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) - module CVars = Vars - open Constr open Context open EConstr @@ -29,7 +27,6 @@ open Tacticals open Tacmach open Tactics open Nametab -open Declare open Tacred open Glob_term open Pretyping @@ -37,58 +34,58 @@ open Termops open Constrintern open Tactypes open Genredexpr - open Equality open Auto open Eauto - open Indfun_common open Context.Rel.Declaration (* Ugly things which should not be here *) -let coq_constant s = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ - Coqlib.lib_ref s +let coq_constant s = + EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s let coq_init_constant s = - EConstr.of_constr(UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s) -;; + EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s) let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in locate (make_qualid dp (Id.of_string s)) let declare_fun name kind ?univs value = - let ce = definition_entry ?univs value (*FIXME *) in - GlobRef.ConstRef(declare_constant ~name ~kind (DefinitionEntry ce)) + let ce = Declare.definition_entry ?univs value (*FIXME *) in + GlobRef.ConstRef + (Declare.declare_constant ~name ~kind (Declare.DefinitionEntry ce)) let defined lemma = - Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None + Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Transparent ~idopt:None let def_of_const t = - match (Constr.kind t) with - Const sp -> - (try (match constant_opt_value_in (Global.env ()) sp with - | Some c -> c - | _ -> raise Not_found) - with Not_found -> - anomaly (str "Cannot find definition of constant " ++ - (Id.print (Label.to_id (Constant.label (fst sp)))) ++ str ".") - ) - |_ -> assert false + match Constr.kind t with + | Const sp -> ( + try + match constant_opt_value_in (Global.env ()) sp with + | Some c -> c + | _ -> raise Not_found + with Not_found -> + anomaly + ( str "Cannot find definition of constant " + ++ Id.print (Label.to_id (Constant.label (fst sp))) + ++ str "." ) ) + | _ -> assert false let type_of_const sigma t = - match (EConstr.kind sigma t) with - | Const (sp, u) -> - let u = EInstance.kind sigma u in - (* FIXME discarding universe constraints *) - Typeops.type_of_constant_in (Global.env()) (sp, u) - |_ -> assert false + match EConstr.kind sigma t with + | Const (sp, u) -> + let u = EInstance.kind sigma u in + (* FIXME discarding universe constraints *) + Typeops.type_of_constant_in (Global.env ()) (sp, u) + | _ -> assert false let constant sl s = UnivGen.constr_of_monomorphic_global (find_reference sl s) let const_of_ref = function - GlobRef.ConstRef kn -> kn + | GlobRef.ConstRef kn -> kn | _ -> anomaly (Pp.str "ConstRef expected.") (* Generic values *) @@ -96,16 +93,16 @@ let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in let ids = Id.Set.of_list ids in List.fold_right - (fun id acc -> next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids)::acc) - idl - [] + (fun id acc -> + next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids) :: acc) + idl [] let next_ident_away_in_goal ids avoid = next_ident_away_in_goal ids (Id.Set.of_list avoid) let compute_renamed_type gls id = - rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty (*no rels*) [] - (pf_get_hyp_typ gls id) + rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty + (*no rels*) [] (pf_get_hyp_typ gls id) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -115,112 +112,140 @@ let k_id = Id.of_string "k" let v_id = Id.of_string "v" let def_id = Id.of_string "def" let p_id = Id.of_string "p" -let rec_res_id = Id.of_string "rec_res";; -let lt = function () -> (coq_init_constant "num.nat.lt") +let rec_res_id = Id.of_string "rec_res" +let lt = function () -> coq_init_constant "num.nat.lt" let le = function () -> Coqlib.lib_ref "num.nat.le" +let ex = function () -> coq_init_constant "core.ex.type" +let nat = function () -> coq_init_constant "num.nat.type" -let ex = function () -> (coq_init_constant "core.ex.type") -let nat = function () -> (coq_init_constant "num.nat.type") let iter_ref () = try find_reference ["Recdef"] "iter" with Not_found -> user_err Pp.(str "module Recdef not loaded") -let iter_rd = function () -> (constr_of_monomorphic_global (delayed_force iter_ref)) -let eq = function () -> (coq_init_constant "core.eq.type") -let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") -let le_lt_n_Sm = function () -> (coq_constant "num.nat.le_lt_n_Sm") -let le_trans = function () -> (coq_constant "num.nat.le_trans") -let le_lt_trans = function () -> (coq_constant "num.nat.le_lt_trans") -let lt_S_n = function () -> (coq_constant "num.nat.lt_S_n") -let le_n = function () -> (coq_init_constant "num.nat.le_n") -let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") -let coq_O = function () -> (coq_init_constant "num.nat.O") -let coq_S = function () -> (coq_init_constant"num.nat.S") -let lt_n_O = function () -> (coq_constant "num.nat.nlt_0_r") -let max_ref = function () -> (find_reference ["Recdef"] "max") -let max_constr = function () -> EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) - -let f_S t = mkApp(delayed_force coq_S, [|t|]);; + +let iter_rd = function + | () -> constr_of_monomorphic_global (delayed_force iter_ref) + +let eq = function () -> coq_init_constant "core.eq.type" +let le_lt_SS = function () -> constant ["Recdef"] "le_lt_SS" +let le_lt_n_Sm = function () -> coq_constant "num.nat.le_lt_n_Sm" +let le_trans = function () -> coq_constant "num.nat.le_trans" +let le_lt_trans = function () -> coq_constant "num.nat.le_lt_trans" +let lt_S_n = function () -> coq_constant "num.nat.lt_S_n" +let le_n = function () -> coq_init_constant "num.nat.le_n" + +let coq_sig_ref = function + | () -> find_reference ["Coq"; "Init"; "Specif"] "sig" + +let coq_O = function () -> coq_init_constant "num.nat.O" +let coq_S = function () -> coq_init_constant "num.nat.S" +let lt_n_O = function () -> coq_constant "num.nat.nlt_0_r" +let max_ref = function () -> find_reference ["Recdef"] "max" + +let max_constr = function + | () -> + EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) + +let f_S t = mkApp (delayed_force coq_S, [|t|]) let rec n_x_id ids n = if Int.equal n 0 then [] - else let x = next_ident_away_in_goal x_id ids in - x::n_x_id (x::ids) (n-1);; - + else + let x = next_ident_away_in_goal x_id ids in + x :: n_x_id (x :: ids) (n - 1) let simpl_iter clause = reduce (Lazy - {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=true;rDelta=false; - rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) + { rBeta = true + ; rMatch = true + ; rFix = true + ; rCofix = true + ; rZeta = true + ; rDelta = false + ; rConst = [EvalConstRef (const_of_ref (delayed_force iter_ref))] }) clause (* Others ugly things ... *) -let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = +let (value_f : Constr.t list -> GlobRef.t -> Constr.t) = let open Term in let open Constr in fun al fterm -> let rev_x_id_l = - ( - List.fold_left - (fun x_id_l _ -> - let x_id = next_ident_away_in_goal x_id x_id_l in - x_id::x_id_l - ) - [] - al - ) + List.fold_left + (fun x_id_l _ -> + let x_id = next_ident_away_in_goal x_id x_id_l in + x_id :: x_id_l) + [] al in - let context = List.map - (fun (x, c) -> LocalAssum (make_annot (Name x) Sorts.Relevant, c)) (List.combine rev_x_id_l (List.rev al)) + let context = + List.map + (fun (x, c) -> LocalAssum (make_annot (Name x) Sorts.Relevant, c)) + (List.combine rev_x_id_l (List.rev al)) in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = - DAst.make @@ - GCases - (RegularStyle,None, - [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l), - (Anonymous,None)], - [CAst.make ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), - [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], - Anonymous)], - DAst.make @@ GVar v_id)]) + DAst.make + @@ GCases + ( RegularStyle + , None + , [ ( DAst.make + @@ GApp + ( DAst.make @@ GRef (fterm, None) + , List.rev_map + (fun x_id -> DAst.make @@ GVar x_id) + rev_x_id_l ) + , (Anonymous, None) ) ] + , [ CAst.make + ( [v_id] + , [ DAst.make + @@ PatCstr + ( (destIndRef (delayed_force coq_sig_ref), 1) + , [ DAst.make @@ PatVar (Name v_id) + ; DAst.make @@ PatVar Anonymous ] + , Anonymous ) ] + , DAst.make @@ GVar v_id ) ] ) in - let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in + let body = fst (understand env (Evd.from_env env) glob_body) (*FIXME*) in let body = EConstr.Unsafe.to_constr body in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = - fun f_id kind input_type fterm_ref -> - declare_fun f_id kind (value_f input_type fterm_ref);; +let (declare_f : + Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = + fun f_id kind input_type fterm_ref -> + declare_fun f_id kind (value_f input_type fterm_ref) let observe_tclTHENLIST s tacl = - if do_observe () - then + if do_observe () then let rec aux n = function | [] -> tclIDTAC - | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + | [tac] -> + observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac :: tacl -> + observe_tac + (fun env sigma -> s env sigma ++ spc () ++ int n) + (tclTHEN tac (aux (succ n) tacl)) in aux 0 tacl else tclTHENLIST tacl module New = struct - open Tacticals.New - let observe_tac = New.observe_tac ~header:(Pp.mt()) + let observe_tac = New.observe_tac ~header:(Pp.mt ()) let observe_tclTHENLIST s tacl = - if do_observe () - then - let rec aux n = function - | [] -> tclIDTAC - | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) - in - aux 0 tacl - else tclTHENLIST tacl - + if do_observe () then + let rec aux n = function + | [] -> tclIDTAC + | [tac] -> + observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac :: tacl -> + observe_tac + (fun env sigma -> s env sigma ++ spc () ++ int n) + (tclTHEN tac (aux (succ n) tacl)) + in + aux 0 tacl + else tclTHENLIST tacl end (* Conclusion tactics *) @@ -234,23 +259,25 @@ let tclUSER tac is_mes l = | None -> tclIDTAC | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l) in - New.observe_tclTHENLIST (fun _ _ -> str "tclUSER1") - [ clear_tac; - if is_mes - then - New.observe_tclTHENLIST (fun _ _ -> str "tclUSER2") - [ unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference - (delayed_force Indfun_common.ltof_ref))] - ; tac - ] - else tac - ] + New.observe_tclTHENLIST + (fun _ _ -> str "tclUSER1") + [ clear_tac + ; ( if is_mes then + New.observe_tclTHENLIST + (fun _ _ -> str "tclUSER2") + [ unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref) ) ] + ; tac ] + else tac ) ] let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = - if is_mes - then Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) - else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) - (tclUSER concl_tac is_mes names_to_suppress) + if is_mes then + Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) + else + (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) + tclUSER concl_tac is_mes names_to_suppress (* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic @@ -263,210 +290,243 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = let check_not_nested env sigma forbidden e = let rec check_not_nested e = match EConstr.kind sigma e with - | Rel _ -> () - | Int _ | Float _ -> () - | Var x -> - if Id.List.mem x forbidden - then user_err ~hdr:"Recdef.check_not_nested" - (str "check_not_nested: failure " ++ Id.print x) - | Meta _ | Evar _ | Sort _ -> () - | Cast(e,_,t) -> check_not_nested e;check_not_nested t - | Prod(_,t,b) -> check_not_nested t;check_not_nested b - | Lambda(_,t,b) -> check_not_nested t;check_not_nested b - | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v - | App(f,l) -> check_not_nested f;Array.iter check_not_nested l - | Proj (p,c) -> check_not_nested c - | Const _ -> () - | Ind _ -> () - | Construct _ -> () - | Case(_,t,e,a) -> - check_not_nested t;check_not_nested e;Array.iter check_not_nested a - | Fix _ -> user_err Pp.(str "check_not_nested : Fix") - | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") + | Rel _ -> () + | Int _ | Float _ -> () + | Var x -> + if Id.List.mem x forbidden then + user_err ~hdr:"Recdef.check_not_nested" + (str "check_not_nested: failure " ++ Id.print x) + | Meta _ | Evar _ | Sort _ -> () + | Cast (e, _, t) -> check_not_nested e; check_not_nested t + | Prod (_, t, b) -> check_not_nested t; check_not_nested b + | Lambda (_, t, b) -> check_not_nested t; check_not_nested b + | LetIn (_, v, t, b) -> + check_not_nested t; check_not_nested b; check_not_nested v + | App (f, l) -> + check_not_nested f; + Array.iter check_not_nested l + | Proj (p, c) -> check_not_nested c + | Const _ -> () + | Ind _ -> () + | Construct _ -> () + | Case (_, t, e, a) -> + check_not_nested t; + check_not_nested e; + Array.iter check_not_nested a + | Fix _ -> user_err Pp.(str "check_not_nested : Fix") + | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in - try - check_not_nested e - with UserError(_,p) -> - user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) + try check_not_nested e + with UserError (_, p) -> + user_err ~hdr:"_" + (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = - { nb_arg : int; (* function number of arguments *) - concl_tac : unit Proofview.tactic; (* final tactic to finish proofs *) - rec_arg_id : Id.t; (*name of the declared recursive argument *) - is_mes : bool; (* type of recursion *) - ih : Id.t; (* induction hypothesis name *) - f_id : Id.t; (* function name *) - f_constr : constr; (* function term *) - f_terminate : constr; (* termination proof term *) - func : GlobRef.t; (* functional reference *) - info : 'a; - is_main_branch : bool; (* on the main branch or on a matched expression *) - is_final : bool; (* final first order term or not *) - values_and_bounds : (Id.t*Id.t) list; - eqs : Id.t list; - forbidden_ids : Id.t list; - acc_inv : constr lazy_t; - acc_id : Id.t; - args_assoc : ((constr list)*constr) list; - } - - -type ('a,'b) journey_info_tac = - 'a -> (* the arguments of the constructor *) - 'b infos -> (* infos of the caller *) - ('b infos -> tactic) -> (* the continuation tactic of the caller *) - 'b infos -> (* argument of the tactic *) - tactic + { nb_arg : int + ; (* function number of arguments *) + concl_tac : unit Proofview.tactic + ; (* final tactic to finish proofs *) + rec_arg_id : Id.t + ; (*name of the declared recursive argument *) + is_mes : bool + ; (* type of recursion *) + ih : Id.t + ; (* induction hypothesis name *) + f_id : Id.t + ; (* function name *) + f_constr : constr + ; (* function term *) + f_terminate : constr + ; (* termination proof term *) + func : GlobRef.t + ; (* functional reference *) + info : 'a + ; is_main_branch : bool + ; (* on the main branch or on a matched expression *) + is_final : bool + ; (* final first order term or not *) + values_and_bounds : (Id.t * Id.t) list + ; eqs : Id.t list + ; forbidden_ids : Id.t list + ; acc_inv : constr lazy_t + ; acc_id : Id.t + ; args_assoc : (constr list * constr) list } + +type ('a, 'b) journey_info_tac = + 'a + -> (* the arguments of the constructor *) + 'b infos + -> (* infos of the caller *) + ('b infos -> tactic) + -> (* the continuation tactic of the caller *) + 'b infos + -> (* argument of the tactic *) + tactic (* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) type journey_info = - { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; - lambdA : ((Name.t*types*constr),constr) journey_info_tac; - casE : ((constr infos -> tactic) -> constr infos -> tactic) -> - ((case_info * constr * constr * constr array),constr) journey_info_tac; - otherS : (unit,constr) journey_info_tac; - apP : (constr*(constr list),constr) journey_info_tac; - app_reC : (constr*(constr list),constr) journey_info_tac; - message : string - } - - + { letiN : (Name.t * constr * types * constr, constr) journey_info_tac + ; lambdA : (Name.t * types * constr, constr) journey_info_tac + ; casE : + ((constr infos -> tactic) -> constr infos -> tactic) + -> (case_info * constr * constr * constr array, constr) journey_info_tac + ; otherS : (unit, constr) journey_info_tac + ; apP : (constr * constr list, constr) journey_info_tac + ; app_reC : (constr * constr list, constr) journey_info_tac + ; message : string } let add_vars sigma forbidden e = let rec aux forbidden e = - match EConstr.kind sigma e with - | Var x -> x::forbidden + match EConstr.kind sigma e with + | Var x -> x :: forbidden | _ -> EConstr.fold sigma aux forbidden e in aux forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = - fun g -> - let rev_context,b = decompose_lam_n (project g) nb_lam e in - let ids = List.fold_left (fun acc (na,_) -> - let pre_id = - match na.binder_name with - | Name x -> x - | Anonymous -> ano_id - in - pre_id::acc - ) [] rev_context in - let rev_ids = pf_get_new_ids (List.rev ids) g in - let new_b = substl (List.map mkVar rev_ids) b in - observe_tclTHENLIST (fun _ _ -> str "treat_case1") - [ - h_intros (List.rev rev_ids); - Proofview.V82.of_tactic (intro_using teq_id); - onLastHypId (fun heq -> - observe_tclTHENLIST (fun _ _ -> str "treat_case2")[ - Proofview.V82.of_tactic (clear to_intros); - h_intros to_intros; - (fun g' -> - let ty_teq = pf_get_hyp_typ g' heq in - let teq_lhs,teq_rhs = - let _,args = try destApp (project g') ty_teq with DestKO -> assert false in - args.(1),args.(2) - in - let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in - let new_infos = { - infos with - info = new_b'; - eqs = heq::infos.eqs; - forbidden_ids = - if forbid_new_ids - then add_vars (project g') infos.forbidden_ids new_b' - else infos.forbidden_ids - } in - finalize_tac new_infos g' - ) - ] - ) - ] g - -let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = + fun g -> + let rev_context, b = decompose_lam_n (project g) nb_lam e in + let ids = + List.fold_left + (fun acc (na, _) -> + let pre_id = + match na.binder_name with Name x -> x | Anonymous -> ano_id + in + pre_id :: acc) + [] rev_context + in + let rev_ids = pf_get_new_ids (List.rev ids) g in + let new_b = substl (List.map mkVar rev_ids) b in + observe_tclTHENLIST + (fun _ _ -> str "treat_case1") + [ h_intros (List.rev rev_ids) + ; Proofview.V82.of_tactic (intro_using teq_id) + ; onLastHypId (fun heq -> + observe_tclTHENLIST + (fun _ _ -> str "treat_case2") + [ Proofview.V82.of_tactic (clear to_intros) + ; h_intros to_intros + ; (fun g' -> + let ty_teq = pf_get_hyp_typ g' heq in + let teq_lhs, teq_rhs = + let _, args = + try destApp (project g') ty_teq + with DestKO -> assert false + in + (args.(1), args.(2)) + in + let new_b' = + Termops.replace_term (project g') teq_lhs teq_rhs new_b + in + let new_infos = + { infos with + info = new_b' + ; eqs = heq :: infos.eqs + ; forbidden_ids = + ( if forbid_new_ids then + add_vars (project g') infos.forbidden_ids new_b' + else infos.forbidden_ids ) } + in + finalize_tac new_infos g') ]) ] + g + +let rec travel_aux jinfo continuation_tac (expr_info : constr infos) g = let sigma = project g in let env = pf_env g in match EConstr.kind sigma expr_info.info with - | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") - | Proj _ -> user_err Pp.(str "Function cannot treat projections") - | LetIn(na,b,t,e) -> - begin + | CoFix _ | Fix _ -> + user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Proj _ -> user_err Pp.(str "Function cannot treat projections") + | LetIn (na, b, t, e) -> + let new_continuation_tac = + jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac + in + travel jinfo new_continuation_tac + {expr_info with info = b; is_final = false} + g + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Prod _ -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Lambda (n, t, b) -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Case (ci, t, a, l) -> + let continuation_tac_a = + jinfo.casE (travel jinfo) (ci, t, a, l) expr_info continuation_tac + in + travel jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; is_final = false} + g + | App _ -> ( + let f, args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f expr_info.f_constr then + jinfo.app_reC (f, args) expr_info continuation_tac expr_info g + else + match EConstr.kind sigma f with + | App _ -> assert false (* f is coming from a decompose_app *) + | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ + |Prod _ | Var _ -> + let new_infos = {expr_info with info = (f, args)} in let new_continuation_tac = - jinfo.letiN (na.binder_name,b,t,e) expr_info continuation_tac + jinfo.apP (f, args) expr_info continuation_tac in - travel jinfo new_continuation_tac - {expr_info with info = b; is_final=false} g - end - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Prod _ -> - begin - try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) - end - | Lambda(n,t,b) -> - begin - try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) - end - | Case(ci,t,a,l) -> - begin - let continuation_tac_a = - jinfo.casE - (travel jinfo) (ci,t,a,l) - expr_info continuation_tac in - travel - jinfo continuation_tac_a - {expr_info with info = a; is_main_branch = false; - is_final = false} g - end - | App _ -> - let f,args = decompose_app sigma expr_info.info in - if EConstr.eq_constr sigma f (expr_info.f_constr) - then jinfo.app_reC (f,args) expr_info continuation_tac expr_info g - else - begin - match EConstr.kind sigma f with - | App _ -> assert false (* f is coming from a decompose_app *) - | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ - | Sort _ | Prod _ | Var _ -> - let new_infos = {expr_info with info=(f,args)} in - let new_continuation_tac = - jinfo.apP (f,args) expr_info continuation_tac in - travel_args jinfo - expr_info.is_main_branch new_continuation_tac new_infos g - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env env sigma expr_info.info ++ Pp.str ".") - end - | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> - let new_continuation_tac = - jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info g + travel_args jinfo expr_info.is_main_branch new_continuation_tac + new_infos g + | Case _ -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str + " can not contain an applied match (See Limitation in Section \ + 2.3 of refman)" ) + | _ -> + anomaly + ( Pp.str "travel_aux : unexpected " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ Pp.str "." ) ) + | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ + |Float _ -> + let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in + new_continuation_tac expr_info g + and travel_args jinfo is_final continuation_tac infos = - let (f_args',args) = infos.info in + let f_args', args = infos.info in match args with - | [] -> - continuation_tac {infos with info = f_args'; is_final = is_final} - | arg::args' -> - let new_continuation_tac new_infos = - let new_arg = new_infos.info in - travel_args jinfo is_final - continuation_tac - {new_infos with info = (mkApp(f_args',[|new_arg|]),args')} - in - travel jinfo new_continuation_tac - {infos with info=arg;is_final=false} + | [] -> continuation_tac {infos with info = f_args'; is_final} + | arg :: args' -> + let new_continuation_tac new_infos = + let new_arg = new_infos.info in + travel_args jinfo is_final continuation_tac + {new_infos with info = (mkApp (f_args', [|new_arg|]), args')} + in + travel jinfo new_continuation_tac {infos with info = arg; is_final = false} + and travel jinfo continuation_tac expr_info = observe_tac - (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) + (fun env sigma -> + str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) @@ -475,164 +535,185 @@ let rec prove_lt hyple g = let sigma = project g in begin try - let (varx,varz) = match decompose_app sigma (pf_concl g) with - | _, x::z::_ when isVar sigma x && isVar sigma z -> x, z + let varx, varz = + match decompose_app sigma (pf_concl g) with + | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) | _ -> assert false in let h = - List.find (fun id -> - match decompose_app sigma (pf_get_hyp_typ g id) with - | _, t::_ -> EConstr.eq_constr sigma t varx - | _ -> false - ) hyple + List.find + (fun id -> + match decompose_app sigma (pf_get_hyp_typ g id) with + | _, t :: _ -> EConstr.eq_constr sigma t varx + | _ -> false) + hyple in let y = - List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) in - observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ - Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); - observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) - ] + List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) + in + observe_tclTHENLIST + (fun _ _ -> str "prove_lt1") + [ Proofview.V82.of_tactic + (apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|]))) + ; observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] with Not_found -> - ( - ( - observe_tclTHENLIST (fun _ _ -> str "prove_lt2")[ - Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); - (observe_tac (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) - ]) - ) + observe_tclTHENLIST + (fun _ _ -> str "prove_lt2") + [ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)) + ; observe_tac + (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) + (Proofview.V82.of_tactic assumption) ] end g -let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = +let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds g = match lbounds with - | [] -> - let ids = pf_ids_of_hyps g in - let s_max = mkApp(delayed_force coq_S, [|bound|]) in - let k = next_ident_away_in_goal k_id ids in - let ids = k::ids in - let h' = next_ident_away_in_goal (h'_id) ids in - let ids = h'::ids in - let def = next_ident_away_in_goal def_id ids in - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux1")[ - Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); - Proofview.V82.of_tactic (intro_then - (fun id -> - Proofview.V82.tactic begin - observe_tac (fun _ _ -> str "destruct_bounds_aux") - (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) - [ - observe_tclTHENLIST (fun _ _ -> str "")[Proofview.V82.of_tactic (intro_using h_id); - Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); - Proofview.V82.of_tactic default_full_auto]; - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux2")[ - observe_tac (fun _ _ -> str "clearing k ") (Proofview.V82.of_tactic (clear [id])); - h_intros [k;h';def]; - observe_tac (fun _ _ -> str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); - observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference infos.func)])); - ( - observe_tclTHENLIST (fun _ _ -> str "test")[ - list_rewrite true - (List.fold_right - (fun e acc -> (mkVar e,true)::acc) - infos.eqs - (List.map (fun e -> (e,true)) rechyps) - ); - (* list_rewrite true *) - (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) - (* ; *) - - (observe_tac (fun _ _ -> str "finishing") - (tclORELSE - (Proofview.V82.of_tactic intros_reflexivity) - (observe_tac (fun _ _ -> str "calling prove_lt") (prove_lt hyple))))]) - ] - ] - )end)) - ] g - | (_,v_bound)::l -> - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux3")[ - Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); - Proofview.V82.of_tactic (clear [v_bound]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 - (fun p_hyp -> - (onNthHypId 2 - (fun p -> - observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux4")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - [hle2;hle1;pmax] -> - destruct_bounds_aux infos - ((mkVar pmax), - hle1::hle2::hyple,(mkVar p_hyp)::rechyps) - l - | _ -> assert false) ; - ] - ) - ) - ) - ] g + | [] -> + let ids = pf_ids_of_hyps g in + let s_max = mkApp (delayed_force coq_S, [|bound|]) in + let k = next_ident_away_in_goal k_id ids in + let ids = k :: ids in + let h' = next_ident_away_in_goal h'_id ids in + let ids = h' :: ids in + let def = next_ident_away_in_goal def_id ids in + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux1") + [ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])) + ; Proofview.V82.of_tactic + (intro_then (fun id -> + Proofview.V82.tactic + (observe_tac + (fun _ _ -> str "destruct_bounds_aux") + (tclTHENS + (Proofview.V82.of_tactic (simplest_case (mkVar id))) + [ observe_tclTHENLIST + (fun _ _ -> str "") + [ Proofview.V82.of_tactic (intro_using h_id) + ; Proofview.V82.of_tactic + (simplest_elim + (mkApp (delayed_force lt_n_O, [|s_max|]))) + ; Proofview.V82.of_tactic default_full_auto ] + ; observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux2") + [ observe_tac + (fun _ _ -> str "clearing k ") + (Proofview.V82.of_tactic (clear [id])) + ; h_intros [k; h'; def] + ; observe_tac + (fun _ _ -> str "simple_iter") + (Proofview.V82.of_tactic + (simpl_iter Locusops.onConcl)) + ; observe_tac + (fun _ _ -> str "unfold functional") + (Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference + infos.func ) ])) + ; observe_tclTHENLIST + (fun _ _ -> str "test") + [ list_rewrite true + (List.fold_right + (fun e acc -> (mkVar e, true) :: acc) + infos.eqs + (List.map (fun e -> (e, true)) rechyps)) + ; (* list_rewrite true *) + (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) + (* ; *) + observe_tac + (fun _ _ -> str "finishing") + (tclORELSE + (Proofview.V82.of_tactic + intros_reflexivity) + (observe_tac + (fun _ _ -> str "calling prove_lt") + (prove_lt hyple))) ] ] ])))) ] + g + | (_, v_bound) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux3") + [ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)) + ; Proofview.V82.of_tactic (clear [v_bound]) + ; tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun p_hyp -> + onNthHypId 2 (fun p -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux4") + [ Proofview.V82.of_tactic + (simplest_elim + (mkApp (delayed_force max_constr, [|bound; mkVar p|]))) + ; tclDO 3 (Proofview.V82.of_tactic intro) + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> + destruct_bounds_aux infos + ( mkVar pmax + , hle1 :: hle2 :: hyple + , mkVar p_hyp :: rechyps ) + l + | _ -> assert false) ])) ] + g let destruct_bounds infos = - destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds + destruct_bounds_aux infos + (delayed_force coq_O, [], []) + infos.values_and_bounds let terminate_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app1")[ - continuation_tac infos; - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) - ] - else continuation_tac infos + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app1") + [ continuation_tac infos + ; observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (1)") + (destruct_bounds infos) ] + else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_others")[ - continuation_tac infos; - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) - ] + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_others") + [ continuation_tac infos + ; observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) + ; observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) + ] else continuation_tac infos -let terminate_letin (na,b,t,e) expr_info continuation_tac info g = +let terminate_letin (na, b, t, e) expr_info continuation_tac info g = let sigma = project g in let env = pf_env g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in - if forbid - then + if forbid then match na with - | Anonymous -> info.forbidden_ids - | Name id -> id::info.forbidden_ids + | Anonymous -> info.forbidden_ids + | Name id -> id :: info.forbidden_ids else info.forbidden_ids in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g let pf_type c tac gl = let evars, ty = Typing.type_of (pf_env gl) (project gl) c in - tclTHEN (Refiner.tclEVARS evars) (tac ty) gl + tclTHEN (Refiner.tclEVARS evars) (tac ty) gl let pf_typel l tac = let rec aux tys l = match l with | [] -> tac (List.rev tys) - | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl) - in aux [] l + | hd :: tl -> pf_type hd (fun ty -> aux (ty :: tys) tl) + in + aux [] l (* This is like the previous one except that it also rewrite on all hypotheses except the ones given in the first argument. All the @@ -646,351 +727,431 @@ let mkDestructEq not_on_hyp expr g = (fun decl -> let open Context.Named.Declaration in let id = get_id decl in - if Id.List.mem id not_on_hyp || not (Termops.dependent (project g) expr (get_type decl)) - then None else Some id) hyps in + if + Id.List.mem id not_on_hyp + || not (Termops.dependent (project g) expr (get_type decl)) + then None + else Some id) + hyps + in let to_revert_constr = List.rev_map mkVar to_revert in let g, type_of_expr = tac_type_of g expr in - let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|])::to_revert_constr in + let new_hyps = + mkApp (Lazy.force refl_equal, [|type_of_expr; expr|]) :: to_revert_constr + in let tac = pf_typel new_hyps (fun _ -> - observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") - [Proofview.V82.of_tactic (generalize new_hyps); - (fun g2 -> - let changefun patvars env sigma = - pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) - in - Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); - Proofview.V82.of_tactic (simplest_case expr)]) + observe_tclTHENLIST + (fun _ _ -> str "mkDestructEq") + [ Proofview.V82.of_tactic (generalize new_hyps) + ; (fun g2 -> + let changefun patvars env sigma = + pattern_occs + [(Locus.AllOccurrencesBut [1], expr)] + (pf_env g2) sigma (pf_concl g2) + in + Proofview.V82.of_tactic + (change_in_concl ~check:true None changefun) + g2) + ; Proofview.V82.of_tactic (simplest_case expr) ]) in - g, tac, to_revert + (g, tac, to_revert) -let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = +let terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos g = let sigma = project g in let env = pf_env g in let f_is_present = try - check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) a; false - with e when CErrors.noncritical e -> - true + with e when CErrors.noncritical e -> true in let a' = infos.info in let new_info = - {infos with - info = mkCase(ci,t,a',l); - is_main_branch = expr_info.is_main_branch; - is_final = expr_info.is_final} in - let g,destruct_tac,rev_to_thin_intro = - mkDestructEq [expr_info.rec_arg_id] a' g in + { infos with + info = mkCase (ci, t, a', l) + ; is_main_branch = expr_info.is_main_branch + ; is_final = expr_info.is_final } + in + let g, destruct_tac, rev_to_thin_intro = + mkDestructEq [expr_info.rec_arg_id] a' g + in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') - (try - (tclTHENS - destruct_tac - (List.map_i (fun i e -> observe_tac (fun _ _ -> str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) - )) - with - | UserError(Some "Refiner.thensn_tac3",_) - | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (fun _ _ -> str "is computable " ++ Printer.pr_leconstr_env env sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) - )) + observe_tac + (fun _ _ -> + str "treating cases (" + ++ int (Array.length l) + ++ str ")" ++ spc () + ++ Printer.pr_leconstr_env (pf_env g) sigma a') + ( try + tclTHENS destruct_tac + (List.map_i + (fun i e -> + observe_tac + (fun _ _ -> str "do treat case") + (treat_case f_is_present to_thin_intro + (next_step continuation_tac) + ci.ci_cstr_ndecls.(i) e new_info)) + 0 (Array.to_list l)) + with + | UserError (Some "Refiner.thensn_tac3", _) + |UserError (Some "Refiner.tclFAIL_s", _) + -> + observe_tac + (fun _ _ -> + str "is computable " + ++ Printer.pr_leconstr_env env sigma new_info.info) + (next_step continuation_tac + { new_info with + info = + Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info }) + ) g -let terminate_app_rec (f,args) expr_info continuation_tac _ g = +let terminate_app_rec (f, args) expr_info continuation_tac _ g = let sigma = project g in let env = pf_env g in - List.iter (check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids)) + List.iter + (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) args; - begin - try - let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in - let new_infos = {expr_info with info = v} in - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec1")[ - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (3)") - (destruct_bounds new_infos) - ] - else - tclIDTAC - ] g - with Not_found -> - observe_tac (fun _ _ -> str "terminate_app_rec not found") (tclTHENS - (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) - [ - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2")[ - Proofview.V82.of_tactic (intro_using rec_res_id); - Proofview.V82.of_tactic intro; - onNthHypId 1 - (fun v_bound -> - (onNthHypId 2 - (fun v -> - let new_infos = { expr_info with - info = (mkVar v); - values_and_bounds = - (v,v_bound)::expr_info.values_and_bounds; - args_assoc=(args,mkVar v)::expr_info.args_assoc - } in - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec3")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec4")[ - observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); - observe_tac (fun _ _ -> str "destruct_bounds (2)") - (destruct_bounds new_infos) - ] - else - tclIDTAC - ] - ) - ) - ) - ]; - observe_tac (fun _ _ -> str "proving decreasing") ( - tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) - [ - observe_tac (fun _ _ -> str "assumption") (Proofview.V82.of_tactic assumption); - observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec5") - [ - tclTRY(list_rewrite true - (List.map - (fun e -> mkVar e,true) - expr_info.eqs - ) - ); - Proofview.V82.of_tactic @@ - tclUSER expr_info.concl_tac true - (Some ( - expr_info.ih::expr_info.acc_id:: - (fun (x,y) -> y) - (List.split expr_info.values_and_bounds) - ) - ); - ] - ]) - ]) g - end + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec1") + [ observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic + (split (ImplicitBindings [new_infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (3)") + (destruct_bounds new_infos) ] + else tclIDTAC ) ] + g + with Not_found -> + observe_tac + (fun _ _ -> str "terminate_app_rec not found") + (tclTHENS + (Proofview.V82.of_tactic + (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args)))) + [ observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec2") + [ Proofview.V82.of_tactic (intro_using rec_res_id) + ; Proofview.V82.of_tactic intro + ; onNthHypId 1 (fun v_bound -> + onNthHypId 2 (fun v -> + let new_infos = + { expr_info with + info = mkVar v + ; values_and_bounds = + (v, v_bound) :: expr_info.values_and_bounds + ; args_assoc = (args, mkVar v) :: expr_info.args_assoc + } + in + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec3") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch + then + observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec4") + [ observe_tac + (fun _ _ -> str "first split") + (Proofview.V82.of_tactic + (split + (ImplicitBindings [new_infos.info]))) + ; observe_tac + (fun _ _ -> str "destruct_bounds (2)") + (destruct_bounds new_infos) ] + else tclIDTAC ) ])) ] + ; observe_tac + (fun _ _ -> str "proving decreasing") + (tclTHENS (* proof of args < formal args *) + (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) + [ observe_tac + (fun _ _ -> str "assumption") + (Proofview.V82.of_tactic assumption) + ; observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec5") + [ tclTRY + (list_rewrite true + (List.map (fun e -> (mkVar e, true)) expr_info.eqs)) + ; Proofview.V82.of_tactic + @@ tclUSER expr_info.concl_tac true + (Some + ( expr_info.ih :: expr_info.acc_id + :: (fun (x, y) -> y) + (List.split expr_info.values_and_bounds) )) + ] ]) ]) + g let terminate_info = - { message = "prove_terminate with term "; - letiN = terminate_letin; - lambdA = (fun _ _ _ _ -> assert false); - casE = terminate_case; - otherS = terminate_others; - apP = terminate_app; - app_reC = terminate_app_rec; - } + { message = "prove_terminate with term " + ; letiN = terminate_letin + ; lambdA = (fun _ _ _ _ -> assert false) + ; casE = terminate_case + ; otherS = terminate_others + ; apP = terminate_app + ; app_reC = terminate_app_rec } let prove_terminate = travel terminate_info - (* Equation proof *) -let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = - observe_tac (fun _ _ -> str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) +let equation_case next_step (ci, a, t, l) expr_info continuation_tac infos = + observe_tac + (fun _ _ -> str "equation case") + (terminate_case next_step (ci, a, t, l) expr_info continuation_tac infos) let rec prove_le g = let sigma = project g in - let x,z = - let _,args = decompose_app sigma (pf_concl g) in - (List.hd args,List.hd (List.tl args)) + let x, z = + let _, args = decompose_app sigma (pf_concl g) in + (List.hd args, List.hd (List.tl args)) in - tclFIRST[ - Proofview.V82.of_tactic assumption; - Proofview.V82.of_tactic (apply (delayed_force le_n)); - begin - try - let matching_fun c = match EConstr.kind sigma c with - | App (c, [| x0 ; _ |]) -> - EConstr.isVar sigma x0 && - Id.equal (destVar sigma x0) (destVar sigma x) && - EConstr.isRefX sigma (le ()) c - | _ -> false - in - let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in - let h = h.binder_name in - let y = - let _,args = decompose_app sigma t in - List.hd (List.tl args) - in - observe_tclTHENLIST (fun _ _ -> str "prove_le")[ - Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); - observe_tac (fun _ _ -> str "prove_le (rec)") (prove_le) - ] - with Not_found -> tclFAIL 0 (mt()) - end; - ] + tclFIRST + [ Proofview.V82.of_tactic assumption + ; Proofview.V82.of_tactic (apply (delayed_force le_n)) + ; begin + try + let matching_fun c = + match EConstr.kind sigma c with + | App (c, [|x0; _|]) -> + EConstr.isVar sigma x0 + && Id.equal (destVar sigma x0) (destVar sigma x) + && EConstr.isRefX sigma (le ()) c + | _ -> false + in + let h, t = + List.find (fun (_, t) -> matching_fun t) (pf_hyps_types g) + in + let h = h.binder_name in + let y = + let _, args = decompose_app sigma t in + List.hd (List.tl args) + in + observe_tclTHENLIST + (fun _ _ -> str "prove_le") + [ Proofview.V82.of_tactic + (apply (mkApp (le_trans (), [|x; y; z; mkVar h|]))) + ; observe_tac (fun _ _ -> str "prove_le (rec)") prove_le ] + with Not_found -> tclFAIL 0 (mt ()) + end ] g let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC - | (_,p,hp)::l -> - observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS - (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in - Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, - ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); - CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) - ) - [make_rewrite_list expr_info max l; - observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list")[ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); - observe_tac (fun _ _ -> str "prove_le(2)") prove_le - ] - ] ) + | (_, p, hp) :: l -> + observe_tac + (fun _ _ -> str "make_rewrite_list") + (tclTHENS + (observe_tac + (fun _ _ -> str "rewrite heq on " ++ Id.print p) + (fun g -> + let sigma = project g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + Proofview.V82.of_tactic + (general_rewrite_bindings false Locus.AllOccurrences true + (* dep proofs also: *) true + ( mkVar hp + , ExplicitBindings + [ CAst.make @@ (NamedHyp def, expr_info.f_constr) + ; CAst.make @@ (NamedHyp k, f_S max) ] ) + false) + g)) + [ make_rewrite_list expr_info max l + ; observe_tclTHENLIST + (fun _ _ -> str "make_rewrite_list") + [ (* x < S max proof *) + Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)) + ; observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ]) let make_rewrite expr_info l hp max = tclTHENFIRST - (observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in - observe_tac (fun _ _ -> str "general_rewrite_bindings") - (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, - ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); - CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) - [observe_tac(fun _ _ -> str "make_rewrite finalize") ( - (* tclORELSE( h_reflexivity) *) - (observe_tclTHENLIST (fun _ _ -> str "make_rewrite")[ - Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); - observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference expr_info.func)])); - - (list_rewrite true - (List.map (fun e -> mkVar e,true) expr_info.eqs)); - (observe_tac (fun _ _ -> str "h_reflexivity") - (Proofview.V82.of_tactic intros_reflexivity) - ) - ])) - ; - observe_tclTHENLIST (fun _ _ -> str "make_rewrite1")[ (* x < S (S max) proof *) - Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); - observe_tac (fun _ _ -> str "prove_le (3)") prove_le - ] - ]) - ) + (observe_tac + (fun _ _ -> str "make_rewrite") + (make_rewrite_list expr_info max l)) + (observe_tac + (fun _ _ -> str "make_rewrite") + (tclTHENS + (fun g -> + let sigma = project g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + observe_tac + (fun _ _ -> str "general_rewrite_bindings") + (Proofview.V82.of_tactic + (general_rewrite_bindings false Locus.AllOccurrences true + (* dep proofs also: *) true + ( mkVar hp + , ExplicitBindings + [ CAst.make @@ (NamedHyp def, expr_info.f_constr) + ; CAst.make @@ (NamedHyp k, f_S (f_S max)) ] ) + false)) + g) + [ observe_tac + (fun _ _ -> str "make_rewrite finalize") + ((* tclORELSE( h_reflexivity) *) + observe_tclTHENLIST + (fun _ _ -> str "make_rewrite") + [ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl) + ; observe_tac + (fun _ _ -> str "unfold functional") + (Proofview.V82.of_tactic + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference expr_info.func ) ])) + ; list_rewrite true + (List.map (fun e -> (mkVar e, true)) expr_info.eqs) + ; observe_tac + (fun _ _ -> str "h_reflexivity") + (Proofview.V82.of_tactic intros_reflexivity) ]) + ; observe_tclTHENLIST + (fun _ _ -> str "make_rewrite1") + [ (* x < S (S max) proof *) + Proofview.V82.of_tactic + (apply (EConstr.of_constr (delayed_force le_lt_SS))) + ; observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ])) let rec compute_max rew_tac max l = match l with - | [] -> rew_tac max - | (_,p,_)::l -> - observe_tclTHENLIST (fun _ _ -> str "compute_max")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| max; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l - | _ -> assert false - )] + | [] -> rew_tac max + | (_, p, _) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "compute_max") + [ Proofview.V82.of_tactic + (simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|]))) + ; tclDO 3 (Proofview.V82.of_tactic intro) + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> compute_max rew_tac (mkVar pmax) l + | _ -> assert false) ] let rec destruct_hex expr_info acc l = match l with - | [] -> - begin - match List.rev acc with - | [] -> tclIDTAC - | (_,p,hp)::tl -> - observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) - end - | (v,hex)::l -> - observe_tclTHENLIST (fun _ _ -> str "destruct_hex")[ - Proofview.V82.of_tactic (simplest_case (mkVar hex)); - Proofview.V82.of_tactic (clear [hex]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hp -> - onNthHypId 2 (fun p -> - observe_tac - (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) - (destruct_hex expr_info ((v,p,hp)::acc) l) - ) - ) - ] + | [] -> ( + match List.rev acc with + | [] -> tclIDTAC + | (_, p, hp) :: tl -> + observe_tac + (fun _ _ -> str "compute max ") + (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) ) + | (v, hex) :: l -> + observe_tclTHENLIST + (fun _ _ -> str "destruct_hex") + [ Proofview.V82.of_tactic (simplest_case (mkVar hex)) + ; Proofview.V82.of_tactic (clear [hex]) + ; tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun hp -> + onNthHypId 2 (fun p -> + observe_tac + (fun _ _ -> + str "destruct_hex after " ++ Id.print hp ++ spc () + ++ Id.print p) + (destruct_hex expr_info ((v, p, hp) :: acc) l))) ] let rec intros_values_eq expr_info acc = - tclORELSE( - observe_tclTHENLIST (fun _ _ -> str "intros_values_eq")[ - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hex -> - (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) - ) - ]) - (tclCOMPLETE ( - destruct_hex expr_info [] acc - )) + tclORELSE + (observe_tclTHENLIST + (fun _ _ -> str "intros_values_eq") + [ tclDO 2 (Proofview.V82.of_tactic intro) + ; onNthHypId 1 (fun hex -> + onNthHypId 2 (fun v -> + intros_values_eq expr_info ((v, hex) :: acc))) ]) + (tclCOMPLETE (destruct_hex expr_info [] acc)) let equation_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then - observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) - (tclTHEN + if expr_info.is_final && expr_info.is_main_branch then + observe_tac + (fun env sigma -> + str "equation_others (cont_tac +intros) " + ++ Printer.pr_leconstr_env env sigma expr_info.info) + (tclTHEN (continuation_tac infos) + (observe_tac + (fun env sigma -> + str "intros_values_eq equation_others " + ++ Printer.pr_leconstr_env env sigma expr_info.info) + (intros_values_eq expr_info []))) + else + observe_tac + (fun env sigma -> + str "equation_others (cont_tac) " + ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) - (observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then ((observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []))) - else continuation_tac infos + if expr_info.is_final && expr_info.is_main_branch then + observe_tac + (fun _ _ -> str "intros_values_eq equation_app") + (intros_values_eq expr_info []) + else continuation_tac infos -let equation_app_rec (f,args) expr_info continuation_tac info g = +let equation_app_rec (f, args) expr_info continuation_tac info g = let sigma = project g in - begin - try - let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in - let new_infos = {expr_info with info = v} in - observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g - with Not_found -> - if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST (fun _ _ -> str "equation_app_rec") - [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; - observe_tac (fun _ _ -> str "app_rec intros_values_eq") (intros_values_eq expr_info []) - ] g - else - observe_tclTHENLIST (fun _ _ -> str "equation_app_rec1")[ - Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - observe_tac (fun _ _ -> str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) - ] g - end + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g + with Not_found -> + if expr_info.is_final && expr_info.is_main_branch then + observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec") + [ Proofview.V82.of_tactic + (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) + ; continuation_tac + { expr_info with + args_assoc = (args, delayed_force coq_O) :: expr_info.args_assoc + } + ; observe_tac + (fun _ _ -> str "app_rec intros_values_eq") + (intros_values_eq expr_info []) ] + g + else + observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec1") + [ Proofview.V82.of_tactic + (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) + ; observe_tac + (fun _ _ -> str "app_rec not_found") + (continuation_tac + { expr_info with + args_assoc = + (args, delayed_force coq_O) :: expr_info.args_assoc }) ] + g let equation_info = - {message = "prove_equation with term "; - letiN = (fun _ -> assert false); - lambdA = (fun _ _ _ _ -> assert false); - casE = equation_case; - otherS = equation_others; - apP = equation_app; - app_reC = equation_app_rec -} + { message = "prove_equation with term " + ; letiN = (fun _ -> assert false) + ; lambdA = (fun _ _ _ _ -> assert false) + ; casE = equation_case + ; otherS = equation_others + ; apP = equation_app + ; app_reC = equation_app_rec } let prove_eq = travel equation_info @@ -1001,271 +1162,268 @@ let compute_terminate_type nb_args func = let open Term in let open Constr in let open CVars in - let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_monomorphic_global func)) in - let rev_args,b = decompose_prod_n nb_args a_arrow_b in + let _, a_arrow_b, _ = + destLambda (def_of_const (constr_of_monomorphic_global func)) + in + let rev_args, b = decompose_prod_n nb_args a_arrow_b in let left = - mkApp(delayed_force iter_rd, - Array.of_list - (lift 5 a_arrow_b:: mkRel 3:: - constr_of_monomorphic_global func::mkRel 1:: - List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) - ) - ) + mkApp + ( delayed_force iter_rd + , Array.of_list + ( lift 5 a_arrow_b :: mkRel 3 + :: constr_of_monomorphic_global func + :: mkRel 1 + :: List.rev (List.map_i (fun i _ -> mkRel (6 + i)) 0 rev_args) ) ) in let right = mkRel 5 in let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in - let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in - let result = (mkProd (make_annot (Name def_id) Sorts.Relevant, lift 4 a_arrow_b, equality)) in - let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in + let equality = mkApp (delayed_force eq, [|lift 5 b; left; right|]) in + let result = + mkProd (make_annot (Name def_id) Sorts.Relevant, lift 4 a_arrow_b, equality) + in + let cond = mkApp (delayed_force lt, [|mkRel 2; mkRel 1|]) in let nb_iter = - mkApp(delayed_force ex, - [|delayed_force nat; - (mkLambda - (make_annot (Name p_id) Sorts.Relevant, - delayed_force nat, - (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, - mkArrow cond Sorts.Relevant result))))|])in - let value = mkApp(constr_of_monomorphic_global (Util.delayed_force coq_sig_ref), - [|b; - (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in + mkApp + ( delayed_force ex + , [| delayed_force nat + ; mkLambda + ( make_annot (Name p_id) Sorts.Relevant + , delayed_force nat + , mkProd + ( make_annot (Name k_id) Sorts.Relevant + , delayed_force nat + , mkArrow cond Sorts.Relevant result ) ) |] ) + in + let value = + mkApp + ( constr_of_monomorphic_global (Util.delayed_force coq_sig_ref) + , [|b; mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter)|] ) + in compose_prod rev_args value - -let termination_proof_header is_mes input_type ids args_id relation - rec_arg_num rec_arg_id tac wf_tac : tactic = - begin - fun g -> - let nargs = List.length args_id in - let pre_rec_args = - List.rev_map - mkVar (fst (List.chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in - let wf_rec_arg = - next_ident_away_in_goal - (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) - (wf_thm::ids) - in - let hrec = next_ident_away_in_goal hrec_id - (wf_rec_arg::wf_thm::ids) in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - tclTHEN - (h_intros args_id) - (tclTHENS +let termination_proof_header is_mes input_type ids args_id relation rec_arg_num + rec_arg_id tac wf_tac : tactic = + fun g -> + let nargs = List.length args_id in + let pre_rec_args = + List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in + let wf_rec_arg = + next_ident_away_in_goal + (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) + (wf_thm :: ids) + in + let hrec = next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) in + let acc_inv = + lazy + (mkApp + (delayed_force acc_inv_id, [|input_type; relation; mkVar rec_arg_id|])) + in + tclTHEN (h_intros args_id) + (tclTHENS + (observe_tac + (fun _ _ -> str "first assert") + (Proofview.V82.of_tactic + (assert_before (Name wf_rec_arg) + (mkApp + ( delayed_force acc_rel + , [|input_type; relation; mkVar rec_arg_id|] ))))) + [ (* accesibility proof *) + tclTHENS (observe_tac - (fun _ _ -> str "first assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_rec_arg) - (mkApp (delayed_force acc_rel, - [|input_type;relation;mkVar rec_arg_id|]) - ) - )) - ) - [ - (* accesibility proof *) - tclTHENS - (observe_tac - (fun _ _ -> str "second assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_thm) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - )) - ) - [ - (* interactive proof that the relation is well_founded *) - observe_tac (fun _ _ -> str "wf_tac") (wf_tac is_mes (Some args_id)); - (* this gives the accessibility argument *) - observe_tac - (fun _ _ -> str "apply wf_thm") - (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) - ) - ] - ; - (* rest of the proof *) - observe_tclTHENLIST (fun _ _ -> str "rest of proof") - [observe_tac (fun _ _ -> str "generalize") - (onNLastHypsId (nargs+1) - (tclMAP (fun id -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) - )) - ; - observe_tac (fun _ _ -> str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); - h_intros args_id; - Proofview.V82.of_tactic (Simple.intro wf_rec_arg); - observe_tac (fun _ _ -> str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) - ] + (fun _ _ -> str "second assert") + (Proofview.V82.of_tactic + (assert_before (Name wf_thm) + (mkApp + (delayed_force well_founded, [|input_type; relation|]))))) + [ (* interactive proof that the relation is well_founded *) + observe_tac + (fun _ _ -> str "wf_tac") + (wf_tac is_mes (Some args_id)) + ; (* this gives the accessibility argument *) + observe_tac + (fun _ _ -> str "apply wf_thm") + (Proofview.V82.of_tactic + (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|])))) ] - ) g - end - - + ; (* rest of the proof *) + observe_tclTHENLIST + (fun _ _ -> str "rest of proof") + [ observe_tac + (fun _ _ -> str "generalize") + (onNLastHypsId (nargs + 1) + (tclMAP (fun id -> + tclTHEN + (Proofview.V82.of_tactic + (Tactics.generalize [mkVar id])) + (Proofview.V82.of_tactic (clear [id]))))) + ; observe_tac + (fun _ _ -> str "fix") + (Proofview.V82.of_tactic (fix hrec (nargs + 1))) + ; h_intros args_id + ; Proofview.V82.of_tactic (Simple.intro wf_rec_arg) + ; observe_tac + (fun _ _ -> str "tac") + (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ]) + g let rec instantiate_lambda sigma t l = match l with | [] -> t - | a::l -> - let (_, _, body) = destLambda sigma t in - instantiate_lambda sigma (subst1 a body) l + | a :: l -> + let _, _, body = destLambda sigma t in + instantiate_lambda sigma (subst1 a body) l -let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : tactic = - begin - fun g -> - let sigma = project g in - let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_monomorphic_global func)) in - let func_body = EConstr.of_constr func_body in - let (f_name, _, body1) = destLambda sigma func_body in - let f_id = - match f_name.binder_name with - | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function.") - in - let n_names_types,_ = decompose_lam_n sigma nb_args body1 in - let n_ids,ids = - List.fold_left - (fun (n_ids,ids) (n_name,_) -> - match n_name.binder_name with - | Name id -> - let n_id = next_ident_away_in_goal id ids in - n_id::n_ids,n_id::ids - | _ -> anomaly (Pp.str "anonymous argument.") - ) - ([],(f_id::ids)) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda sigma func_body (mkVar f_id::(List.map mkVar n_ids)) in - termination_proof_header - is_mes - input_type - ids - n_ids - relation - rec_arg_num - rec_arg_id - (fun rec_arg_id hrec acc_id acc_inv g -> - (prove_terminate (fun infos -> tclIDTAC) - { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *) - is_final = true; (* and on leaf (more or less) *) - f_terminate = delayed_force coq_O; - nb_arg = nb_args; - concl_tac; - rec_arg_id = rec_arg_id; - is_mes = is_mes; - ih = hrec; - f_id = f_id; - f_constr = mkVar f_id; - func = func; - info = expr; - acc_inv = acc_inv; - acc_id = acc_id; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - args_assoc = [] - } - ) - g - ) - (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) - g - end +let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : + tactic = + fun g -> + let sigma = project g in + let ids = Termops.ids_of_named_context (pf_hyps g) in + let func_body = def_of_const (constr_of_monomorphic_global func) in + let func_body = EConstr.of_constr func_body in + let f_name, _, body1 = destLambda sigma func_body in + let f_id = + match f_name.binder_name with + | Name f_id -> next_ident_away_in_goal f_id ids + | Anonymous -> anomaly (Pp.str "Anonymous function.") + in + let n_names_types, _ = decompose_lam_n sigma nb_args body1 in + let n_ids, ids = + List.fold_left + (fun (n_ids, ids) (n_name, _) -> + match n_name.binder_name with + | Name id -> + let n_id = next_ident_away_in_goal id ids in + (n_id :: n_ids, n_id :: ids) + | _ -> anomaly (Pp.str "anonymous argument.")) + ([], f_id :: ids) + n_names_types + in + let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in + let expr = + instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) + in + termination_proof_header is_mes input_type ids n_ids relation rec_arg_num + rec_arg_id + (fun rec_arg_id hrec acc_id acc_inv g -> + (prove_terminate + (fun infos -> tclIDTAC) + { is_main_branch = true + ; (* we are on the main branche (i.e. still on a match ... with .... end *) + is_final = true + ; (* and on leaf (more or less) *) + f_terminate = delayed_force coq_O + ; nb_arg = nb_args + ; concl_tac + ; rec_arg_id + ; is_mes + ; ih = hrec + ; f_id + ; f_constr = mkVar f_id + ; func + ; info = expr + ; acc_inv + ; acc_id + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; args_assoc = [] }) + g) + (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) + g let get_current_subgoals_types pstate = - let p = Proof_global.get_proof pstate in - let Proof.{ goals=sgs; sigma; _ } = Proof.data p in - sigma, List.map (Goal.V82.abstract_type sigma) sgs + let p = Declare.Proof.get_proof pstate in + let Proof.{goals = sgs; sigma; _} = Proof.data p in + (sigma, List.map (Goal.V82.abstract_type sigma) sgs) exception EmptySubgoals + let build_and_l sigma l = - let and_constr = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" in + let and_constr = + UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" + in let conj_constr = Coqlib.lib_ref "core.and.conj" in - let mk_and p1 p2 = - mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in + let mk_and p1 p2 = mkApp (EConstr.of_constr and_constr, [|p1; p2|]) in let rec is_well_founded t = match EConstr.kind sigma t with - | Prod(_,_,t') -> is_well_founded t' - | App(_,_) -> - let (f,_) = decompose_app sigma t in - EConstr.eq_constr sigma f (well_founded ()) - | _ -> - false + | Prod (_, _, t') -> is_well_founded t' + | App (_, _) -> + let f, _ = decompose_app sigma t in + EConstr.eq_constr sigma f (well_founded ()) + | _ -> false in let compare t1 t2 = - let b1,b2= is_well_founded t1,is_well_founded t2 in - if (b1&&b2) || not (b1 || b2) then 0 - else if b1 && not b2 then 1 else -1 + let b1, b2 = (is_well_founded t1, is_well_founded t2) in + if (b1 && b2) || not (b1 || b2) then 0 else if b1 && not b2 then 1 else -1 in let l = List.sort compare l in - let rec f = function + let rec f = function | [] -> raise EmptySubgoals - | [p] -> p,tclIDTAC,1 - | p1::pl -> - let c,tac,nb = f pl in - mk_and p1 c, - tclTHENS - (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) - [tclIDTAC; - tac - ],nb+1 - in f l - + | [p] -> (p, tclIDTAC, 1) + | p1 :: pl -> + let c, tac, nb = f pl in + ( mk_and p1 c + , tclTHENS + (Proofview.V82.of_tactic + (apply + (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) + [tclIDTAC; tac] + , nb + 1 ) + in + f l let is_rec_res id = - let rec_res_name = Id.to_string rec_res_id in + let rec_res_name = Id.to_string rec_res_id in let id_name = Id.to_string id in try - String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name + String.equal + (String.sub id_name 0 (String.length rec_res_name)) + rec_res_name with Invalid_argument _ -> false let clear_goals sigma = let rec clear_goal t = match EConstr.kind sigma t with - | Prod({binder_name=Name id} as na,t',b) -> - let b' = clear_goal b in - if noccurn sigma 1 b' && (is_rec_res id) - then Vars.lift (-1) b' - else if b' == b then t - else mkProd(na,t',b') - | _ -> EConstr.map sigma clear_goal t + | Prod (({binder_name = Name id} as na), t', b) -> + let b' = clear_goal b in + if noccurn sigma 1 b' && is_rec_res id then Vars.lift (-1) b' + else if b' == b then t + else mkProd (na, t', b') + | _ -> EConstr.map sigma clear_goal t in List.map clear_goal - let build_new_goal_type lemma = let sigma, sub_gls_types = Lemmas.pf_fold get_current_subgoals_types lemma in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let res = build_and_l sigma sub_gls_types in - sigma, res + (sigma, res) let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Proof_global.Opaque - | Declarations.Undef _ -> Proof_global.Opaque - | Declarations.Def _ -> Proof_global.Transparent - | Declarations.Primitive _ -> Proof_global.Opaque + | Declarations.OpaqueDef _ -> Declare.Opaque + | Declarations.Undef _ -> Declare.Opaque + | Declarations.Def _ -> Declare.Transparent + | Declarations.Primitive _ -> Declare.Opaque -let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name + (gls_type, decompose_and_tac, nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Lemmas.pf_fold Proof_global.get_proof_name lemma in - let name = match goal_name with + let current_proof_name = Lemmas.pf_fold Declare.Proof.get_proof_name lemma in + let name = + match goal_name with | Some s -> s - | None -> - try add_suffix current_proof_name "_subproof" - with e when CErrors.noncritical e -> - anomaly (Pp.str "open_new_goal with an unnamed theorem.") + | None -> ( + try add_suffix current_proof_name "_subproof" + with e when CErrors.noncritical e -> + anomaly (Pp.str "open_new_goal with an unnamed theorem.") ) in let na = next_global_ident_away name Id.Set.empty in if Termops.occur_existential sigma gls_type then @@ -1275,8 +1433,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let na_ref = qualid_of_ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with - GlobRef.ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") + | GlobRef.ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Value (EConstr.Unsafe.to_constr lemma); @@ -1288,7 +1446,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let open Tacticals.New in Proofview.Goal.enter (fun gl -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gl) in - New.observe_tclTHENLIST (fun _ _ -> mt ()) + New.observe_tclTHENLIST + (fun _ _ -> mt ()) [ generalize [lemma] ; Simple.intro hid ; Proofview.Goal.enter (fun gl -> @@ -1299,195 +1458,252 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let ids' = pf_ids_of_hyps gl in lid := List.rev (List.subtract Id.equal ids' ids); if List.is_empty !lid then lid := [hid]; - tclIDTAC))) - ]) in + tclIDTAC))) ]) + in let end_tac = let open Tacmach.New in let open Tacticals.New in Proofview.Goal.enter (fun gl -> let sigma = project gl in match EConstr.kind sigma (pf_concl gl) with - | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> + | App (f, _) when EConstr.eq_constr sigma f (well_founded ()) -> Auto.h_auto None [] (Some []) | _ -> incr h_num; - tclCOMPLETE( - tclFIRST - [ tclTHEN - (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) - e_assumption - ; Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] - [Hints.Hint_db.empty TransparentState.empty false - ] - ] - )) in + tclCOMPLETE + (tclFIRST + [ tclTHEN + (eapply_with_bindings + (mkVar (List.nth !lid !h_num), NoBindings)) + e_assumption + ; Eauto.eauto_with_bases (true, 5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + [Hints.Hint_db.empty TransparentState.empty false] ])) + in let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) () in - let lemma = Lemmas.start_lemma - ~name:na - ~poly:false (* FIXME *) ~info - sigma gls_type in - let lemma = if Indfun_common.is_strict_tcc () - then - fst @@ Lemmas.by (Proofview.V82.tactic (tclIDTAC)) lemma - else - fst @@ Lemmas.by (Proofview.V82.tactic begin - fun g -> - tclTHEN - (decompose_and_tac) - (tclORELSE - (tclFIRST - (List.map - (fun c -> - Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST - [intros; - Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); - Tacticals.New.tclCOMPLETE Auto.default_auto - ]) - ) - using_lemmas) - ) tclIDTAC) - g end) lemma + let lemma = + Lemmas.start_lemma ~name:na ~poly:false (* FIXME *) ~info sigma gls_type + in + let lemma = + if Indfun_common.is_strict_tcc () then + fst @@ Lemmas.by (Proofview.V82.tactic tclIDTAC) lemma + else + fst + @@ Lemmas.by + (Proofview.V82.tactic (fun g -> + tclTHEN decompose_and_tac + (tclORELSE + (tclFIRST + (List.map + (fun c -> + Proofview.V82.of_tactic + (Tacticals.New.tclTHENLIST + [ intros + ; Simple.apply + (fst + (interp_constr (Global.env ()) + Evd.empty c)) + (*FIXME*) + ; Tacticals.New.tclCOMPLETE Auto.default_auto + ])) + using_lemmas)) + tclIDTAC) + g)) + lemma in - if Lemmas.(pf_fold Proof_global.get_open_goals) lemma = 0 then (defined lemma; None) else Some lemma - -let com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_ref - is_mes - fonctional_ref - input_type - relation - rec_arg_num - thm_name using_lemmas - nb_args ctx - hook = + if Lemmas.(pf_fold Declare.Proof.get_open_goals) lemma = 0 then ( + defined lemma; None ) + else Some lemma + +let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes + fonctional_ref input_type relation rec_arg_num thm_name using_lemmas nb_args + ctx hook = let start_proof env ctx tac_start tac_end = let info = Lemmas.Info.make ~hook () in - let lemma = Lemmas.start_lemma ~name:thm_name - ~poly:false (*FIXME*) - ~info - ctx - (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) in - let lemma = fst @@ Lemmas.by (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) lemma in - fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num ))) lemma + let lemma = + Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) ~info ctx + (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) + in + let lemma = + fst + @@ Lemmas.by + (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) + lemma + in + fst + @@ Lemmas.by + (Proofview.V82.tactic + (observe_tac + (fun _ _ -> str "whole_start") + (whole_start tac_end nb_args is_mes fonctional_ref input_type + relation rec_arg_num))) + lemma + in + let lemma = + start_proof + Global.(env ()) + ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in - let lemma = start_proof Global.(env ()) ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in try let sigma, new_goal_type = build_new_goal_type lemma in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in - open_new_goal ~lemma start_proof sigma - using_lemmas tcc_lemma_ref - (Some tcc_lemma_name) - (new_goal_type) + open_new_goal ~lemma start_proof sigma using_lemmas tcc_lemma_ref + (Some tcc_lemma_name) new_goal_type with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - if interactive_proof then Some lemma - else (defined lemma; None) + if interactive_proof then Some lemma else (defined lemma; None) -let start_equation (f:GlobRef.t) (term_f:GlobRef.t) - (cont_tactic:Id.t list -> tactic) g = +let start_equation (f : GlobRef.t) (term_f : GlobRef.t) + (cont_tactic : Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_monomorphic_global term_f in let terminate_constr = EConstr.of_constr terminate_constr in - let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in + let nargs = + nb_prod (project g) + (EConstr.of_constr (type_of_const sigma terminate_constr)) + in let x = n_x_id ids nargs in - observe_tac (fun _ _ -> str "start_equation") (observe_tclTHENLIST (fun _ _ -> str "start_equation") [ - h_intros x; - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); - observe_tac (fun _ _ -> str "simplest_case") - (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, - Array.of_list (List.map mkVar x))))); - observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x)]) g;; - -let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = - let open CVars in - let opacity = - match terminate_ref with - | GlobRef.ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") - in - let evd = Evd.from_ctx uctx in - let f_constr = constr_of_monomorphic_global f_ref in - let equation_lemma_type = subst1 f_constr equation_lemma_type in - let lemma = Lemmas.start_lemma ~name:eq_name ~poly:false evd - (EConstr.of_constr equation_lemma_type) in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (start_equation f_ref terminate_ref - (fun x -> - prove_eq (fun _ -> tclIDTAC) - {nb_arg=nb_arg; - f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); - f_constr = EConstr.of_constr f_constr; - concl_tac = Tacticals.New.tclIDTAC; - func=functional_ref; - info=(instantiate_lambda Evd.empty - (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) - (EConstr.of_constr f_constr::List.map mkVar x) - ); - is_main_branch = true; - is_final = true; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - acc_inv = lazy (assert false); - acc_id = Id.of_string "____"; - args_assoc = []; - f_id = Id.of_string "______"; - rec_arg_id = Id.of_string "______"; - is_mes = false; - ih = Id.of_string "______"; - } - ) - )) lemma in - let _ = Flags.silently (fun () -> Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None) () in - () -(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + observe_tac + (fun _ _ -> str "start_equation") + (observe_tclTHENLIST + (fun _ _ -> str "start_equation") + [ h_intros x + ; Proofview.V82.of_tactic + (unfold_in_concl + [(Locus.AllOccurrences, evaluable_of_global_reference f)]) + ; observe_tac + (fun _ _ -> str "simplest_case") + (Proofview.V82.of_tactic + (simplest_case + (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))) + ; observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ]) + g +let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref + equation_lemma_type = + let open CVars in + let opacity = + match terminate_ref with + | GlobRef.ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") + in + let evd = Evd.from_ctx uctx in + let f_constr = constr_of_monomorphic_global f_ref in + let equation_lemma_type = subst1 f_constr equation_lemma_type in + let lemma = + Lemmas.start_lemma ~name:eq_name ~poly:false evd + (EConstr.of_constr equation_lemma_type) + in + let lemma = + fst + @@ Lemmas.by + (Proofview.V82.tactic + (start_equation f_ref terminate_ref (fun x -> + prove_eq + (fun _ -> tclIDTAC) + { nb_arg + ; f_terminate = + EConstr.of_constr + (constr_of_monomorphic_global terminate_ref) + ; f_constr = EConstr.of_constr f_constr + ; concl_tac = Tacticals.New.tclIDTAC + ; func = functional_ref + ; info = + instantiate_lambda Evd.empty + (EConstr.of_constr + (def_of_const + (constr_of_monomorphic_global functional_ref))) + (EConstr.of_constr f_constr :: List.map mkVar x) + ; is_main_branch = true + ; is_final = true + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; acc_inv = lazy (assert false) + ; acc_id = Id.of_string "____" + ; args_assoc = [] + ; f_id = Id.of_string "______" + ; rec_arg_id = Id.of_string "______" + ; is_mes = false + ; ih = Id.of_string "______" }))) + lemma + in + let _ = + Flags.silently + (fun () -> Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None) + () + in + () -let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : Lemmas.t option = +(* Pp.msgnl (fun _ _ -> str "eqn finished"); *) + +let recursive_definition ~interactive_proof ~is_mes function_name rec_impls + type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : + Lemmas.t option = let open Term in let open Constr in let open CVars in - let env = Global.env() in + let env = Global.env () in let evd = Evd.from_env env in - let evd, function_type = interp_type_evars ~program_mode:false env evd type_of_f in - let function_r = Sorts.Relevant in (* TODO relevance *) - let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (make_annot function_name function_r,function_type)) env in + let evd, function_type = + interp_type_evars ~program_mode:false env evd type_of_f + in + let function_r = Sorts.Relevant in + (* TODO relevance *) + let env = + EConstr.push_named + (Context.Named.Declaration.LocalAssum + (make_annot function_name function_r, function_type)) + env + in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let evd, ty = interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq in + let evd, ty = + interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq + in let evd = Evd.minimize_universes evd in - let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in - let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in + let equation_lemma_type = + Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) + in + let function_type = + EConstr.to_constr ~abort_on_undefined_evars:false evd function_type + in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in - (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) - let res_vars,eq' = decompose_prod equation_lemma_type in - let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in + (* Pp.msgnl (fun _ _ -> str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) + let res_vars, eq' = decompose_prod equation_lemma_type in + let env_eq' = + Environ.push_rel_context + (List.map (fun (x, y) -> LocalAssum (x, y)) res_vars) + env + in let eq' = Reductionops.nf_zeta env_eq' evd (EConstr.of_constr eq') in let eq' = EConstr.Unsafe.to_constr eq' in let res = -(* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) -(* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) -(* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) + (* Pp.msgnl (fun _ _ -> str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) + (* Pp.msgnl (fun _ _ -> str "rec_arg_num := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) + (* Pp.msgnl (fun _ _ -> str "eq' := " ++ str (fun _ _ -> string_of_int rec_arg_num)); *) match Constr.kind eq' with - | App(e,[|_;_;eq_fix|]) -> - mkLambda (make_annot (Name function_name) Sorts.Relevant,function_type,subst_var function_name (compose_lam res_vars eq_fix)) - | _ -> failwith "Recursive Definition (res not eq)" + | App (e, [|_; _; eq_fix|]) -> + mkLambda + ( make_annot (Name function_name) Sorts.Relevant + , function_type + , subst_var function_name (compose_lam res_vars eq_fix) ) + | _ -> failwith "Recursive Definition (res not eq)" + in + let pre_rec_args, function_type_before_rec_arg = + decompose_prod_n (rec_arg_num - 1) function_type + in + let _, rec_arg_type, _ = destProd function_type_before_rec_arg in + let arg_types = + List.rev_map snd + (fst (decompose_prod_n (List.length res_vars) function_type)) in - let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in - let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in - let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in let equation_id = add_suffix function_name "_equation" in - let functional_id = add_suffix function_name "_F" in + let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = let univs = Evd.univ_entry ~poly:false evd in @@ -1495,57 +1711,61 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type in (* Refresh the global universes, now including those of _F *) let evd = Evd.from_env (Global.env ()) in - let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in - let relation, evuctx = - interp_constr env_with_pre_rec_args evd r + let env_with_pre_rec_args = + push_rel_context + (List.map (function x, t -> LocalAssum (x, t)) pre_rec_args) + env in + let relation, evuctx = interp_constr env_with_pre_rec_args evd r in let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook { DeclareDef.Hook.S.uctx ; _ } = + let hook {DeclareDef.Hook.S.uctx; _} = let term_ref = Nametab.locate (qualid_of_ident term_id) in - let f_ref = declare_f function_name Decls.(IsProof Lemma) arg_types term_ref in - let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] in + let f_ref = + declare_f function_name Decls.(IsProof Lemma) arg_types term_ref + in + let _ = + Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] + in (* message "start second proof"; *) let stop = (* XXX: What is the correct way to get sign at hook time *) try - com_eqn uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + com_eqn uctx (List.length res_vars) equation_id functional_ref f_ref + term_ref + (subst_var function_name equation_lemma_type); false with e when CErrors.noncritical e -> - begin - if do_observe () - then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) - else CErrors.user_err ~hdr:"Cannot create equation Lemma" - (str "Cannot create equation lemma." ++ spc () ++ - str "This may be because the function is nested-recursive.") - ; - true - end + if do_observe () then + Feedback.msg_debug + (str "Cannot create equation Lemma " ++ CErrors.print e) + else + CErrors.user_err ~hdr:"Cannot create equation Lemma" + ( str "Cannot create equation lemma." + ++ spc () + ++ str "This may be because the function is nested-recursive." ); + true in - if not stop - then - let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in + if not stop then + let eq_ref = Nametab.locate (qualid_of_ident equation_id) in let f_ref = destConst (constr_of_monomorphic_global f_ref) - and functional_ref = destConst (constr_of_monomorphic_global functional_ref) + and functional_ref = + destConst (constr_of_monomorphic_global functional_ref) and eq_ref = destConst (constr_of_monomorphic_global eq_ref) in - generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num + generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref + rec_arg_num (EConstr.of_constr rec_arg_type) - (nb_prod evd (EConstr.of_constr res)) relation + (nb_prod evd (EConstr.of_constr res)) + relation in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) - funind_purify (fun () -> - com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref + funind_purify + (fun () -> + com_terminate interactive_proof tcc_lemma_name tcc_lemma_constr is_mes + functional_ref (EConstr.of_constr rec_arg_type) - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - evd (DeclareDef.Hook.make hook)) + relation rec_arg_num term_id using_lemmas (List.length res_vars) evd + (DeclareDef.Hook.make hook)) () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index 3225411c85..4e5146e37c 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,13 +1,13 @@ open Constr -val tclUSER_if_not_mes - : unit Proofview.tactic +val tclUSER_if_not_mes : + unit Proofview.tactic -> bool -> Names.Id.t list option -> unit Proofview.tactic -val recursive_definition - : interactive_proof:bool +val recursive_definition : + interactive_proof:bool -> is_mes:bool -> Names.Id.t -> Constrintern.internalization_env @@ -15,7 +15,14 @@ val recursive_definition -> Constrexpr.constr_expr -> int -> Constrexpr.constr_expr - -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) + -> ( pconstant + -> Indfun_common.tcc_lemma_value ref + -> pconstant + -> pconstant + -> int + -> EConstr.types + -> int + -> EConstr.constr + -> unit) -> Constrexpr.constr_expr list -> Lemmas.t option diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 7b1aa7a07a..0bad3cbe5b 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -312,7 +312,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = if poly then ctx else (* This is a global universe context that shouldn't be refreshed at every use of the hint, declare it globally. *) - (Declare.declare_universe_context ~poly:false ctx; + (DeclareUctx.declare_universe_context ~poly:false ctx; Univ.ContextSet.empty) in CAst.make ?loc:(Constrexpr_ops.constr_loc ce) ((c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t) in @@ -346,7 +346,7 @@ open Vars let constr_flags () = { Pretyping.use_typeclasses = Pretyping.UseTC; - Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); + Pretyping.solve_unification_constraints = Proof.use_unification_heuristics (); Pretyping.fail_evar = false; Pretyping.expand_evars = true; Pretyping.program_mode = false; @@ -918,7 +918,7 @@ END VERNAC COMMAND EXTEND GrabEvars STATE proof | [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.V82.grab_evars p) pstate } + -> { fun ~pstate -> Declare.Proof.map_proof (fun p -> Proof.V82.grab_evars p) pstate } END (* Shelves all the goals under focus. *) @@ -950,7 +950,7 @@ END VERNAC COMMAND EXTEND Unshelve STATE proof | [ "Unshelve" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.unshelve p) pstate } + -> { fun ~pstate -> Declare.Proof.map_proof (fun p -> Proof.unshelve p) pstate } END (* Gives up on the goals under focus: the goals are considered solved, @@ -1102,7 +1102,7 @@ END VERNAC COMMAND EXTEND OptimizeProof | ![ proof ] [ "Optimize" "Proof" ] => { classify_as_proofstep } -> - { fun ~pstate -> Proof_global.compact_the_proof pstate } + { fun ~pstate -> Declare.Proof.compact pstate } | [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 2bd4211c90..5baa23b3e9 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -342,7 +342,7 @@ GRAMMAR EXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - { Hints.HintsExtern (n,c, in_tac tac) } ] ] + { ComHints.HintsExtern (n,c, in_tac tac) } ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> @@ -364,12 +364,12 @@ let print_info_trace = let vernac_solve ~pstate n info tcom b = let open Goal_select in - let pstate, status = Proof_global.map_fold_proof_endline (fun etac p -> + let pstate, status = Declare.Proof.map_fold_proof_endline (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in let info = Option.append info (print_info_trace ()) in let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + Proof.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p in (* in case a strict subtree was completed, go back to the top of the prooftree *) diff --git a/tactics/leminv.ml b/plugins/ltac/leminv.ml index 5a8ec404ee..5a8ec404ee 100644 --- a/tactics/leminv.ml +++ b/plugins/ltac/leminv.ml diff --git a/tactics/leminv.mli b/plugins/ltac/leminv.mli index 5a5de7b58f..5a5de7b58f 100644 --- a/tactics/leminv.mli +++ b/plugins/ltac/leminv.mli diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index e83eab20dc..f31361279c 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -9,6 +9,7 @@ Tactic_debug Tacintern Profile_ltac Tactic_matching +Leminv Tacinterp Tacentries Evar_tactics diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 321b05b97c..f002bbc57a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -639,7 +639,7 @@ let solve_remaining_by env sigma holes by = let env = Environ.reset_with_named_context evi.evar_hyps env in let ty = evi.evar_concl in let name, poly = Id.of_string "rewrite", false in - let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma ty solve_tac in + let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma ty solve_tac in Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep @@ -1559,7 +1559,7 @@ let assert_replacing id newt tac = if Id.equal n id then ev' else mkVar n in let (e, _) = destEvar sigma ev in - (sigma, mkEvar (e, Array.map_of_list map nc)) + (sigma, mkEvar (e, List.map map nc)) end end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) @@ -1864,14 +1864,14 @@ let proper_projection env sigma r ty = Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx -let declare_projection n instance_id r = +let declare_projection name instance_id r = let poly = Global.is_polymorphic r in let env = Global.env () in let sigma = Evd.from_env env in let sigma,c = Evd.fresh_global env sigma r in let ty = Retyping.get_type_of env sigma c in - let term = proper_projection env sigma c ty in - let sigma, typ = Typing.type_of env sigma term in + let body = proper_projection env sigma c ty in + let sigma, typ = Typing.type_of env sigma body in let ctx, typ = decompose_prod_assum sigma typ in let typ = let n = @@ -1892,14 +1892,11 @@ let declare_projection n instance_id r = let ctx,ccl = Reductionops.splay_prod_n env sigma (3 * n) typ in it_mkProd_or_LetIn ccl ctx in - let typ = it_mkProd_or_LetIn typ ctx in - let univs = Evd.univ_entry ~poly sigma in - let typ = EConstr.to_constr sigma typ in - let term = EConstr.to_constr sigma term in - let cst = Declare.definition_entry ~types:typ ~univs term in - let _ : Constant.t = - Declare.declare_constant ~name:n ~kind:Decls.(IsDefinition Definition) - (Declare.DefinitionEntry cst) + let types = Some (it_mkProd_or_LetIn typ ctx) in + let kind, opaque, scope = Decls.(IsDefinition Definition), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let impargs, udecl = [], UState.default_univ_decl in + let _r : GlobRef.t = + DeclareDef.declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ~poly ~types ~body sigma in () let build_morphism_signature env sigma m = @@ -1927,10 +1924,7 @@ let build_morphism_signature env sigma m = in let morph = e_app_poly env evd (PropGlobal.proper_type env) [| t; sig_; m |] in let evd = solve_constraints env !evd in - let evd = Evd.minimize_universes evd in - let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in - Pretyping.check_evars env evd (EConstr.of_constr m); - Evd.evar_universe_context evd, m + evd, morph let default_morphism sign m = let env = Global.env () in @@ -1965,22 +1959,24 @@ let add_morphism_as_parameter atts m n : unit = let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in - let uctx, instance = build_morphism_signature env evd m in - let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in - let cst = Declare.declare_constant ~name:instance_id - ~kind:Decls.(IsAssumption Logical) - (Declare.ParameterEntry (None,(instance,uctx),None)) - in - Classes.add_instance (Classes.mk_instance - (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (GlobRef.ConstRef cst)); - declare_projection n instance_id (GlobRef.ConstRef cst) + let poly = atts.polymorphic in + let kind, opaque, scope = Decls.(IsAssumption Logical), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let impargs, udecl = [], UState.default_univ_decl in + let evd, types = build_morphism_signature env evd m in + let evd, pe = DeclareDef.prepare_parameter ~poly ~udecl ~types evd in + let cst = Declare.declare_constant ~name:instance_id ~kind (Declare.ParameterEntry pe) in + let cst = GlobRef.ConstRef cst in + Classes.add_instance + (Classes.mk_instance + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global cst); + declare_projection n instance_id cst let add_morphism_interactive atts m n : Lemmas.t = init_setoid (); let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in - let uctx, instance = build_morphism_signature env evd m in + let evd, morph = build_morphism_signature env evd m in let poly = atts.polymorphic in let kind = Decls.(IsDefinition Instance) in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in @@ -1996,7 +1992,7 @@ let add_morphism_interactive atts m n : Lemmas.t = let info = Lemmas.Info.make ~hook ~kind () in Flags.silently (fun () -> - let lemma = Lemmas.start_lemma ~name:instance_id ~poly ~info (Evd.from_ctx uctx) (EConstr.of_constr instance) in + let lemma = Lemmas.start_lemma ~name:instance_id ~poly ~info evd morph in fst (Lemmas.by (Tacinterp.interp tac) lemma)) () let add_morphism atts binders m s n = diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 4127d28bae..9910796d9c 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -299,7 +299,7 @@ let classify_tactic_notation tacobj = Substitute tacobj let inTacticGrammar : tactic_grammar_obj -> obj = declare_object {(default_object "TacticGrammar") with - open_function = open_tactic_notation; + open_function = simple_open open_tactic_notation; load_function = load_tactic_notation; cache_function = cache_tactic_notation; subst_function = subst_tactic_notation; diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index ce9189792e..76d47f5482 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -182,7 +182,7 @@ let inMD : bool * ltac_constant option * bool * glob_tactic_expr * declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; - open_function = open_md; + open_function = simple_open open_md; subst_function = subst_md; classify_function = classify_md} diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index b0e26e1def..dda7f0742c 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -2070,7 +2070,7 @@ let _ = *) let name, poly = Id.of_string "ltac_gen", poly in let name, poly = Id.of_string "ltac_gen", poly in - let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in + let (c, sigma) = Proof.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval diff --git a/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml index 4f00f17892..922d2f7792 100644 --- a/plugins/ltac/tactic_option.ml +++ b/plugins/ltac/tactic_option.ml @@ -32,7 +32,7 @@ let declare_tactic_option ?(default=Tacexpr.TacId []) name = { (default_object name) with cache_function = cache; load_function = (fun _ -> load); - open_function = (fun _ -> load); + open_function = simple_open (fun _ -> load); classify_function = (fun (local, tac) -> if local then Dispose else Substitute (local, tac)); subst_function = subst} diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 2eef459217..79d6c05e1d 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1899,8 +1899,15 @@ let destructure_goal = let destructure_goal = destructure_goal +let warn_omega_is_deprecated = + let name = "omega-is-deprecated" in + let category = "deprecated" in + CWarnings.create ~name ~category (fun () -> + Pp.str "omega is deprecated since 8.12; use “lia” instead.") + let omega_solver = Proofview.tclUNIT () >>= fun () -> (* delay for [check_required_library] *) + warn_omega_is_deprecated (); Coqlib.check_required_library ["Coq";"omega";"Omega"]; reset_all (); destructure_goal diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 0646af3552..633cdbd735 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -150,7 +150,7 @@ let decl_constant na univs c = let open Constr in let vars = CVars.universes_of_constr c in let univs = UState.restrict_universe_context ~lbound:(Global.universes_lbound ()) univs vars in - let () = Declare.declare_universe_context ~poly:false univs in + let () = DeclareUctx.declare_universe_context ~poly:false univs in let types = (Typeops.infer (Global.env ()) c).uj_type in let univs = Monomorphic_entry Univ.ContextSet.empty in mkConst(declare_constant ~name:(Id.of_string na) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index e0b083a70a..134a9e4b36 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -537,7 +537,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = let rec put evlist c = match Constr.kind c with | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k || List.mem k rigid then evlist else - let n = max 0 (Array.length a - nenv) in + let n = max 0 (List.length a - nenv) in let t = abs_evar n k in (k, (n, t)) :: put evlist t | _ -> Constr.fold put evlist c in let evlist = put [] c0 in @@ -549,6 +549,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = | Evar (ev, a) -> let j, n = lookup ev i evlist in if j = 0 then Constr.map (get i) c else if n = 0 then mkRel j else + let a = Array.of_list a in mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) | _ -> Constr.map_with_binders ((+) 1) get i c in let rec loop c i = function @@ -598,7 +599,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let rec put evlist c = match Constr.kind c with | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else - let n = max 0 (Array.length a - nenv) in + let n = max 0 (List.length a - nenv) in let k_ty = Retyping.get_sort_family_of (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in @@ -636,6 +637,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = | Evar (ev, a) -> let j, n = lookup ev i evlist in if j = 0 then Constr.map (get evlist i) c else if n = 0 then mkRel j else + let a = Array.of_list a in mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) | _ -> Constr.map_with_binders ((+) 1) (get evlist) i c in let rec app extra_args i c = match decompose_app c with diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 1c776398e7..d5a781e472 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -263,7 +263,7 @@ let nf_open_term sigma0 ise c = let rec nf c' = match kind c' with | Evar ex -> begin try nf (existential_value0 s ex) with _ -> - let k, a = ex in let a' = Array.map nf a in + let k, a = ex in let a' = List.map nf a in if not (Evd.mem !s' k) then s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); mkEvar (k, a') @@ -307,7 +307,7 @@ let pf_unify_HO gl t1 t2 = (* This is what the definition of iter_constr should be... *) let iter_constr_LR f c = match kind c with - | Evar (k, a) -> Array.iter f a + | Evar (k, a) -> List.iter f a | Cast (cc, _, t) -> f cc; f t | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b @@ -387,7 +387,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = with NotInstantiatedEvar -> if Evd.mem sigma0 k then map put c else let evi = Evd.find !sigma k in - let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in + let dc = List.firstn (max 0 (List.length a - nenv)) (evar_filtered_context evi) in let abs_dc (d, c) = function | Context.Named.Declaration.LocalDef (x, b, t) -> d, mkNamedLetIn x (put b) (put t) c @@ -601,7 +601,8 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = | KpatFixed | KpatConst -> ise | KpatEvar _ -> let _, pka = destEvar u.up_f and _, ka = destEvar f in - unif_HO_args env ise pka 0 ka + let fold ise pk k = unif_HO env ise (EConstr.of_constr pk) (EConstr.of_constr k) in + List.fold_left2 fold ise pka ka | KpatLet -> let x, v, t, b = destLetIn f in let _, pv, _, pb = destLetIn u.up_f in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index f816599a17..b39ec37cd1 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -446,7 +446,7 @@ let rec norm_head info env t stack = Some c -> norm_head info env c stack | None -> let e, xs = ev in - let xs' = Array.map (apply_env env) xs in + let xs' = List.map (apply_env env) xs in (VAL(0, mkEvar (e,xs')), stack)) (* non-neutral cases *) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index f85635528d..25aa8915ba 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -404,7 +404,7 @@ let matches_core env sigma allow_bound_rels Array.fold_left2 (fun subst na1 na2 -> add_binders na1 na2 binding_vars subst) subst lna1 lna2 | PEvar (c1,args1), Evar (c2,args2) when Evar.equal c1 c2 -> - Array.fold_left2 (sorec ctx env) subst args1 args2 + List.fold_left2 (sorec ctx env) subst args1 args2 | PInt i1, Int i2 when Uint63.equal i1 i2 -> subst | PFloat f1, Float f2 when Float64.equal f1 f2 -> subst | (PRef _ | PVar _ | PRel _ | PApp _ | PProj _ | PLambda _ diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 857918c928..ff278baf9f 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -790,7 +790,7 @@ and detype_r d flags avoid env sigma t = id,l with Not_found -> Id.of_string ("X" ^ string_of_int (Evar.repr evk)), - (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl) + (List.map (fun c -> (Id.of_string "__",c)) cl) in GEvar (id, List.map (on_snd (detype d flags avoid env sigma)) l) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3d887e1a95..f1506f5f59 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -195,7 +195,7 @@ let occur_rigidly flags env evd (evk,_) t = | 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) + Rigid (List.exists (fun x -> rigid_normal_occ (aux x)) l) else Reducible | Cast (p, _, _) -> aux p | Lambda (na, t, b) -> aux b @@ -351,6 +351,14 @@ let ise_array2 evd f v1 v2 = if Int.equal lv1 (Array.length v2) then allrec evd (pred lv1) else UnifFailure (evd,NotSameArgSize) +let rec ise_inst2 evd f l1 l2 = match l1, l2 with +| [], [] -> Success evd +| [], (_ :: _) | (_ :: _), [] -> assert false +| c1 :: l1, c2 :: l2 -> + match ise_inst2 evd f l1 l2 with + | Success evd' -> f evd' c1 c2 + | UnifFailure _ as x -> x + (* Applicative node of stack are read from the outermost to the innermost but are unified the other way. *) let rec ise_app_stack2 env f evd sk1 sk2 = @@ -1019,7 +1027,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty 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 + ise_inst2 i' (fun i' -> evar_conv_x flags env i' CONV) al1 al2 |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (evd,NotSameArgSize) else UnifFailure (evd,NotSameHead) @@ -1241,6 +1249,7 @@ let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the fv of args to have a well-typed filter; don't know how necessary it is however to have a well-typed filter here *) + let args = Array.of_list args in let fv1 = free_rels evd (mkApp (c,args)) (* Hack: locally untyped *) in let fv2 = collect_vars evd (mkApp (c,args)) in let len = Array.length args in @@ -1309,8 +1318,8 @@ let thin_evars env sigma sign c = 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 filter = List.map (fun c -> Id.Set.subset (collect_vars !sigma c) ctx) args in + let filter = Filter.make filter in let candidates = Option.map (List.map EConstr.of_constr) (evar_candidates evi) in let evd, ev = restrict_evar !sigma ev filter candidates in sigma := evd; whd_evar !sigma t @@ -1336,9 +1345,9 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = 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 args = List.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 argsubst = List.map2 (fun id c -> (id, c)) vars 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); @@ -1416,7 +1425,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = set_holes env_rhs' evd rhs' subst | [] -> evd, rhs in - let subst = make_subst (ctxt,Array.to_list args,argoccs) in + let subst = make_subst (ctxt,args,argoccs) in let evd, rhs' = set_holes env_rhs evd rhs subst in let rhs' = nf_evar evd rhs' in @@ -1533,7 +1542,7 @@ let default_evar_selection flags evd (ev,args) = 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 + in aux args evi.evar_abstract_arguments let second_order_matching_with_args flags env evd with_ho pbty ev l t = if with_ho then diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 50187d82cc..71edcaa231 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -113,7 +113,7 @@ let define_evar_as_product env evd (evk,args) = (* Quick way to compute the instantiation of evk with args *) let na,dom,rng = destProd evd prod in let evdom = mkEvar (fst (destEvar evd dom), args) in - let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evrngargs = mkRel 1 :: List.map (lift 1) args in let evrng = mkEvar (fst (destEvar evd rng), evrngargs) in evd, mkProd (na, evdom, evrng) @@ -152,7 +152,7 @@ let define_evar_as_lambda env evd (evk,args) = let evd,lam = define_pure_evar_as_lambda env evd evk in (* Quick way to compute the instantiation of evk with args *) let na,dom,body = destLambda evd lam in - let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evbodyargs = mkRel 1 :: List.map (lift 1) args in let evbody = mkEvar (fst (destEvar evd body), evbodyargs) in evd, mkLambda (na, dom, evbody) @@ -163,7 +163,7 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function let evd,lam = define_pure_evar_as_lambda env evd evk in let _,_,body = destLambda evd lam in let evk = fst (destEvar evd body) in - evar_absorb_arguments env evd (evk, Array.cons a args) l + evar_absorb_arguments env evd (evk, a :: args) l (* Refining an evar to a sort *) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index e475e4c52b..34684e4a34 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -217,7 +217,7 @@ type 'a update = | NoUpdate open Context.Named.Declaration -let inst_of_vars sign = Array.map_of_list (get_id %> mkVar) sign +let inst_of_vars sign = List.map (get_id %> mkVar) sign let restrict_evar_key evd evk filter candidates = match filter, candidates with @@ -247,7 +247,7 @@ let restrict_applied_evar evd (evk,argsv) filter candidates = | Some filter -> let evi = Evd.find evd evk in let subfilter = Filter.compose (evar_filter evi) filter in - Filter.filter_array subfilter argsv in + Filter.filter_list subfilter argsv in evd,(newevk,newargsv) (* Restrict an evar in the current evar_map *) @@ -258,7 +258,7 @@ let restrict_evar evd evk filter candidates = let restrict_instance evd evk filter argsv = match filter with None -> argsv | Some filter -> let evi = Evd.find evd evk in - Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv + Filter.filter_list (Filter.compose (evar_filter evi) filter) argsv open Context.Rel.Declaration let noccur_evar env evd evk c = @@ -269,7 +269,7 @@ let noccur_evar env evd evk c = if Evar.equal evk evk' then raise Occur else (if check_types then occur_rec false acc (existential_type evd ev'); - Array.iter (occur_rec check_types acc) args') + List.iter (occur_rec check_types acc) args') | Rel i when i > k -> if not (Int.Set.mem (i-k) !cache) then let decl = Environ.lookup_rel i env in @@ -552,17 +552,13 @@ let get_actual_deps env evd aliases l t = open Context.Named.Declaration let remove_instance_local_defs evd evk args = let evi = Evd.find evd evk in - let len = Array.length args in - let rec aux sign i = match sign with - | [] -> - let () = assert (i = len) in [] - | LocalAssum _ :: sign -> - let () = assert (i < len) in - (Array.unsafe_get args i) :: aux sign (succ i) - | LocalDef _ :: sign -> - aux sign (succ i) + let rec aux sign args = match sign, args with + | [], [] -> [] + | LocalAssum _ :: sign, c :: args -> c :: aux sign args + | LocalDef _ :: sign, _ :: args -> aux sign args + | _ -> assert false in - aux (evar_filtered_context evi) 0 + aux (evar_filtered_context evi) args (* Check if an applied evar "?X[args] l" is a Miller's pattern *) @@ -688,7 +684,7 @@ let make_projectable_subst aliases sigma evi args = let all = Int.Map.add i [a, id] all in (rest,all,cstrs,revmap)) | _ -> anomaly (Pp.str "Instance does not match its signature.")) 0 - sign (Array.rev_to_list args,Int.Map.empty,Constrmap.empty,Id.Map.empty) in + sign (List.rev args,Int.Map.empty,Constrmap.empty,Id.Map.empty) in (full_subst,cstr_subst) (*------------------------------------* @@ -765,7 +761,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = (mkRel 1)::(List.map (lift 1) inst_in_sign), push_rel d env,evd,Id.Set.add id.binder_name avoid)) rel_sign - (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,avoid) + (sign1,filter1,args1,inst_in_sign,env1,evd,avoid) in let evd,ev2ty_in_sign = let s = Retyping.get_sort_of env evd ty_in_env in @@ -775,11 +771,12 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = ty_t_in_sign sign2 filter2 inst2_in_env in let (evd, ev2_in_sign) = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in - let ev2_in_env = (fst (destEvar evd ev2_in_sign), Array.of_list inst2_in_env) in + let ev2_in_env = (fst (destEvar evd ev2_in_sign), inst2_in_env) in (evd, ev2_in_sign, ev2_in_env) let restrict_upon_filter evd evk p args = let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in + let args = Array.of_list args in let len = Array.length args in Filter.restrict_upon oldfullfilter len (fun i -> p (Array.unsafe_get args i)) @@ -1034,7 +1031,7 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = let p = invert_arg fullenv evd aliases k evk subst arg in extract_unique_projection p in - Array.map invert args' + List.map invert args' (* Redefines an evar with a smaller context (i.e. it may depend on less * variables) such that c becomes closed. @@ -1390,9 +1387,9 @@ let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = try evdref := Evd.add_universe_constraints !evdref cstr; true with UniversesDiffer -> false in - if Array.equal eq_constr argsv1 argsv2 then !evdref else + if List.equal eq_constr argsv1 argsv2 then !evdref else (* Filter and restrict if needed *) - let args = Array.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in + let args = List.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in let untypedfilter = restrict_upon_filter evd evk (fun (a1,a2) -> unify flags TermUnification env evd Reduction.CONV a1 a2) args in @@ -1452,7 +1449,7 @@ let occur_evar_upto_types sigma n c = | Evar (sp,_) when Evar.equal sp n -> raise Occur | Evar (sp,args as e) -> if Evar.Set.mem sp !seen then - Array.iter occur_rec args + List.iter occur_rec args else ( seen := Evar.Set.add sp !seen; Option.iter occur_rec (existential_opt_value0 sigma e); @@ -1570,7 +1567,7 @@ let rec invert_definition unify flags choose imitate_defs (* Evar/Evar problem (but left evar is virtual) *) let aliases = lift_aliases k aliases in (try - let ev = (evk,Array.map (lift k) argsv) in + let ev = (evk,List.map (lift k) argsv) in let evd,body = project_evar_on_evar false unify flags env' !evdref aliases k None ev' ev in evdref := evd; body @@ -1648,7 +1645,7 @@ let rec invert_definition unify flags choose imitate_defs | [], [] -> true | _ -> false in - is_id_subst filter_ctxt (Array.to_list argsv) && + is_id_subst filter_ctxt argsv && closed0 evd rhs && Id.Set.subset (collect_vars evd rhs) !names in diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 0a1b731e6b..3fb80432ad 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -99,7 +99,7 @@ val refresh_universes : env -> evar_map -> types -> evar_map * types val solve_refl : ?can_drop:bool -> conversion_check -> unify_flags -> env -> evar_map -> - bool option -> Evar.t -> constr array -> constr array -> evar_map + bool option -> Evar.t -> constr list -> constr list -> evar_map val solve_evar_evar : ?force:bool -> (env -> evar_map -> bool option -> existential -> constr -> evar_map) -> @@ -128,7 +128,7 @@ val check_evar_instance : unifier -> unify_flags -> env -> evar_map -> Evar.t -> constr -> evar_map val remove_instance_local_defs : - evar_map -> Evar.t -> 'a array -> 'a list + evar_map -> Evar.t -> 'a list -> 'a list val get_type_of_refresh : ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index a006c82993..cb868e0480 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -60,12 +60,20 @@ let glob_sort_family = let open Sorts in function | UNamed [GSet,0] -> InSet | _ -> raise ComplexSort -let glob_sort_eq u1 u2 = match u1, u2 with +let glob_sort_expr_eq f u1 u2 = + match u1, u2 with | UAnonymous {rigid=r1}, UAnonymous {rigid=r2} -> r1 = r2 - | UNamed l1, UNamed l2 -> - List.equal (fun (x,m) (y,n) -> glob_sort_name_eq x y && Int.equal m n) l1 l2 + | UNamed l1, UNamed l2 -> f l1 l2 | (UNamed _ | UAnonymous _), _ -> false +let glob_sort_eq u1 u2 = + glob_sort_expr_eq + (List.equal (fun (x,m) (y,n) -> glob_sort_name_eq x y && Int.equal m n)) + u1 u2 + +let glob_level_eq u1 u2 = + glob_sort_expr_eq glob_sort_name_eq u1 u2 + let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Explicit, Explicit -> true | NonMaxImplicit, NonMaxImplicit -> true @@ -123,7 +131,9 @@ let instance_eq f (x1,c1) (x2,c2) = Id.equal x1 x2 && f c1 c2 let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with - | GRef (gr1, _), GRef (gr2, _) -> GlobRef.equal gr1 gr2 + | GRef (gr1, u1), GRef (gr2, u2) -> + GlobRef.equal gr1 gr2 && + Option.equal (List.equal glob_level_eq) u1 u2 | GVar id1, GVar id2 -> Id.equal id1 id2 | GEvar (id1, arg1), GEvar (id2, arg2) -> Id.equal id1 id2 && List.equal (instance_eq f) arg1 arg2 diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 14bf2f6764..6da8173dce 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -15,6 +15,8 @@ open Glob_term val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool +val glob_level_eq : Glob_term.glob_level -> Glob_term.glob_level -> bool + val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool (** Expect a Prop/SProp/Set/Type universe; raise [ComplexSort] if diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index c1ca40329a..d672ddc906 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -423,8 +423,8 @@ and nf_evar env sigma evk args = let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in let ty = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then begin - assert (Int.equal (Array.length args) 0); - mkEvar (evk, [||]), ty + assert (Array.is_empty args); + mkEvar (evk, []), ty end else (* Let-bound arguments are present in the evar arguments but not @@ -436,7 +436,7 @@ and nf_evar env sigma evk args = (* nf_args takes arguments in the reverse order but produces them in the correct one, so we have to reverse them again for the evar node *) - mkEvar (evk, Array.rev_of_list args), ty + mkEvar (evk, List.rev args), ty let evars_of_evar_map sigma = { Nativelambda.evars_val = Evd.existential_opt_value0 sigma; @@ -498,25 +498,29 @@ let native_norm env sigma c ty = Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); *) - let ml_filename, prefix = Nativelib.get_ml_filename () in - let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in let profile = get_profiling_enabled () in let print_timing = get_timing_enabled () in - let tc0 = Sys.time () in + let ml_filename, prefix = Nativelib.get_ml_filename () in + let tnc0 = Unix.gettimeofday () in + let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in + let tnc1 = Unix.gettimeofday () in + let time_info = Format.sprintf "native_compute: Conversion to native code done in %.5f" (tnc1 -. tnc0) in + if print_timing then Feedback.msg_info (Pp.str time_info); + let tc0 = Unix.gettimeofday () in let fn = Nativelib.compile ml_filename code ~profile:profile in - let tc1 = Sys.time () in - let time_info = Format.sprintf "native_compute: Compilation done in %.5f@." (tc1 -. tc0) in + let tc1 = Unix.gettimeofday () in + let time_info = Format.sprintf "native_compute: Compilation done in %.5f" (tc1 -. tc0) in if print_timing then Feedback.msg_info (Pp.str time_info); let profiler_pid = if profile then start_profiler () else None in - let t0 = Sys.time () in + let t0 = Unix.gettimeofday () in Nativelib.call_linker ~fatal:true env ~prefix fn (Some upd); - let t1 = Sys.time () in + let t1 = Unix.gettimeofday () in if profile then stop_profiler profiler_pid; - let time_info = Format.sprintf "native_compute: Evaluation done in %.5f@." (t1 -. t0) in + let time_info = Format.sprintf "native_compute: Evaluation done in %.5f" (t1 -. t0) in if print_timing then Feedback.msg_info (Pp.str time_info); let res = nf_val env sigma !Nativelib.rt1 ty in - let t2 = Sys.time () in - let time_info = Format.sprintf "native_compute: Reification done in %.5f@." (t2 -. t1) in + let t2 = Unix.gettimeofday () in + let time_info = Format.sprintf "native_compute: Reification done in %.5f" (t2 -. t1) in if print_timing then Feedback.msg_info (Pp.str time_info); EConstr.of_constr res diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index 3f2e690da5..1dfb8b2cd1 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -24,7 +24,7 @@ type case_info_pattern = type constr_pattern = | PRef of GlobRef.t | PVar of Id.t - | PEvar of Evar.t * constr_pattern array + | PEvar of constr_pattern Constr.pexistential | PRel of int | PApp of constr_pattern * constr_pattern array | PSoApp of patvar * constr_pattern list diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index b8635d03b7..6d30e0338e 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -31,7 +31,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with | PRef r1, PRef r2 -> GlobRef.equal r1 r2 | PVar v1, PVar v2 -> Id.equal v1 v2 | PEvar (ev1, ctx1), PEvar (ev2, ctx2) -> - Evar.equal ev1 ev2 && Array.equal constr_pattern_eq ctx1 ctx2 + Evar.equal ev1 ev2 && List.equal constr_pattern_eq ctx1 ctx2 | PRel i1, PRel i2 -> Int.equal i1 i2 | PApp (t1, arg1), PApp (t2, arg2) -> @@ -115,7 +115,7 @@ let rec occurn_pattern n = function (occurn_pattern n c) || (List.exists (fun (_,_,p) -> occurn_pattern n p) br) | PMeta _ | PSoApp _ -> true - | PEvar (_,args) -> Array.exists (occurn_pattern n) args + | PEvar (_,args) -> List.exists (occurn_pattern n) args | PVar _ | PRef _ | PSort _ | PInt _ | PFloat _ -> false | PFix (_,(_,tl,bl)) -> Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl @@ -190,7 +190,7 @@ let pattern_of_constr env sigma t = (* These are the two evar kinds used for existing goals *) (* see Proofview.mark_in_evm *) if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value0 sigma ev) - else PEvar (evk,Array.map (pattern_of_constr env) ctxt) + else PEvar (evk,List.map (pattern_of_constr env) ctxt) | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false | _ -> PMeta None) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 015c26531a..f7e3d651ff 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -438,7 +438,15 @@ let pretype_ref ?loc sigma env ref us = match ref with | GlobRef.VarRef id -> (* Section variable *) - (try sigma, make_judge (mkVar id) (NamedDecl.get_type (lookup_named id !!env)) + (try + let ty = NamedDecl.get_type (lookup_named id !!env) in + (match us with + | None | Some [] -> () + | Some (_ :: _) -> + CErrors.user_err ?loc + Pp.(str "Section variables are not polymorphic:" ++ spc () + ++ str "universe instance should have length 0.")); + sigma, make_judge (mkVar id) ty with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal @@ -599,7 +607,7 @@ let pretype_instance self ~program_mode ~poly resolve_tc env sigma loc hyps evk ((id,c)::subst, update, sigma) in let subst,inst,sigma = List.fold_right f hyps ([],update,sigma) in check_instance loc subst inst; - sigma, Array.map_of_list snd subst + sigma, List.map snd subst module Default = struct diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 70605d58ab..2c717b8774 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -86,7 +86,7 @@ let evaluable_reference_eq sigma r1 r2 = match r1, r2 with | EvalVar id1, EvalVar id2 -> Id.equal id1 id2 | EvalRel i1, EvalRel i2 -> Int.equal i1 i2 | EvalEvar (e1, ctx1), EvalEvar (e2, ctx2) -> - Evar.equal e1 e2 && Array.equal (EConstr.eq_constr sigma) ctx1 ctx2 + Evar.equal e1 e2 && List.equal (EConstr.eq_constr sigma) ctx1 ctx2 | _ -> false let mkEvalRef ref u = @@ -408,7 +408,7 @@ let substl_with_function subst sigma constr = let (sigma, evk) = Evarutil.new_pure_evar venv sigma dummy in evd := sigma; minargs := Evar.Map.add evk min !minargs; - Vars.lift k (mkEvar (evk, [|fx;ref|])) + Vars.lift k (mkEvar (evk, [fx; ref])) | (fx, None) -> Vars.lift k fx else mkRel (i - Array.length v) | _ -> @@ -455,7 +455,7 @@ let substl_checking_arity env subst sigma c = (* we propagate the constraints: solved problems are substituted; the other ones are replaced by the function symbol *) let rec nf_fix c = match EConstr.kind sigma c with - | Evar (i,[|fx;f|]) when Evar.Map.mem i minargs -> + | Evar (i,[fx;f]) when Evar.Map.mem i minargs -> (* FIXME: find a less hackish way of doing this *) begin match EConstr.kind sigma' c with | Evar _ -> f diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e168f6d1b6..f5aaac315a 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -76,7 +76,7 @@ let occur_meta_or_undefined_evar evd c = | Evar (ev,args) -> (match evar_body (Evd.find evd ev) with | Evar_defined c -> - occrec (EConstr.Unsafe.to_constr c); Array.iter occrec args + occrec (EConstr.Unsafe.to_constr c); List.iter occrec args | Evar_empty -> raise Occur) | _ -> Constr.iter occrec c in try occrec c; false with Occur | Not_found -> true @@ -138,9 +138,9 @@ let abstract_list_all env evd typ c l = error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in evd,(p,typp) -let set_occurrences_of_last_arg args = +let set_occurrences_of_last_arg n = Evarconv.AtOccurrences AllOccurrences :: - List.tl (Array.map_to_list (fun _ -> Evarconv.Unspecified Abstraction.Abstract) args) + List.tl (List.init n (fun _ -> Evarconv.Unspecified Abstraction.Abstract)) let occurrence_test _ _ _ env sigma _ c1 c2 = match EConstr.eq_constr_universes env sigma c1 c2 with @@ -153,7 +153,8 @@ let abstract_list_all_with_dependencies env evd typ c l = let (evd, ev) = new_evar env evd typ in let evd,ev' = evar_absorb_arguments env evd (destEvar evd ev) l in let n = List.length l in - let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in + let () = assert (n <= List.length (snd ev')) in + let argoccs = set_occurrences_of_last_arg n in let evd,b = Evarconv.second_order_matching (Evarconv.default_flags_of TransparentState.empty) @@ -623,7 +624,7 @@ let subst_defined_metas_evars sigma (bl,el) c = substrec (EConstr.Unsafe.to_constr (pi2 (List.find select bl))) | Evar (evk,args) -> let eq c1 c2 = Constr.equal c1 (EConstr.Unsafe.to_constr c2) in - let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.for_all2 eq args args' in + let select (_,(evk',args'),_) = Evar.equal evk evk' && List.for_all2 eq args args' in (try substrec (EConstr.Unsafe.to_constr (pi3 (List.find select el))) with Not_found -> Constr.map substrec c) | _ -> Constr.map substrec c diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index d4da93cc5b..37c34d55cf 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -205,7 +205,7 @@ and nf_evar env sigma evk stk = let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in let concl = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then - nf_stk env sigma (mkEvar (evk, [||])) concl stk + nf_stk env sigma (mkEvar (evk, [])) concl stk else match stk with | Zapp args :: stk -> (* We assume that there is no consecutive Zapp nodes in a VM stack. Is that @@ -217,6 +217,7 @@ and nf_evar env sigma evk stk = let t = List.fold_left fold concl hyps in let t, args = nf_args env sigma args t in let inst, args = Array.chop (List.length hyps) args in + let inst = Array.to_list inst in let c = mkApp (mkEvar (evk, inst), args) in nf_stk env sigma c t stk | _ -> diff --git a/printing/printer.ml b/printing/printer.ml index 81c0a36f53..c2f73715f0 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -989,4 +989,5 @@ let print_and_diff oldp newp = let pr_typing_flags flags = str "check_guarded: " ++ bool flags.check_guarded ++ fnl () ++ str "check_positive: " ++ bool flags.check_positive ++ fnl () - ++ str "check_universes: " ++ bool flags.check_universes + ++ str "check_universes: " ++ bool flags.check_universes ++ fnl () + ++ str "cumulative sprop: " ++ bool flags.cumulative_sprop diff --git a/proofs/goal.ml b/proofs/goal.ml index b1f8fd3e97..53d3047bc7 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -69,7 +69,7 @@ module V82 = struct let (evars, evk) = Evarutil.new_pure_evar_full evars ~typeclass_candidate:false evi in let evars = Evd.restore_future_goals evars prev_future_goals in let ctxt = Environ.named_context_of_val hyps in - let inst = Array.map_of_list (NamedDecl.get_id %> EConstr.mkVar) ctxt in + let inst = List.map (NamedDecl.get_id %> EConstr.mkVar) ctxt in let ev = EConstr.mkEvar (evk,inst) in (evk, ev, evars) diff --git a/proofs/proof.ml b/proofs/proof.ml index 21006349d2..75aca7e7ff 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -63,7 +63,7 @@ exception CannotUnfocusThisWay (* Cannot focus on non-existing subgoals *) exception NoSuchGoals of int * int -exception NoSuchGoal of Names.Id.t +exception NoSuchGoal of Names.Id.t option exception FullyUnfocused @@ -74,8 +74,10 @@ let _ = CErrors.register_handler begin function Some Pp.(str "[Focus] No such goal (" ++ int i ++ str").") | NoSuchGoals (i,j) -> Some Pp.(str "[Focus] Not every goal in range ["++ int i ++ str","++int j++str"] exist.") - | NoSuchGoal id -> + | NoSuchGoal (Some id) -> Some Pp.(str "[Focus] No such goal: " ++ str (Names.Id.to_string id) ++ str ".") + | NoSuchGoal None -> + Some Pp.(str "[Focus] No such goal.") | FullyUnfocused -> Some (Pp.str "The proof is not focused") | _ -> None @@ -233,7 +235,7 @@ let focus_id cond inf id pr = raise CannotUnfocusThisWay end | None -> - raise (NoSuchGoal id) + raise (NoSuchGoal (Some id)) end let rec unfocus kind pr () = @@ -506,3 +508,124 @@ let pr_proof p = str "given up: " ++ pr_goal_list given_up ++ str "]" ) + +let use_unification_heuristics = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Solve";"Unification";"Constraints"] + ~value:true + +exception SuggestNoSuchGoals of int * t + +let solve ?with_end_tac gi info_lvl tac pr = + let tac = match with_end_tac with + | None -> tac + | Some etac -> Proofview.tclTHEN tac etac in + let tac = match info_lvl with + | None -> tac + | Some _ -> Proofview.Trace.record_info_trace tac + in + let nosuchgoal = Proofview.tclZERO (SuggestNoSuchGoals (1,pr)) in + let tac = let open Goal_select in match gi with + | SelectAlreadyFocused -> + let open Proofview.Notations in + Proofview.numgoals >>= fun n -> + if n == 1 then tac + else + let e = CErrors.UserError + (None, + Pp.(str "Expected a single focused goal but " ++ + int n ++ str " goals are focused.")) + in + Proofview.tclZERO e + + | SelectNth i -> Proofview.tclFOCUS ~nosuchgoal i i tac + | SelectList l -> Proofview.tclFOCUSLIST ~nosuchgoal l tac + | SelectId id -> Proofview.tclFOCUSID ~nosuchgoal id tac + | SelectAll -> tac + in + let tac = + if use_unification_heuristics () then + Proofview.tclTHEN tac Refine.solve_constraints + else tac + in + let env = Global.env () in + let (p,(status,info),()) = run_tactic env tac pr in + let env = Global.env () in + let sigma = Evd.from_env env in + let () = + match info_lvl with + | None -> () + | Some i -> Feedback.msg_info (Pp.hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) + in + (p,status) + +(**********************************************************************) +(* Shortcut to build a term using tactics *) + +let refine_by_tactic ~name ~poly env sigma ty tac = + (* Save the initial side-effects to restore them afterwards. We set the + current set of side-effects to be empty so that we can retrieve the + ones created during the tactic invocation easily. *) + let eff = Evd.eval_side_effects sigma in + let sigma = Evd.drop_side_effects sigma in + (* Save the existing goals *) + let prev_future_goals = Evd.save_future_goals sigma in + (* Start a proof *) + let prf = start ~name ~poly sigma [env, ty] in + let (prf, _, ()) = + try run_tactic env tac prf + with Logic_monad.TacticFailure e as src -> + (* Catch the inner error of the monad tactic *) + let (_, info) = Exninfo.capture src in + Exninfo.iraise (e, info) + in + (* Plug back the retrieved sigma *) + let { goals; stack; shelf; given_up; sigma; entry } = data prf in + assert (stack = []); + let ans = match Proofview.initial_goals entry with + | [c, _] -> c + | _ -> assert false + in + let ans = EConstr.to_constr ~abort_on_undefined_evars:false sigma ans in + (* [neff] contains the freshly generated side-effects *) + let neff = Evd.eval_side_effects sigma in + (* Reset the old side-effects *) + let sigma = Evd.drop_side_effects sigma in + let sigma = Evd.emit_side_effects eff sigma in + (* Restore former goals *) + let sigma = Evd.restore_future_goals sigma prev_future_goals in + (* Push remaining goals as future_goals which is the only way we + have to inform the caller that there are goals to collect while + not being encapsulated in the monad *) + (* Goals produced by tactic "shelve" *) + let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in + (* Goals produced by tactic "give_up" *) + let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in + (* Other goals *) + let sigma = List.fold_right Evd.declare_future_goal goals sigma in + (* Get rid of the fresh side-effects by internalizing them in the term + itself. Note that this is unsound, because the tactic may have solved + other goals that were already present during its invocation, so that + those goals rely on effects that are not present anymore. Hopefully, + this hack will work in most cases. *) + let neff = neff.Evd.seff_private in + let (ans, _) = Safe_typing.inline_private_constants env ((ans, Univ.ContextSet.empty), neff) in + ans, sigma + +let get_nth_V82_goal p i = + let { sigma; goals } = data p in + try { Evd.it = List.nth goals (i-1) ; sigma } + with Failure _ -> raise (NoSuchGoal None) + +let get_goal_context_gen pf i = + let { Evd.it=goal ; sigma=sigma; } = get_nth_V82_goal pf i in + (sigma, Global.env_of_context (Goal.V82.hyps sigma goal)) + +let get_proof_context p = + try get_goal_context_gen p 1 + with + | NoSuchGoal _ -> + (* No more focused goals *) + let { sigma } = data p in + sigma, Global.env () diff --git a/proofs/proof.mli b/proofs/proof.mli index 1a0b105723..0e5bdaf07d 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -143,6 +143,8 @@ exception CannotUnfocusThisWay Bullet.push. *) exception NoSuchGoals of int * int +exception NoSuchGoal of Names.Id.t option + (* Unfocusing command. Raises [FullyUnfocused] if the proof is not focused. Raises [CannotUnfocusThisWay] if the proof the unfocusing condition @@ -207,3 +209,41 @@ end (* returns the set of all goals in the proof *) val all_goals : t -> Goal.Set.t + +(** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th + subgoal of the current focused proof. [solve SelectAll + tac] applies [tac] to all subgoals. *) + +val solve : + ?with_end_tac:unit Proofview.tactic + -> Goal_select.t + -> int option + -> unit Proofview.tactic + -> t + -> t * bool + +(** Option telling if unification heuristics should be used. *) +val use_unification_heuristics : unit -> bool + +val refine_by_tactic + : name:Names.Id.t + -> poly:bool + -> Environ.env + -> Evd.evar_map + -> EConstr.types + -> unit Proofview.tactic + -> Constr.constr * Evd.evar_map +(** A variant of the above function that handles open terms as well. + Caveat: all effects are purged in the returned term at the end, but other + evars solved by side-effects are NOT purged, so that unexpected failures may + occur. Ideally all code using this function should be rewritten in the + monad. *) + +exception SuggestNoSuchGoals of int * t + +(** {6 Helpers to obtain proof state when in an interactive proof } *) +val get_goal_context_gen : t -> int -> Evd.evar_map * Environ.env + +(** [get_proof_context ()] gets the goal context for the first subgoal + of the proof *) +val get_proof_context : t -> Evd.evar_map * Environ.env diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index f619bc86a1..41cb7399da 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -191,11 +191,8 @@ let put p b = let suggest p = (current_behavior ()).suggest p -(* Better printing for bullet exceptions *) -exception SuggestNoSuchGoals of int * Proof.t - let _ = CErrors.register_handler begin function - | SuggestNoSuchGoals(n,proof) -> + | Proof.SuggestNoSuchGoals(n,proof) -> let suffix = suggest proof in Some (Pp.(str "No such " ++ str (CString.plural n "goal") ++ str "." ++ pr_non_empty_arg (fun x -> x) suffix)) diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index 687781361c..f15b7824ff 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -44,5 +44,3 @@ val register_behavior : behavior -> unit *) val put : Proof.t -> t -> Proof.t val suggest : Proof.t -> Pp.t - -exception SuggestNoSuchGoals of int * Proof.t diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 6a78dd5529..2ff76e69f8 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -50,7 +50,7 @@ let is_focused_goal_simple ~doc id = | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { Vernacstate.lemmas }) -> Option.cata (Vernacstate.LemmaStack.with_top_pstate ~f:(fun proof -> - let proof = Proof_global.get_proof proof in + let proof = Declare.Proof.get_proof proof in let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in if List.for_all (fun x -> simple_goal sigma x rest) focused diff --git a/stm/stm.ml b/stm/stm.ml index 5b88ee3d68..f3768e9b99 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -27,7 +27,7 @@ open Feedback open Vernacexpr open Vernacextend -module PG_compat = Vernacstate.Proof_global [@@ocaml.warning "-3"] +module PG_compat = Vernacstate.Declare [@@ocaml.warning "-3"] let is_vtkeep = function VtKeep _ -> true | _ -> false let get_vtkeep = function VtKeep x -> x | _ -> assert false @@ -147,7 +147,7 @@ let update_global_env () = PG_compat.update_global_env () module Vcs_ = Vcs.Make(Stateid.Self) -type future_proof = Proof_global.closed_proof_output Future.computation +type future_proof = Declare.closed_proof_output Future.computation type depth = int type branch_type = @@ -1164,7 +1164,7 @@ end = struct (* {{{ *) let get_proof ~doc id = match state_of_id ~doc id with - | `Valid (Some vstate) -> Option.map (Vernacstate.LemmaStack.with_top_pstate ~f:Proof_global.get_proof) vstate.Vernacstate.lemmas + | `Valid (Some vstate) -> Option.map (Vernacstate.LemmaStack.with_top_pstate ~f:Declare.Proof.get_proof) vstate.Vernacstate.lemmas | _ -> None let undo_vernac_classifier v ~doc = @@ -1358,7 +1358,7 @@ module rec ProofTask : sig t_stop : Stateid.t; t_drop : bool; t_states : competence; - t_assign : Proof_global.closed_proof_output Future.assignment -> unit; + t_assign : Declare.closed_proof_output Future.assignment -> unit; t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1381,7 +1381,7 @@ module rec ProofTask : sig ?loc:Loc.t -> drop_pt:bool -> Stateid.t * Stateid.t -> Stateid.t -> - Proof_global.closed_proof_output Future.computation + Declare.closed_proof_output Future.computation (* If set, only tasks overlapping with this list are processed *) val set_perspective : Stateid.t list -> unit @@ -1397,7 +1397,7 @@ end = struct (* {{{ *) t_stop : Stateid.t; t_drop : bool; t_states : competence; - t_assign : Proof_global.closed_proof_output Future.assignment -> unit; + t_assign : Declare.closed_proof_output Future.assignment -> unit; t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1419,7 +1419,7 @@ end = struct (* {{{ *) e_safe_states : Stateid.t list } type response = - | RespBuiltProof of Proof_global.closed_proof_output * float + | RespBuiltProof of Declare.closed_proof_output * float | RespError of error | RespStates of (Stateid.t * State.partial_state) list @@ -1530,7 +1530,7 @@ end = struct (* {{{ *) PG_compat.close_future_proof ~feedback_id:stop (Future.from_val ~fix_exn p) in let st = Vernacstate.freeze_interp_state ~marshallable:false in - let opaque = Proof_global.Opaque in + let opaque = Declare.Opaque in stm_qed_delay_proof ~st ~id:stop ~proof:pobject ~info:(Lemmas.Info.make ()) ~loc ~control:[] (Proved (opaque,None))) in ignore(Future.join checked_proof); @@ -1664,7 +1664,7 @@ end = struct (* {{{ *) let _proof = PG_compat.return_partial_proof () in `OK_ADMITTED else begin - let opaque = Proof_global.Opaque in + let opaque = Declare.Opaque in (* The original terminator, a hook, has not been saved in the .vio*) let proof, _info = @@ -1723,7 +1723,7 @@ end = struct (* {{{ *) | `ERROR -> exit 1 | `ERROR_ADMITTED -> cst, false | `OK_ADMITTED -> cst, false - | `OK { Proof_global.name } -> + | `OK { Declare.name } -> let con = Nametab.locate_constant (Libnames.qualid_of_ident name) in let c = Global.lookup_constant con in let o = match c.Declarations.const_body with @@ -2149,7 +2149,7 @@ let collect_proof keep cur hd brkind id = | id :: _ -> Names.Id.to_string id in let loc = (snd cur).expr.CAst.loc in let is_defined_expr = function - | VernacEndProof (Proved (Proof_global.Transparent,_)) -> true + | VernacEndProof (Proved (Declare.Transparent,_)) -> true | _ -> false in let is_defined = function | _, { expr = e } -> is_defined_expr e.CAst.v.expr @@ -2310,7 +2310,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = Option.iter PG_compat.unfreeze lemmas; PG_compat.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; - fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); + fst (Proof.solve Goal_select.SelectAll None tac p), ()); (* STATE SPEC: * - start: Modifies the input state adding a proof. * - end : maybe after recovery command. @@ -2514,7 +2514,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeep VtKeepAxiom -> qed.fproof <- Some (None, ref false); None | VtKeep opaque -> - let opaque = let open Proof_global in match opaque with + let opaque = let open Declare in match opaque with | VtKeepOpaque -> Opaque | VtKeepDefined -> Transparent | VtKeepAxiom -> assert false in diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 567acb1c73..cf127648b4 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -37,7 +37,7 @@ let string_of_vernac_classification = function | VtMeta -> "Meta " | VtProofMode _ -> "Proof Mode" -let vtkeep_of_opaque = let open Proof_global in function +let vtkeep_of_opaque = let open Declare in function | Opaque -> VtKeepOpaque | Transparent -> VtKeepDefined diff --git a/tactics/abstract.ml b/tactics/abstract.ml index e85d94cd72..6b575d0807 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -11,7 +11,6 @@ open Util open Termops open EConstr -open Evarutil module NamedDecl = Context.Named.Declaration @@ -41,6 +40,9 @@ let name_op_to_name ~name_op ~name suffix = | Some s -> s | None -> Nameops.add_suffix name suffix +let declare_abstract = ref (fun ~name ~poly ~kind ~sign ~secsign ~opaque ~solve_tac sigma concl -> + CErrors.anomaly (Pp.str "Abstract declaration hook not registered")) + let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let open Tacticals.New in let open Tacmach.New in @@ -76,61 +78,9 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = | None -> Proofview.Goal.concl gl | Some ty -> ty in let concl = it_mkNamedProd_or_LetIn concl sign in - let concl = - try flush_and_check_evars sigma concl - with Uninstantiated_evar _ -> - CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials.") in - - let sigma, ctx, concl = - (* FIXME: should be done only if the tactic succeeds *) - let sigma = Evd.minimize_universes sigma in - let ctx = Evd.universe_context_set sigma in - sigma, ctx, Evarutil.nf_evars_universes sigma concl - in - let concl = EConstr.of_constr concl in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) Tactics.intro) tac) in - let ectx = Evd.evar_universe_context sigma in - let (const, safe, ectx) = - try Pfedit.build_constant_by_tactic ~name ~opaque:Proof_global.Transparent ~poly ~uctx:ectx ~sign:secsign concl solve_tac - with Logic_monad.TacticFailure e as src -> - (* if the tactic [tac] fails, it reports a [TacticFailure e], - which is an error irrelevant to the proof system (in fact it - means that [e] comes from [tac] failing to yield enough - success). Hence it reraises [e]. *) - let (_, info) = Exninfo.capture src in - Exninfo.iraise (e, info) - in - let body, effs = Future.force const.Declare.proof_entry_body in - (* We drop the side-effects from the entry, they already exist in the ambient environment *) - let const = Declare.Internal.map_entry_body const ~f:(fun _ -> body, ()) in - (* EJGA: Hack related to the above call to - `build_constant_by_tactic` with `~opaque:Transparent`. Even if - the abstracted term is destined to be opaque, if we trigger the - `if poly && opaque && private_poly_univs ()` in `Proof_global` - kernel will boom. This deserves more investigation. *) - let const = Declare.Internal.set_opacity ~opaque const in - let const, args = Declare.Internal.shrink_entry sign const in - let args = List.map EConstr.of_constr args in - let cst () = - (* do not compute the implicit arguments, it may be costly *) - let () = Impargs.make_implicit_args false in - (* ppedrot: seems legit to have abstracted subproofs as local*) - Declare.declare_private_constant ~local:Declare.ImportNeedQualified ~name ~kind const - in - let cst, eff = Impargs.with_implicit_protection cst () in - let inst = match const.Declare.proof_entry_universes with - | Entries.Monomorphic_entry _ -> EInstance.empty - | Entries.Polymorphic_entry (_, ctx) -> - (* We mimic what the kernel does, that is ensuring that no additional - constraints appear in the body of polymorphic constants. Ideally this - should be enforced statically. *) - let (_, body_uctx), _ = Future.force const.Declare.proof_entry_body in - let () = assert (Univ.ContextSet.is_empty body_uctx) in - EInstance.make (Univ.UContext.instance ctx) - in - let lem = mkConstU (cst, inst) in - let sigma = Evd.set_universe_context sigma ectx in - let effs = Evd.concat_side_effects eff effs in + let effs, sigma, lem, args, safe = + !declare_abstract ~name ~poly ~sign ~secsign ~kind ~opaque ~solve_tac sigma concl in let solve = Proofview.tclEFFECTS effs <*> tacK lem args diff --git a/tactics/abstract.mli b/tactics/abstract.mli index 5c936ff9d6..a138a457b3 100644 --- a/tactics/abstract.mli +++ b/tactics/abstract.mli @@ -20,3 +20,15 @@ val cache_term_by_tactic_then -> unit Proofview.tactic val tclABSTRACT : ?opaque:bool -> Id.t option -> unit Proofview.tactic -> unit Proofview.tactic + +val declare_abstract : + ( name:Names.Id.t + -> poly:bool + -> kind:Decls.logical_kind + -> sign:EConstr.named_context + -> secsign:Environ.named_context_val + -> opaque:bool + -> solve_tac:unit Proofview.tactic + -> Evd.evar_map + -> EConstr.t + -> Evd.side_effects * Evd.evar_map * EConstr.t * EConstr.t list * bool) ref diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 57eab7ddf8..a51fc8b347 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1188,7 +1188,7 @@ let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = with Refiner.FailError _ -> raise Not_found in let evd = sig_sig gls' in - let t' = mkEvar (ev, Array.of_list subst) in + let t' = mkEvar (ev, subst) in let term = Evarutil.nf_evar evd t' in term, evd end in diff --git a/tactics/declare.ml b/tactics/declare.ml deleted file mode 100644 index 324007930a..0000000000 --- a/tactics/declare.ml +++ /dev/null @@ -1,512 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** This module is about the low-level declaration of logical objects *) - -open Pp -open Util -open Names -open Declarations -open Entries -open Safe_typing -open Libobject -open Lib - -(* object_kind , id *) -exception AlreadyDeclared of (string option * Id.t) - -let _ = CErrors.register_handler (function - | AlreadyDeclared (kind, id) -> - Some - (seq [ Pp.pr_opt_no_spc (fun s -> str s ++ spc ()) kind - ; Id.print id; str " already exists."]) - | _ -> - None) - -module NamedDecl = Context.Named.Declaration - -type import_status = ImportDefaultBehavior | ImportNeedQualified - -(** Monomorphic universes need to survive sections. *) - -let name_instance inst = - let map lvl = match Univ.Level.name lvl with - | None -> (* Having Prop/Set/Var as section universes makes no sense *) - assert false - | Some na -> - try - let qid = Nametab.shortest_qualid_of_universe na in - Name (Libnames.qualid_basename qid) - with Not_found -> - (* Best-effort naming from the string representation of the level. - See univNames.ml for a similar hack. *) - Name (Id.of_string_soft (Univ.Level.to_string lvl)) - in - Array.map map (Univ.Instance.to_array inst) - -let declare_universe_context ~poly ctx = - if poly then - let uctx = Univ.ContextSet.to_context ctx in - let nas = name_instance (Univ.UContext.instance uctx) in - Global.push_section_context (nas, uctx) - else - Global.push_context_set ~strict:true ctx - -(** Declaration of constants and parameters *) - -type constant_obj = { - cst_kind : Decls.logical_kind; - cst_locl : import_status; -} - -type 'a proof_entry = { - proof_entry_body : 'a Entries.const_entry_body; - (* List of section variables *) - proof_entry_secctx : Id.Set.t option; - (* State id on which the completion of type checking is reported *) - proof_entry_feedback : Stateid.t option; - proof_entry_type : Constr.types option; - proof_entry_universes : Entries.universes_entry; - proof_entry_opaque : bool; - proof_entry_inline_code : bool; -} - -type 'a constant_entry = - | DefinitionEntry of 'a proof_entry - | ParameterEntry of parameter_entry - | PrimitiveEntry of primitive_entry - -(* At load-time, the segment starting from the module name to the discharge *) -(* section (if Remark or Fact) is needed to access a construction *) -let load_constant i ((sp,kn), obj) = - if Nametab.exists_cci sp then - raise (AlreadyDeclared (None, Libnames.basename sp)); - let con = Global.constant_of_delta_kn kn in - Nametab.push (Nametab.Until i) sp (GlobRef.ConstRef con); - Dumpglob.add_constant_kind con obj.cst_kind - -(* Opening means making the name without its module qualification available *) -let open_constant i ((sp,kn), obj) = - (* Never open a local definition *) - match obj.cst_locl with - | ImportNeedQualified -> () - | ImportDefaultBehavior -> - let con = Global.constant_of_delta_kn kn in - Nametab.push (Nametab.Exactly i) sp (GlobRef.ConstRef con) - -let exists_name id = - Decls.variable_exists id || Global.exists_objlabel (Label.of_id id) - -let check_exists id = - if exists_name id then - raise (AlreadyDeclared (None, id)) - -let cache_constant ((sp,kn), obj) = - (* Invariant: the constant must exist in the logical environment, except when - redefining it when exiting a section. See [discharge_constant]. *) - let kn' = - if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) - then Constant.make1 kn - else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") - in - assert (Constant.equal kn' (Constant.make1 kn)); - Nametab.push (Nametab.Until 1) sp (GlobRef.ConstRef (Constant.make1 kn)); - Dumpglob.add_constant_kind (Constant.make1 kn) obj.cst_kind - -let discharge_constant ((sp, kn), obj) = - Some obj - -(* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_constant cst = { - cst_kind = cst.cst_kind; - cst_locl = cst.cst_locl; -} - -let classify_constant cst = Substitute (dummy_constant cst) - -let (objConstant : constant_obj Libobject.Dyn.tag) = - declare_object_full { (default_object "CONSTANT") with - cache_function = cache_constant; - load_function = load_constant; - open_function = open_constant; - classify_function = classify_constant; - subst_function = ident_subst_function; - discharge_function = discharge_constant } - -let inConstant v = Libobject.Dyn.Easy.inj v objConstant - -let update_tables c = - Impargs.declare_constant_implicits c; - Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstRef c) - -let register_constant kn kind local = - let o = inConstant { - cst_kind = kind; - cst_locl = local; - } in - let id = Label.to_id (Constant.label kn) in - let _ = add_leaf id o in - update_tables kn - -let register_side_effect (c, role) = - let () = register_constant c Decls.(IsProof Theorem) ImportDefaultBehavior in - match role with - | None -> () - | Some (Evd.Schema (ind, kind)) -> DeclareScheme.declare_scheme kind [|ind,c|] - -let get_roles export eff = - let map c = - let role = try Some (Cmap.find c eff.Evd.seff_roles) with Not_found -> None in - (c, role) - in - List.map map export - -let export_side_effects eff = - let export = Global.export_private_constants eff.Evd.seff_private in - let export = get_roles export eff in - List.iter register_side_effect export - -let record_aux env s_ty s_bo = - let open Environ in - let in_ty = keep_hyps env s_ty in - let v = - String.concat " " - (CList.map_filter (fun decl -> - let id = NamedDecl.get_id decl in - if List.exists (NamedDecl.get_id %> Id.equal id) in_ty then None - else Some (Id.to_string id)) - (keep_hyps env s_bo)) in - Aux_file.record_in_aux "context_used" v - -let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty - -let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?types - ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) ?(univsbody=Univ.ContextSet.empty) body = - { proof_entry_body = Future.from_val ?fix_exn ((body,univsbody), eff); - proof_entry_secctx = section_vars; - proof_entry_type = types; - proof_entry_universes = univs; - proof_entry_opaque = opaque; - proof_entry_feedback = feedback_id; - proof_entry_inline_code = inline} - -let pure_definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types - ?(univs=default_univ_entry) body = - { proof_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), ()); - proof_entry_secctx = None; - proof_entry_type = types; - proof_entry_universes = univs; - proof_entry_opaque = opaque; - proof_entry_feedback = None; - proof_entry_inline_code = inline} - -let delayed_definition_entry ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?(univs=default_univ_entry) ?types body = - { proof_entry_body = body - ; proof_entry_secctx = section_vars - ; proof_entry_type = types - ; proof_entry_universes = univs - ; proof_entry_opaque = opaque - ; proof_entry_feedback = feedback_id - ; proof_entry_inline_code = inline - } - -let cast_proof_entry e = - let (body, ctx), () = Future.force e.proof_entry_body in - let univs = - if Univ.ContextSet.is_empty ctx then e.proof_entry_universes - else match e.proof_entry_universes with - | Monomorphic_entry ctx' -> - (* This can actually happen, try compiling EqdepFacts for instance *) - Monomorphic_entry (Univ.ContextSet.union ctx' ctx) - | Polymorphic_entry _ -> - CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition."); - in - { - const_entry_body = body; - const_entry_secctx = e.proof_entry_secctx; - const_entry_feedback = e.proof_entry_feedback; - const_entry_type = e.proof_entry_type; - const_entry_universes = univs; - const_entry_inline_code = e.proof_entry_inline_code; - } - -type ('a, 'b) effect_entry = -| EffectEntry : (private_constants, private_constants Entries.const_entry_body) effect_entry -| PureEntry : (unit, Constr.constr) effect_entry - -let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proof_entry) : b opaque_entry = - let typ = match e.proof_entry_type with - | None -> assert false - | Some typ -> typ - in - let secctx = match e.proof_entry_secctx with - | None -> - let open Environ in - let env = Global.env () in - let hyp_typ, hyp_def = - if List.is_empty (Environ.named_context env) then - Id.Set.empty, Id.Set.empty - else - let ids_typ = global_vars_set env typ in - let pf, env = match entry with - | PureEntry -> - let (pf, _), () = Future.force e.proof_entry_body in - pf, env - | EffectEntry -> - let (pf, _), eff = Future.force e.proof_entry_body in - let env = Safe_typing.push_private_constants env eff in - pf, env - in - let vars = global_vars_set env pf in - ids_typ, vars - in - let () = if Aux_file.recording () then record_aux env hyp_typ hyp_def in - Environ.really_needed env (Id.Set.union hyp_typ hyp_def) - | Some hyps -> hyps - in - let (body, univs : b * _) = match entry with - | PureEntry -> - let (body, uctx), () = Future.force e.proof_entry_body in - let univs = match e.proof_entry_universes with - | Monomorphic_entry uctx' -> Monomorphic_entry (Univ.ContextSet.union uctx uctx') - | Polymorphic_entry _ -> - assert (Univ.ContextSet.is_empty uctx); - e.proof_entry_universes - in - body, univs - | EffectEntry -> e.proof_entry_body, e.proof_entry_universes - in - { - opaque_entry_body = body; - opaque_entry_secctx = secctx; - opaque_entry_feedback = e.proof_entry_feedback; - opaque_entry_type = typ; - opaque_entry_universes = univs; - } - -let feedback_axiom () = Feedback.(feedback AddedAxiom) - -let is_unsafe_typing_flags () = - let flags = Environ.typing_flags (Global.env()) in - not (flags.check_universes && flags.check_guarded && flags.check_positive) - -let define_constant ~name cd = - (* Logically define the constant and its subproofs, no libobject tampering *) - let decl, unsafe = match cd with - | DefinitionEntry de -> - (* We deal with side effects *) - if not de.proof_entry_opaque then - let body, eff = Future.force de.proof_entry_body in - (* This globally defines the side-effects in the environment - and registers their libobjects. *) - let () = export_side_effects eff in - let de = { de with proof_entry_body = Future.from_val (body, ()) } in - let cd = Entries.DefinitionEntry (cast_proof_entry de) in - ConstantEntry cd, false - else - let map (body, eff) = body, eff.Evd.seff_private in - let body = Future.chain de.proof_entry_body map in - let de = { de with proof_entry_body = body } in - let de = cast_opaque_proof_entry EffectEntry de in - OpaqueEntry de, false - | ParameterEntry e -> - ConstantEntry (Entries.ParameterEntry e), not (Lib.is_modtype_strict()) - | PrimitiveEntry e -> - ConstantEntry (Entries.PrimitiveEntry e), false - in - let kn = Global.add_constant name decl in - if unsafe || is_unsafe_typing_flags() then feedback_axiom(); - kn - -let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = - let () = check_exists name in - let kn = define_constant ~name cd in - (* Register the libobjects attached to the constants *) - let () = register_constant kn kind local in - kn - -let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind de = - let kn, eff = - let de = - if not de.proof_entry_opaque then - DefinitionEff (cast_proof_entry de) - else - let de = cast_opaque_proof_entry PureEntry de in - OpaqueEff de - in - Global.add_private_constant name de - in - let () = register_constant kn kind local in - let seff_roles = match role with - | None -> Cmap.empty - | Some r -> Cmap.singleton kn r - in - let eff = { Evd.seff_private = eff; Evd.seff_roles; } in - kn, eff - -let inline_private_constants ~uctx env ce = - let body, eff = Future.force ce.proof_entry_body in - let cb, ctx = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in - let uctx = UState.merge ~sideff:true Evd.univ_rigid uctx ctx in - cb, uctx - -(** Declaration of section variables and local definitions *) -type variable_declaration = - | SectionLocalDef of Evd.side_effects proof_entry - | SectionLocalAssum of { typ:Constr.types; impl:Glob_term.binding_kind; } - -(* This object is only for things which iterate over objects to find - variables (only Prettyp.print_context AFAICT) *) -let objVariable : unit Libobject.Dyn.tag = - declare_object_full { (default_object "VARIABLE") with - classify_function = (fun () -> Dispose)} - -let inVariable v = Libobject.Dyn.Easy.inj v objVariable - -let declare_variable ~name ~kind d = - (* Variables are distinguished by only short names *) - if Decls.variable_exists name then - raise (AlreadyDeclared (None, name)); - - let impl,opaque = match d with (* Fails if not well-typed *) - | SectionLocalAssum {typ;impl} -> - let () = Global.push_named_assum (name,typ) in - impl, true - | SectionLocalDef (de) -> - (* The body should already have been forced upstream because it is a - section-local definition, but it's not enforced by typing *) - let ((body, body_ui), eff) = Future.force de.proof_entry_body in - let () = export_side_effects eff in - let poly, entry_ui = match de.proof_entry_universes with - | Monomorphic_entry uctx -> false, uctx - | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx - in - let univs = Univ.ContextSet.union body_ui entry_ui in - (* We must declare the universe constraints before type-checking the - term. *) - let () = declare_universe_context ~poly univs in - let se = { - secdef_body = body; - secdef_secctx = de.proof_entry_secctx; - secdef_feedback = de.proof_entry_feedback; - secdef_type = de.proof_entry_type; - } in - let () = Global.push_named_def (name, se) in - Glob_term.Explicit, de.proof_entry_opaque - in - Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); - Decls.(add_variable_data name {opaque;kind}); - ignore(add_leaf name (inVariable ()) : Libobject.object_name); - Impargs.declare_var_implicits ~impl name; - Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) - -(* Declaration messages *) - -let pr_rank i = pr_nth (i+1) - -let fixpoint_message indexes l = - Flags.if_verbose Feedback.msg_info (match l with - | [] -> CErrors.anomaly (Pp.str "no recursive definition.") - | [id] -> Id.print id ++ str " is recursively defined" ++ - (match indexes with - | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" - | _ -> mt ()) - | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ - spc () ++ str "are recursively defined" ++ - match indexes with - | Some a -> spc () ++ str "(decreasing respectively on " ++ - prvect_with_sep pr_comma pr_rank a ++ - str " arguments)" - | None -> mt ())) - -let cofixpoint_message l = - Flags.if_verbose Feedback.msg_info (match l with - | [] -> CErrors.anomaly (Pp.str "No corecursive definition.") - | [id] -> Id.print id ++ str " is corecursively defined" - | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ - spc () ++ str "are corecursively defined")) - -let recursive_message isfix i l = - (if isfix then fixpoint_message i else cofixpoint_message) l - -let definition_message id = - Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined") - -let assumption_message id = - (* Changing "assumed" to "declared", "assuming" referring more to - the type of the object than to the name of the object (see - discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) - Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is declared") - -module Internal = struct - - let map_entry_body ~f entry = - { entry with proof_entry_body = Future.chain entry.proof_entry_body f } - - let map_entry_type ~f entry = - { entry with proof_entry_type = f entry.proof_entry_type } - - let set_opacity ~opaque entry = - { entry with proof_entry_opaque = opaque } - - let get_fix_exn entry = Future.fix_exn_of entry.proof_entry_body - - let rec decompose len c t accu = - let open Constr in - let open Context.Rel.Declaration in - if len = 0 then (c, t, accu) - else match kind c, kind t with - | Lambda (na, u, c), Prod (_, _, t) -> - decompose (pred len) c t (LocalAssum (na, u) :: accu) - | LetIn (na, b, u, c), LetIn (_, _, _, t) -> - decompose (pred len) c t (LocalDef (na, b, u) :: accu) - | _ -> assert false - - let rec shrink ctx sign c t accu = - let open Constr in - let open Vars in - match ctx, sign with - | [], [] -> (c, t, accu) - | p :: ctx, decl :: sign -> - if noccurn 1 c && noccurn 1 t then - let c = subst1 mkProp c in - let t = subst1 mkProp t in - shrink ctx sign c t accu - else - let c = Term.mkLambda_or_LetIn p c in - let t = Term.mkProd_or_LetIn p t in - let accu = if Context.Rel.Declaration.is_local_assum p - then mkVar (NamedDecl.get_id decl) :: accu - else accu - in - shrink ctx sign c t accu - | _ -> assert false - - let shrink_entry sign const = - let typ = match const.proof_entry_type with - | None -> assert false - | Some t -> t - in - (* The body has been forced by the call to [build_constant_by_tactic] *) - let () = assert (Future.is_over const.proof_entry_body) in - let ((body, uctx), eff) = Future.force const.proof_entry_body in - let (body, typ, ctx) = decompose (List.length sign) body typ [] in - let (body, typ, args) = shrink ctx sign body typ [] in - { const with - proof_entry_body = Future.from_val ((body, uctx), eff) - ; proof_entry_type = Some typ - }, args - - type nonrec constant_obj = constant_obj - - let objVariable = objVariable - let objConstant = objConstant - -end diff --git a/tactics/declare.mli b/tactics/declare.mli deleted file mode 100644 index 615cffeae7..0000000000 --- a/tactics/declare.mli +++ /dev/null @@ -1,159 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Names -open Constr -open Entries - -(** This module provides the official functions to declare new variables, - parameters, constants and inductive types. Using the following functions - will add the entries in the global environment (module [Global]), will - register the declarations in the library (module [Lib]) --- so that the - reset works properly --- and will fill some global tables such as - [Nametab] and [Impargs]. *) - -(** Proof entries *) -type 'a proof_entry = private { - proof_entry_body : 'a Entries.const_entry_body; - (* List of section variables *) - proof_entry_secctx : Id.Set.t option; - (* State id on which the completion of type checking is reported *) - proof_entry_feedback : Stateid.t option; - proof_entry_type : Constr.types option; - proof_entry_universes : Entries.universes_entry; - proof_entry_opaque : bool; - proof_entry_inline_code : bool; -} - -(** Declaration of local constructions (Variable/Hypothesis/Local) *) - -type variable_declaration = - | SectionLocalDef of Evd.side_effects proof_entry - | SectionLocalAssum of { typ:types; impl:Glob_term.binding_kind; } - -type 'a constant_entry = - | DefinitionEntry of 'a proof_entry - | ParameterEntry of parameter_entry - | PrimitiveEntry of primitive_entry - -val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit - -val declare_variable - : name:variable - -> kind:Decls.logical_kind - -> variable_declaration - -> unit - -(** Declaration of global constructions - i.e. Definition/Theorem/Axiom/Parameter/... *) - -(* Default definition entries, transparent with no secctx or proj information *) -val definition_entry - : ?fix_exn:Future.fix_exn - -> ?opaque:bool - -> ?inline:bool - -> ?feedback_id:Stateid.t - -> ?section_vars:Id.Set.t - -> ?types:types - -> ?univs:Entries.universes_entry - -> ?eff:Evd.side_effects - -> ?univsbody:Univ.ContextSet.t - (** Universe-constraints attached to the body-only, used in - vio-delayed opaque constants and private poly universes *) - -> constr - -> Evd.side_effects proof_entry - -val pure_definition_entry - : ?fix_exn:Future.fix_exn - -> ?opaque:bool - -> ?inline:bool - -> ?types:types - -> ?univs:Entries.universes_entry - -> constr - -> unit proof_entry - -(* Delayed definition entries *) -val delayed_definition_entry - : ?opaque:bool - -> ?inline:bool - -> ?feedback_id:Stateid.t - -> ?section_vars:Id.Set.t - -> ?univs:Entries.universes_entry - -> ?types:types - -> 'a Entries.const_entry_body - -> 'a proof_entry - -type import_status = ImportDefaultBehavior | ImportNeedQualified - -(** [declare_constant id cd] declares a global declaration - (constant/parameter) with name [id] in the current section; it returns - the full path of the declaration - - internal specify if the constant has been created by the kernel or by the - user, and in the former case, if its errors should be silent *) -val declare_constant - : ?local:import_status - -> name:Id.t - -> kind:Decls.logical_kind - -> Evd.side_effects constant_entry - -> Constant.t - -val declare_private_constant - : ?role:Evd.side_effect_role - -> ?local:import_status - -> name:Id.t - -> kind:Decls.logical_kind - -> unit proof_entry - -> Constant.t * Evd.side_effects - -(** [inline_private_constants ~sideff ~uctx env ce] will inline the - constants in [ce]'s body and return the body plus the updated - [UState.t]. *) -val inline_private_constants - : uctx:UState.t - -> Environ.env - -> Evd.side_effects proof_entry - -> Constr.t * UState.t - -(** Declaration messages *) - -val definition_message : Id.t -> unit -val assumption_message : Id.t -> unit -val fixpoint_message : int array option -> Id.t list -> unit -val cofixpoint_message : Id.t list -> unit -val recursive_message : bool (** true = fixpoint *) -> - int array option -> Id.t list -> unit - -val check_exists : Id.t -> unit - -(* Used outside this module only in indschemes *) -exception AlreadyDeclared of (string option * Id.t) - -(** {6 For legacy support, do not use} *) - -module Internal : sig - - val map_entry_body : f:('a Entries.proof_output -> 'b Entries.proof_output) -> 'a proof_entry -> 'b proof_entry - val map_entry_type : f:(Constr.t option -> Constr.t option) -> 'a proof_entry -> 'a proof_entry - (* Overriding opacity is indeed really hacky *) - val set_opacity : opaque:bool -> 'a proof_entry -> 'a proof_entry - - (* TODO: This is only used in DeclareDef to forward the fix to - hooks, should eventually go away *) - val get_fix_exn : 'a proof_entry -> Future.fix_exn - - val shrink_entry : EConstr.named_context -> 'a proof_entry -> 'a proof_entry * Constr.constr list - - type constant_obj - - val objConstant : constant_obj Libobject.Dyn.tag - val objVariable : unit Libobject.Dyn.tag - -end diff --git a/tactics/declareUctx.ml b/tactics/declareUctx.ml new file mode 100644 index 0000000000..3f67ff20a4 --- /dev/null +++ b/tactics/declareUctx.ml @@ -0,0 +1,34 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Monomorphic universes need to survive sections. *) + +let name_instance inst = + let map lvl = match Univ.Level.name lvl with + | None -> (* Having Prop/Set/Var as section universes makes no sense *) + assert false + | Some na -> + try + let qid = Nametab.shortest_qualid_of_universe na in + Names.Name (Libnames.qualid_basename qid) + with Not_found -> + (* Best-effort naming from the string representation of the level. + See univNames.ml for a similar hack. *) + Names.Name (Names.Id.of_string_soft (Univ.Level.to_string lvl)) + in + Array.map map (Univ.Instance.to_array inst) + +let declare_universe_context ~poly ctx = + if poly then + let uctx = Univ.ContextSet.to_context ctx in + let nas = name_instance (Univ.UContext.instance uctx) in + Global.push_section_context (nas, uctx) + else + Global.push_context_set ~strict:true ctx diff --git a/tactics/declareUctx.mli b/tactics/declareUctx.mli new file mode 100644 index 0000000000..7ecfab04f2 --- /dev/null +++ b/tactics/declareUctx.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit diff --git a/tactics/eauto.ml b/tactics/eauto.ml index a89e5ef19a..28b5ed5811 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -430,29 +430,39 @@ let make_dimension n = function | None -> (true,make_depth n) | Some d -> (false,d) +let autounfolds ids csts gl cls = + let hyps = Tacmach.New.pf_ids_of_hyps gl in + let env = Tacmach.New.pf_env gl in + let ids = List.filter (fun id -> List.mem id hyps && Tacred.is_evaluable env (EvalVarRef id)) ids in + let csts = List.filter (fun cst -> Tacred.is_evaluable env (EvalConstRef cst)) csts in + let flags = + List.fold_left (fun flags cst -> CClosure.RedFlags.(red_add flags (fCONST cst))) + (List.fold_left (fun flags id -> CClosure.RedFlags.(red_add flags (fVAR id))) + CClosure.betaiotazeta ids) csts + in reduct_option ~check:false (Reductionops.clos_norm_flags flags, DEFAULTcast) cls + let cons a l = a :: l -let autounfolds db occs cls gl = - let unfolds = List.concat (List.map (fun dbname -> - let db = try searchtable_map dbname - with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) - in - let (ids, csts) = Hint_db.unfolds db in - let hyps = pf_ids_of_hyps gl in - let ids = Id.Set.filter (fun id -> List.mem id hyps) ids in - Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts - (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) - in Proofview.V82.of_tactic (unfold_option unfolds cls) gl +exception UnknownDatabase of string let autounfold db cls = - Proofview.V82.tactic begin fun gl -> - let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in - let tac = autounfolds db in - tclMAP (function - | OnHyp (id,occs,where) -> tac occs (Some (id,where)) - | OnConcl occs -> tac occs None) - cls gl - end + if not (Locusops.clause_with_generic_occurrences cls) then + user_err ~hdr:"autounfold" (str "\"at\" clause not supported"); + match List.fold_left (fun (ids, csts) dbname -> + let db = try searchtable_map dbname + with Not_found -> raise (UnknownDatabase dbname) + in + let (db_ids, db_csts) = Hint_db.unfolds db in + (Id.Set.fold cons db_ids ids, Cset.fold cons db_csts csts)) ([], []) db + with + | (ids, csts) -> Proofview.Goal.enter begin fun gl -> + let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in + let tac = autounfolds ids csts gl in + Tacticals.New.tclMAP (function + | OnHyp (id, _, where) -> tac (Some (id, where)) + | OnConcl _ -> tac None) cls + end + | exception UnknownDatabase dbname -> Tacticals.New.tclZEROMSG (str "Unknown database " ++ str dbname) let autounfold_tac db cls = Proofview.tclUNIT () >>= fun () -> diff --git a/tactics/hints.ml b/tactics/hints.ml index f8a46fcb1d..5fb519cc4f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -23,7 +23,6 @@ open Globnames open Libobject open Namegen open Libnames -open Smartlocate open Termops open Inductiveops open Typeclasses @@ -100,8 +99,6 @@ let empty_hint_info = (* The Type of Constructions Autotactic Hints *) (************************************************************************) -type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen - type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) @@ -164,10 +161,6 @@ type full_hint = hint with_metadata type hint_entry = GlobRef.t option * raw_hint hint_ast with_uid with_metadata -type reference_or_constr = - | HintsReference of qualid - | HintsConstr of Constrexpr.constr_expr - type hint_mode = | ModeInput (* No evars *) | ModeNoHeadEvar (* No evar at the head *) @@ -178,16 +171,6 @@ type 'a hints_transparency_target = | HintsConstants | HintsReferences of 'a list -type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsResolveIFF of bool * qualid list * int option - | HintsImmediate of reference_or_constr list - | HintsUnfold of qualid list - | HintsTransparency of qualid hints_transparency_target * bool - | HintsMode of qualid * hint_mode list - | HintsConstructors of qualid list - | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - type import_level = HintLax | HintWarn | HintStrict let warn_hint_to_string = function @@ -895,7 +878,7 @@ let fresh_global_or_constr env sigma poly cr = else begin if isgr then warn_polymorphic_hint (pr_hint_term env sigma ctx cr); - Declare.declare_universe_context ~poly:false ctx; + DeclareUctx.declare_universe_context ~poly:false ctx; (c, Univ.ContextSet.empty) end @@ -1163,7 +1146,7 @@ let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with cache_function = cache_autohint; load_function = load_autohint; - open_function = open_autohint; + open_function = simple_open open_autohint; subst_function = subst_autohint; classify_function = classify_autohint; } @@ -1310,114 +1293,6 @@ let prepare_hint check env init (sigma,c) = let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in (c', diff) -let project_hint ~poly pri l2r r = - let open EConstr in - let open Coqlib in - let gr = Smartlocate.global_with_alias r in - let env = Global.env() in - let sigma = Evd.from_env env in - let sigma, c = Evd.fresh_global env sigma gr in - let t = Retyping.get_type_of env sigma c in - let t = - Tacred.reduce_to_quantified_ref env sigma (lib_ref "core.iff.type") t in - let sign,ccl = decompose_prod_assum sigma t in - let (a,b) = match snd (decompose_app sigma ccl) with - | [a;b] -> (a,b) - | _ -> assert false in - let p = - if l2r then lib_ref "core.iff.proj1" else lib_ref "core.iff.proj2" in - let sigma, p = Evd.fresh_global env sigma p in - let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in - let c = it_mkLambda_or_LetIn - (mkApp (p,[|mkArrow a Sorts.Relevant (lift 1 b);mkArrow b Sorts.Relevant (lift 1 a);c|])) sign in - let name = - Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) - in - let ctx = Evd.univ_entry ~poly sigma in - let c = EConstr.to_constr sigma c in - let cb = Declare.(DefinitionEntry (definition_entry ~univs:ctx ~opaque:false c)) in - let c = Declare.declare_constant - ~local:Declare.ImportDefaultBehavior - ~name ~kind:Decls.(IsDefinition Definition) cb - in - let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in - (info,false,true,PathAny, IsGlobRef (GlobRef.ConstRef c)) - -let warn_deprecated_hint_constr = - CWarnings.create ~name:"deprecated-hint-constr" ~category:"deprecated" - (fun () -> - Pp.strbrk - "Declaring arbitrary terms as hints is deprecated; declare a global reference instead" - ) - -let interp_hints ~poly = - fun h -> - let env = Global.env () in - let sigma = Evd.from_env env in - let f poly c = - let evd,c = Constrintern.interp_open_constr env sigma c in - let env = Global.env () in - let sigma = Evd.from_env env in - let (c, diff) = prepare_hint true env sigma (evd,c) in - if poly then IsConstr (c, diff) - else - let () = Declare.declare_universe_context ~poly:false diff in - IsConstr (c, Univ.ContextSet.empty) - in - let fref r = - let gr = global_with_alias r in - Dumpglob.add_glob ?loc:r.CAst.loc gr; - gr in - let fr r = evaluable_of_global_reference env (fref r) in - let fi c = - match c with - | HintsReference c -> - let gr = global_with_alias c in - (PathHints [gr], poly, IsGlobRef gr) - | HintsConstr c -> - let () = warn_deprecated_hint_constr () in - (PathAny, poly, f poly c) - in - let fp = Constrintern.intern_constr_pattern env sigma in - let fres (info, b, r) = - let path, poly, gr = fi r in - let info = { info with hint_pattern = Option.map fp info.hint_pattern } in - (info, poly, b, path, gr) - in - let ft = function - | HintsVariables -> HintsVariables - | HintsConstants -> HintsConstants - | HintsReferences lhints -> HintsReferences (List.map fr lhints) - in - let fp = Constrintern.intern_constr_pattern (Global.env()) in - match h with - | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) - | HintsResolveIFF (l2r, lc, n) -> - HintsResolveEntry (List.map (project_hint ~poly n l2r) lc) - | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) - | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) - | HintsTransparency (t, b) -> HintsTransparencyEntry (ft t, b) - | HintsMode (r, l) -> HintsModeEntry (fref r, l) - | HintsConstructors lqid -> - let constr_hints_of_ind qid = - let ind = global_inductive_with_alias qid in - let mib,_ = Global.lookup_inductive ind in - Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (string_of_qualid qid) "ind"; - List.init (nconstructors env ind) - (fun i -> let c = (ind,i+1) in - let gr = GlobRef.ConstructRef c in - empty_hint_info, - (Declareops.inductive_is_polymorphic mib), true, - PathHints [gr], IsGlobRef gr) - in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) - | HintsExtern (pri, patcom, tacexp) -> - let pat = Option.map (fp sigma) patcom in - let l = match pat with None -> [] | Some (l, _) -> l in - let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in - let env = Genintern.({ (empty_glob_sign env) with ltacvars }) in - let _, tacexp = Genintern.generic_intern env tacexp in - HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) - let add_hints ~locality dbnames h = let local, superglobal = match locality with | Goptions.OptDefault | Goptions.OptGlobal -> false, true @@ -1562,8 +1437,7 @@ let pr_hint_term env sigma cl = (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint pf = let env = Global.env () in - let pts = Proof_global.get_proof pf in - let Proof.{goals;sigma} = Proof.data pts in + let Proof.{goals;sigma} = Proof.data pf in match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") | g::_ -> diff --git a/tactics/hints.mli b/tactics/hints.mli index 9e11931247..f5fd3348e4 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -32,8 +32,6 @@ val empty_hint_info : 'a Typeclasses.hint_info_gen (** Pre-created hint databases *) -type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen - type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) @@ -78,10 +76,6 @@ type search_entry type hint_entry -type reference_or_constr = - | HintsReference of Libnames.qualid - | HintsConstr of Constrexpr.constr_expr - type hint_mode = | ModeInput (* No evars *) | ModeNoHeadEvar (* No evar at the head *) @@ -92,16 +86,6 @@ type 'a hints_transparency_target = | HintsConstants | HintsReferences of 'a list -type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsResolveIFF of bool * Libnames.qualid list * int option - | HintsImmediate of reference_or_constr list - | HintsUnfold of Libnames.qualid list - | HintsTransparency of Libnames.qualid hints_transparency_target * bool - | HintsMode of Libnames.qualid * hint_mode list - | HintsConstructors of Libnames.qualid list - | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - type 'a hints_path_gen = | PathAtom of 'a hints_path_atom_gen | PathStar of 'a hints_path_gen @@ -217,8 +201,6 @@ val current_db_names : unit -> String.Set.t val current_pure_db : unit -> hint_db list -val interp_hints : poly:bool -> hints_expr -> hints_entry - val add_hints : locality:Goptions.option_locality -> hint_db_name list -> hints_entry -> unit val prepare_hint : bool (* Check no remaining evars *) -> @@ -306,7 +288,7 @@ val wrap_hint_warning_fun : env -> evar_map -> (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t -val pr_applicable_hint : Proof_global.t -> Pp.t +val pr_applicable_hint : Proof.t -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 8336fae02f..e422366ed6 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -86,15 +86,15 @@ let compute_name internal id = Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name else id +let declare_definition_scheme = ref (fun ~internal ~univs ~role ~name c -> + CErrors.anomaly (Pp.str "scheme declaration not registered")) + let define internal role id c poly univs = let id = compute_name internal id in let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in let univs = UState.univ_entry ~poly ctx in - let entry = Declare.pure_definition_entry ~univs c in - let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id entry in - let () = if internal then () else Declare.definition_message id in - kn, eff + !declare_definition_scheme ~internal ~univs ~role ~name:id c let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let (c, ctx), eff = f mode ind in diff --git a/tactics/ind_tables.mli b/tactics/ind_tables.mli index dad2036c64..736de2af37 100644 --- a/tactics/ind_tables.mli +++ b/tactics/ind_tables.mli @@ -59,3 +59,11 @@ val check_scheme : 'a scheme_kind -> inductive -> bool val lookup_scheme : 'a scheme_kind -> inductive -> Constant.t val pr_scheme_kind : 'a scheme_kind -> Pp.t + +val declare_definition_scheme : + (internal : bool + -> univs:Entries.universes_entry + -> role:Evd.side_effect_role + -> name:Id.t + -> Constr.t + -> Constant.t * Evd.side_effects) ref diff --git a/tactics/pfedit.ml b/tactics/pfedit.ml deleted file mode 100644 index c139594f13..0000000000 --- a/tactics/pfedit.ml +++ /dev/null @@ -1,189 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Pp -open Util -open Names -open Environ -open Evd - -let use_unification_heuristics = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Solve";"Unification";"Constraints"] - ~value:true - -exception NoSuchGoal -let () = CErrors.register_handler begin function - | NoSuchGoal -> Some Pp.(str "No such goal.") - | _ -> None -end - -let get_nth_V82_goal p i = - let Proof.{ sigma; goals } = Proof.data p in - try { it = List.nth goals (i-1) ; sigma } - with Failure _ -> raise NoSuchGoal - -let get_goal_context_gen pf i = - let { it=goal ; sigma=sigma; } = get_nth_V82_goal pf i in - (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) - -let get_goal_context pf i = - let p = Proof_global.get_proof pf in - get_goal_context_gen p i - -let get_current_goal_context pf = - let p = Proof_global.get_proof pf in - try get_goal_context_gen p 1 - with - | NoSuchGoal -> - (* spiwack: returning empty evar_map, since if there is no goal, - under focus, there is no accessible evar either. EJGA: this - seems strange, as we have pf *) - let env = Global.env () in - Evd.from_env env, env - -let get_proof_context p = - try get_goal_context_gen p 1 - with - | NoSuchGoal -> - (* No more focused goals *) - let { Proof.sigma } = Proof.data p in - sigma, Global.env () - -let get_current_context pf = - let p = Proof_global.get_proof pf in - get_proof_context p - -let solve ?with_end_tac gi info_lvl tac pr = - let tac = match with_end_tac with - | None -> tac - | Some etac -> Proofview.tclTHEN tac etac in - let tac = match info_lvl with - | None -> tac - | Some _ -> Proofview.Trace.record_info_trace tac - in - let nosuchgoal = Proofview.tclZERO (Proof_bullet.SuggestNoSuchGoals (1,pr)) in - let tac = let open Goal_select in match gi with - | SelectAlreadyFocused -> - let open Proofview.Notations in - Proofview.numgoals >>= fun n -> - if n == 1 then tac - else - let e = CErrors.UserError - (None, - Pp.(str "Expected a single focused goal but " ++ - int n ++ str " goals are focused.")) - in - Proofview.tclZERO e - - | SelectNth i -> Proofview.tclFOCUS ~nosuchgoal i i tac - | SelectList l -> Proofview.tclFOCUSLIST ~nosuchgoal l tac - | SelectId id -> Proofview.tclFOCUSID ~nosuchgoal id tac - | SelectAll -> tac - in - let tac = - if use_unification_heuristics () then - Proofview.tclTHEN tac Refine.solve_constraints - else tac - in - let env = Global.env () in - let (p,(status,info),()) = Proof.run_tactic env tac pr in - let env = Global.env () in - let sigma = Evd.from_env env in - let () = - match info_lvl with - | None -> () - | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) - in - (p,status) - -let by tac = Proof_global.map_fold_proof (solve (Goal_select.SelectNth 1) None tac) - -(**********************************************************************) -(* Shortcut to build a term using tactics *) - -let next = let n = ref 0 in fun () -> incr n; !n - -let build_constant_by_tactic ~name ?(opaque=Proof_global.Transparent) ~uctx ~sign ~poly typ tac = - let evd = Evd.from_ctx uctx in - let goals = [ (Global.env_of_context sign , typ) ] in - let pf = Proof_global.start_proof ~name ~poly ~udecl:UState.default_univ_decl evd goals in - let pf, status = by tac pf in - let open Proof_global in - let { entries; uctx } = close_proof ~opaque ~keep_body_ucst_separate:false pf in - match entries with - | [entry] -> - entry, status, uctx - | _ -> - CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") - -let build_by_tactic ?(side_eff=true) env ~uctx ~poly ~typ tac = - let name = Id.of_string ("temporary_proof"^string_of_int (next())) in - let sign = val_of_named_context (named_context env) in - let ce, status, univs = build_constant_by_tactic ~name ~uctx ~sign ~poly typ tac in - let cb, uctx = - if side_eff then Declare.inline_private_constants ~uctx env ce - else - (* GG: side effects won't get reset: no need to treat their universes specially *) - let (cb, ctx), _eff = Future.force ce.Declare.proof_entry_body in - cb, UState.merge ~sideff:false Evd.univ_rigid uctx ctx - in - cb, ce.Declare.proof_entry_type, status, univs - -let refine_by_tactic ~name ~poly env sigma ty tac = - (* Save the initial side-effects to restore them afterwards. We set the - current set of side-effects to be empty so that we can retrieve the - ones created during the tactic invocation easily. *) - let eff = Evd.eval_side_effects sigma in - let sigma = Evd.drop_side_effects sigma in - (* Save the existing goals *) - let prev_future_goals = save_future_goals sigma in - (* Start a proof *) - let prf = Proof.start ~name ~poly sigma [env, ty] in - let (prf, _, ()) = - try Proof.run_tactic env tac prf - with Logic_monad.TacticFailure e as src -> - (* Catch the inner error of the monad tactic *) - let (_, info) = Exninfo.capture src in - Exninfo.iraise (e, info) - in - (* Plug back the retrieved sigma *) - let Proof.{ goals; stack; shelf; given_up; sigma; entry } = Proof.data prf in - assert (stack = []); - let ans = match Proofview.initial_goals entry with - | [c, _] -> c - | _ -> assert false - in - let ans = EConstr.to_constr ~abort_on_undefined_evars:false sigma ans in - (* [neff] contains the freshly generated side-effects *) - let neff = Evd.eval_side_effects sigma in - (* Reset the old side-effects *) - let sigma = Evd.drop_side_effects sigma in - let sigma = Evd.emit_side_effects eff sigma in - (* Restore former goals *) - let sigma = restore_future_goals sigma prev_future_goals in - (* Push remaining goals as future_goals which is the only way we - have to inform the caller that there are goals to collect while - not being encapsulated in the monad *) - (* Goals produced by tactic "shelve" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in - (* Goals produced by tactic "give_up" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in - (* Other goals *) - let sigma = List.fold_right Evd.declare_future_goal goals sigma in - (* Get rid of the fresh side-effects by internalizing them in the term - itself. Note that this is unsound, because the tactic may have solved - other goals that were already present during its invocation, so that - those goals rely on effects that are not present anymore. Hopefully, - this hack will work in most cases. *) - let neff = neff.Evd.seff_private in - let (ans, _) = Safe_typing.inline_private_constants env ((ans, Univ.ContextSet.empty), neff) in - ans, sigma diff --git a/tactics/pfedit.mli b/tactics/pfedit.mli deleted file mode 100644 index c49e997757..0000000000 --- a/tactics/pfedit.mli +++ /dev/null @@ -1,94 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Global proof state. A quite redundant wrapper on {!Proof_global}. *) - -open Names -open Constr -open Environ - -(** {6 ... } *) - -exception NoSuchGoal - -(** [get_goal_context n] returns the context of the [n]th subgoal of - the current focused proof or raises a [UserError] if there is no - focused proof or if there is no more subgoals *) - -val get_goal_context : Proof_global.t -> int -> Evd.evar_map * env - -(** [get_current_goal_context ()] works as [get_goal_context 1] *) -val get_current_goal_context : Proof_global.t -> Evd.evar_map * env - -(** [get_proof_context ()] gets the goal context for the first subgoal - of the proof *) -val get_proof_context : Proof.t -> Evd.evar_map * env - -(** [get_current_context ()] returns the context of the - current focused goal. If there is no focused goal but there - is a proof in progress, it returns the corresponding evar_map. - If there is no pending proof then it returns the current global - environment and empty evar_map. *) -val get_current_context : Proof_global.t -> Evd.evar_map * env - -(** {6 ... } *) - -(** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th - subgoal of the current focused proof. [solve SelectAll - tac] applies [tac] to all subgoals. *) - -val solve : ?with_end_tac:unit Proofview.tactic -> - Goal_select.t -> int option -> unit Proofview.tactic -> - Proof.t -> Proof.t * bool - -(** [by tac] applies tactic [tac] to the 1st subgoal of the current - focused proof. - Returns [false] if an unsafe tactic has been used. *) - -val by : unit Proofview.tactic -> Proof_global.t -> Proof_global.t * bool - -(** Option telling if unification heuristics should be used. *) -val use_unification_heuristics : unit -> bool - -(** [build_by_tactic typ tac] returns a term of type [typ] by calling - [tac]. The return boolean, if [false] indicates the use of an unsafe - tactic. *) - -val build_constant_by_tactic - : name:Id.t - -> ?opaque:Proof_global.opacity_flag - -> uctx:UState.t - -> sign:named_context_val - -> poly:bool - -> EConstr.types - -> unit Proofview.tactic - -> Evd.side_effects Declare.proof_entry * bool * UState.t - -val build_by_tactic - : ?side_eff:bool - -> env - -> uctx:UState.t - -> poly:bool - -> typ:EConstr.types - -> unit Proofview.tactic - -> constr * types option * bool * UState.t - -val refine_by_tactic - : name:Id.t - -> poly:bool - -> env -> Evd.evar_map - -> EConstr.types - -> unit Proofview.tactic - -> constr * Evd.evar_map -(** A variant of the above function that handles open terms as well. - Caveat: all effects are purged in the returned term at the end, but other - evars solved by side-effects are NOT purged, so that unexpected failures may - occur. Ideally all code using this function should be rewritten in the - monad. *) diff --git a/tactics/proof_global.ml b/tactics/proof_global.ml deleted file mode 100644 index 68de9c7a00..0000000000 --- a/tactics/proof_global.ml +++ /dev/null @@ -1,283 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Util -open Names -open Context - -module NamedDecl = Context.Named.Declaration - -(*** Proof Global Environment ***) - -type proof_object = - { name : Names.Id.t - (* [name] only used in the STM *) - ; entries : Evd.side_effects Declare.proof_entry list - ; uctx: UState.t - } - -type opacity_flag = Opaque | Transparent - -type t = - { endline_tactic : Genarg.glob_generic_argument option - ; section_vars : Id.Set.t option - ; proof : Proof.t - ; udecl: UState.universe_decl - (** Initial universe declarations *) - ; initial_euctx : UState.t - (** The initial universe context (for the statement) *) - } - -(*** Proof Global manipulation ***) - -let get_proof ps = ps.proof -let get_proof_name ps = (Proof.data ps.proof).Proof.name - -let get_initial_euctx ps = ps.initial_euctx - -let map_proof f p = { p with proof = f p.proof } -let map_fold_proof f p = let proof, res = f p.proof in { p with proof }, res - -let map_fold_proof_endline f ps = - let et = - match ps.endline_tactic with - | None -> Proofview.tclUNIT () - | Some tac -> - let open Geninterp in - let {Proof.poly} = Proof.data ps.proof in - let ist = { lfun = Id.Map.empty; poly; extra = TacStore.empty } in - let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in - let tac = Geninterp.interp tag ist tac in - Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) - in - let (newpr,ret) = f et ps.proof in - let ps = { ps with proof = newpr } in - ps, ret - -let compact_the_proof pf = map_proof Proof.compact pf - -(* Sets the tactic to be used when a tactic line is closed with [...] *) -let set_endline_tactic tac ps = - { ps with endline_tactic = Some tac } - -(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of - name [name] with goals [goals] (a list of pairs of environment and - conclusion). The proof is started in the evar map [sigma] (which - can typically contain universe constraints), and with universe - bindings [udecl]. *) -let start_proof ~name ~udecl ~poly sigma goals = - let proof = Proof.start ~name ~poly sigma goals in - let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in - { proof - ; endline_tactic = None - ; section_vars = None - ; udecl - ; initial_euctx - } - -let start_dependent_proof ~name ~udecl ~poly goals = - let proof = Proof.dependent_start ~name ~poly goals in - let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in - { proof - ; endline_tactic = None - ; section_vars = None - ; udecl - ; initial_euctx - } - -let get_used_variables pf = pf.section_vars -let get_universe_decl pf = pf.udecl - -let set_used_variables ps l = - let open Context.Named.Declaration in - let env = Global.env () in - let ids = List.fold_right Id.Set.add l Id.Set.empty in - let ctx = Environ.keep_hyps env ids in - let ctx_set = - List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in - let vars_of = Environ.global_vars_set in - let aux env entry (ctx, all_safe as orig) = - match entry with - | LocalAssum ({binder_name=x},_) -> - if Id.Set.mem x all_safe then orig - else (ctx, all_safe) - | LocalDef ({binder_name=x},bo, ty) as decl -> - if Id.Set.mem x all_safe then orig else - let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in - if Id.Set.subset vars all_safe - then (decl :: ctx, Id.Set.add x all_safe) - else (ctx, all_safe) in - let ctx, _ = - Environ.fold_named_context aux env ~init:(ctx,ctx_set) in - if not (Option.is_empty ps.section_vars) then - CErrors.user_err Pp.(str "Used section variables can be declared only once"); - ctx, { ps with section_vars = Some (Context.Named.to_vars ctx) } - -let get_open_goals ps = - let Proof.{ goals; stack; shelf } = Proof.data ps.proof in - List.length goals + - List.fold_left (+) 0 - (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + - List.length shelf - -type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t - -let private_poly_univs = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Private";"Polymorphic";"Universes"] - ~value:true - -(* XXX: This is still separate from close_proof below due to drop_pt in the STM *) -let return_proof { proof } = - let Proof.{name=pid;entry} = Proof.data proof in - let initial_goals = Proofview.initial_goals entry in - let evd = Proof.return ~pid proof in - let eff = Evd.eval_side_effects evd in - let evd = Evd.minimize_universes evd in - let proof_opt c = - match EConstr.to_constr_opt evd c with - | Some p -> p - | None -> CErrors.user_err Pp.(str "Some unresolved existential variables remain") - in - (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate - side-effects... This may explain why one need to uniquize side-effects - thereafter... *) - (* EJGA: actually side-effects de-duplication and this codepath is - unrelated. Duplicated side-effects arise from incorrect scheme - generation code, the main bulk of it was mostly fixed by #9836 - but duplication can still happen because of rewriting schemes I - think; however the code below is mostly untested, the only - code-paths that generate several proof entries are derive and - equations and so far there is no code in the CI that will - actually call those and do a side-effect, TTBOMK *) - (* EJGA: likely the right solution is to attach side effects to the first constant only? *) - let proofs = List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in - proofs, Evd.evar_universe_context evd - -let close_proof ~opaque ~keep_body_ucst_separate ps = - let elist, uctx = return_proof ps in - let { section_vars; proof; udecl; initial_euctx } = ps in - let { Proof.name; poly; entry; sigma } = Proof.data proof in - let opaque = match opaque with Opaque -> true | Transparent -> false in - - (* Because of dependent subgoals at the beginning of proofs, we could - have existential variables in the initial types of goals, we need to - normalise them for the kernel. *) - let subst_evar k = Evd.existential_opt_value0 sigma k in - let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst uctx) in - - let make_entry (body, eff) (_, typ) = - let allow_deferred = - not poly && (keep_body_ucst_separate || - not (Safe_typing.empty_private_constants = eff.Evd.seff_private)) - in - (* EJGA: Why are we doing things this way? *) - let typ = EConstr.Unsafe.to_constr typ in - let typ = if allow_deferred then typ else nf typ in - (* EJGA: End "Why are we doing things this way?" *) - - let used_univs_body = Vars.universes_of_constr body in - let used_univs_typ = Vars.universes_of_constr typ in - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let utyp, ubody = - if allow_deferred then - let utyp = UState.univ_entry ~poly initial_euctx in - let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in - (* For vi2vo compilation proofs are computed now but we need to - complement the univ constraints of the typ with the ones of - the body. So we keep the two sets distinct. *) - let uctx_body = UState.restrict uctx used_univs in - let ubody = UState.check_mono_univ_decl uctx_body udecl in - utyp, ubody - else if poly && opaque && private_poly_univs () then - let universes = UState.restrict uctx used_univs in - let typus = UState.restrict universes used_univs_typ in - let utyp = UState.check_univ_decl ~poly typus udecl in - let ubody = Univ.ContextSet.diff - (UState.context_set universes) - (UState.context_set typus) - in - utyp, ubody - else - (* Since the proof is computed now, we can simply have 1 set of - constraints in which we merge the ones for the body and the ones - for the typ. We recheck the declaration after restricting with - the actually used universes. - TODO: check if restrict is really necessary now. *) - let ctx = UState.restrict uctx used_univs in - let utyp = UState.check_univ_decl ~poly ctx udecl in - utyp, Univ.ContextSet.empty - in - Declare.definition_entry ~opaque ?section_vars ~univs:utyp ~univsbody:ubody ~types:typ ~eff body - in - let entries = CList.map2 make_entry elist (Proofview.initial_goals entry) in - { name; entries; uctx } - -let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.computation) = - let { section_vars; proof; udecl; initial_euctx } = ps in - let { Proof.name; poly; entry; sigma } = Proof.data proof in - - (* We don't allow poly = true in this path *) - if poly then - CErrors.anomaly (Pp.str "Cannot delay universe-polymorphic constants."); - - let fpl, uctx = Future.split2 fpl in - (* Because of dependent subgoals at the beginning of proofs, we could - have existential variables in the initial types of goals, we need to - normalise them for the kernel. *) - let subst_evar k = Evd.existential_opt_value0 sigma k in - let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst initial_euctx) in - - (* We only support opaque proofs, this will be enforced by using - different entries soon *) - let opaque = true in - let make_entry p (_, types) = - (* Already checked the univ_decl for the type universes when starting the proof. *) - let univs = UState.univ_entry ~poly:false initial_euctx in - let types = nf (EConstr.Unsafe.to_constr types) in - - Future.chain p (fun (pt,eff) -> - (* Deferred proof, we already checked the universe declaration with - the initial universes, ensure that the final universes respect - the declaration as well. If the declaration is non-extensible, - this will prevent the body from adding universes and constraints. *) - let uctx = Future.force uctx in - let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in - let used_univs = Univ.LSet.union - (Vars.universes_of_constr types) - (Vars.universes_of_constr pt) - in - let univs = UState.restrict uctx used_univs in - let univs = UState.check_mono_univ_decl univs udecl in - (pt,univs),eff) - |> Declare.delayed_definition_entry ~opaque ~feedback_id ?section_vars ~univs ~types - in - let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in - { name; entries; uctx = initial_euctx } - -let close_future_proof = close_proof_delayed - -let return_partial_proof { proof } = - let proofs = Proof.partial_proof proof in - let Proof.{sigma=evd} = Proof.data proof in - let eff = Evd.eval_side_effects evd in - (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate - side-effects... This may explain why one need to uniquize side-effects - thereafter... *) - let proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in - proofs, Evd.evar_universe_context evd - -let update_global_env = - map_proof (fun p -> - let { Proof.sigma } = Proof.data p in - let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in - let p, (status,info), _ = Proof.run_tactic (Global.env ()) tac p in - p) diff --git a/tactics/proof_global.mli b/tactics/proof_global.mli deleted file mode 100644 index 874708ded8..0000000000 --- a/tactics/proof_global.mli +++ /dev/null @@ -1,98 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** State for interactive proofs. *) - -type t - -(* Should be moved into a proper view *) -val get_proof : t -> Proof.t -val get_proof_name : t -> Names.Id.t -val get_used_variables : t -> Names.Id.Set.t option - -(** Get the universe declaration associated to the current proof. *) -val get_universe_decl : t -> UState.universe_decl - -(** Get initial universe state *) -val get_initial_euctx : t -> UState.t - -val compact_the_proof : t -> t - -(** When a proof is closed, it is reified into a [proof_object] *) -type proof_object = - { name : Names.Id.t - (** name of the proof *) - ; entries : Evd.side_effects Declare.proof_entry list - (** list of the proof terms (in a form suitable for definitions). *) - ; uctx: UState.t - (** universe state *) - } - -type opacity_flag = Opaque | Transparent - -(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of - name [name] with goals [goals] (a list of pairs of environment and - conclusion); [poly] determines if the proof is universe - polymorphic. The proof is started in the evar map [sigma] (which - can typically contain universe constraints), and with universe - bindings [udecl]. *) -val start_proof - : name:Names.Id.t - -> udecl:UState.universe_decl - -> poly:bool - -> Evd.evar_map - -> (Environ.env * EConstr.types) list - -> t - -(** Like [start_proof] except that there may be dependencies between - initial goals. *) -val start_dependent_proof - : name:Names.Id.t - -> udecl:UState.universe_decl - -> poly:bool - -> Proofview.telescope - -> t - -(** Update the proofs global environment after a side-effecting command - (e.g. a sublemma definition) has been run inside it. Assumes - there_are_pending_proofs. *) -val update_global_env : t -> t - -(* Takes a function to add to the exceptions data relative to the - state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> t -> proof_object - -(* Intermediate step necessary to delegate the future. - * Both access the current proof state. The former is supposed to be - * chained with a computation that completed the proof *) - -type closed_proof_output - -(** Requires a complete proof. *) -val return_proof : t -> closed_proof_output - -(** An incomplete proof is allowed (no error), and a warn is given if - the proof is complete. *) -val return_partial_proof : t -> closed_proof_output -val close_future_proof : feedback_id:Stateid.t -> t -> closed_proof_output Future.computation -> proof_object - -val get_open_goals : t -> int - -val map_proof : (Proof.t -> Proof.t) -> t -> t -val map_fold_proof : (Proof.t -> Proof.t * 'a) -> t -> t * 'a -val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a - -(** Sets the tactic to be used when a tactic line is closed with [...] *) -val set_endline_tactic : Genarg.glob_generic_argument -> t -> t - -(** Sets the section variables assumed by the proof, returns its closure - * (w.r.t. type dependencies and let-ins covered by it) *) -val set_used_variables : t -> - Names.Id.t list -> Constr.named_context * t diff --git a/tactics/tactics.ml b/tactics/tactics.ml index c79aca3d3c..0df4f5b207 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2763,8 +2763,8 @@ let pose_tac na c = let id = make_annot id Sorts.Relevant in let nhyps = EConstr.push_named_context_val (NamedDecl.LocalDef (id, c, t)) hyps in let (sigma, ev) = Evarutil.new_pure_evar nhyps sigma concl in - let inst = Array.map_of_list (fun d -> mkVar (get_id d)) (named_context env) in - let body = mkEvar (ev, Array.append [|mkRel 1|] inst) in + let inst = List.map (fun d -> mkVar (get_id d)) (named_context env) in + let body = mkEvar (ev, mkRel 1 :: inst) in (sigma, mkLetIn (map_annot Name.mk_name id, c, t, body)) end end @@ -4499,7 +4499,7 @@ let check_expected_type env sigma (elimc,bl) elimt = if n == 0 then error "Scheme cannot be applied."; 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 + let (_,u,_) = destProd sigma (whd_all env sigma cl.cl_concl) in fun t -> match Evarconv.unify_leq_delay env sigma t u with | _sigma -> true | exception Evarconv.UnableToUnify _ -> false diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 0c4e496650..36d61feed1 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,7 +1,4 @@ DeclareScheme -Declare -Proof_global -Pfedit Dnet Dn Btermdn @@ -20,7 +17,7 @@ Elim Equality Contradiction Inv -Leminv +DeclareUctx Hints Auto Eauto diff --git a/test-suite/Makefile b/test-suite/Makefile index eade52b6eb..dece21885c 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -62,6 +62,10 @@ coqtopbyte := $(BIN)coqtop.byte -q coqc_interactive := $(coqc) -test-mode -async-proofs-cache force coqdep := $(BIN)coqdep +# This is the convention for coq_makefile +OPT=-$(BEST) +export OPT + VERBOSE?= SHOW := $(if $(VERBOSE),@true,@echo) HIDE := $(if $(VERBOSE),,@) @@ -354,8 +358,7 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v primit } > "$@" @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi $(HIDE)if ! grep -q -F "Error!" $@; then { \ - opts="$(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-I $(shell dirname $<) -norec $(shell basename $< .v))"; \ - $(coqchk) -silent $(call get_set_impredicativity,$<) $$opts 2>&1; R=$$?; \ + $(coqchk) -silent $(call get_set_impredicativity,$<) $(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-Q $(shell dirname $<) "" -norec $(shell basename $< .v)) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ @@ -381,7 +384,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v } > "$@" @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi $(HIDE)if ! grep -q -F "Error!" $@; then { \ - $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ + $(coqchk) -silent -Q $(shell dirname $<) "" -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ @@ -405,7 +408,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) } > "$@" @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi $(HIDE)if ! grep -q -F "Error!" $@; then { \ - $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ + $(coqchk) -silent -Q $(shell dirname $<) "" -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ diff --git a/test-suite/bugs/closed/HoTT_coq_107.v b/test-suite/bugs/closed/HoTT_coq_107.v index fa4072a8f6..91f5c423a5 100644 --- a/test-suite/bugs/closed/HoTT_coq_107.v +++ b/test-suite/bugs/closed/HoTT_coq_107.v @@ -2,6 +2,7 @@ (* File reduced by coq-bug-finder from 4897 lines to 2605 lines, then from 2297 lines to 236 lines, then from 239 lines to 137 lines, then from 118 lines to 67 lines, then from 520 lines to 76 lines. *) (** Note: The bug here is the same as the #113, that is, HoTT_coq_113.v *) Require Import Coq.Init.Logic. +Require Import Coq.Init.Ltac. Global Set Universe Polymorphism. Global Set Asymmetric Patterns. Set Implicit Arguments. diff --git a/test-suite/bugs/closed/bug_11783.v b/test-suite/bugs/closed/bug_11783.v new file mode 100644 index 0000000000..a07391add5 --- /dev/null +++ b/test-suite/bugs/closed/bug_11783.v @@ -0,0 +1,5 @@ +Section S. + Variable A : Type. + Require Hurkens. + Definition foo := Hurkens.Generic.paradox A. +End S. diff --git a/test-suite/bugs/closed/bug_11935.v b/test-suite/bugs/closed/bug_11935.v new file mode 100644 index 0000000000..ad5ffc68b5 --- /dev/null +++ b/test-suite/bugs/closed/bug_11935.v @@ -0,0 +1,6 @@ +Section S. + Variable A : Prop. + + Fail Check A@{Type}. + Check A@{}. +End S. diff --git a/test-suite/bugs/closed/bug_12045.v b/test-suite/bugs/closed/bug_12045.v new file mode 100644 index 0000000000..4e416778a9 --- /dev/null +++ b/test-suite/bugs/closed/bug_12045.v @@ -0,0 +1,19 @@ +(* Check enough reduction happens in the conclusion of an induction scheme *) + +Lemma foo : + forall (P : nat -> Prop), + (forall n, P (S n)) -> + forall n, + (fun e => + IsSucc e -> + P e) n. +Proof. +Admitted. + +Theorem bar : forall n, + IsSucc n -> + True. +Proof. + intros. + Fail induction n using foo. (* was an anomaly *) +Admitted. diff --git a/test-suite/bugs/closed/bug_1912.v b/test-suite/bugs/closed/bug_1912.v index 987a541778..0228abbb9b 100644 --- a/test-suite/bugs/closed/bug_1912.v +++ b/test-suite/bugs/closed/bug_1912.v @@ -1,4 +1,4 @@ -Require Import ZArith. +Require Import Omega. Goal forall x, Z.succ (Z.pred x) = x. intros x. diff --git a/test-suite/bugs/closed/bug_3881.v b/test-suite/bugs/closed/bug_3881.v index d7e097e326..50e9de60e5 100644 --- a/test-suite/bugs/closed/bug_3881.v +++ b/test-suite/bugs/closed/bug_3881.v @@ -4,6 +4,7 @@ coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (90ed6636dea41486ddf2cc0daead83f9f0788163) *) Generalizable All Variables. Require Import Coq.Init.Notations. +Require Import Coq.Init.Ltac. Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Notation "A -> B" := (forall (_ : A), B) : type_scope. Axiom admit : forall {T}, T. diff --git a/test-suite/bugs/closed/bug_4527.v b/test-suite/bugs/closed/bug_4527.v index dfb07520f1..cf802eb89b 100644 --- a/test-suite/bugs/closed/bug_4527.v +++ b/test-suite/bugs/closed/bug_4527.v @@ -5,7 +5,7 @@ then from 269 lines to 255 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) -Declare ML Module "ltac_plugin". +Require Import Coq.Init.Ltac. Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/bug_4533.v b/test-suite/bugs/closed/bug_4533.v index d2f9fb9099..2d628f414d 100644 --- a/test-suite/bugs/closed/bug_4533.v +++ b/test-suite/bugs/closed/bug_4533.v @@ -5,7 +5,7 @@ then from 285 lines to 271 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) -Declare ML Module "ltac_plugin". +Require Import Coq.Init.Ltac. Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/bug_4544.v b/test-suite/bugs/closed/bug_4544.v index e9e9c552f6..213c91bfa0 100644 --- a/test-suite/bugs/closed/bug_4544.v +++ b/test-suite/bugs/closed/bug_4544.v @@ -2,7 +2,7 @@ (* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) -Declare ML Module "ltac_plugin". +Require Import Coq.Init.Ltac. Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/bug_6661.v b/test-suite/bugs/closed/bug_6661.v index 28a9ffc7bd..0f4ae2b4c5 100644 --- a/test-suite/bugs/closed/bug_6661.v +++ b/test-suite/bugs/closed/bug_6661.v @@ -7,6 +7,7 @@ Require Export Coq.Init.Notations. +Require Export Coq.Init.Ltac. Notation "'∏' x .. y , P" := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity) : type_scope. Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) diff --git a/test-suite/bugs/closed/bug_7812.v b/test-suite/bugs/closed/bug_7812.v new file mode 100644 index 0000000000..a714eea81d --- /dev/null +++ b/test-suite/bugs/closed/bug_7812.v @@ -0,0 +1,30 @@ +Module Foo. + Definition binary A := A -> A -> Prop. + + Definition inter A (R1 R2 : binary A): binary A := + fun (x y:A) => R1 x y /\ R2 x y. +End Foo. + +Module Simple_sparse_proof. + Parameter node : Type. + Parameter graph : Type. + Parameter has_edge : graph -> node -> node -> Prop. + Implicit Types x y z : node. + Implicit Types G : graph. + + Parameter mem : forall A, A -> list A -> Prop. + Hypothesis mem_nil : forall x, mem node x nil = False. + + Definition notin (l: list node): node -> node -> Prop := + fun x y => ~ mem node x l /\ ~ mem node y l. + + Definition edge_notin G l : node -> node -> Prop := + Foo.inter node (has_edge G) (notin l). + + Hint Unfold Foo.inter notin edge_notin : rel_crush. + + Lemma edge_notin_nil G : forall x y, edge_notin G nil x y <-> has_edge G x y. + Proof. + intros. autounfold with rel_crush. rewrite !mem_nil. tauto. + Qed. +End Simple_sparse_proof. diff --git a/test-suite/coq-makefile/native1/_CoqProject b/test-suite/coq-makefile/native1/_CoqProject index 3dfca7ffc0..85276fd9b9 100644 --- a/test-suite/coq-makefile/native1/_CoqProject +++ b/test-suite/coq-makefile/native1/_CoqProject @@ -1,6 +1,8 @@ -R src test -R theories test -I src +-arg -w +-arg +native-compiler-disabled -arg -native-compiler -arg yes diff --git a/test-suite/coq-makefile/native2/run.sh b/test-suite/coq-makefile/native2/run.sh index 857f70fdff..aaae81630f 100755 --- a/test-suite/coq-makefile/native2/run.sh +++ b/test-suite/coq-makefile/native2/run.sh @@ -7,7 +7,7 @@ if [[ $(which ocamlopt) && ! $NONATIVECOMP ]]; then coq_makefile -f _CoqProject -o Makefile cat Makefile.conf -COQEXTRAFLAGS="-native-compiler yes" make +COQEXTRAFLAGS="-w +native-compiler-disabled -native-compiler yes" make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug diff --git a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired index 7900c034da..ebe44f3548 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired @@ -1,15 +1,5 @@ -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' COQDEP VFILES -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' COQC Slow.v -Slow (real: 0.04, user: 0.02, sys: 0.01, mem: 45512 ko) +Slow.vo (real: 0.04, user: 0.02, sys: 0.01, mem: 45512 ko) COQC Fast.v -Fast (real: 0.41, user: 0.37, sys: 0.04, mem: 395200 ko) -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' +Fast.vo (real: 0.41, user: 0.37, sys: 0.04, mem: 395200 ko) diff --git a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired index 7ab0bc75d9..bf17a3e95c 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired @@ -1,15 +1,5 @@ -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' COQDEP VFILES -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' COQC Slow.v -Slow (real: 0.40, user: 0.35, sys: 0.04, mem: 394968 ko) +Slow.vo (real: 0.40, user: 0.35, sys: 0.04, mem: 394968 ko) COQC Fast.v -Fast (real: 0.04, user: 0.03, sys: 0.00, mem: 46564 ko) -Makefile:69: warning: undefined variable '*' -Makefile:204: warning: undefined variable 'DSTROOT' +Fast.vo (real: 0.04, user: 0.03, sys: 0.00, mem: 46564 ko) diff --git a/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired index 72c520218c..c8f35dc1e4 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired @@ -2,5 +2,5 @@ After | File Name | Before || Change | % Change -------------------------------------------------------- 0m00.34s | Total | 0m00.49s || -0m00.14s | -30.61% -------------------------------------------------------- -0m00.32s | Fast | 0m00.02s || +0m00.30s | +1500.00% -0m00.02s | Slow | 0m00.47s || -0m00.44s | -95.74%
\ No newline at end of file +0m00.32s | Fast.vo | 0m00.02s || +0m00.30s | +1500.00% +0m00.02s | Slow.vo | 0m00.47s || -0m00.44s | -95.74%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index 4ee4aae36c..f556638640 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -63,7 +63,7 @@ TO_SED_IN_PER_LINE=( for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do for ext in "" .desired; do - grep -v 'warning: undefined variable' < ${file}${ext} | sed "${TO_SED_IN_BOTH[@]}" "${TO_SED_IN_PER_FILE[@]}" > ${file}${ext}.processed + sed "${TO_SED_IN_BOTH[@]}" "${TO_SED_IN_PER_FILE[@]}" ${file}${ext} > ${file}${ext}.processed done echo "cat $file" cat "$file" diff --git a/test-suite/coqdoc/binder.html.out b/test-suite/coqdoc/binder.html.out new file mode 100644 index 0000000000..af8eb46845 --- /dev/null +++ b/test-suite/coqdoc/binder.html.out @@ -0,0 +1,41 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.binder</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.binder</h1> + +<div class="code"> +</div> + +<div class="doc"> +Link binders +</div> +<div class="code"> + +<br/> +<span class="id" title="keyword">Definition</span> <a id="foo" class="idref" href="#foo"><span class="id" title="definition">foo</span></a> <a id="alpha:1" class="idref" href="#alpha:1"><span class="id" title="binder">alpha</span></a> <a id="beta:2" class="idref" href="#beta:2"><span class="id" title="binder">beta</span></a> := <a class="idref" href="Coqdoc.binder.html#alpha:1"><span class="id" title="variable">alpha</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.binder.html#beta:2"><span class="id" title="variable">beta</span></a>.<br/> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/binder.tex.out b/test-suite/coqdoc/binder.tex.out new file mode 100644 index 0000000000..2b5648aee6 --- /dev/null +++ b/test-suite/coqdoc/binder.tex.out @@ -0,0 +1,28 @@ +\documentclass[12pt]{report} +\usepackage[utf8x]{inputenc} + +%Warning: tipa declares many non-standard macros used by utf8x to +%interpret utf8 characters but extra packages might have to be added +%such as "textgreek" for Greek letters not already in tipa +%or "stmaryrd" for mathematical symbols. +%Utf8 codes missing a LaTeX interpretation can be defined by using +%\DeclareUnicodeCharacter{code}{interpretation}. +%Use coqdoc's option -p to add new packages or declarations. +\usepackage{tipa} + +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.binder}{Library }{Coqdoc.binder} + +\begin{coqdoccode} +\end{coqdoccode} +Link binders \begin{coqdoccode} +\coqdocemptyline +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.binder.foo}{foo}{\coqdocdefinition{foo}} \coqdef{Coqdoc.binder.alpha:1}{alpha}{\coqdocbinder{alpha}} \coqdef{Coqdoc.binder.beta:2}{beta}{\coqdocbinder{beta}} := \coqref{Coqdoc.binder.alpha:1}{\coqdocvariable{alpha}} \coqexternalref{::nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.binder.beta:2}{\coqdocvariable{beta}}.\coqdoceol +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/binder.v b/test-suite/coqdoc/binder.v new file mode 100644 index 0000000000..283ef64ac5 --- /dev/null +++ b/test-suite/coqdoc/binder.v @@ -0,0 +1,3 @@ +(** Link binders *) + +Definition foo alpha beta := alpha + beta. diff --git a/test-suite/coqdoc/bug11194.html.out b/test-suite/coqdoc/bug11194.html.out index 304d041033..6fc6533e59 100644 --- a/test-suite/coqdoc/bug11194.html.out +++ b/test-suite/coqdoc/bug11194.html.out @@ -19,11 +19,11 @@ <h1 class="libtitle">Library Coqdoc.bug11194</h1> <div class="code"> -<span class="id" title="keyword">Record</span> <a name="a_struct"><span class="id" title="record">a_struct</span></a> := { <a name="anum"><span class="id" title="projection">anum</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> }.<br/> -<span class="id" title="keyword">Canonical</span> <span class="id" title="keyword">Structure</span> <a name="a_struct_0"><span class="id" title="definition">a_struct_0</span></a> := {| <a class="idref" href="Coqdoc.bug11194.html#Build_a_struct"><span class="id" title="constructor">anum</span></a> <a class="idref" href="Coqdoc.bug11194.html#Build_a_struct"><span class="id" title="constructor">:=</span></a> <a class="idref" href="Coqdoc.bug11194.html#Build_a_struct"><span class="id" title="constructor">0</span></a>|}.<br/> -<span class="id" title="keyword">Definition</span> <a name="rename_a_s_0"><span class="id" title="definition">rename_a_s_0</span></a> := <a class="idref" href="Coqdoc.bug11194.html#a_struct_0"><span class="id" title="definition">a_struct_0</span></a>.<br/> -<span class="id" title="keyword">Coercion</span> <a name="some_nat"><span class="id" title="definition">some_nat</span></a> := (@<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#Some"><span class="id" title="constructor">Some</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>).<br/> -<span class="id" title="keyword">Definition</span> <a name="rename_some_nat"><span class="id" title="definition">rename_some_nat</span></a> := <a class="idref" href="Coqdoc.bug11194.html#some_nat"><span class="id" title="definition">some_nat</span></a>.<br/> +<span class="id" title="keyword">Record</span> <a id="a_struct" class="idref" href="#a_struct"><span class="id" title="record">a_struct</span></a> := { <a id="anum" class="idref" href="#anum"><span class="id" title="projection">anum</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> }.<br/> +<span class="id" title="keyword">Canonical</span> <span class="id" title="keyword">Structure</span> <a id="a_struct_0" class="idref" href="#a_struct_0"><span class="id" title="definition">a_struct_0</span></a> := {| <a class="idref" href="Coqdoc.bug11194.html#Build_a_struct"><span class="id" title="constructor">anum</span></a> <a class="idref" href="Coqdoc.bug11194.html#Build_a_struct"><span class="id" title="constructor">:=</span></a> <a class="idref" href="Coqdoc.bug11194.html#Build_a_struct"><span class="id" title="constructor">0</span></a>|}.<br/> +<span class="id" title="keyword">Definition</span> <a id="rename_a_s_0" class="idref" href="#rename_a_s_0"><span class="id" title="definition">rename_a_s_0</span></a> := <a class="idref" href="Coqdoc.bug11194.html#a_struct_0"><span class="id" title="definition">a_struct_0</span></a>.<br/> +<span class="id" title="keyword">Coercion</span> <a id="some_nat" class="idref" href="#some_nat"><span class="id" title="definition">some_nat</span></a> := (@<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#Some"><span class="id" title="constructor">Some</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>).<br/> +<span class="id" title="keyword">Definition</span> <a id="rename_some_nat" class="idref" href="#rename_some_nat"><span class="id" title="definition">rename_some_nat</span></a> := <a class="idref" href="Coqdoc.bug11194.html#some_nat"><span class="id" title="definition">some_nat</span></a>.<br/> </div> </div> diff --git a/test-suite/coqdoc/bug11353.html.out b/test-suite/coqdoc/bug11353.html.out index 0b4b4b6e37..f9d6a79906 100644 --- a/test-suite/coqdoc/bug11353.html.out +++ b/test-suite/coqdoc/bug11353.html.out @@ -19,13 +19,13 @@ <h1 class="libtitle">Library Coqdoc.bug11353</h1> <div class="code"> -<span class="id" title="keyword">Definition</span> <a name="a"><span class="id" title="definition">a</span></a> := 0. #[ <span class="id" title="var">universes</span>( <span class="id" title="var">template</span>) ]<br/> -<span class="id" title="keyword">Inductive</span> <a name="mysum"><span class="id" title="inductive">mysum</span></a> (<span class="id" title="var">A</span> <span class="id" title="var">B</span>:<span class="id" title="keyword">Type</span>) : <span class="id" title="keyword">Type</span> :=<br/> - | <a name="myinl"><span class="id" title="constructor">myinl</span></a> : <a class="idref" href="Coqdoc.bug11353.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#1c93e43e07fbeaeb6a625cb6614beb5d"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B"><span class="id" title="variable">B</span></a><br/> - | <a name="myinr"><span class="id" title="constructor">myinr</span></a> : <a class="idref" href="Coqdoc.bug11353.html#B"><span class="id" title="variable">B</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#1c93e43e07fbeaeb6a625cb6614beb5d"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B"><span class="id" title="variable">B</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="a" class="idref" href="#a"><span class="id" title="definition">a</span></a> := 0. #[ <span class="id" title="var">universes</span>( <span class="id" title="var">template</span>) ]<br/> +<span class="id" title="keyword">Inductive</span> <a id="mysum" class="idref" href="#mysum"><span class="id" title="inductive">mysum</span></a> (<a id="A:1" class="idref" href="#A:1"><span class="id" title="binder">A</span></a> <a id="B:2" class="idref" href="#B:2"><span class="id" title="binder">B</span></a>:<span class="id" title="keyword">Type</span>) : <span class="id" title="keyword">Type</span> :=<br/> + | <a id="myinl" class="idref" href="#myinl"><span class="id" title="constructor">myinl</span></a> : <a class="idref" href="Coqdoc.bug11353.html#A:1"><span class="id" title="variable">A</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#::type_scope:x_'->'_x"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum:3"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A:1"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B:2"><span class="id" title="variable">B</span></a><br/> + | <a id="myinr" class="idref" href="#myinr"><span class="id" title="constructor">myinr</span></a> : <a class="idref" href="Coqdoc.bug11353.html#B:2"><span class="id" title="variable">B</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#::type_scope:x_'->'_x"><span class="id" title="notation">→</span></a> <a class="idref" href="Coqdoc.bug11353.html#mysum:3"><span class="id" title="inductive">mysum</span></a> <a class="idref" href="Coqdoc.bug11353.html#A:1"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.bug11353.html#B:2"><span class="id" title="variable">B</span></a>.<br/> <br/> -#[<span class="id" title="var">local</span>]<span class="id" title="keyword">Definition</span> <a name="b"><span class="id" title="definition">b</span></a> := 1.<br/> +#[<span class="id" title="var">local</span>]<span class="id" title="keyword">Definition</span> <a id="b" class="idref" href="#b"><span class="id" title="definition">b</span></a> := 1.<br/> </div> </div> diff --git a/test-suite/coqdoc/bug11353.tex.out b/test-suite/coqdoc/bug11353.tex.out index a6478682d8..12ea109d0e 100644 --- a/test-suite/coqdoc/bug11353.tex.out +++ b/test-suite/coqdoc/bug11353.tex.out @@ -22,11 +22,11 @@ \coqdocnoindent \coqdockw{Definition} \coqdef{Coqdoc.bug11353.a}{a}{\coqdocdefinition{a}} := 0. \#[ \coqdocvar{universes}( \coqdocvar{template}) ]\coqdoceol \coqdocnoindent -\coqdockw{Inductive} \coqdef{Coqdoc.bug11353.mysum}{mysum}{\coqdocinductive{mysum}} (\coqdocvar{A} \coqdocvar{B}:\coqdockw{Type}) : \coqdockw{Type} :=\coqdoceol +\coqdockw{Inductive} \coqdef{Coqdoc.bug11353.mysum}{mysum}{\coqdocinductive{mysum}} (\coqdef{Coqdoc.bug11353.A:1}{A}{\coqdocbinder{A}} \coqdef{Coqdoc.bug11353.B:2}{B}{\coqdocbinder{B}}:\coqdockw{Type}) : \coqdockw{Type} :=\coqdoceol \coqdocindent{1.00em} -\ensuremath{|} \coqdef{Coqdoc.bug11353.myinl}{myinl}{\coqdocconstructor{myinl}} : \coqdocvariable{A} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum}{\coqdocinductive{mysum}} \coqdocvariable{A} \coqdocvariable{B}\coqdoceol +\ensuremath{|} \coqdef{Coqdoc.bug11353.myinl}{myinl}{\coqdocconstructor{myinl}} : \coqref{Coqdoc.bug11353.A:1}{\coqdocvariable{A}} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum:3}{\coqdocinductive{mysum}} \coqref{Coqdoc.bug11353.A:1}{\coqdocvariable{A}} \coqref{Coqdoc.bug11353.B:2}{\coqdocvariable{B}}\coqdoceol \coqdocindent{1.00em} -\ensuremath{|} \coqdef{Coqdoc.bug11353.myinr}{myinr}{\coqdocconstructor{myinr}} : \coqdocvariable{B} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum}{\coqdocinductive{mysum}} \coqdocvariable{A} \coqdocvariable{B}.\coqdoceol +\ensuremath{|} \coqdef{Coqdoc.bug11353.myinr}{myinr}{\coqdocconstructor{myinr}} : \coqref{Coqdoc.bug11353.B:2}{\coqdocvariable{B}} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqref{Coqdoc.bug11353.mysum:3}{\coqdocinductive{mysum}} \coqref{Coqdoc.bug11353.A:1}{\coqdocvariable{A}} \coqref{Coqdoc.bug11353.B:2}{\coqdocvariable{B}}.\coqdoceol \coqdocemptyline \coqdocnoindent \#[\coqdocvar{local}]\coqdockw{Definition} \coqdef{Coqdoc.bug11353.b}{b}{\coqdocdefinition{b}} := 1.\coqdoceol diff --git a/test-suite/coqdoc/bug5648.html.out b/test-suite/coqdoc/bug5648.html.out index 5c5a2dc299..e1d1c1313e 100644 --- a/test-suite/coqdoc/bug5648.html.out +++ b/test-suite/coqdoc/bug5648.html.out @@ -19,18 +19,18 @@ <h1 class="libtitle">Library Coqdoc.bug5648</h1> <div class="code"> -<span class="id" title="keyword">Lemma</span> <a name="a"><span class="id" title="lemma">a</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a>.<br/> +<span class="id" title="keyword">Lemma</span> <a id="a" class="idref" href="#a"><span class="id" title="lemma">a</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a>.<br/> <span class="id" title="keyword">Proof</span>.<br/> <span class="id" title="tactic">auto</span>.<br/> <span class="id" title="keyword">Qed</span>.<br/> <br/> -<span class="id" title="keyword">Variant</span> <a name="t"><span class="id" title="inductive">t</span></a> :=<br/> -| <a name="A"><span class="id" title="constructor">A</span></a> | <a name="Add"><span class="id" title="constructor">Add</span></a> | <a name="G"><span class="id" title="constructor">G</span></a> | <a name="Goal"><span class="id" title="constructor">Goal</span></a> | <a name="L"><span class="id" title="constructor">L</span></a> | <a name="Lemma"><span class="id" title="constructor">Lemma</span></a> | <a name="P"><span class="id" title="constructor">P</span></a> | <a name="Proof"><span class="id" title="constructor">Proof</span></a> .<br/> +<span class="id" title="keyword">Variant</span> <a id="t" class="idref" href="#t"><span class="id" title="inductive">t</span></a> :=<br/> +| <a id="A" class="idref" href="#A"><span class="id" title="constructor">A</span></a> | <a id="Add" class="idref" href="#Add"><span class="id" title="constructor">Add</span></a> | <a id="G" class="idref" href="#G"><span class="id" title="constructor">G</span></a> | <a id="Goal" class="idref" href="#Goal"><span class="id" title="constructor">Goal</span></a> | <a id="L" class="idref" href="#L"><span class="id" title="constructor">L</span></a> | <a id="Lemma" class="idref" href="#Lemma"><span class="id" title="constructor">Lemma</span></a> | <a id="P" class="idref" href="#P"><span class="id" title="constructor">P</span></a> | <a id="Proof" class="idref" href="#Proof"><span class="id" title="constructor">Proof</span></a> .<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="d"><span class="id" title="definition">d</span></a> <span class="id" title="var">x</span> :=<br/> - <span class="id" title="keyword">match</span> <a class="idref" href="Coqdoc.bug5648.html#x"><span class="id" title="variable">x</span></a> <span class="id" title="keyword">with</span><br/> +<span class="id" title="keyword">Definition</span> <a id="d" class="idref" href="#d"><span class="id" title="definition">d</span></a> <a id="x:3" class="idref" href="#x:3"><span class="id" title="binder">x</span></a> :=<br/> + <span class="id" title="keyword">match</span> <a class="idref" href="Coqdoc.bug5648.html#x:3"><span class="id" title="variable">x</span></a> <span class="id" title="keyword">with</span><br/> | <a class="idref" href="Coqdoc.bug5648.html#A"><span class="id" title="constructor">A</span></a> ⇒ 0<br/> | <a class="idref" href="Coqdoc.bug5648.html#Add"><span class="id" title="constructor">Add</span></a> ⇒ 1<br/> | <a class="idref" href="Coqdoc.bug5648.html#G"><span class="id" title="constructor">G</span></a> ⇒ 2<br/> diff --git a/test-suite/coqdoc/bug5648.tex.out b/test-suite/coqdoc/bug5648.tex.out index 82f7da2309..c221d7ca8a 100644 --- a/test-suite/coqdoc/bug5648.tex.out +++ b/test-suite/coqdoc/bug5648.tex.out @@ -34,9 +34,9 @@ \ensuremath{|} \coqdef{Coqdoc.bug5648.A}{A}{\coqdocconstructor{A}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Add}{Add}{\coqdocconstructor{Add}} \ensuremath{|} \coqdef{Coqdoc.bug5648.G}{G}{\coqdocconstructor{G}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Goal}{Goal}{\coqdocconstructor{Goal}} \ensuremath{|} \coqdef{Coqdoc.bug5648.L}{L}{\coqdocconstructor{L}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Lemma}{Lemma}{\coqdocconstructor{Lemma}} \ensuremath{|} \coqdef{Coqdoc.bug5648.P}{P}{\coqdocconstructor{P}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Proof}{Proof}{\coqdocconstructor{Proof}} .\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Definition} \coqdef{Coqdoc.bug5648.d}{d}{\coqdocdefinition{d}} \coqdocvar{x} :=\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.bug5648.d}{d}{\coqdocdefinition{d}} \coqdef{Coqdoc.bug5648.x:3}{x}{\coqdocbinder{x}} :=\coqdoceol \coqdocindent{1.00em} -\coqdockw{match} \coqdocvariable{x} \coqdockw{with}\coqdoceol +\coqdockw{match} \coqref{Coqdoc.bug5648.x:3}{\coqdocvariable{x}} \coqdockw{with}\coqdoceol \coqdocindent{1.00em} \ensuremath{|} \coqref{Coqdoc.bug5648.A}{\coqdocconstructor{A}} \ensuremath{\Rightarrow} 0\coqdoceol \coqdocindent{1.00em} diff --git a/test-suite/coqdoc/bug5700.html.out b/test-suite/coqdoc/bug5700.html.out index b96fc6281d..286e8bba4d 100644 --- a/test-suite/coqdoc/bug5700.html.out +++ b/test-suite/coqdoc/bug5700.html.out @@ -26,7 +26,7 @@ </div> <div class="code"> -<span class="id" title="keyword">Definition</span> <a name="const1"><span class="id" title="definition">const1</span></a> := 1.<br/> +<span class="id" title="keyword">Definition</span> <a id="const1" class="idref" href="#const1"><span class="id" title="definition">const1</span></a> := 1.<br/> <br/> </div> @@ -36,7 +36,7 @@ </div> <div class="code"> -<span class="id" title="keyword">Definition</span> <a name="const2"><span class="id" title="definition">const2</span></a> := 2.<br/> +<span class="id" title="keyword">Definition</span> <a id="const2" class="idref" href="#const2"><span class="id" title="definition">const2</span></a> := 2.<br/> </div> </div> diff --git a/test-suite/coqdoc/links.html.out b/test-suite/coqdoc/links.html.out index d2d4d5d764..12d284dc54 100644 --- a/test-suite/coqdoc/links.html.out +++ b/test-suite/coqdoc/links.html.out @@ -51,93 +51,93 @@ Various checks for coqdoc <span class="id" title="keyword">Require</span> <span class="id" title="keyword">Import</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Strings.String.html#"><span class="id" title="library">String</span></a>.<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="g"><span class="id" title="definition">g</span></a> := "dfjkh""sdfhj forall <> * ~"%<span class="id" title="var">string</span>.<br/> +<span class="id" title="keyword">Definition</span> <a id="g" class="idref" href="#g"><span class="id" title="definition">g</span></a> := "dfjkh""sdfhj forall <> * ~"%<span class="id" title="var">string</span>.<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="a"><span class="id" title="definition">a</span></a> (<span class="id" title="var">b</span>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>) := <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="a" class="idref" href="#a"><span class="id" title="definition">a</span></a> (<a id="b:1" class="idref" href="#b:1"><span class="id" title="binder">b</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>) := <a class="idref" href="Coqdoc.links.html#b:1"><span class="id" title="variable">b</span></a>.<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="f"><span class="id" title="definition">f</span></a> := <span class="id" title="keyword">∀</span> <span class="id" title="var">C</span>:<span class="id" title="keyword">Prop</span>, <a class="idref" href="Coqdoc.links.html#C"><span class="id" title="variable">C</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="f" class="idref" href="#f"><span class="id" title="definition">f</span></a> := <span class="id" title="keyword">∀</span> <a id="C:2" class="idref" href="#C:2"><span class="id" title="binder">C</span></a>:<span class="id" title="keyword">Prop</span>, <a class="idref" href="Coqdoc.links.html#C:2"><span class="id" title="variable">C</span></a>.<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>).<br/> +<span class="id" title="keyword">Notation</span> <a id="f03f7a04ef75ff3ac66ca5c23554e52e" class="idref" href="#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>).<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#mult"><span class="id" title="abbreviation">mult</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>). +<span class="id" title="keyword">Notation</span> <a id="f03f7a04ef75ff3ac66ca5c23554e52e" class="idref" href="#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#mult"><span class="id" title="abbreviation">mult</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>). <br/> -<span class="id" title="keyword">Notation</span> <a name="f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">"</span></a>n ** m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> +<span class="id" title="keyword">Notation</span> <a id="f07b3676d96b68749d342542fd80e2b0" class="idref" href="#f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">"</span></a>n ** m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">"</span></a>n ▵ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> +<span class="id" title="keyword">Notation</span> <a id="a647c51c9816a1b44fcfa5312db8344a" class="idref" href="#a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">"</span></a>n ▵ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">"</span></a>n '_' ++ 'x' m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 3).<br/> +<span class="id" title="keyword">Notation</span> <a id="3dd9eae9daa65efe5444f5fc3529a2e7" class="idref" href="#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">"</span></a>n '_' ++ 'x' m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 3).<br/> <br/> -<span class="id" title="keyword">Inductive</span> <a name="eq"><span class="id" title="inductive">eq</span></a> (<span class="id" title="var">A</span>:<span class="id" title="keyword">Type</span>) (<span class="id" title="var">x</span>:<a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a>) : <span class="id" title="var">A</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#1c93e43e07fbeaeb6a625cb6614beb5d"><span class="id" title="notation">→</span></a> <span class="id" title="keyword">Prop</span> := <a name="eq_refl"><span class="id" title="constructor">eq_refl</span></a> : <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a><a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a><br/> +<span class="id" title="keyword">Inductive</span> <a id="eq" class="idref" href="#eq"><span class="id" title="inductive">eq</span></a> (<a id="A:3" class="idref" href="#A:3"><span class="id" title="binder">A</span></a>:<span class="id" title="keyword">Type</span>) (<a id="x:4" class="idref" href="#x:4"><span class="id" title="binder">x</span></a>:<a class="idref" href="Coqdoc.links.html#A:3"><span class="id" title="variable">A</span></a>) : <span class="id" title="var">A</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#::type_scope:x_'->'_x"><span class="id" title="notation">→</span></a> <span class="id" title="keyword">Prop</span> := <a id="eq_refl" class="idref" href="#eq_refl"><span class="id" title="constructor">eq_refl</span></a> : <a class="idref" href="Coqdoc.links.html#x:4"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> <a class="idref" href="Coqdoc.links.html#x:4"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a><a class="idref" href="Coqdoc.links.html#A:3"><span class="id" title="variable">A</span></a><br/> <br/> -<span class="id" title="keyword">where</span> <a name="b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq"><span class="id" title="inductive">eq</span></a> <span class="id" title="var">A</span> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> +<span class="id" title="keyword">where</span> <a id="b8b2ebc8e1a8b9aa935c0702efb5dccf" class="idref" href="#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq:6"><span class="id" title="inductive">eq</span></a> <span class="id" title="var">A</span> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="eq0"><span class="id" title="definition">eq0</span></a> := 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="eq0" class="idref" href="#eq0"><span class="id" title="definition">eq0</span></a> := 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">"</span></a>( x # y ; .. ; z )" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> .. (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) .. <span class="id" title="var">z</span>).<br/> +<span class="id" title="keyword">Notation</span> <a id="2c0c193cd2aedf7ecdb713db64dbfce6" class="idref" href="#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">"</span></a>( x # y ; .. ; z )" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> .. (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) .. <span class="id" title="var">z</span>).<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="9f5a1d89cbd4d38f5e289576db7123d1"><span class="id" title="definition">b_α</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a><a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">(</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">#</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">;</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">)</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">,</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a>0 <a class="idref" href="Coqdoc.links.html#f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">**</span></a> 0<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">))</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a id="9f5a1d89cbd4d38f5e289576db7123d1" class="idref" href="#9f5a1d89cbd4d38f5e289576db7123d1"><span class="id" title="definition">b_α</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a><a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">(</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">#</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">;</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">)</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">,</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a>0 <a class="idref" href="Coqdoc.links.html#f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">**</span></a> 0<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">))</span></a>.<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="h"><span class="id" title="abbreviation">h</span></a> := <a class="idref" href="Coqdoc.links.html#a"><span class="id" title="definition">a</span></a>.<br/> +<span class="id" title="keyword">Notation</span> <a id="h" class="idref" href="#h"><span class="id" title="abbreviation">h</span></a> := <a class="idref" href="Coqdoc.links.html#a"><span class="id" title="definition">a</span></a>.<br/> <br/> - <span class="id" title="keyword">Section</span> <a name="test"><span class="id" title="section">test</span></a>.<br/> + <span class="id" title="keyword">Section</span> <a id="test" class="idref" href="#test"><span class="id" title="section">test</span></a>.<br/> <br/> - <span class="id" title="keyword">Variables</span> <a name="test.b'"><span class="id" title="variable">b'</span></a> <a name="test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="keyword">Variables</span> <a id="test.b'" class="idref" href="#test.b'"><span class="id" title="variable">b'</span></a> <a id="test.b2" class="idref" href="#test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> - <span class="id" title="keyword">Notation</span> <a name="2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">"</span></a>n + m" := (<span class="id" title="var">n</span> <a class="idref" href="Coqdoc.links.html#a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">▵</span></a> <span class="id" title="var">m</span>) : <span class="id" title="var">my_scope</span>.<br/> + <span class="id" title="keyword">Notation</span> <a id="2158f15740ce05a939b657be222c26d6" class="idref" href="#2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">"</span></a>n + m" := (<span class="id" title="var">n</span> <a class="idref" href="Coqdoc.links.html#a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">▵</span></a> <span class="id" title="var">m</span>) : <span class="id" title="var">my_scope</span>.<br/> <br/> <span class="id" title="keyword">Delimit</span> <span class="id" title="keyword">Scope</span> <span class="id" title="var">my_scope</span> <span class="id" title="keyword">with</span> <span class="id" title="var">my</span>.<br/> <br/> - <span class="id" title="keyword">Notation</span> <a name="l"><span class="id" title="abbreviation">l</span></a> := 0.<br/> + <span class="id" title="keyword">Notation</span> <a id="l" class="idref" href="#l"><span class="id" title="abbreviation">l</span></a> := 0.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="ab410a966ac148e9b78c65c6cdf301fd"><span class="id" title="definition">α</span></a> := (0 <a class="idref" href="Coqdoc.links.html#2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#l"><span class="id" title="abbreviation">l</span></a>)%<span class="id" title="var">my</span>.<br/> + <span class="id" title="keyword">Definition</span> <a id="ab410a966ac148e9b78c65c6cdf301fd" class="idref" href="#ab410a966ac148e9b78c65c6cdf301fd"><span class="id" title="definition">α</span></a> := (0 <a class="idref" href="Coqdoc.links.html#2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#l"><span class="id" title="abbreviation">l</span></a>)%<span class="id" title="var">my</span>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="a'"><span class="id" title="definition">a'</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test.b'"><span class="id" title="variable">b'</span></a><a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a>0<a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a>.<br/> + <span class="id" title="keyword">Definition</span> <a id="a'" class="idref" href="#a'"><span class="id" title="definition">a'</span></a> <a id="b:9" class="idref" href="#b:9"><span class="id" title="binder">b</span></a> := <a class="idref" href="Coqdoc.links.html#test.b'"><span class="id" title="variable">b'</span></a><a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a>0<a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b:9"><span class="id" title="variable">b</span></a>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="c"><span class="id" title="definition">c</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}+{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}</span></a>.<br/> + <span class="id" title="keyword">Definition</span> <a id="c" class="idref" href="#c"><span class="id" title="definition">c</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}+{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}</span></a>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="d"><span class="id" title="definition">d</span></a> := (1<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a>2)%<span class="id" title="var">nat</span>.<br/> + <span class="id" title="keyword">Definition</span> <a id="d" class="idref" href="#d"><span class="id" title="definition">d</span></a> := (1<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a>2)%<span class="id" title="var">nat</span>.<br/> <br/> - <span class="id" title="keyword">Lemma</span> <a name="e"><span class="id" title="lemma">e</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e03f39daf98516fa530d3f6f5a1b4d92"><span class="id" title="notation">+</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="keyword">Lemma</span> <a id="e" class="idref" href="#e"><span class="id" title="lemma">e</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e03f39daf98516fa530d3f6f5a1b4d92"><span class="id" title="notation">+</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <span class="id" title="var">Admitted</span>.<br/> <br/> <span class="id" title="keyword">End</span> <a class="idref" href="Coqdoc.links.html#test"><span class="id" title="section">test</span></a>.<br/> <br/> - <span class="id" title="keyword">Section</span> <a name="test2"><span class="id" title="section">test2</span></a>.<br/> + <span class="id" title="keyword">Section</span> <a id="test2" class="idref" href="#test2"><span class="id" title="section">test2</span></a>.<br/> <br/> - <span class="id" title="keyword">Variables</span> <a name="test2.b'"><span class="id" title="variable">b'</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="keyword">Variables</span> <a id="test2.b'" class="idref" href="#test2.b'"><span class="id" title="variable">b'</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> - <span class="id" title="keyword">Section</span> <a name="test2.test"><span class="id" title="section">test</span></a>.<br/> + <span class="id" title="keyword">Section</span> <a id="test2.test" class="idref" href="#test2.test"><span class="id" title="section">test</span></a>.<br/> <br/> - <span class="id" title="keyword">Variables</span> <a name="test2.test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="keyword">Variables</span> <a id="test2.test.b2" class="idref" href="#test2.test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="a''"><span class="id" title="definition">a''</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test2.b'"><span class="id" title="variable">b'</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#O"><span class="id" title="constructor">O</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#test2.test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#h"><span class="id" title="abbreviation">h</span></a> 0.<br/> + <span class="id" title="keyword">Definition</span> <a id="a''" class="idref" href="#a''"><span class="id" title="definition">a''</span></a> <a id="b:12" class="idref" href="#b:12"><span class="id" title="binder">b</span></a> := <a class="idref" href="Coqdoc.links.html#test2.b'"><span class="id" title="variable">b'</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#O"><span class="id" title="constructor">O</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#test2.test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b:12"><span class="id" title="variable">b</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#h"><span class="id" title="abbreviation">h</span></a> 0.<br/> <br/> <span class="id" title="keyword">End</span> <a class="idref" href="Coqdoc.links.html#test2.test"><span class="id" title="section">test</span></a>.<br/> diff --git a/test-suite/coqdoc/links.tex.out b/test-suite/coqdoc/links.tex.out index 24f96ff1e6..2304f5ecc1 100644 --- a/test-suite/coqdoc/links.tex.out +++ b/test-suite/coqdoc/links.tex.out @@ -45,10 +45,10 @@ Various checks for coqdoc \coqdockw{Definition} \coqdef{Coqdoc.links.g}{g}{\coqdocdefinition{g}} := "dfjkh""sdfhj forall <> * \~{}"\%\coqdocvar{string}.\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Definition} \coqdef{Coqdoc.links.a}{a}{\coqdocdefinition{a}} (\coqdocvar{b}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}) := \coqdocvariable{b}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.a}{a}{\coqdocdefinition{a}} (\coqdef{Coqdoc.links.b:1}{b}{\coqdocbinder{b}}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}) := \coqref{Coqdoc.links.b:1}{\coqdocvariable{b}}.\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Definition} \coqdef{Coqdoc.links.f}{f}{\coqdocdefinition{f}} := \coqdockw{\ensuremath{\forall}} \coqdocvar{C}:\coqdockw{Prop}, \coqdocvariable{C}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.f}{f}{\coqdocdefinition{f}} := \coqdockw{\ensuremath{\forall}} \coqdef{Coqdoc.links.C:2}{C}{\coqdocbinder{C}}:\coqdockw{Prop}, \coqref{Coqdoc.links.C:2}{\coqdocvariable{C}}.\coqdoceol \coqdocemptyline \coqdocnoindent \coqdockw{Notation} \coqdef{Coqdoc.links.:::x '++' x}{"}{"}n ++ m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}).\coqdoceol @@ -65,11 +65,11 @@ Various checks for coqdoc \coqdockw{Notation} \coqdef{Coqdoc.links.:::x ''' ''' '++' 'x' x}{"}{"}n '\_' ++ 'x' m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 3).\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Inductive} \coqdef{Coqdoc.links.eq}{eq}{\coqdocinductive{eq}} (\coqdocvar{A}:\coqdockw{Type}) (\coqdocvar{x}:\coqdocvariable{A}) : \coqdocvar{A} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqdockw{Prop} := \coqdef{Coqdoc.links.eq refl}{eq\_refl}{\coqdocconstructor{eq\_refl}} : \coqdocvariable{x} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{=}} \coqdocvariable{x} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{:>}}\coqdocvariable{A}\coqdoceol +\coqdockw{Inductive} \coqdef{Coqdoc.links.eq}{eq}{\coqdocinductive{eq}} (\coqdef{Coqdoc.links.A:3}{A}{\coqdocbinder{A}}:\coqdockw{Type}) (\coqdef{Coqdoc.links.x:4}{x}{\coqdocbinder{x}}:\coqref{Coqdoc.links.A:3}{\coqdocvariable{A}}) : \coqdocvar{A} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqdockw{Prop} := \coqdef{Coqdoc.links.eq refl}{eq\_refl}{\coqdocconstructor{eq\_refl}} : \coqref{Coqdoc.links.x:4}{\coqdocvariable{x}} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{=}} \coqref{Coqdoc.links.x:4}{\coqdocvariable{x}} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{:>}}\coqref{Coqdoc.links.A:3}{\coqdocvariable{A}}\coqdoceol \coqdocnoindent \coqdoceol \coqdocnoindent -\coqdockw{where} \coqdef{Coqdoc.links.::type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqref{Coqdoc.links.eq}{\coqdocinductive{eq}} \coqdocvar{A} \coqdocvar{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol +\coqdockw{where} \coqdef{Coqdoc.links.::type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqref{Coqdoc.links.eq:6}{\coqdocinductive{eq}} \coqdocvar{A} \coqdocvar{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol \coqdocemptyline \coqdocnoindent \coqdockw{Definition} \coqdef{Coqdoc.links.eq0}{eq0}{\coqdocdefinition{eq0}} := 0 \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{=}} 0 \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{:>}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol @@ -102,7 +102,7 @@ Various checks for coqdoc \coqdockw{Definition} \coqdef{Coqdoc.links.xCExB1}{α}{\coqdocdefinition{α}} := (0 \coqref{Coqdoc.links.test.::my scope:x '+' x}{\coqdocnotation{+}} \coqref{Coqdoc.links.l}{\coqdocabbreviation{l}})\%\coqdocvar{my}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} -\coqdockw{Definition} \coqdef{Coqdoc.links.a'}{a'}{\coqdocdefinition{a'}} \coqdocvar{b} := \coqdocvariable{b'}\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}0\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}\coqdocvariable{b2} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}}\coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.a'}{a'}{\coqdocdefinition{a'}} \coqdef{Coqdoc.links.b:9}{b}{\coqdocbinder{b}} := \coqref{Coqdoc.links.test.b'}{\coqdocvariable{b'}}\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}0\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}\coqref{Coqdoc.links.test.b2}{\coqdocvariable{b2}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}}\coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqref{Coqdoc.links.b:9}{\coqdocvariable{b}}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} \coqdockw{Definition} \coqdef{Coqdoc.links.c}{c}{\coqdocdefinition{c}} := \coqexternalref{::type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{::type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}+\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{::type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}}}.\coqdoceol @@ -131,7 +131,7 @@ Various checks for coqdoc \coqdockw{Variables} \coqdef{Coqdoc.links.test2.test.b2}{b2}{\coqdocvariable{b2}}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol \coqdocemptyline \coqdocindent{3.00em} -\coqdockw{Definition} \coqdef{Coqdoc.links.a''}{a'{}'}{\coqdocdefinition{a'{}'}} \coqdocvar{b} := \coqdocvariable{b'} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqexternalref{O}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{O}} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqdocvariable{b2} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b} \coqexternalref{::nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.links.h}{\coqdocabbreviation{h}} 0.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.a''}{a'{}'}{\coqdocdefinition{a'{}'}} \coqdef{Coqdoc.links.b:12}{b}{\coqdocbinder{b}} := \coqref{Coqdoc.links.test2.b'}{\coqdocvariable{b'}} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqexternalref{O}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{O}} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqref{Coqdoc.links.test2.test.b2}{\coqdocvariable{b2}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqref{Coqdoc.links.b:12}{\coqdocvariable{b}} \coqexternalref{::nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.links.h}{\coqdocabbreviation{h}} 0.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} \coqdockw{End} \coqref{Coqdoc.links.test2.test}{\coqdocsection{test}}.\coqdoceol diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index abc7f0f88e..e0aa758812 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -2,9 +2,9 @@ The command has indeed failed with message: Flag "rename" expected to rename A into B. File "stdin", line 3, characters 0-25: Warning: This command is just asserting the names of arguments of identity. -If this is what you want add ': assert' to silence the warning. If you want -to clear implicit arguments add ': clear implicits'. If you want to clear -notation scopes add ': clear scopes' [arguments-assert,vernacular] +If this is what you want, add ': assert' to silence the warning. If you want +to clear implicit arguments, add ': clear implicits'. If you want to clear +notation scopes, add ': clear scopes' [arguments-assert,vernacular] @eq_refl : forall (B : Type) (y : B), y = y eq_refl diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index e121b5e86c..f48eaac4c9 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -14,6 +14,10 @@ Entry constr:myconstr is : nat [<< # 0 >>] : option nat +[b + c] + : nat +fun a : nat => [a + a] + : nat -> nat [1 {f 1}] : Expr fun (x : nat) (y z : Expr) => [1 + y z + {f x}] @@ -81,18 +85,18 @@ fun x : nat => [x] : nat -> nat ∀ x : nat, x = x : Prop -File "stdin", line 219, characters 0-160: +File "stdin", line 226, characters 0-160: Warning: Notation "∀ _ .. _ , _" was already defined with a different format in scope type_scope. [notation-incompatible-format,parsing] ∀x : nat,x = x : Prop -File "stdin", line 232, characters 0-60: +File "stdin", line 239, characters 0-60: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 236, characters 0-64: +File "stdin", line 243, characters 0-64: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 241, characters 0-62: +File "stdin", line 248, characters 0-62: Warning: Lonely notation "_ %%%% _" was already defined with a different format. [notation-incompatible-format,parsing] 3 %% 4 @@ -101,9 +105,9 @@ format. [notation-incompatible-format,parsing] : nat 3 %% 4 : nat -File "stdin", line 269, characters 0-61: +File "stdin", line 276, characters 0-61: Warning: The format modifier is irrelevant for only parsing rules. [irrelevant-format-only-parsing,parsing] -File "stdin", line 273, characters 0-63: +File "stdin", line 280, characters 0-63: Warning: The only parsing modifier has no effect in Reserved Notation. [irrelevant-reserved-notation-only-parsing,parsing] diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 1cf0d919b1..4d4b37a8b2 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -22,6 +22,13 @@ Notation "<< x >>" := x (in custom myconstr at level 3, x custom anotherconstr a Notation "# x" := (Some x) (in custom anotherconstr at level 8, x constr at level 9). Check [ << # 0 >> ]. +(* Now check with global *) + +Axiom c : nat. +Notation "x" := x (in custom myconstr at level 0, x global). +Check [ b + c ]. +Check fun a => [ a + a ]. + End A. Module B. diff --git a/test-suite/output/NotationsSigma.out b/test-suite/output/NotationsSigma.out new file mode 100644 index 0000000000..0e4df87148 --- /dev/null +++ b/test-suite/output/NotationsSigma.out @@ -0,0 +1,40 @@ +{0 = 0} + {0 < 1} + : Set +(0 = 0) + {0 < 1} + : Set +{x : nat | x = 1} + : Set +{x : nat | x = 1 & 0 < x} + : Set +{x : nat | x = 1} + : Set +{x : nat | x = 1 & 0 < x} + : Set +{x : nat & x = 1} + : Set +{x : nat & x = 1 & 0 < x} + : Set +{x : nat & x = 1} + : Set +{x : nat & x = 1 & 0 < x} + : Set +{'(x, _) : nat * ?T | x = 1} + : Type +where +?T : [pat : nat * ?T |- Type] (pat cannot be used) +{'(x, y) : nat * nat | x = 1 & y = 0} + : Set +{'(x, _) : nat * nat | x = 1} + : Set +{'(x, y) : nat * nat | x = 1 & y = 0} + : Set +{'(x, _) : nat * ?T & x = 1} + : Type +where +?T : [pat : nat * ?T |- Type] (pat cannot be used) +{'(x, y) : nat * nat & x = 1 & y = 0} + : Type +{'(x, _) : nat * nat & x = 1} + : Type +{'(x, y) : nat * nat & x = 1 & y = 0} + : Type diff --git a/test-suite/output/NotationsSigma.v b/test-suite/output/NotationsSigma.v new file mode 100644 index 0000000000..6780d63a04 --- /dev/null +++ b/test-suite/output/NotationsSigma.v @@ -0,0 +1,22 @@ +(* Check notations for sigma types *) + +Check { 0 = 0 } + { 0 < 1 }. +Check (0 = 0) + { 0 < 1 }. + +Check { x | x = 1 }. +Check { x | x = 1 & 0 < x }. +Check { x : nat | x = 1 }. +Check { x : nat | x = 1 & 0 < x }. +Check { x & x = 1 }. +Check { x & x = 1 & 0 < x }. +Check { x : nat & x = 1 }. +Check { x : nat & x = 1 & 0 < x }. + +Check {'(x,y) | x = 1 }. +Check {'(x,y) | x = 1 & y = 0 }. +Check {'(x,y) : nat * nat | x = 1 }. +Check {'(x,y) : nat * nat | x = 1 & y = 0 }. +Check {'(x,y) & x = 1 }. +Check {'(x,y) & x = 1 & y = 0 }. +Check {'(x,y) : nat * nat & x = 1 }. +Check {'(x,y) : nat * nat & x = 1 & y = 0 }. diff --git a/test-suite/output/Projections.out b/test-suite/output/Projections.out index e9c28faf1d..1dd89c9bcd 100644 --- a/test-suite/output/Projections.out +++ b/test-suite/output/Projections.out @@ -1,2 +1,17 @@ fun S : store => S.(store_funcs) : store -> host_func +a = +fun A : Type => +let B := A in fun (C : Type) (u : U A C) => (A, B, C, c _ _ u) + : forall A : Type, + let B := A in + forall C : Type, U A C -> Type * Type * Type * (B * A * C) + +Arguments a (_ _)%type_scope +b = +fun A : Type => let B := A in fun (C : Type) (u : U A C) => b _ _ u + : forall A : Type, + let B := A in + forall (C : Type) (u : U A C), (A, B, C, c _ _ u) = (A, B, C, c _ _ u) + +Arguments b (_ _)%type_scope diff --git a/test-suite/output/Projections.v b/test-suite/output/Projections.v index 14d63d39c4..83a581338f 100644 --- a/test-suite/output/Projections.v +++ b/test-suite/output/Projections.v @@ -10,3 +10,12 @@ Section store. End store. Check (fun (S:@store nat) => S.(store_funcs)). + +Module LocalDefUnfolding. + +Unset Printing Projections. +Record U A (B:=A) C := {c:B*A*C;a:=(A,B,C,c);b:a=a}. +Print a. +Print b. + +End LocalDefUnfolding. diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 9d8e830d64..593d0c7f67 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -136,7 +136,7 @@ h': newdef n <> n (use "About" for full details on implicit arguments) (use "About" for full details on implicit arguments) The command has indeed failed with message: -No such goal. +[Focus] No such goal. The command has indeed failed with message: Query commands only support the single numbered goal selector. The command has indeed failed with message: diff --git a/test-suite/output/UselessSyndef.out b/test-suite/output/UselessSyndef.out new file mode 100644 index 0000000000..ce484889b3 --- /dev/null +++ b/test-suite/output/UselessSyndef.out @@ -0,0 +1,2 @@ +a + : nat diff --git a/test-suite/output/UselessSyndef.v b/test-suite/output/UselessSyndef.v new file mode 100644 index 0000000000..96ad6e9f5c --- /dev/null +++ b/test-suite/output/UselessSyndef.v @@ -0,0 +1,10 @@ +Module M. + Definition a := 0. +End M. +Module N. + Notation a := M.a (only parsing). +End N. + +Import M. Import N. + +Check a. diff --git a/test-suite/output/bug_11934.out b/test-suite/output/bug_11934.out new file mode 100644 index 0000000000..072136c82e --- /dev/null +++ b/test-suite/output/bug_11934.out @@ -0,0 +1,13 @@ +thing = forall x y : foo, bla x y + : Prop +thing = +forall (x : foo@{thing.u0}) (y : foo@{thing.u1}), bla x y + : Prop +(* {thing.u1 thing.u0} |= bla.u0 = thing.u0 + bla.u1 = thing.u1 *) +thing = +forall (x : @foo@{thing.u0} True) (y : @foo@{thing.u1} True), +@bla True True x y + : Prop +(* {thing.u1 thing.u0} |= bla.u0 = thing.u0 + bla.u1 = thing.u1 *) diff --git a/test-suite/output/bug_11934.v b/test-suite/output/bug_11934.v new file mode 100644 index 0000000000..fe9772dc62 --- /dev/null +++ b/test-suite/output/bug_11934.v @@ -0,0 +1,13 @@ +Polymorphic Axiom foo@{u} : Prop -> Prop. +Arguments foo {_}. + +Axiom bla : forall {A B}, @foo A -> @foo B -> Prop. +Definition thing := forall (x:@foo@{Type} True) (y:@foo@{Type} True), bla x y. + +Print thing. (* forall x y : foo, bla x y *) + +Set Printing Universes. +Print thing. (* forall (x : foo@{thing.u0}) (y : foo@{thing.u1}), bla x y *) + +Set Printing Implicit. +Print thing. (* BAD: forall x y : @foo@{thing.u0} True, @bla True True x y *) diff --git a/test-suite/output/undeclared_key.out b/test-suite/output/undeclared_key.out new file mode 100644 index 0000000000..ed768751fc --- /dev/null +++ b/test-suite/output/undeclared_key.out @@ -0,0 +1,13 @@ +The command has indeed failed with message: +There is no flag, option or table with this name: "Search Blacklists". +The command has indeed failed with message: +There is no qualid-valued table with this name: "Search Blacklist". +File "stdin", line 3, characters 0-22: +Warning: There is no flag or option with this name: "Search Blacklists". +[unknown-option,option] +The command has indeed failed with message: +There is no string-valued table with this name: "Search Blacklists". +The command has indeed failed with message: +There is no qualid-valued table with this name: "Search Blacklist". +The command has indeed failed with message: +There is no qualid-valued table with this name: "Search Blacklist". diff --git a/test-suite/output/undeclared_key.v b/test-suite/output/undeclared_key.v new file mode 100644 index 0000000000..4134bc8bfa --- /dev/null +++ b/test-suite/output/undeclared_key.v @@ -0,0 +1,6 @@ +Fail Test Search Blacklists. +Fail Test Search Blacklist for foo. +Set Search Blacklists. +Fail Remove Search Blacklists "bar" foo. +Fail Remove Search Blacklist "bar" foo. +Fail Add Search Blacklist "bar" foo. diff --git a/test-suite/success/PartialImport.v b/test-suite/success/PartialImport.v new file mode 100644 index 0000000000..720083aec5 --- /dev/null +++ b/test-suite/success/PartialImport.v @@ -0,0 +1,58 @@ +Module M. + + Definition a := 0. + Definition b := 1. + + Module N. + + Notation c := (a + b). + + End N. + + Inductive even : nat -> Prop := + | even_0 : even 0 + | even_S n : odd n -> even (S n) + with odd : nat -> Set := + odd_S n : even n -> odd (S n). + +End M. + +Module Simple. + + Import M(a). + + Check a. + Fail Check b. + Fail Check N.c. + + (* todo output test: this prints a+M.b since the notation isn't imported *) + Check M.N.c. + + Fail Import M(c). + Fail Import M(M.b). + + Import M(N.c). + Check N.c. + (* interestingly prints N.c (also does with unfiltered Import M) *) + + Import M(even(..)). + Check even. Check even_0. Check even_S. + Check even_sind. Check even_ind. + Fail Check even_rect. (* doesn't exist *) + Fail Check odd. Check M.odd. + Fail Check odd_S. Fail Check odd_sind. + +End Simple. + +Module WithExport. + + Module X. + Export M(a, N.c). + End X. + + Import X. + Check a. + Check N.c. (* also prints N.c *) + Fail Check b. + +End WithExport. diff --git a/theories/Init/Byte.v b/theories/Init/Byte.v index 33eabb20d9..7449b52d76 100644 --- a/theories/Init/Byte.v +++ b/theories/Init/Byte.v @@ -10,6 +10,7 @@ (** * Bytes *) +Require Import Coq.Init.Ltac. Require Import Coq.Init.Datatypes. Require Import Coq.Init.Logic. Require Import Coq.Init.Specif. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 50d4314a6b..0f2717beef 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -11,6 +11,7 @@ Set Implicit Arguments. Require Import Notations. +Require Import Ltac. Require Import Logic. (********************************************************************) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index ae48febc49..8f9f68a292 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -11,6 +11,7 @@ Set Implicit Arguments. Require Export Notations. +Require Import Ltac. Notation "A -> B" := (forall (_ : A), B) : type_scope. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index d07fe68715..3d9937ae89 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -13,6 +13,7 @@ Set Implicit Arguments. +Require Import Ltac. Require Import Datatypes. Require Export Logic. diff --git a/theories/Init/Ltac.v b/theories/Init/Ltac.v new file mode 100644 index 0000000000..ac5a69a38a --- /dev/null +++ b/theories/Init/Ltac.v @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Declare ML Module "ltac_plugin". + +Export Set Default Proof Mode "Classic". diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index fdb88a0c82..da540cb099 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -68,33 +68,40 @@ Reserved Notation "{ x }" (at level 0, x at level 99). (** Notations for sigma-types or subsets *) -Reserved Notation "{ A } + { B }" (at level 50, left associativity). -Reserved Notation "A + { B }" (at level 50, left associativity). +Reserved Notation "{ A } + { B }" (at level 50, left associativity). +Reserved Notation "A + { B }" (at level 50, left associativity). -Reserved Notation "{ x | P }" (at level 0, x at level 99). -Reserved Notation "{ x | P & Q }" (at level 0, x at level 99). +Reserved Notation "{ x | P }" (at level 0, x at level 99). +Reserved Notation "{ x | P & Q }" (at level 0, x at level 99). -Reserved Notation "{ x : A | P }" (at level 0, x at level 99). -Reserved Notation "{ x : A | P & Q }" (at level 0, x at level 99). +Reserved Notation "{ x : A | P }" (at level 0, x at level 99). +Reserved Notation "{ x : A | P & Q }" (at level 0, x at level 99). -Reserved Notation "{ x & P }" (at level 0, x at level 99). -Reserved Notation "{ x : A & P }" (at level 0, x at level 99). -Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99). +Reserved Notation "{ x & P }" (at level 0, x at level 99). +Reserved Notation "{ x & P & Q }" (at level 0, x at level 99). + +Reserved Notation "{ x : A & P }" (at level 0, x at level 99). +Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99). Reserved Notation "{ ' pat | P }" - (at level 0, pat strict pattern, format "{ ' pat | P }"). + (at level 0, pat strict pattern, format "{ ' pat | P }"). Reserved Notation "{ ' pat | P & Q }" - (at level 0, pat strict pattern, format "{ ' pat | P & Q }"). + (at level 0, pat strict pattern, format "{ ' pat | P & Q }"). Reserved Notation "{ ' pat : A | P }" (at level 0, pat strict pattern, format "{ ' pat : A | P }"). Reserved Notation "{ ' pat : A | P & Q }" - (at level 0, pat strict pattern, format "{ ' pat : A | P & Q }"). + (at level 0, pat strict pattern, format "{ ' pat : A | P & Q }"). + +Reserved Notation "{ ' pat & P }" + (at level 0, pat strict pattern, format "{ ' pat & P }"). +Reserved Notation "{ ' pat & P & Q }" + (at level 0, pat strict pattern, format "{ ' pat & P & Q }"). Reserved Notation "{ ' pat : A & P }" - (at level 0, pat strict pattern, format "{ ' pat : A & P }"). + (at level 0, pat strict pattern, format "{ ' pat : A & P }"). Reserved Notation "{ ' pat : A & P & Q }" - (at level 0, pat strict pattern, format "{ ' pat : A & P & Q }"). + (at level 0, pat strict pattern, format "{ ' pat : A & P & Q }"). (** Support for Gonthier-Ssreflect's "if c is pat then u else v" *) @@ -122,9 +129,3 @@ Bind Scope type_scope with Sortclass. Open Scope core_scope. Open Scope function_scope. Open Scope type_scope. - -(** ML Tactic Notations *) - -Declare ML Module "ltac_plugin". - -Global Set Default Proof Mode "Classic". diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 394fa879c4..02903643d4 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -26,6 +26,7 @@ *) Require Import Notations. +Require Import Ltac. Require Import Datatypes. Require Import Logic. Require Coq.Init.Nat. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 71ba3e645d..6a81517d7e 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -18,10 +18,11 @@ Require Coq.Init.Decimal. Require Coq.Init.Nat. Require Export Peano. Require Export Coq.Init.Wf. +Require Export Coq.Init.Ltac. Require Export Coq.Init.Tactics. Require Export Coq.Init.Tauto. (* Some initially available plugins. See also: - - ltac_plugin (in Notations) + - ltac_plugin (in Ltac) - tauto_plugin (in Tauto). *) Declare ML Module "cc_plugin". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 692fe3d8d0..4ff007570e 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -14,6 +14,7 @@ Set Implicit Arguments. Set Reversible Pattern Implicit. Require Import Notations. +Require Import Ltac. Require Import Datatypes. Require Import Logic. @@ -58,23 +59,26 @@ Arguments sig2 (A P Q)%type. Arguments sigT (A P)%type. Arguments sigT2 (A P Q)%type. -Notation "{ x | P }" := (sig (fun x => P)) : type_scope. -Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. -Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) : type_scope. -Notation "{ x : A | P & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) : +Notation "{ x | P }" := (sig (fun x => P)) : type_scope. +Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. +Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) : type_scope. +Notation "{ x : A | P & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. -Notation "{ x & P }" := (sigT (fun x => P)) : type_scope. -Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. -Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) : +Notation "{ x & P }" := (sigT (fun x => P)) : type_scope. +Notation "{ x & P & Q }" := (sigT2 (fun x => P) (fun x => Q)) : type_scope. +Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope. +Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) : type_scope. -Notation "{ ' pat | P }" := (sig (fun pat => P)) : type_scope. -Notation "{ ' pat | P & Q }" := (sig2 (fun pat => P) (fun pat => Q)) : type_scope. -Notation "{ ' pat : A | P }" := (sig (A:=A) (fun pat => P)) : type_scope. -Notation "{ ' pat : A | P & Q }" := (sig2 (A:=A) (fun pat => P) (fun pat => Q)) : +Notation "{ ' pat | P }" := (sig (fun pat => P)) : type_scope. +Notation "{ ' pat | P & Q }" := (sig2 (fun pat => P) (fun pat => Q)) : type_scope. +Notation "{ ' pat : A | P }" := (sig (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A | P & Q }" := (sig2 (A:=A) (fun pat => P) (fun pat => Q)) : type_scope. -Notation "{ ' pat : A & P }" := (sigT (A:=A) (fun pat => P)) : type_scope. -Notation "{ ' pat : A & P & Q }" := (sigT2 (A:=A) (fun pat => P) (fun pat => Q)) : +Notation "{ ' pat & P }" := (sigT (fun pat => P)) : type_scope. +Notation "{ ' pat & P & Q }" := (sigT2 (fun pat => P) (fun pat => Q)) : type_scope. +Notation "{ ' pat : A & P }" := (sigT (A:=A) (fun pat => P)) : type_scope. +Notation "{ ' pat : A & P & Q }" := (sigT2 (A:=A) (fun pat => P) (fun pat => Q)) : type_scope. Add Printing Let sig. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index a4347bbe62..b13206db94 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -9,6 +9,7 @@ (************************************************************************) Require Import Notations. +Require Import Ltac. Require Import Logic. Require Import Specif. diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v index 87b7a9a3be..2fc6f3cfa6 100644 --- a/theories/Init/Tauto.v +++ b/theories/Init/Tauto.v @@ -1,4 +1,17 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * The tauto and intuition tactics *) + Require Import Notations. +Require Import Ltac. Require Import Datatypes. Require Import Logic. diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index 06afd9bac0..a305626eb3 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -16,6 +16,7 @@ Set Implicit Arguments. Require Import Notations. +Require Import Ltac. Require Import Logic. Require Import Datatypes. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index f050f11170..5d5f74db44 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -2559,6 +2559,33 @@ Section ReDun. * now apply incl_Add_inv with a l'. Qed. + Lemma NoDup_incl_NoDup (l l' : list A) : NoDup l -> + length l' <= length l -> incl l l' -> NoDup l'. + Proof. + revert l'; induction l; simpl; intros l' Hnd Hlen Hincl. + - now destruct l'; inversion Hlen. + - assert (In a l') as Ha by now apply Hincl; left. + apply in_split in Ha as [l1' [l2' ->]]. + inversion_clear Hnd as [|? ? Hnin Hnd']. + apply (NoDup_Add (Add_app a l1' l2')); split. + + apply IHl; auto. + * rewrite app_length. + rewrite app_length in Hlen; simpl in Hlen; rewrite Nat.add_succ_r in Hlen. + now apply Nat.succ_le_mono. + * apply incl_Add_inv with (u:= l1' ++ l2') in Hincl; auto. + apply Add_app. + + intros Hnin'. + assert (incl (a :: l) (l1' ++ l2')) as Hincl''. + { apply incl_tran with (l1' ++ a :: l2'); auto. + intros x Hin. + apply in_app_or in Hin as [Hin|[->|Hin]]; intuition. } + apply NoDup_incl_length in Hincl''; [ | now constructor ]. + apply (Nat.nle_succ_diag_l (length l1' + length l2')). + rewrite_all app_length. + simpl in Hlen; rewrite Nat.add_succ_r in Hlen. + now transitivity (S (length l)). + Qed. + End ReDun. (** NoDup and map *) diff --git a/theories/Logic/WKL.v b/theories/Logic/WKL.v index 478bc434ad..d9eea2f89d 100644 --- a/theories/Logic/WKL.v +++ b/theories/Logic/WKL.v @@ -25,7 +25,7 @@ Require Import WeakFan List. Import ListNotations. -Require Import Omega. +Require Import Arith. (** [is_path_from P n l] means that there exists a path of length [n] from [l] on which [P] does not hold *) diff --git a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v index 7e51b575ba..ce263e1d21 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v @@ -31,9 +31,9 @@ Local Open Scope CReal_scope. uniquely extends to a uniformly continuous function CReal_abs : CReal -> CReal *) -Lemma CauchyAbsStable : forall xn : nat -> Q, - QCauchySeq xn Pos.to_nat - -> QCauchySeq (fun n => Qabs (xn n)) Pos.to_nat. +Lemma CauchyAbsStable : forall xn : positive -> Q, + QCauchySeq xn id + -> QCauchySeq (fun n => Qabs (xn n)) id. Proof. intros xn cau n p q H H0. specialize (cau n p q H H0). @@ -53,23 +53,22 @@ Definition CReal_abs (x : CReal) : CReal exist _ (fun n => Qabs (xn n)) (CauchyAbsStable xn cau). Lemma CReal_neg_nth : forall (x : CReal) (n : positive), - (proj1_sig x (Pos.to_nat n) < -1#n)%Q + (proj1_sig x n < -1#n)%Q -> x < 0. Proof. intros. destruct x as [xn cau]; unfold proj1_sig in H. apply Qlt_minus_iff in H. - setoid_replace ((-1 # n) + - xn (Pos.to_nat n))%Q - with (- ((1 # n) + xn (Pos.to_nat n)))%Q in H. - destruct (Qarchimedean (2 / (-((1#n) + xn (Pos.to_nat n))))) as [k kmaj]. + setoid_replace ((-1 # n) + - xn n)%Q + with (- ((1 # n) + xn n))%Q in H. + destruct (Qarchimedean (2 / (-((1#n) + xn n)))) as [k kmaj]. exists (Pos.max k n). simpl. unfold Qminus; rewrite Qplus_0_l. - specialize (cau n (Pos.to_nat n) (max (Pos.to_nat k) (Pos.to_nat n)) - (le_refl _) (Nat.le_max_r _ _)). + specialize (cau n n (Pos.max k n) + (Pos.le_refl _) (Pos.le_max_r _ _)). apply (Qle_lt_trans _ (2#k)). unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_l. discriminate. apply Pos2Z.pos_le_pos, Pos.le_max_l. - rewrite <- Pos2Nat.inj_max in cau. - apply (Qmult_lt_l _ _ (-((1 # n) + xn (Pos.to_nat n)))) in kmaj. + apply (Qmult_lt_l _ _ (-((1 # n) + xn n))) in kmaj. rewrite Qmult_div_r in kmaj. apply (Qmult_lt_r _ _ (1 # k)) in kmaj. rewrite <- Qmult_assoc in kmaj. @@ -77,13 +76,13 @@ Proof. rewrite Qmult_1_r in kmaj. setoid_replace (2#k)%Q with (2 * (1 # k))%Q. 2: reflexivity. apply (Qlt_trans _ _ _ kmaj). clear kmaj. - apply (Qplus_lt_l _ _ ((1#n) + xn (Pos.to_nat (Pos.max k n)))). + apply (Qplus_lt_l _ _ ((1#n) + xn (Pos.max k n))). ring_simplify. rewrite Qplus_comm. - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat (Pos.max k n))))). + apply (Qle_lt_trans _ (Qabs (xn n - xn (Pos.max k n)))). 2: exact cau. rewrite <- Qabs_opp. - setoid_replace (- (xn (Pos.to_nat n) - xn (Pos.to_nat (Pos.max k n))))%Q - with (xn (Pos.to_nat (Pos.max k n)) + -1 * xn (Pos.to_nat n))%Q. + setoid_replace (- (xn n - xn (Pos.max k n)))%Q + with (xn (Pos.max k n) + -1 * xn n)%Q. apply Qle_Qabs. ring. 2: reflexivity. unfold Qmult, Qeq, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_l. reflexivity. @@ -92,10 +91,10 @@ Proof. Qed. Lemma CReal_nonneg : forall (x : CReal) (n : positive), - 0 <= x -> (-1#n <= proj1_sig x (Pos.to_nat n))%Q. + 0 <= x -> (-1#n <= proj1_sig x n)%Q. Proof. intros. destruct x as [xn cau]; unfold proj1_sig. - destruct (Qlt_le_dec (xn (Pos.to_nat n)) (-1#n)). + destruct (Qlt_le_dec (xn n) (-1#n)). 2: exact q. exfalso. apply H. clear H. apply (CReal_neg_nth _ n). exact q. Qed. @@ -107,13 +106,13 @@ Proof. apply (CReal_nonneg _ n) in H. simpl in H. rewrite Qabs_pos. 2: unfold Qminus; rewrite <- Qle_minus_iff; apply Qle_Qabs. - destruct (Qlt_le_dec (xn (Pos.to_nat n)) 0). + destruct (Qlt_le_dec (xn n) 0). - rewrite Qabs_neg. 2: apply Qlt_le_weak, q. apply Qopp_le_compat in H. apply (Qmult_le_l _ _ (1#2)). reflexivity. ring_simplify. setoid_replace ((1 # 2) * (2 # n))%Q with (-(-1#n))%Q. 2: reflexivity. - setoid_replace ((-2 # 2) * xn (Pos.to_nat n))%Q with (- xn (Pos.to_nat n))%Q. + setoid_replace ((-2 # 2) * xn n)%Q with (- xn n)%Q. exact H. ring. - rewrite Qabs_pos. unfold Qminus. rewrite Qplus_opp_r. discriminate. exact q. Qed. @@ -121,7 +120,7 @@ Qed. Lemma CReal_le_abs : forall x : CReal, x <= CReal_abs x. Proof. intros. intros [n nmaj]. destruct x as [xn cau]; simpl in nmaj. - apply (Qle_not_lt _ _ (Qle_Qabs (xn (Pos.to_nat n)))). + apply (Qle_not_lt _ _ (Qle_Qabs (xn n))). apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)). reflexivity. exact nmaj. Qed. @@ -129,7 +128,7 @@ Qed. Lemma CReal_abs_pos : forall x : CReal, 0 <= CReal_abs x. Proof. intros. intros [n nmaj]. destruct x as [xn cau]; simpl in nmaj. - apply (Qle_not_lt _ _ (Qabs_nonneg (xn (Pos.to_nat n)))). + apply (Qle_not_lt _ _ (Qabs_nonneg (xn n))). apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)). reflexivity. exact nmaj. Qed. @@ -153,7 +152,7 @@ Lemma CReal_abs_appart_0 : forall x : CReal, 0 < CReal_abs x -> x # 0. Proof. intros x [n nmaj]. destruct x as [xn cau]; simpl in nmaj. - destruct (Qlt_le_dec (xn (Pos.to_nat n)) 0). + destruct (Qlt_le_dec (xn n) 0). - left. exists n. simpl. rewrite Qabs_neg in nmaj. apply (Qlt_le_trans _ _ _ nmaj). ring_simplify. apply Qle_refl. apply Qlt_le_weak, q. @@ -189,7 +188,7 @@ Qed. Lemma CReal_abs_le : forall a b:CReal, -b <= a <= b -> CReal_abs a <= b. Proof. intros a b H [n nmaj]. destruct a as [an cau]; simpl in nmaj. - destruct (Qlt_le_dec (an (Pos.to_nat n)) 0). + destruct (Qlt_le_dec (an n) 0). - rewrite Qabs_neg in nmaj. destruct H. apply H. clear H H0. exists n. simpl. destruct b as [bn caub]; simpl; simpl in nmaj. @@ -250,14 +249,14 @@ Lemma CReal_abs_gt : forall x : CReal, x < CReal_abs x -> x < 0. Proof. intros x [n nmaj]. destruct x as [xn cau]; simpl in nmaj. - assert (xn (Pos.to_nat n) < 0)%Q. - { destruct (Qlt_le_dec (xn (Pos.to_nat n)) 0). exact q. + assert (xn n < 0)%Q. + { destruct (Qlt_le_dec (xn n) 0). exact q. exfalso. rewrite Qabs_pos in nmaj. unfold Qminus in nmaj. rewrite Qplus_opp_r in nmaj. inversion nmaj. exact q. } rewrite Qabs_neg in nmaj. 2: apply Qlt_le_weak, H. apply (CReal_neg_nth _ n). simpl. ring_simplify in nmaj. - apply (Qplus_lt_l _ _ ((1#n) - xn (Pos.to_nat n))). + apply (Qplus_lt_l _ _ ((1#n) - xn n)). apply (Qmult_lt_l _ _ 2). reflexivity. ring_simplify. setoid_replace (2 * (1 # n))%Q with (2 # n)%Q. 2: reflexivity. rewrite <- Qplus_assoc. @@ -274,7 +273,7 @@ Proof. destruct H as [i imaj]. destruct H0 as [j jmaj]. exists (Pos.max i j). destruct x as [xn caux], y as [yn cauy]; simpl. simpl in imaj, jmaj. - destruct (Qlt_le_dec (xn (Pos.to_nat (Pos.max i j))) 0). + destruct (Qlt_le_dec (xn (Pos.max i j)) 0). - rewrite Qabs_neg. specialize (jmaj (Pos.max i j) (Pos.le_max_r _ _)). apply (Qle_lt_trans _ (2#j)). 2: exact jmaj. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v index 167f8d41c9..8ca65c30c8 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyReals.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v @@ -33,20 +33,26 @@ Require CMorphisms. The double quantification on p q is needed to avoid forall un, QSeqEquiv un (fun _ => un O) (fun q => O) which says nothing about the limit of un. + + We define sequences as positive -> Q instead of nat -> Q, + so that we can compute arguments like 2^n fast. + + WARNING: this module is not meant to be imported directly, + please import `Reals.Abstract.ConstructiveReals` instead. *) -Definition QSeqEquiv (un vn : nat -> Q) (cvmod : positive -> nat) +Definition QSeqEquiv (un vn : positive -> Q) (cvmod : positive -> positive) : Prop - := forall (k : positive) (p q : nat), - le (cvmod k) p - -> le (cvmod k) q + := forall (k : positive) (p q : positive), + Pos.le (cvmod k) p + -> Pos.le (cvmod k) q -> Qlt (Qabs (un p - vn q)) (1 # k). (* A Cauchy sequence is a sequence equivalent to itself. If sequences are equivalent, they are both Cauchy and have the same limit. *) -Definition QCauchySeq (un : nat -> Q) (cvmod : positive -> nat) : Prop +Definition QCauchySeq (un : positive -> Q) (cvmod : positive -> positive) : Prop := QSeqEquiv un un cvmod. -Lemma QSeqEquiv_sym : forall (un vn : nat -> Q) (cvmod : positive -> nat), +Lemma QSeqEquiv_sym : forall (un vn : positive -> Q) (cvmod : positive -> positive), QSeqEquiv un vn cvmod -> QSeqEquiv vn un cvmod. Proof. @@ -59,11 +65,12 @@ Proof. intros. unfold Qeq. simpl. destruct a; reflexivity. Qed. -Lemma QSeqEquiv_trans : forall (un vn wn : nat -> Q) - (cvmod cvmodw : positive -> nat), +Lemma QSeqEquiv_trans : forall (un vn wn : positive -> Q) + (cvmod cvmodw : positive -> positive), QSeqEquiv un vn cvmod -> QSeqEquiv vn wn cvmodw - -> QSeqEquiv un wn (fun q => max (cvmod (2 * q)%positive) (cvmodw (2 * q)%positive)). + -> QSeqEquiv un wn (fun q => Pos.max (cvmod (2 * q)%positive) + (cvmodw (2 * q)%positive)). Proof. intros. intros k p q H1 H2. setoid_replace (un p - wn q) with (un p - vn p + (vn p - wn q)). @@ -71,38 +78,42 @@ Proof. _ (Qabs (un p - vn p) + Qabs (vn p - wn q))). apply Qabs_triangle. apply (Qlt_le_trans _ ((1 # (2*k)) + (1 # (2*k)))). apply Qplus_lt_le_compat. - - assert ((cvmod (2 * k)%positive <= p)%nat). - { apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). - apply Nat.le_max_l. assumption. } + - assert ((cvmod (2 * k)%positive <= p)%positive). + { apply (Pos.le_trans _ (Pos.max (cvmod (2 * k)%positive) + (cvmodw (2 * k)%positive))). + apply Pos.le_max_l. assumption. } apply H. assumption. assumption. - apply Qle_lteq. left. apply H0. - apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). - apply Nat.le_max_r. assumption. - apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). - apply Nat.le_max_r. assumption. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * k)%positive) + (cvmodw (2 * k)%positive))). + apply Pos.le_max_r. assumption. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * k)%positive) + (cvmodw (2 * k)%positive))). + apply Pos.le_max_r. assumption. - rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. - ring. Qed. -Definition QSeqEquivEx (un vn : nat -> Q) : Prop - := exists (cvmod : positive -> nat), QSeqEquiv un vn cvmod. +Definition QSeqEquivEx (un vn : positive -> Q) : Prop + := exists (cvmod : positive -> positive), QSeqEquiv un vn cvmod. -Lemma QSeqEquivEx_sym : forall (un vn : nat -> Q), QSeqEquivEx un vn -> QSeqEquivEx vn un. +Lemma QSeqEquivEx_sym : forall (un vn : positive -> Q), + QSeqEquivEx un vn -> QSeqEquivEx vn un. Proof. intros. destruct H. exists x. apply QSeqEquiv_sym. apply H. Qed. -Lemma QSeqEquivEx_trans : forall un vn wn : nat -> Q, +Lemma QSeqEquivEx_trans : forall un vn wn : positive -> Q, QSeqEquivEx un vn -> QSeqEquivEx vn wn -> QSeqEquivEx un wn. Proof. intros. destruct H,H0. - exists (fun q => max (x (2 * q)%positive) (x0 (2 * q)%positive)). + exists (fun q => Pos.max (x (2 * q)%positive) (x0 (2 * q)%positive)). apply (QSeqEquiv_trans un vn wn); assumption. Qed. -Lemma QSeqEquiv_cau_r : forall (un vn : nat -> Q) (cvmod : positive -> nat), +Lemma QSeqEquiv_cau_r : forall (un vn : positive -> Q) (cvmod : positive -> positive), QSeqEquiv un vn cvmod -> QCauchySeq vn (fun k => cvmod (2 * k)%positive). Proof. @@ -118,82 +129,15 @@ Proof. apply Qabs_triangle. apply (Qlt_le_trans _ ((1 # (2 * k)) + (1 # (2 * k)))). apply Qplus_lt_le_compat. - + rewrite Qabs_Qminus. apply H. apply le_refl. assumption. - + apply Qle_lteq. left. apply H. apply le_refl. assumption. + + rewrite Qabs_Qminus. apply H. apply Pos.le_refl. assumption. + + apply Qle_lteq. left. apply H. apply Pos.le_refl. assumption. + rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. - ring. Qed. -Fixpoint increasing_modulus (modulus : positive -> nat) (n : nat) - := match n with - | O => modulus xH - | S p => max (modulus (Pos.of_nat n)) (increasing_modulus modulus p) - end. - -Lemma increasing_modulus_inc : forall (modulus : positive -> nat) (n p : nat), - le (increasing_modulus modulus n) - (increasing_modulus modulus (p + n)). -Proof. - induction p. - - apply le_refl. - - apply (le_trans _ (increasing_modulus modulus (p + n))). - apply IHp. simpl. destruct (plus p n). apply Nat.le_max_r. apply Nat.le_max_r. -Qed. - -Lemma increasing_modulus_max : forall (modulus : positive -> nat) (p n : nat), - le n p -> le (modulus (Pos.of_nat n)) - (increasing_modulus modulus p). -Proof. - induction p. - - intros. inversion H. subst n. apply le_refl. - - intros. simpl. destruct p. simpl. - + destruct n. apply Nat.le_max_l. apply le_S_n in H. - inversion H. apply Nat.le_max_l. - + apply Nat.le_succ_r in H. destruct H. - apply (le_trans _ (increasing_modulus modulus (S p))). - 2: apply Nat.le_max_r. apply IHp. apply H. - subst n. apply (le_trans _ (modulus (Pos.succ (Pos.of_nat (S p))))). - apply le_refl. apply Nat.le_max_l. -Qed. - -(* Choice of a standard element in each QSeqEquiv class. *) -Lemma standard_modulus : forall (un : nat -> Q) (cvmod : positive -> nat), - QCauchySeq un cvmod - -> (QCauchySeq (fun n => un (increasing_modulus cvmod n)) Pos.to_nat - /\ QSeqEquiv un (fun n => un (increasing_modulus cvmod n)) - (fun p => max (cvmod p) (Pos.to_nat p))). -Proof. - intros. split. - - intros k p q H0 H1. apply H. - + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). - apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). - rewrite Pos2Nat.id. apply le_refl. - destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. - destruct (Nat.le_exists_sub (Pos.to_nat k) p H0) as [i [H2 H3]]. subst p. - apply increasing_modulus_inc. - + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). - apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). - rewrite Pos2Nat.id. apply le_refl. - destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. - destruct (Nat.le_exists_sub (Pos.to_nat k) q H1) as [i [H2 H3]]. subst q. - apply increasing_modulus_inc. - - intros k p q H0 H1. apply H. - + apply (le_trans _ (Init.Nat.max (cvmod k) (Pos.to_nat k))). - apply Nat.le_max_l. assumption. - + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). - apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). - rewrite Pos2Nat.id. apply le_refl. - destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. - assert (le (Pos.to_nat k) q). - { apply (le_trans _ (Init.Nat.max (cvmod k) (Pos.to_nat k))). - apply Nat.le_max_r. assumption. } - destruct (Nat.le_exists_sub (Pos.to_nat k) q H2) as [i [H3 H4]]. subst q. - apply increasing_modulus_inc. -Qed. - (* A Cauchy real is a Cauchy sequence with the standard modulus *) Definition CReal : Set - := { x : (nat -> Q) | QCauchySeq x Pos.to_nat }. + := { x : (positive -> Q) | QCauchySeq x id }. Declare Scope CReal_scope. @@ -208,12 +152,10 @@ Local Open Scope CReal_scope. (* So QSeqEquiv is the equivalence relation of this constructive pre-order *) Definition CRealLt (x y : CReal) : Set - := { n : positive | Qlt (2 # n) - (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)) }. + := { n : positive | Qlt (2 # n) (proj1_sig y n - proj1_sig x n) }. Definition CRealLtProp (x y : CReal) : Prop - := exists n : positive, Qlt (2 # n) - (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). + := exists n : positive, Qlt (2 # n) (proj1_sig y n - proj1_sig x n). Definition CRealGt (x y : CReal) := CRealLt y x. Definition CReal_appart (x y : CReal) := sum (CRealLt x y) (CRealLt y x). @@ -226,23 +168,23 @@ Infix "#" := CReal_appart : CReal_scope. Lemma CRealLtEpsilon : forall x y : CReal, CRealLtProp x y -> x < y. Proof. - intros. - assert (exists n : nat, n <> O - /\ Qlt (2 # Pos.of_nat n) (proj1_sig y n - proj1_sig x n)). - { destruct H as [n maj]. exists (Pos.to_nat n). split. - intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. - inversion abs. rewrite Pos2Nat.id. apply maj. } + intros. unfold CRealLtProp in H. + (* Convert to nat to use indefinite description. *) + assert (exists n : nat, lt O n /\ Qlt (2 # Pos.of_nat n) + (proj1_sig y (Pos.of_nat n) - proj1_sig x (Pos.of_nat n))). + { destruct H as [n maj]. exists (Pos.to_nat n). split. apply Pos2Nat.is_pos. + rewrite Pos2Nat.id. exact maj. } + clear H. apply constructive_indefinite_ground_description_nat in H0. - destruct H0 as [n maj]. exists (Pos.of_nat n). - rewrite Nat2Pos.id. apply maj. apply maj. + destruct H0 as [n maj]. exists (Pos.of_nat n). exact (proj2 maj). intro n. destruct n. right. - intros [abs _]. exact (abs (eq_refl O)). + intros [abs _]. inversion abs. destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) - (proj1_sig y (S n) - proj1_sig x (S n))). - left. split. discriminate. apply q. + (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))). + left. split. apply le_n_S, le_0_n. apply q. right. intros [_ abs]. apply (Qlt_not_le (2 # Pos.of_nat (S n)) - (proj1_sig y (S n) - proj1_sig x (S n))); assumption. + (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))); assumption. Qed. Lemma CRealLtForget : forall x y : CReal, @@ -254,18 +196,18 @@ Qed. (* CRealLt is decided by the LPO in Type, which is a non-constructive oracle. *) Lemma CRealLt_lpo_dec : forall x y : CReal, - (forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + (forall (P : nat -> Prop), (forall n:nat, {P n} + {~P n}) -> {n | ~P n} + {forall n, P n}) -> CRealLt x y + (CRealLt x y -> False). Proof. intros x y lpo. - destruct (lpo (fun n:nat => Qle (proj1_sig y (S n) - proj1_sig x (S n)) + destruct (lpo (fun n:nat => Qle (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n))) (2 # Pos.of_nat (S n)))). - intro n. destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) - (proj1_sig y (S n) - proj1_sig x (S n))). + (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))). right. apply Qlt_not_le. exact q. left. exact q. - left. destruct s as [n nmaj]. exists (Pos.of_nat (S n)). - rewrite Nat2Pos.id. apply Qnot_le_lt. exact nmaj. discriminate. + apply Qnot_le_lt. exact nmaj. - right. intro abs. destruct abs as [n majn]. specialize (q (pred (Pos.to_nat n))). replace (S (pred (Pos.to_nat n))) with (Pos.to_nat n) in q. @@ -296,41 +238,37 @@ Definition CRealEq (x y : CReal) : Prop Infix "==" := CRealEq : CReal_scope. Lemma CRealLe_not_lt : forall x y : CReal, - (forall n:positive, Qle (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n)) - (2 # n)) + (forall n:positive, Qle (proj1_sig x n - proj1_sig y n) (2 # n)) <-> x <= y. Proof. intros. split. - intros. intro H0. destruct H0 as [n H0]. specialize (H n). apply (Qle_not_lt (2 # n) (2 # n)). apply Qle_refl. - apply (Qlt_le_trans _ (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))). + apply (Qlt_le_trans _ (proj1_sig x n - proj1_sig y n)). assumption. assumption. - intros. - destruct (Qlt_le_dec (2 # n) (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))). + destruct (Qlt_le_dec (2 # n) (proj1_sig x n - proj1_sig y n)). exfalso. apply H. exists n. assumption. assumption. Qed. Lemma CRealEq_diff : forall (x y : CReal), CRealEq x y - <-> forall n:positive, Qle (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) - (2 # n). + <-> forall n:positive, Qle (Qabs (proj1_sig x n - proj1_sig y n)) (2 # n). Proof. intros. split. - intros. destruct H. apply Qabs_case. intro. pose proof (CRealLe_not_lt x y) as [_ H2]. apply H2. assumption. intro. pose proof (CRealLe_not_lt y x) as [_ H2]. - setoid_replace (- (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) - with (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). + setoid_replace (- (proj1_sig x n - proj1_sig y n)) + with (proj1_sig y n - proj1_sig x n). apply H2. assumption. ring. - intros. split. + apply CRealLe_not_lt. intro n. specialize (H n). rewrite Qabs_Qminus in H. - apply (Qle_trans _ (Qabs (proj1_sig y (Pos.to_nat n) - - proj1_sig x (Pos.to_nat n)))). + apply (Qle_trans _ (Qabs (proj1_sig y n - proj1_sig x n))). apply Qle_Qabs. apply H. + apply CRealLe_not_lt. intro n. specialize (H n). - apply (Qle_trans _ (Qabs (proj1_sig x (Pos.to_nat n) - - proj1_sig y (Pos.to_nat n)))). + apply (Qle_trans _ (Qabs (proj1_sig x n - proj1_sig y n))). apply Qle_Qabs. apply H. Qed. @@ -339,111 +277,106 @@ Qed. Lemma CRealEq_modindep : forall (x y : CReal), QSeqEquivEx (proj1_sig x) (proj1_sig y) <-> forall n:positive, - Qle (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) (2 # n). + Qle (Qabs (proj1_sig x n - proj1_sig y n)) (2 # n). Proof. assert (forall x y: CReal, QSeqEquivEx (proj1_sig x) (proj1_sig y) -> x <= y ). { intros [xn limx] [yn limy] [cvmod H] [n abs]. simpl in abs, H. - pose (xn (Pos.to_nat n) - yn (Pos.to_nat n) - (2#n)) as eps. + pose (xn n - yn n - (2#n)) as eps. destruct (Qarchimedean (/eps)) as [k maj]. - remember (max (cvmod k) (Pos.to_nat n)) as p. - assert (le (cvmod k) p). - { rewrite Heqp. apply Nat.le_max_l. } - assert (Pos.to_nat n <= p)%nat. - { rewrite Heqp. apply Nat.le_max_r. } + remember (Pos.max (cvmod k) n) as p. + assert (Pos.le (cvmod k) p). + { rewrite Heqp. apply Pos.le_max_l. } + assert (n <= p)%positive. + { rewrite Heqp. apply Pos.le_max_r. } specialize (H k p p H0 H0). setoid_replace (Z.pos k #1)%Q with (/ (1#k)) in maj. 2: reflexivity. apply Qinv_lt_contravar in maj. 2: reflexivity. unfold eps in maj. clear abs. (* less precise majoration *) apply (Qplus_lt_r _ _ (2#n)) in maj. ring_simplify in maj. apply (Qlt_not_le _ _ maj). clear maj. - setoid_replace (xn (Pos.to_nat n) + -1 * yn (Pos.to_nat n)) - with (xn (Pos.to_nat n) - xn p + (xn p - yn p + (yn p - yn (Pos.to_nat n)))). + setoid_replace (xn n + -1 * yn n) + with (xn n - xn p + (xn p - yn p + (yn p - yn n))). 2: ring. setoid_replace (2 # n)%Q with ((1 # n) + (1#n)). rewrite <- Qplus_assoc. apply Qplus_le_compat. apply (Qle_trans _ _ _ (Qle_Qabs _)). - apply Qlt_le_weak. apply limx. apply le_refl. assumption. + apply Qlt_le_weak. apply limx. apply Pos.le_refl. assumption. rewrite (Qplus_comm (1#n)). apply Qplus_le_compat. apply (Qle_trans _ _ _ (Qle_Qabs _)). apply Qlt_le_weak. exact H. apply (Qle_trans _ _ _ (Qle_Qabs _)). apply Qlt_le_weak. apply limy. - assumption. apply le_refl. ring_simplify. reflexivity. + assumption. apply Pos.le_refl. ring_simplify. reflexivity. unfold eps. unfold Qminus. rewrite <- Qlt_minus_iff. exact abs. } split. - rewrite <- CRealEq_diff. intros. split. apply H, QSeqEquivEx_sym. exact H0. apply H. exact H0. - clear H. intros. destruct x as [xn limx], y as [yn limy]. - exists (fun q => Pos.to_nat (2 * (3 * q))). intros k p q H0 H1. + exists (fun q:positive => 2 * (3 * q))%positive. intros k p q H0 H1. unfold proj1_sig. specialize (H (2 * (3 * k))%positive). - assert ((Pos.to_nat (3 * k) <= Pos.to_nat (2 * (3 * k)))%nat). - { generalize (3 * k)%positive. intros. rewrite Pos2Nat.inj_mul. - rewrite <- (mult_1_l (Pos.to_nat p0)). apply Nat.mul_le_mono_nonneg. - auto. unfold Pos.to_nat. simpl. auto. - apply (le_trans 0 1). auto. apply Pos2Nat.is_pos. rewrite mult_1_l. - apply le_refl. } + assert (3 * k <= 2 * (3 * k))%positive. + { generalize (3 * k)%positive. intros. apply (Pos.le_trans _ (1 * p0)). + apply Pos.le_refl. rewrite <- Pos.mul_le_mono_r. discriminate. } setoid_replace (xn p - yn q) - with (xn p - xn (Pos.to_nat (2 * (3 * k))) - + (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k))) - + (yn (Pos.to_nat (2 * (3 * k))) - yn q))). + with (xn p - xn (2 * (3 * k))%positive + + (xn (2 * (3 * k))%positive - yn (2 * (3 * k))%positive + + (yn (2 * (3 * k))%positive - yn q))). + 2: ring. setoid_replace (1 # k)%Q with ((1 # 3 * k) + ((1 # 3 * k) + (1 # 3 * k))). apply (Qle_lt_trans - _ (Qabs (xn p - xn (Pos.to_nat (2 * (3 * k)))) - + (Qabs (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k))) - + (yn (Pos.to_nat (2 * (3 * k))) - yn q))))). + _ (Qabs (xn p - xn (2 * (3 * k))%positive) + + (Qabs (xn (2 * (3 * k))%positive - yn (2 * (3 * k))%positive + + (yn (2 * (3 * k))%positive - yn q))))). apply Qabs_triangle. apply Qplus_lt_le_compat. - apply limx. apply (le_trans _ (Pos.to_nat (2 * (3 * k)))). assumption. assumption. + apply limx. apply (Pos.le_trans _ (2 * (3 * k))). assumption. assumption. assumption. apply (Qle_trans - _ (Qabs (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k)))) - + Qabs (yn (Pos.to_nat (2 * (3 * k))) - yn q))). + _ (Qabs (xn (2 * (3 * k))%positive - yn (2 * (3 * k))%positive) + + Qabs (yn (2 * (3 * k))%positive - yn q))). apply Qabs_triangle. apply Qplus_le_compat. setoid_replace (1 # 3 * k)%Q with (2 # 2 * (3 * k))%Q. apply H. - rewrite (factorDenom _ _ 3). rewrite (factorDenom _ _ 2). rewrite (factorDenom _ _ 3). + rewrite (factorDenom _ _ 3). + rewrite (factorDenom _ _ 2). rewrite (factorDenom _ _ 3). rewrite Qmult_assoc. rewrite (Qmult_comm (1#2)). rewrite <- Qmult_assoc. apply Qmult_comp. reflexivity. unfold Qeq. reflexivity. apply Qle_lteq. left. apply limy. assumption. - apply (le_trans _ (Pos.to_nat (2 * (3 * k)))). assumption. assumption. - rewrite (factorDenom _ _ 3). ring_simplify. reflexivity. field. + apply (Pos.le_trans _ (2 * (3 * k))). assumption. assumption. + rewrite (factorDenom _ _ 3). ring_simplify. reflexivity. Qed. (* Extend separation to all indices above *) Lemma CRealLt_aboveSig : forall (x y : CReal) (n : positive), (Qlt (2 # n) - (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n))) - -> let (k, _) := Qarchimedean (/(proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n) - (2#n))) + (proj1_sig y n - proj1_sig x n)) + -> let (k, _) := Qarchimedean (/(proj1_sig y n - proj1_sig x n - (2#n))) in forall p:positive, Pos.le (Pos.max n (2*k)) p -> Qlt (2 # (Pos.max n (2*k))) - (proj1_sig y (Pos.to_nat p) - proj1_sig x (Pos.to_nat p)). + (proj1_sig y p - proj1_sig x p). Proof. intros [xn limx] [yn limy] n maj. unfold proj1_sig; unfold proj1_sig in maj. - pose (yn (Pos.to_nat n) - xn (Pos.to_nat n)) as dn. - destruct (Qarchimedean (/(yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2#n)))) as [k kmaj]. - assert (0 < yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2 # n))%Q as H0. + pose (yn n - xn n) as dn. + destruct (Qarchimedean (/(yn n - xn n - (2#n)))) as [k kmaj]. + assert (0 < yn n - xn n - (2 # n))%Q as H0. { rewrite <- (Qplus_opp_r (2#n)). apply Qplus_lt_l. assumption. } - intros. - remember (yn (Pos.to_nat p) - xn (Pos.to_nat p)) as dp. - + intros. remember (yn p - xn p) as dp. rewrite <- (Qplus_0_r dp). rewrite <- (Qplus_opp_r dn). rewrite (Qplus_comm dn). rewrite Qplus_assoc. assert (Qlt (Qabs (dp - dn)) (2#n)). { rewrite Heqdp. unfold dn. - setoid_replace (yn (Pos.to_nat p) - xn (Pos.to_nat p) - (yn (Pos.to_nat n) - xn (Pos.to_nat n))) - with (yn (Pos.to_nat p) - yn (Pos.to_nat n) - + (xn (Pos.to_nat n) - xn (Pos.to_nat p))). - apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat p) - yn (Pos.to_nat n)) - + Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat p)))). + setoid_replace (yn p - xn p - (yn n - xn n)) + with (yn p - yn n + (xn n - xn p)). + apply (Qle_lt_trans _ (Qabs (yn p - yn n) + Qabs (xn n - xn p))). apply Qabs_triangle. setoid_replace (2#n)%Q with ((1#n) + (1#n))%Q. apply Qplus_lt_le_compat. apply limy. - apply Pos2Nat.inj_le. apply (Pos.le_trans _ (Pos.max n (2 * k))). + apply (Pos.le_trans _ (Pos.max n (2 * k))). apply Pos.le_max_l. assumption. - apply le_refl. apply Qlt_le_weak. apply limx. apply le_refl. - apply Pos2Nat.inj_le. apply (Pos.le_trans _ (Pos.max n (2 * k))). + apply Pos.le_refl. apply Qlt_le_weak. apply limx. apply Pos.le_refl. + apply (Pos.le_trans _ (Pos.max n (2 * k))). apply Pos.le_max_l. assumption. - rewrite Qinv_plus_distr. reflexivity. field. } + rewrite Qinv_plus_distr. reflexivity. ring. } apply (Qle_lt_trans _ (-(2#n) + dn)). rewrite Qplus_comm. unfold dn. apply Qlt_le_weak. apply (Qle_lt_trans _ (2 # (2 * k))). apply Pos.le_max_r. @@ -463,12 +396,11 @@ Qed. Lemma CRealLt_above : forall (x y : CReal), CRealLt x y -> { k : positive | forall p:positive, - Pos.le k p -> Qlt (2 # k) (proj1_sig y (Pos.to_nat p) - - proj1_sig x (Pos.to_nat p)) }. + Pos.le k p -> Qlt (2 # k) (proj1_sig y p - proj1_sig x p) }. Proof. intros x y [n maj]. pose proof (CRealLt_aboveSig x y n maj). - destruct (Qarchimedean (/ (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n) - (2 # n)))) + destruct (Qarchimedean (/ (proj1_sig y n - proj1_sig x n - (2 # n)))) as [k kmaj]. exists (Pos.max n (2*k)). apply H. Qed. @@ -476,28 +408,26 @@ Qed. (* The CRealLt index separates the Cauchy sequences *) Lemma CRealLt_above_same : forall (x y : CReal) (n : positive), Qlt (2 # n) - (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)) - -> forall p:positive, Pos.le n p - -> Qlt (proj1_sig x (Pos.to_nat p)) (proj1_sig y (Pos.to_nat p)). + (proj1_sig y n - proj1_sig x n) + -> forall p:positive, Pos.le n p -> Qlt (proj1_sig x p) (proj1_sig y p). Proof. intros [xn limx] [yn limy] n inf p H. simpl. simpl in inf. - apply (Qplus_lt_l _ _ (- xn (Pos.to_nat n))). - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat p) + - xn (Pos.to_nat n)))). + apply (Qplus_lt_l _ _ (- xn n)). + apply (Qle_lt_trans _ (Qabs (xn p + - xn n))). apply Qle_Qabs. apply (Qlt_trans _ (1#n)). - apply limx. apply Pos2Nat.inj_le. assumption. apply le_refl. - rewrite <- (Qplus_0_r (yn (Pos.to_nat p))). - rewrite <- (Qplus_opp_r (yn (Pos.to_nat n))). - rewrite (Qplus_comm (yn (Pos.to_nat n))). rewrite Qplus_assoc. + apply limx. exact H. apply Pos.le_refl. + rewrite <- (Qplus_0_r (yn p)). + rewrite <- (Qplus_opp_r (yn n)). + rewrite (Qplus_comm (yn n)). rewrite Qplus_assoc. rewrite <- Qplus_assoc. setoid_replace (1#n)%Q with (-(1#n) + (2#n))%Q. apply Qplus_lt_le_compat. apply (Qplus_lt_l _ _ (1#n)). rewrite Qplus_opp_r. - apply (Qplus_lt_r _ _ (yn (Pos.to_nat n) + - yn (Pos.to_nat p))). + apply (Qplus_lt_r _ _ (yn n + - yn p)). ring_simplify. - setoid_replace (yn (Pos.to_nat n) + (-1 # 1) * yn (Pos.to_nat p)) - with (yn (Pos.to_nat n) - yn (Pos.to_nat p)). - apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat n) - yn (Pos.to_nat p)))). - apply Qle_Qabs. apply limy. apply le_refl. apply Pos2Nat.inj_le. assumption. + setoid_replace (yn n + (-1 # 1) * yn p) with (yn n - yn p). + apply (Qle_lt_trans _ (Qabs (yn n - yn p))). + apply Qle_Qabs. apply limy. apply Pos.le_refl. assumption. field. apply Qle_lteq. left. assumption. rewrite Qplus_comm. rewrite Qinv_minus_distr. reflexivity. @@ -508,10 +438,10 @@ Proof. intros x y H [n q]. apply CRealLt_above in H. destruct H as [p H]. pose proof (CRealLt_above_same y x n q). - apply (Qlt_not_le (proj1_sig y (Pos.to_nat (Pos.max n p))) - (proj1_sig x (Pos.to_nat (Pos.max n p)))). + apply (Qlt_not_le (proj1_sig y (Pos.max n p)) + (proj1_sig x (Pos.max n p))). apply H0. apply Pos.le_max_l. - apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.to_nat (Pos.max n p)))). + apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.max n p))). rewrite Qplus_opp_r. apply (Qlt_trans _ (2#p)). unfold Qlt. simpl. unfold Z.lt. auto. apply H. apply Pos.le_max_r. Qed. @@ -542,31 +472,24 @@ Lemma CRealLt_dec : forall x y z : CReal, Proof. intros [xn limx] [yn limy] [zn limz] [n inf]. unfold proj1_sig in inf. - remember (yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2 # n)) as eps. + remember (yn n - xn n - (2 # n)) as eps. assert (Qlt 0 eps) as epsPos. { subst eps. unfold Qminus. apply (Qlt_minus_iff (2#n)). assumption. } - assert (forall n p, Pos.to_nat n <= Pos.to_nat (Pos.max n p))%nat. - { intros. apply Pos2Nat.inj_le. unfold Pos.max. unfold Pos.le. - destruct (n0 ?= p)%positive eqn:des. - rewrite des. discriminate. rewrite des. discriminate. - unfold Pos.compare. rewrite Pos.compare_cont_refl. discriminate. } destruct (Qarchimedean (/eps)) as [k kmaj]. - destruct (Qlt_le_dec ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2#1)) - (zn (Pos.to_nat (Pos.max n (4 * k))))) + destruct (Qlt_le_dec ((yn n + xn n) / (2#1)) + (zn (Pos.max n (4 * k)))) as [decMiddle|decMiddle]. - left. exists (Pos.max n (4 * k)). unfold proj1_sig. unfold Qminus. - rewrite <- (Qplus_0_r (zn (Pos.to_nat (Pos.max n (4 * k))))). - rewrite <- (Qplus_opp_r (xn (Pos.to_nat n))). - rewrite (Qplus_comm (xn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- (Qplus_0_r (zn (Pos.max n (4 * k)))). + rewrite <- (Qplus_opp_r (xn n)). + rewrite (Qplus_comm (xn n)). rewrite Qplus_assoc. rewrite <- Qplus_assoc. rewrite <- Qplus_0_r. rewrite <- (Qplus_opp_r (1#n)). rewrite Qplus_assoc. apply Qplus_lt_le_compat. - + apply (Qplus_lt_l _ _ (- xn (Pos.to_nat n))) in decMiddle. - apply (Qlt_trans _ ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1) - + - xn (Pos.to_nat n))). - setoid_replace ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1) - - xn (Pos.to_nat n)) - with ((yn (Pos.to_nat n) - xn (Pos.to_nat n)) / (2 # 1)). + + apply (Qplus_lt_l _ _ (- xn n)) in decMiddle. + apply (Qlt_trans _ ((yn n + xn n) / (2 # 1) + - xn n)). + setoid_replace ((yn n + xn n) / (2 # 1) - xn n) + with ((yn n - xn n) / (2 # 1)). apply Qlt_shift_div_l. unfold Qlt. simpl. unfold Z.lt. auto. rewrite Qmult_plus_distr_l. setoid_replace ((1 # n) * (2 # 1))%Q with (2#n)%Q. @@ -580,31 +503,30 @@ Proof. apply Qinv_lt_contravar. reflexivity. apply epsPos. apply kmaj. unfold Qeq. simpl. rewrite Pos.mul_1_r. reflexivity. field. assumption. - + setoid_replace (xn (Pos.to_nat n) + - xn (Pos.to_nat (Pos.max n (4 * k)))) - with (-(xn (Pos.to_nat (Pos.max n (4 * k))) - xn (Pos.to_nat n))). + + setoid_replace (xn n + - xn (Pos.max n (4 * k))) + with (-(xn (Pos.max n (4 * k)) - xn n)). apply Qopp_le_compat. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat (Pos.max n (4 * k))) - xn (Pos.to_nat n)))). - apply Qle_Qabs. apply Qle_lteq. left. apply limx. apply H. - apply le_refl. field. + apply (Qle_trans _ (Qabs (xn (Pos.max n (4 * k)) - xn n))). + apply Qle_Qabs. apply Qle_lteq. left. apply limx. apply Pos.le_max_l. + apply Pos.le_refl. ring. - right. exists (Pos.max n (4 * k)). unfold proj1_sig. unfold Qminus. - rewrite <- (Qplus_0_r (yn (Pos.to_nat (Pos.max n (4 * k))))). - rewrite <- (Qplus_opp_r (yn (Pos.to_nat n))). - rewrite (Qplus_comm (yn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- (Qplus_0_r (yn (Pos.max n (4 * k)))). + rewrite <- (Qplus_opp_r (yn n)). + rewrite (Qplus_comm (yn n)). rewrite Qplus_assoc. rewrite <- Qplus_assoc. rewrite <- Qplus_0_l. rewrite <- (Qplus_opp_r (1#n)). rewrite (Qplus_comm (1#n)). rewrite <- Qplus_assoc. apply Qplus_lt_le_compat. - + apply (Qplus_lt_r _ _ (yn (Pos.to_nat n) - yn (Pos.to_nat (Pos.max n (4 * k))) + (1#n))) + + apply (Qplus_lt_r _ _ (yn n - yn (Pos.max n (4 * k)) + (1#n))) ; ring_simplify. - setoid_replace (-1 * yn (Pos.to_nat (Pos.max n (4 * k)))) - with (- yn (Pos.to_nat (Pos.max n (4 * k)))). 2: ring. - apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat n) - - yn (Pos.to_nat (Pos.max n (4 * k)))))). - apply Qle_Qabs. apply limy. apply le_refl. apply H. + setoid_replace (-1 * yn (Pos.max n (4 * k))) + with (- yn (Pos.max n (4 * k))). 2: ring. + apply (Qle_lt_trans _ (Qabs (yn n - yn (Pos.max n (4 * k))))). + apply Qle_Qabs. apply limy. apply Pos.le_refl. apply Pos.le_max_l. + apply Qopp_le_compat in decMiddle. - apply (Qplus_le_r _ _ (yn (Pos.to_nat n))) in decMiddle. - apply (Qle_trans _ (yn (Pos.to_nat n) + - ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1)))). - setoid_replace (yn (Pos.to_nat n) + - ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1))) - with ((yn (Pos.to_nat n) - xn (Pos.to_nat n)) / (2 # 1)). + apply (Qplus_le_r _ _ (yn n)) in decMiddle. + apply (Qle_trans _ (yn n + - ((yn n + xn n) / (2 # 1)))). + setoid_replace (yn n + - ((yn n + xn n) / (2 # 1))) + with ((yn n - xn n) / (2 # 1)). apply Qle_shift_div_l. unfold Qlt. simpl. unfold Z.lt. auto. rewrite Qmult_plus_distr_l. setoid_replace ((1 # n) * (2 # 1))%Q with (2#n)%Q. @@ -766,7 +688,7 @@ Qed. (* Injection of Q into CReal *) Lemma ConstCauchy : forall q : Q, - QCauchySeq (fun _ => q) Pos.to_nat. + QCauchySeq (fun _ => q) id. Proof. intros. intros k p r H H0. unfold Qminus. rewrite Qplus_opp_r. unfold Qlt. simpl. @@ -811,64 +733,64 @@ Qed. by a factor 2. *) Lemma CRealLtQ : forall (x : CReal) (q : Q), CRealLt x (inject_Q q) - -> forall p:positive, Qlt (proj1_sig x (Pos.to_nat p)) (q + (1#p)). + -> forall p:positive, Qlt (proj1_sig x p) (q + (1#p)). Proof. intros [xn cau] q maj p. simpl. - destruct (Qlt_le_dec (xn (Pos.to_nat p)) (q + (1 # p))). assumption. + destruct (Qlt_le_dec (xn p) (q + (1 # p))). assumption. exfalso. apply CRealLt_above in maj. destruct maj as [k maj]; simpl in maj. specialize (maj (Pos.max k p) (Pos.le_max_l _ _)). - specialize (cau p (Pos.to_nat p) (Pos.to_nat (Pos.max k p)) (le_refl _)). - pose proof (Qplus_lt_le_compat (2#k) (q - xn (Pos.to_nat (Pos.max k p))) - (q + (1 # p)) (xn (Pos.to_nat p)) maj q0). + specialize (cau p p (Pos.max k p) (Pos.le_refl _)). + pose proof (Qplus_lt_le_compat (2#k) (q - xn (Pos.max k p)) + (q + (1 # p)) (xn p) maj q0). rewrite Qplus_comm in H. unfold Qminus in H. rewrite <- Qplus_assoc in H. rewrite <- Qplus_assoc in H. apply Qplus_lt_r in H. - rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat p))) in maj. + rewrite <- (Qplus_lt_r _ _ (xn p)) in maj. apply (Qlt_not_le (1#p) ((1 # p) + (2 # k))). rewrite <- (Qplus_0_r (1#p)). rewrite <- Qplus_assoc. apply Qplus_lt_r. reflexivity. apply Qlt_le_weak. - apply (Qlt_trans _ (- xn (Pos.to_nat (Pos.max k p)) + xn (Pos.to_nat p)) _ H). + apply (Qlt_trans _ (- xn (Pos.max k p) + xn p) _ H). rewrite Qplus_comm. - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat p) - xn (Pos.to_nat (Pos.max k p))))). - apply Qle_Qabs. apply cau. apply Pos2Nat.inj_le. apply Pos.le_max_r. + apply (Qle_lt_trans _ (Qabs (xn p - xn (Pos.max k p)))). + apply Qle_Qabs. apply cau. apply Pos.le_max_r. Qed. Lemma CRealLtQopp : forall (x : CReal) (q : Q), CRealLt (inject_Q q) x - -> forall p:positive, Qlt (q - (1#p)) (proj1_sig x (Pos.to_nat p)). + -> forall p:positive, Qlt (q - (1#p)) (proj1_sig x p). Proof. intros [xn cau] q maj p. simpl. - destruct (Qlt_le_dec (q - (1 # p)) (xn (Pos.to_nat p))). assumption. + destruct (Qlt_le_dec (q - (1 # p)) (xn p)). assumption. exfalso. apply CRealLt_above in maj. destruct maj as [k maj]; simpl in maj. specialize (maj (Pos.max k p) (Pos.le_max_l _ _)). - specialize (cau p (Pos.to_nat (Pos.max k p)) (Pos.to_nat p)). - pose proof (Qplus_lt_le_compat (2#k) (xn (Pos.to_nat (Pos.max k p)) - q) - (xn (Pos.to_nat p)) (q - (1 # p)) maj q0). + specialize (cau p (Pos.max k p) p). + pose proof (Qplus_lt_le_compat (2#k) (xn (Pos.max k p) - q) + (xn p) (q - (1 # p)) maj q0). unfold Qminus in H. rewrite <- Qplus_assoc in H. rewrite (Qplus_assoc (-q)) in H. rewrite (Qplus_comm (-q)) in H. rewrite Qplus_opp_r in H. rewrite Qplus_0_l in H. apply (Qplus_lt_l _ _ (1#p)) in H. - rewrite <- (Qplus_assoc (xn (Pos.to_nat (Pos.max k p)))) in H. + rewrite <- (Qplus_assoc (xn (Pos.max k p))) in H. rewrite (Qplus_comm (-(1#p))) in H. rewrite Qplus_opp_r in H. rewrite Qplus_0_r in H. rewrite Qplus_comm in H. - rewrite Qplus_assoc in H. apply (Qplus_lt_l _ _ (- xn (Pos.to_nat p))) in H. + rewrite Qplus_assoc in H. apply (Qplus_lt_l _ _ (- xn p)) in H. rewrite <- Qplus_assoc in H. rewrite Qplus_opp_r in H. rewrite Qplus_0_r in H. apply (Qlt_not_le (1#p) ((1 # p) + (2 # k))). rewrite <- (Qplus_0_r (1#p)). rewrite <- Qplus_assoc. apply Qplus_lt_r. reflexivity. apply Qlt_le_weak. - apply (Qlt_trans _ (xn (Pos.to_nat (Pos.max k p)) - xn (Pos.to_nat p)) _ H). - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max k p)) - xn (Pos.to_nat p)))). - apply Qle_Qabs. apply cau. apply Pos2Nat.inj_le. - apply Pos.le_max_r. apply le_refl. + apply (Qlt_trans _ (xn (Pos.max k p) - xn p) _ H). + apply (Qle_lt_trans _ (Qabs (xn (Pos.max k p) - xn p))). + apply Qle_Qabs. apply cau. + apply Pos.le_max_r. apply Pos.le_refl. Qed. Lemma inject_Q_compare : forall (x : CReal) (p : positive), - x <= inject_Q (proj1_sig x (Pos.to_nat p) + (1#p)). + x <= inject_Q (proj1_sig x p + (1#p)). Proof. intros. intros [n nmaj]. destruct x as [xn xcau]; simpl in nmaj. @@ -876,18 +798,17 @@ Proof. ring_simplify in nmaj. destruct (Pos.max_dec p n). - apply Pos.max_l_iff in e. - apply Pos2Nat.inj_le in e. - specialize (xcau n (Pos.to_nat n) (Pos.to_nat p) (le_refl _) e). - apply (Qlt_le_trans _ _ (Qabs (xn (Pos.to_nat n) + -1 * xn (Pos.to_nat p)))) in nmaj. + specialize (xcau n n p (Pos.le_refl _) e). + apply (Qlt_le_trans _ _ (Qabs (xn n + -1 * xn p))) in nmaj. 2: apply Qle_Qabs. apply (Qlt_trans _ _ _ nmaj) in xcau. apply (Qplus_lt_l _ _ (-(1#n)-(1#p))) in xcau. ring_simplify in xcau. setoid_replace ((2 # n) + -1 * (1 # n)) with (1#n)%Q in xcau. discriminate xcau. setoid_replace (-1 * (1 # n)) with (-1#n)%Q. 2: reflexivity. rewrite Qinv_plus_distr. reflexivity. - - apply Pos.max_r_iff, Pos2Nat.inj_le in e. - specialize (xcau p (Pos.to_nat n) (Pos.to_nat p) e (le_refl _)). - apply (Qlt_le_trans _ _ (Qabs (xn (Pos.to_nat n) + -1 * xn (Pos.to_nat p)))) in nmaj. + - apply Pos.max_r_iff in e. + specialize (xcau p n p e (Pos.le_refl _)). + apply (Qlt_le_trans _ _ (Qabs (xn n + -1 * xn p))) in nmaj. 2: apply Qle_Qabs. apply (Qlt_trans _ _ _ nmaj) in xcau. apply (Qplus_lt_l _ _ (-(1#p))) in xcau. ring_simplify in xcau. discriminate. @@ -921,12 +842,12 @@ Qed. (* Algebraic operations *) Lemma CReal_plus_cauchy - : forall (xn yn zn : nat -> Q) (cvmod : positive -> nat), + : forall (xn yn zn : positive -> Q) (cvmod : positive -> positive), QSeqEquiv xn yn cvmod - -> QCauchySeq zn Pos.to_nat - -> QSeqEquiv (fun n:nat => xn n + zn n) (fun n:nat => yn n + zn n) - (fun p => max (cvmod (2 * p)%positive) - (Pos.to_nat (2 * p)%positive)). + -> QCauchySeq zn id + -> QSeqEquiv (fun n:positive => xn n + zn n) (fun n:positive => yn n + zn n) + (fun p => Pos.max (cvmod (2 * p)%positive) + (2 * p)%positive). Proof. intros. intros p n k H1 H2. setoid_replace (xn n + zn n - (yn k + zn k)) @@ -936,70 +857,67 @@ Proof. apply Qabs_triangle. setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. apply Qplus_lt_le_compat. - - apply H. apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). - apply Nat.le_max_l. apply H1. - apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). - apply Nat.le_max_l. apply H2. + - apply H. apply (Pos.le_trans _ (Pos.max (cvmod (2 * p)%positive) (2 * p))). + apply Pos.le_max_l. apply H1. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * p)%positive) (2 * p))). + apply Pos.le_max_l. apply H2. - apply Qle_lteq. left. apply H0. - apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). - apply Nat.le_max_r. apply H1. - apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). - apply Nat.le_max_r. apply H2. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * p)%positive) (2 * p))). + apply Pos.le_max_r. apply H1. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * p)%positive) (2 * p))). + apply Pos.le_max_r. apply H2. - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. Qed. Definition CReal_plus (x y : CReal) : CReal. Proof. destruct x as [xn limx], y as [yn limy]. - pose proof (CReal_plus_cauchy xn xn yn Pos.to_nat limx limy). - exists (fun n : nat => xn (2 * n)%nat + yn (2 * n)%nat). + pose proof (CReal_plus_cauchy xn xn yn id limx limy). + exists (fun n : positive => xn (2 * n)%positive + yn (2 * n)%positive). intros p k n H0 H1. apply H. - - rewrite max_l. rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. apply le_0_n. apply le_refl. - apply le_0_n. apply H0. apply le_refl. - - rewrite Pos2Nat.inj_mul. rewrite max_l. - apply Nat.mul_le_mono_nonneg. apply le_0_n. apply le_refl. - apply le_0_n. apply H1. apply le_refl. + - rewrite Pos.max_l. unfold id. rewrite <- Pos.mul_le_mono_l. + exact H0. apply Pos.le_refl. + - rewrite Pos.max_l. unfold id. + apply Pos.mul_le_mono_l. exact H1. apply Pos.le_refl. Defined. Infix "+" := CReal_plus : CReal_scope. -Lemma CReal_plus_nth : forall (x y : CReal) (n : nat), - proj1_sig (x + y) n = Qplus (proj1_sig x (2*n)%nat) (proj1_sig y (2*n)%nat). +Lemma CReal_plus_nth : forall (x y : CReal) (n : positive), + proj1_sig (x + y) n = Qplus (proj1_sig x (2*n)%positive) + (proj1_sig y (2*n)%positive). Proof. intros. destruct x,y; reflexivity. Qed. Lemma CReal_plus_unfold : forall (x y : CReal), QSeqEquiv (proj1_sig (CReal_plus x y)) - (fun n : nat => proj1_sig x n + proj1_sig y n)%Q - (fun p => Pos.to_nat (2 * p)). + (fun n : positive => proj1_sig x n + proj1_sig y n)%Q + (fun p => 2 * p)%positive. Proof. intros [xn limx] [yn limy]. unfold CReal_plus; simpl. intros p n k H H0. - setoid_replace (xn (2 * n)%nat + yn (2 * n)%nat - (xn k + yn k))%Q - with (xn (2 * n)%nat - xn k + (yn (2 * n)%nat - yn k))%Q. + setoid_replace (xn (2 * n)%positive + yn (2 * n)%positive - (xn k + yn k))%Q + with (xn (2 * n)%positive - xn k + (yn (2 * n)%positive - yn k))%Q. 2: field. - apply (Qle_lt_trans _ (Qabs (xn (2 * n)%nat - xn k) + Qabs (yn (2 * n)%nat - yn k))). + apply (Qle_lt_trans _ (Qabs (xn (2 * n)%positive - xn k) + Qabs (yn (2 * n)%positive - yn k))). apply Qabs_triangle. setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. apply Qplus_lt_le_compat. - - apply limx. apply (le_trans _ n). apply H. - rewrite <- (mult_1_l n). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. simpl. auto. - apply le_0_n. apply le_refl. apply H0. - - apply Qlt_le_weak. apply limy. apply (le_trans _ n). apply H. - rewrite <- (mult_1_l n). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. simpl. auto. - apply le_0_n. apply le_refl. apply H0. + - apply limx. apply (Pos.le_trans _ n). apply H. + apply (Pos.le_trans _ (1 * n)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. exact H0. + - apply Qlt_le_weak. apply limy. apply (Pos.le_trans _ n). apply H. + apply (Pos.le_trans _ (1 * n)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. exact H0. - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. Qed. Definition CReal_opp (x : CReal) : CReal. Proof. destruct x as [xn limx]. - exists (fun n : nat => - xn n). + exists (fun n : positive => - xn n). intros k p q H H0. unfold Qminus. rewrite Qopp_involutive. rewrite Qplus_comm. apply limx; assumption. Defined. @@ -1011,10 +929,10 @@ Definition CReal_minus (x y : CReal) : CReal Infix "-" := CReal_minus : CReal_scope. -Lemma belowMultiple : forall n p : nat, lt 0 p -> le n (p * n). +Lemma belowMultiple : forall n p : positive, Pos.le n (p * n). Proof. - intros. rewrite <- (mult_1_l n). apply Nat.mul_le_mono_nonneg. - auto. assumption. apply le_0_n. rewrite mult_1_l. apply le_refl. + intros. apply (Pos.le_trans _ (1*n)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. destruct p; discriminate. Qed. Lemma CReal_plus_assoc : forall (x y z : CReal), @@ -1024,20 +942,20 @@ Proof. intros. apply CRealEq_diff. intro n. destruct x as [xn limx], y as [yn limy], z as [zn limz]. unfold CReal_plus; unfold proj1_sig. - setoid_replace (xn (2 * (2 * Pos.to_nat n))%nat + yn (2 * (2 * Pos.to_nat n))%nat - + zn (2 * Pos.to_nat n)%nat - - (xn (2 * Pos.to_nat n)%nat + (yn (2 * (2 * Pos.to_nat n))%nat - + zn (2 * (2 * Pos.to_nat n))%nat)))%Q - with (xn (2 * (2 * Pos.to_nat n))%nat - xn (2 * Pos.to_nat n)%nat - + (zn (2 * Pos.to_nat n)%nat - zn (2 * (2 * Pos.to_nat n))%nat))%Q. - apply (Qle_trans _ (Qabs (xn (2 * (2 * Pos.to_nat n))%nat - xn (2 * Pos.to_nat n)%nat) - + Qabs (zn (2 * Pos.to_nat n)%nat - zn (2 * (2 * Pos.to_nat n))%nat))). + setoid_replace (xn (2 * (2 * n))%positive + yn (2 * (2 * n))%positive + + zn (2 * n)%positive + - (xn (2 * n)%positive + (yn (2 * (2 * n))%positive + + zn (2 * (2 * n))%positive)))%Q + with (xn (2 * (2 * n))%positive - xn (2 * n)%positive + + (zn (2 * n)%positive - zn (2 * (2 * n))%positive))%Q. + apply (Qle_trans _ (Qabs (xn (2 * (2 * n))%positive - xn (2 * n)%positive) + + Qabs (zn (2 * n)%positive - zn (2 * (2 * n))%positive))). apply Qabs_triangle. rewrite <- (Qinv_plus_distr 1 1 n). apply Qplus_le_compat. - apply Qle_lteq. left. apply limx. rewrite mult_assoc. - apply belowMultiple. simpl. auto. apply belowMultiple. auto. - apply Qle_lteq. left. apply limz. apply belowMultiple. auto. - rewrite mult_assoc. apply belowMultiple. simpl. auto. field. + apply Qle_lteq. left. apply limx. rewrite Pos.mul_assoc. + apply belowMultiple. apply belowMultiple. + apply Qle_lteq. left. apply limz. apply belowMultiple. + rewrite Pos.mul_assoc. apply belowMultiple. simpl. field. Qed. Lemma CReal_plus_comm : forall x y : CReal, @@ -1045,39 +963,40 @@ Lemma CReal_plus_comm : forall x y : CReal, Proof. intros [xn limx] [yn limy]. apply CRealEq_diff. intros. unfold CReal_plus, proj1_sig. - setoid_replace (xn (2 * Pos.to_nat n)%nat + yn (2 * Pos.to_nat n)%nat - - (yn (2 * Pos.to_nat n)%nat + xn (2 * Pos.to_nat n)%nat))%Q + setoid_replace (xn (2 * n)%positive + yn (2 * n)%positive + - (yn (2 * n)%positive + xn (2 * n)%positive))%Q with 0%Q. unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd. field. Qed. Lemma CReal_plus_0_l : forall r : CReal, - CRealEq (CReal_plus (inject_Q 0) r) r. + inject_Q 0 + r == r. Proof. - intro r. assert (forall n:nat, le n (2 * n)). - { intro n. simpl. rewrite <- (plus_0_r n). rewrite <- plus_assoc. - apply Nat.add_le_mono_l. apply le_0_n. } - split. - - intros [n maj]. destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. + intro r. split. + - intros [n maj]. + destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. rewrite Qplus_0_l in maj. - specialize (q n (Pos.to_nat n) (mult 2 (Pos.to_nat n)) (le_refl _)). - apply (Qlt_not_le (2#n) (xn (Pos.to_nat n) - xn (2 * Pos.to_nat n)%nat)). + specialize (q n n (Pos.mul 2 n) (Pos.le_refl _)). + apply (Qlt_not_le (2#n) (xn n - xn (2 * n)%positive)). assumption. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (2 * Pos.to_nat n)%nat))). + apply (Qle_trans _ (Qabs (xn n - xn (2 * n)%positive))). apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q. - apply H. unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_xO. - apply H. - - intros [n maj]. destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. + apply belowMultiple. + unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. + discriminate. discriminate. + - intros [n maj]. + destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. rewrite Qplus_0_l in maj. - specialize (q n (Pos.to_nat n) (mult 2 (Pos.to_nat n)) (le_refl _)). + specialize (q n n (Pos.mul 2 n) (Pos.le_refl _)). rewrite Qabs_Qminus in q. - apply (Qlt_not_le (2#n) (xn (mult 2 (Pos.to_nat n)) - xn (Pos.to_nat n))). + apply (Qlt_not_le (2#n) (xn (Pos.mul 2 n) - xn n)). assumption. - apply (Qle_trans _ (Qabs (xn (mult 2 (Pos.to_nat n)) - xn (Pos.to_nat n)))). + apply (Qle_trans _ (Qabs (xn (Pos.mul 2 n) - xn n))). apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q. - apply H. unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_xO. - apply H. + apply belowMultiple. + unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. + discriminate. discriminate. Qed. Lemma CReal_plus_0_r : forall r : CReal, @@ -1091,14 +1010,11 @@ Lemma CReal_plus_lt_compat_l : Proof. intros. apply CRealLt_above in H. destruct H as [n maj]. - exists n. specialize (maj (xO n)). - rewrite Pos2Nat.inj_xO in maj. - setoid_replace (proj1_sig (CReal_plus x z) (Pos.to_nat n) - - proj1_sig (CReal_plus x y) (Pos.to_nat n))%Q - with (proj1_sig z (2 * Pos.to_nat n)%nat - proj1_sig y (2 * Pos.to_nat n)%nat)%Q. - apply maj. apply Pos2Nat.inj_le. - rewrite <- (plus_0_r (Pos.to_nat n)). rewrite Pos2Nat.inj_xO. - simpl. apply Nat.add_le_mono_l. apply le_0_n. + exists n. specialize (maj (2 * n)%positive). + setoid_replace (proj1_sig (CReal_plus x z) n + - proj1_sig (CReal_plus x y) n)%Q + with (proj1_sig z (2 * n)%positive - proj1_sig y (2 * n)%positive)%Q. + apply maj. apply belowMultiple. simpl. destruct x as [xn limx], y as [yn limy], z as [zn limz]. simpl; ring. Qed. @@ -1114,12 +1030,13 @@ Lemma CReal_plus_lt_reg_l : forall x y z : CReal, x + y < x + z -> y < z. Proof. intros. destruct H as [n maj]. exists (2*n)%positive. - setoid_replace (proj1_sig z (Pos.to_nat (2 * n)) - proj1_sig y (Pos.to_nat (2 * n)))%Q - with (proj1_sig (CReal_plus x z) (Pos.to_nat n) - proj1_sig (CReal_plus x y) (Pos.to_nat n))%Q. - apply (Qle_lt_trans _ (2#n)). unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. - rewrite <- (plus_0_r (Pos.to_nat n~0)). rewrite (Pos2Nat.inj_xO (n~0)). - simpl. apply Nat.add_le_mono_l. apply le_0_n. - apply maj. rewrite Pos2Nat.inj_xO. + setoid_replace (proj1_sig z (2 * n)%positive - proj1_sig y (2 * n)%positive)%Q + with (proj1_sig (CReal_plus x z) n - proj1_sig (CReal_plus x y) n)%Q. + apply (Qle_lt_trans _ (2#n)). + setoid_replace (2 # 2 * n)%Q with (1 # n)%Q. 2: reflexivity. + unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. + discriminate. discriminate. + apply maj. destruct x as [xn limx], y as [yn limy], z as [zn limz]. simpl; ring. Qed. @@ -1173,7 +1090,7 @@ Lemma CReal_plus_opp_r : forall x : CReal, Proof. intros [xn limx]. apply CRealEq_diff. intros. unfold CReal_plus, CReal_opp, inject_Q, proj1_sig. - setoid_replace (xn (2 * Pos.to_nat n)%nat + - xn (2 * Pos.to_nat n)%nat - 0)%Q + setoid_replace (xn (2 * n)%positive + - xn (2 * n)%positive - 0)%Q with 0%Q. unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd. field. Qed. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v index fa24bd988e..f3a59b493f 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v @@ -20,82 +20,57 @@ Require CMorphisms. Local Open Scope CReal_scope. -Fixpoint BoundFromZero (qn : nat -> Q) (k : nat) (A : positive) { struct k } - : (forall n:nat, le k n -> Qlt (Qabs (qn n)) (Z.pos A # 1)) - -> { B : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos B # 1) }. -Proof. - intro H. destruct k. - - exists A. intros. apply H. apply le_0_n. - - destruct (Qarchimedean (Qabs (qn k))) as [a maj]. - apply (BoundFromZero qn k (Pos.max A a)). - intros n H0. destruct (Nat.le_gt_cases n k). - + pose proof (Nat.le_antisymm n k H1 H0). subst k. - apply (Qlt_le_trans _ (Z.pos a # 1)). apply maj. - unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. - apply Pos.le_max_r. - + apply (Qlt_le_trans _ (Z.pos A # 1)). apply H. - apply H1. unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. - apply Pos.le_max_l. -Qed. - -Lemma QCauchySeq_bounded (qn : nat -> Q) (cvmod : positive -> nat) +Definition QCauchySeq_bound (qn : positive -> Q) (cvmod : positive -> positive) + : positive + := match Qnum (qn (cvmod 1%positive)) with + | Z0 => 1%positive + | Z.pos p => p + 1 + | Z.neg p => p + 1 + end. + +Lemma QCauchySeq_bounded_prop (qn : positive -> Q) (cvmod : positive -> positive) : QCauchySeq qn cvmod - -> { A : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos A # 1) }. -Proof. - intros. remember (Zplus (Qnum (Qabs (qn (cvmod xH)))) 1) as z. - assert (Z.lt 0 z) as zPos. - { subst z. assert (Qle 0 (Qabs (qn (cvmod 1%positive)))). - apply Qabs_nonneg. destruct (Qabs (qn (cvmod 1%positive))). simpl. - unfold Qle in H0. simpl in H0. rewrite Zmult_1_r in H0. - apply (Z.lt_le_trans 0 1). unfold Z.lt. auto. - rewrite <- (Zplus_0_l 1). rewrite Zplus_assoc. apply Zplus_le_compat_r. - rewrite Zplus_0_r. assumption. } - assert { A : positive | forall n:nat, - le (cvmod xH) n -> Qlt ((Qabs (qn n)) * (1#A)) 1 }. - destruct z eqn:des. - - exfalso. apply (Z.lt_irrefl 0). assumption. - - exists p. intros. specialize (H xH (cvmod xH) n (le_refl _) H0). - assert (Qlt (Qabs (qn n)) (Qabs (qn (cvmod 1%positive)) + 1)). - { apply (Qplus_lt_l _ _ (-Qabs (qn (cvmod 1%positive)))). - rewrite <- (Qplus_comm 1). rewrite <- Qplus_assoc. rewrite Qplus_opp_r. - rewrite Qplus_0_r. apply (Qle_lt_trans _ (Qabs (qn n - qn (cvmod 1%positive)))). - apply Qabs_triangle_reverse. rewrite Qabs_Qminus. assumption. } - apply (Qlt_le_trans _ ((Qabs (qn (cvmod 1%positive)) + 1) * (1#p))). - apply Qmult_lt_r. unfold Qlt. simpl. unfold Z.lt. auto. assumption. - unfold Qle. simpl. rewrite Zmult_1_r. rewrite Zmult_1_r. rewrite Zmult_1_r. - rewrite Pos.mul_1_r. rewrite Pos2Z.inj_mul. rewrite Heqz. - destruct (Qabs (qn (cvmod 1%positive))) eqn:desAbs. - rewrite Z.mul_add_distr_l. rewrite Zmult_1_r. - apply Zplus_le_compat_r. rewrite <- (Zmult_1_l (QArith_base.Qnum (Qnum # Qden))). - rewrite Zmult_assoc. apply Zmult_le_compat_r. rewrite Zmult_1_r. - simpl. unfold Z.le. rewrite <- Pos2Z.inj_compare. - unfold Pos.compare. destruct Qden; discriminate. - simpl. assert (Qle 0 (Qnum # Qden)). rewrite <- desAbs. - apply Qabs_nonneg. unfold Qle in H2. simpl in H2. rewrite Zmult_1_r in H2. - assumption. - - exfalso. inversion zPos. - - destruct H0. apply (BoundFromZero _ (cvmod xH) x). intros n H0. - specialize (q n H0). setoid_replace (Z.pos x # 1)%Q with (/(1#x))%Q. - rewrite <- (Qmult_1_l (/(1#x))). apply Qlt_shift_div_l. - reflexivity. apply q. reflexivity. + -> forall n:positive, Pos.le (cvmod 1%positive) n + -> Qlt (Qabs (qn n)) (Z.pos (QCauchySeq_bound qn cvmod) # 1). +Proof. + intros H n H0. unfold QCauchySeq_bound. + specialize (H 1%positive (cvmod 1%positive) n (Pos.le_refl _) H0). + destruct (qn (cvmod 1%positive)) as [a b]. unfold Qnum. + rewrite Qabs_Qminus in H. + apply (Qplus_lt_l _ _ (-Qabs (a#b))). + apply (Qlt_le_trans _ 1). + exact (Qle_lt_trans _ _ _ (Qabs_triangle_reverse (qn n) (a#b)) H). + assert (forall p : positive, + (1 <= (Z.pos (p + 1) # 1) + - (Z.pos p # b))%Q). + { intro p. unfold Qle, Qopp, Qplus, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_add, Pos.mul_1_l. + apply (Z.add_le_mono_l _ _ (Z.pos p -Z.pos b)). + ring_simplify. apply (Z.le_trans _ (Z.pos p * 1)). + rewrite Z.mul_1_r. apply Z.le_refl. + apply Z.mul_le_mono_nonneg_l. discriminate. destruct b; discriminate. } + destruct a. + - setoid_replace (Qabs (0#b)) with 0%Q. 2: reflexivity. + rewrite Qplus_0_r. apply Qle_refl. + - apply H1. + - apply H1. Qed. Lemma CReal_mult_cauchy - : forall (xn yn zn : nat -> Q) (Ay Az : positive) (cvmod : positive -> nat), + : forall (xn yn zn : positive -> Q) (Ay Az : positive) (cvmod : positive -> positive), QSeqEquiv xn yn cvmod - -> QCauchySeq zn Pos.to_nat - -> (forall n:nat, Qlt (Qabs (yn n)) (Z.pos Ay # 1)) - -> (forall n:nat, Qlt (Qabs (zn n)) (Z.pos Az # 1)) - -> QSeqEquiv (fun n:nat => xn n * zn n) (fun n:nat => yn n * zn n) - (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) - (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). + -> QCauchySeq zn id + -> (forall n:positive, Pos.le (cvmod 2%positive) n + -> Qlt (Qabs (yn n)) (Z.pos Ay # 1)) + -> (forall n:positive, Pos.le 1 n + -> Qlt (Qabs (zn n)) (Z.pos Az # 1)) + -> QSeqEquiv (fun n:positive => xn n * zn n) (fun n:positive => yn n * zn n) + (fun p => Pos.max (Pos.max (cvmod 2%positive) + (cvmod (2 * (Pos.max Ay Az) * p)%positive)) + (2 * (Pos.max Ay Az) * p)%positive). Proof. intros xn yn zn Ay Az cvmod limx limz majy majz. remember (Pos.mul 2 (Pos.max Ay Az)) as z. intros k p q H H0. - assert (Pos.to_nat k <> O) as kPos. - { intro absurd. pose proof (Pos2Nat.is_pos k). - rewrite absurd in H1. inversion H1. } setoid_replace (xn p * zn p - yn q * zn q)%Q with ((xn p - yn q) * zn p + yn q * (zn p - zn q))%Q. 2: ring. @@ -106,30 +81,39 @@ Proof. apply Qplus_lt_le_compat. - apply (Qle_lt_trans _ ((1#z * k) * Qabs (zn p)%nat)). + apply Qmult_le_compat_r. apply Qle_lteq. left. apply limx. - apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). - apply Nat.le_max_l. assumption. - apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). - apply Nat.le_max_l. assumption. apply Qabs_nonneg. + apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) (z * k))). + apply Pos.le_max_l. refine (Pos.le_trans _ _ _ _ H). + rewrite <- Pos.max_assoc. apply Pos.le_max_r. + apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) (z * k))). + apply Pos.le_max_l. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.max_assoc. apply Pos.le_max_r. apply Qabs_nonneg. + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. - apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. + apply Qmult_lt_l. reflexivity. apply (Qle_lt_trans _ (Qabs (zn p)%nat * (1 # Az))). rewrite <- (Qmult_comm (1 # Az)). apply Qmult_le_compat_r. unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_r. apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Az)). + 2: intro abs; inversion abs. rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. - setoid_replace (/(1#Az))%Q with (Z.pos Az # 1)%Q. apply majz. - reflexivity. intro abs. inversion abs. + setoid_replace (/(1#Az))%Q with (Z.pos Az # 1)%Q. + 2: reflexivity. + apply majz. refine (Pos.le_trans _ _ _ _ H). + apply (Pos.le_trans _ (2 * Pos.max Ay Az * k)). + discriminate. apply Pos.le_max_r. - apply (Qle_trans _ ((1 # z * k) * Qabs (yn q)%nat)). + rewrite Qmult_comm. apply Qmult_le_compat_r. apply Qle_lteq. left. apply limz. - apply (le_trans _ (max (cvmod (z * k)%positive) - (Pos.to_nat (z * k)%positive))). - apply Nat.le_max_r. assumption. - apply (le_trans _ (max (cvmod (z * k)%positive) - (Pos.to_nat (z * k)%positive))). - apply Nat.le_max_r. assumption. apply Qabs_nonneg. + apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) + (z * k)%positive)). + apply Pos.le_max_r. refine (Pos.le_trans _ _ _ _ H). + rewrite <- Pos.max_assoc. apply Pos.le_max_r. + apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) + (z * k)%positive)). + apply Pos.le_max_r. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.max_assoc. apply Pos.le_max_r. + apply Qabs_nonneg. + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. @@ -139,165 +123,196 @@ Proof. rewrite <- (Qmult_comm (1 # Ay)). apply Qmult_le_compat_r. unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Ay)). + 2: intro abs; inversion abs. rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. - setoid_replace (/(1#Ay))%Q with (Z.pos Ay # 1)%Q. apply majy. - reflexivity. intro abs. inversion abs. + setoid_replace (/(1#Ay))%Q with (Z.pos Ay # 1)%Q. 2: reflexivity. + apply majy. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.max_assoc. apply Pos.le_max_l. - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. Qed. -Lemma linear_max : forall (p Ax Ay : positive) (i : nat), - le (Pos.to_nat p) i - -> (Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) - (Pos.to_nat (2 * Pos.max Ax Ay * p)) <= Pos.to_nat (2 * Pos.max Ax Ay) * i)%nat. -Proof. - intros. rewrite max_l. 2: apply le_refl. - rewrite Pos2Nat.inj_mul. apply Nat.mul_le_mono_nonneg. - apply le_0_n. apply le_refl. apply le_0_n. apply H. +Lemma linear_max : forall (p Ax Ay i : positive), + Pos.le p i + -> (Pos.max (Pos.max 2 (2 * Pos.max Ax Ay * p)) + (2 * Pos.max Ax Ay * p) + <= (2 * Pos.max Ax Ay) * i)%positive. +Proof. + intros. rewrite Pos.max_l. 2: apply Pos.le_max_r. rewrite Pos.max_r. + apply Pos.mul_le_mono_l. exact H. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2). + destruct (Pos.max Ax Ay * p)%positive; discriminate. Qed. Definition CReal_mult (x y : CReal) : CReal. Proof. destruct x as [xn limx]. destruct y as [yn limy]. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). - exists (fun n : nat => xn (Pos.to_nat (2 * Pos.max Ax Ay)* n)%nat - * yn (Pos.to_nat (2 * Pos.max Ax Ay) * n)%nat). + pose (QCauchySeq_bound xn id) as Ax. + pose (QCauchySeq_bound yn id) as Ay. + exists (fun n : positive => xn ((2 * Pos.max Ax Ay) * n)%positive + * yn ((2 * Pos.max Ax Ay) * n)%positive). intros p n k H0 H1. - apply H; apply linear_max; assumption. + apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). + intros. apply (QCauchySeq_bounded_prop xn id limx). + apply (Pos.le_trans _ 2). discriminate. exact H. + intros. exact (QCauchySeq_bounded_prop yn id limy _ H). + apply linear_max; assumption. apply linear_max; assumption. Defined. Infix "*" := CReal_mult : CReal_scope. Lemma CReal_mult_unfold : forall x y : CReal, QSeqEquivEx (proj1_sig (CReal_mult x y)) - (fun n : nat => proj1_sig x n * proj1_sig y n)%Q. + (fun n : positive => proj1_sig x n * proj1_sig y n)%Q. Proof. intros [xn limx] [yn limy]. unfold CReal_mult ; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - simpl. - pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) - (Pos.to_nat (2 * Pos.max Ax Ay * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - apply H. apply linear_max. - apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). - rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. - apply le_0_n. apply le_refl. apply H0. rewrite max_l. - apply H1. apply le_refl. + Pos.max (2 * Pos.max Ax Ay * p) + (2 * Pos.max Ax Ay * p)). + intros p n k H0 H1. rewrite Pos.max_l in H0, H1. + apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). + 2: apply majy. intros. apply majx. + refine (Pos.le_trans _ _ _ _ H). discriminate. + 3: apply Pos.le_refl. 3: apply Pos.le_refl. + apply linear_max. refine (Pos.le_trans _ _ _ _ H0). + apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. + rewrite Pos.max_l. + rewrite Pos.max_r. apply H1. 2: apply Pos.le_max_r. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. unfold id. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). + destruct (Pos.max Ax Ay * p)%positive; discriminate. Qed. -Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : nat -> Q), +Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : positive -> Q), QSeqEquivEx xn yn (* both are Cauchy with same limit *) - -> QSeqEquiv zn zn Pos.to_nat + -> QSeqEquiv zn zn id -> QSeqEquivEx (fun n => xn n * zn n)%Q (fun n => yn n * zn n)%Q. Proof. - intros. destruct H as [cvmod cveq]. - destruct (QCauchySeq_bounded yn (fun k => cvmod (2 * k)%positive) - (QSeqEquiv_cau_r xn yn cvmod cveq)) - as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat H0) as [Az majz]. - exists (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) - (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). - apply CReal_mult_cauchy; assumption. + intros xn yn zn [cvmod cveq] H0. + exists (fun p => Pos.max (Pos.max (cvmod 2%positive) (cvmod (2 * (Pos.max (QCauchySeq_bound yn (fun k : positive => cvmod (2 * k)%positive)) (QCauchySeq_bound zn id)) * p)%positive)) + (2 * (Pos.max (QCauchySeq_bound yn (fun k : positive => cvmod (2 * k)%positive)) (QCauchySeq_bound zn id)) * p)%positive). + apply (CReal_mult_cauchy _ _ _ _ _ _ cveq H0). + exact (QCauchySeq_bounded_prop + yn (fun k => cvmod (2 * k)%positive) + (QSeqEquiv_cau_r xn yn cvmod cveq)). + exact (QCauchySeq_bounded_prop zn id H0). Qed. -Lemma CReal_mult_assoc : forall x y z : CReal, - CRealEq (CReal_mult (CReal_mult x y) z) - (CReal_mult x (CReal_mult y z)). +Lemma CReal_mult_assoc : forall x y z : CReal, (x * y) * z == x * (y * z). Proof. intros. apply CRealEq_diff. apply CRealEq_modindep. apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n * proj1_sig z n)%Q). - apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n * proj1_sig z n)%Q). apply CReal_mult_unfold. destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - apply CReal_mult_assoc_bounded_r. 2: apply limz. - simpl. - pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + pose proof (QCauchySeq_bounded_prop zn id limz) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + remember (QCauchySeq_bound zn id) as Az. + apply CReal_mult_assoc_bounded_r. 2: exact limz. exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) - (Pos.to_nat (2 * Pos.max Ax Ay * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - apply H. apply linear_max. - apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). - rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. - apply le_0_n. apply le_refl. apply H0. rewrite max_l. - apply H1. apply le_refl. - - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig (CReal_mult y z) n)%Q). + Pos.max (2 * Pos.max Ax Ay * p) + (2 * Pos.max Ax Ay * p)). + intros p n k H0 H1. + apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). + 2: exact majy. intros. apply majx. refine (Pos.le_trans _ _ _ _ H). + discriminate. rewrite Pos.max_l in H0, H1. + 2: apply Pos.le_refl. 2: apply Pos.le_refl. + apply linear_max. + apply (Pos.le_trans _ (2 * Pos.max Ax Ay * p)). + apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. + exact H0. rewrite Pos.max_l. 2: apply Pos.le_max_r. + rewrite Pos.max_r in H1. 2: apply Pos.le_refl. + refine (Pos.le_trans _ _ _ _ H1). rewrite Pos.max_r. + apply Pos.le_refl. apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + unfold id. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). + destruct (Pos.max Ax Ay * p)%positive; discriminate. + - apply (QSeqEquivEx_trans + _ (fun n => proj1_sig x n * proj1_sig (CReal_mult y z) n)%Q). 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - simpl. - pose proof (CReal_mult_assoc_bounded_r (fun n0 : nat => yn n0 * zn n0)%Q (fun n : nat => - yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat - * zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat)%Q xn) + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + pose proof (QCauchySeq_bounded_prop zn id limz) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + remember (QCauchySeq_bound zn id) as Az. + pose proof (CReal_mult_assoc_bounded_r (fun n0 : positive => yn n0 * zn n0)%Q (fun n : positive => + yn ((Pos.max Ay Az)~0 * n)%positive + * zn ((Pos.max Ay Az)~0 * n)%positive)%Q xn) as [cvmod cveq]. - - pose proof (CReal_mult_cauchy yn yn zn Ay Az Pos.to_nat limy limz majy majz). - exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Az * p)) - (Pos.to_nat (2 * Pos.max Ay Az * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - apply H. rewrite max_l. apply H0. apply le_refl. - apply linear_max. - apply (le_trans _ (Pos.to_nat (2 * Pos.max Ay Az * p))). - rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. - apply le_0_n. apply le_refl. apply H1. - apply limx. - exists cvmod. intros p k n H1 H2. specialize (cveq p k n H1 H2). - setoid_replace (xn k * yn k * zn k - - xn n * - (yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * - zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat))%Q - with ((fun n : nat => yn n * zn n * xn n) k - - (fun n : nat => - yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * - zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * - xn n) n)%Q. - apply cveq. ring. + + exists (fun p : positive => + Pos.max (2 * Pos.max Ay Az * p) + (2 * Pos.max Ay Az * p)). + intros p n k H0 H1. rewrite Pos.max_l in H0, H1. + apply (CReal_mult_cauchy yn yn zn Ay Az id limy limz). + 2: exact majz. intros. apply majy. refine (Pos.le_trans _ _ _ _ H). + discriminate. + 3: apply Pos.le_refl. 3: apply Pos.le_refl. + rewrite Pos.max_l. rewrite Pos.max_r. apply H0. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. unfold id. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). + destruct (Pos.max Ay Az * p)%positive; discriminate. + apply Pos.le_max_r. + apply linear_max. refine (Pos.le_trans _ _ _ _ H1). + apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. + + exact limx. + + exists cvmod. intros p k n H1 H2. specialize (cveq p k n H1 H2). + setoid_replace (xn k * yn k * zn k - + xn n * + (yn ((Pos.max Ay Az)~0 * n)%positive * + zn ((Pos.max Ay Az)~0 * n)%positive))%Q + with ((fun n : positive => yn n * zn n * xn n) k - + (fun n : positive => + yn ((Pos.max Ay Az)~0 * n)%positive * + zn ((Pos.max Ay Az)~0 * n)%positive * + xn n) n)%Q. + apply cveq. ring. Qed. -Lemma CReal_mult_comm : forall x y : CReal, - CRealEq (CReal_mult x y) (CReal_mult y x). +Lemma CReal_mult_comm : forall x y : CReal, x * y == y * x. Proof. intros. apply CRealEq_diff. apply CRealEq_modindep. apply (QSeqEquivEx_trans _ (fun n => proj1_sig y n * proj1_sig x n)%Q). destruct x as [xn limx], y as [yn limy]; simpl. 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]; simpl. + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. apply QSeqEquivEx_sym. - - pose proof (CReal_mult_cauchy yn yn xn Ay Ax Pos.to_nat limy limx majy majx). exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Ax * p)) - (Pos.to_nat (2 * Pos.max Ay Ax * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - rewrite (Qmult_comm (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)). - apply (H p n). rewrite max_l. apply H0. apply le_refl. - rewrite max_l. apply (le_trans _ k). apply H1. - rewrite <- (mult_1_l k). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. - apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. - apply le_refl. + Pos.max (2 * Pos.max Ay Ax * p) + (2 * Pos.max Ay Ax * p)). + intros p n k H0 H1. rewrite Pos.max_l in H0, H1. + 2: apply Pos.le_refl. 2: apply Pos.le_refl. + rewrite (Qmult_comm (xn ((Pos.max Ax Ay)~0 * k)%positive)). + apply (CReal_mult_cauchy yn yn xn Ay Ax id limy limx). + 2: exact majx. intros. apply majy. refine (Pos.le_trans _ _ _ _ H). + discriminate. + rewrite Pos.max_l. rewrite Pos.max_r. apply H0. + unfold id. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). + destruct (Pos.max Ay Ax * p)%positive; discriminate. + apply Pos.le_max_r. rewrite (Pos.max_comm Ax Ay). + apply linear_max. refine (Pos.le_trans _ _ _ _ H1). + apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. Qed. Lemma CReal_mult_proper_l : forall x y z : CReal, - CRealEq y z -> CRealEq (CReal_mult x y) (CReal_mult x z). + y == z -> x * y == x * z. Proof. intros. apply CRealEq_diff. apply CRealEq_modindep. apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n)%Q). @@ -307,46 +322,48 @@ Proof. apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig z n)%Q). apply CReal_mult_unfold. destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. - destruct H. simpl in H. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - pose proof (CReal_mult_cauchy yn zn xn Az Ax x H limx majz majx). + destruct H as [cvmod H]. simpl in H. + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop + zn (fun k => cvmod (2 * k)%positive) + (QSeqEquiv_cau_r yn zn cvmod H)) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound zn (fun k => cvmod (2 * k)%positive)) as Az. apply QSeqEquivEx_sym. exists (fun p : positive => - Init.Nat.max (x (2 * Pos.max Az Ax * p)%positive) - (Pos.to_nat (2 * Pos.max Az Ax * p))). - intros p n k H1 H2. specialize (H0 p n k H1 H2). + Pos.max (Pos.max (cvmod (2%positive)) (cvmod (2 * Pos.max Az Ax * p)%positive)) + (2 * Pos.max Az Ax * p)). + intros p n k H1 H2. setoid_replace (xn n * yn n - xn k * zn k)%Q - with (yn n * xn n - zn k * xn k)%Q. - apply H0. ring. + with (yn n * xn n - zn k * xn k)%Q. 2: ring. + apply (CReal_mult_cauchy yn zn xn Az Ax cvmod H limx majz majx). + exact H1. exact H2. Qed. Lemma CReal_mult_lt_0_compat : forall x y : CReal, - CRealLt (inject_Q 0) x - -> CRealLt (inject_Q 0) y - -> CRealLt (inject_Q 0) (CReal_mult x y). + inject_Q 0 < x + -> inject_Q 0 < y + -> inject_Q 0 < x * y. Proof. intros. destruct H as [x0 H], H0 as [x1 H0]. pose proof (CRealLt_aboveSig (inject_Q 0) x x0 H). pose proof (CRealLt_aboveSig (inject_Q 0) y x1 H0). - destruct x as [xn limx], y as [yn limy]. - simpl in H, H1, H2. simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (Qarchimedean (/ (xn (Pos.to_nat x0) - 0 - (2 # x0)))). - destruct (Qarchimedean (/ (yn (Pos.to_nat x1) - 0 - (2 # x1)))). + destruct x as [xn limx], y as [yn limy]; simpl in H, H1, H2, H0. + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + destruct (Qarchimedean (/ (xn x0 - 0 - (2 # x0)))). + destruct (Qarchimedean (/ (yn x1 - 0 - (2 # x1)))). exists (Pos.max x0 x~0 * Pos.max x1 x2~0)%positive. - simpl. unfold Qminus. rewrite Qplus_0_r. - rewrite <- Pos2Nat.inj_mul. + simpl. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + unfold Qminus. rewrite Qplus_0_r. unfold Qminus in H1, H2. specialize (H1 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive). assert (Pos.max x1 x2~0 <= (Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive. - { apply Pos2Nat.inj_le. - rewrite Pos.mul_assoc. rewrite Pos2Nat.inj_mul. - rewrite <- (mult_1_l (Pos.to_nat (Pos.max x1 x2~0))). - rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. - rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. - apply le_refl. } + { rewrite Pos.mul_assoc. + rewrite <- (Pos.mul_1_l (Pos.max x1 x2~0)). + rewrite Pos.mul_assoc. apply Pos.mul_le_mono_r. discriminate. } specialize (H2 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive H3). rewrite Qplus_0_r in H1, H2. apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (2 # Pos.max x1 x2~0))). @@ -355,7 +372,7 @@ Proof. replace (Z.pos p~0) with (2 * Z.pos p)%Z. apply Z.mul_lt_mono_pos_r. apply Pos2Z.is_pos. reflexivity. reflexivity. apply H4. - apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (yn (Pos.to_nat ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0)))))). + apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (yn ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive))). apply Qmult_lt_l. reflexivity. apply H2. apply Qmult_lt_r. apply (Qlt_trans 0 (2 # Pos.max x1 x2~0)). reflexivity. apply H2. apply H1. rewrite Pos.mul_comm. apply Pos2Nat.inj_le. @@ -375,115 +392,136 @@ Proof. apply CReal_mult_unfold. apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n + proj1_sig (CReal_mult x z) n))%Q. - 2: apply QSeqEquivEx_sym; exists (fun p => Pos.to_nat (2 * p)) + 2: apply QSeqEquivEx_sym; exists (fun p:positive => 2 * p)%positive ; apply CReal_plus_unfold. apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * (proj1_sig y n + proj1_sig z n))%Q). - pose proof (CReal_plus_unfold y z). destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl; simpl in H. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - pose proof (CReal_mult_cauchy (fun n => yn (n + (n + 0))%nat + zn (n + (n + 0))%nat)%Q + pose proof (QCauchySeq_bounded_prop xn id) as majx. + pose proof (QCauchySeq_bounded_prop yn id) as majy. + pose proof (QCauchySeq_bounded_prop zn id) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + remember (QCauchySeq_bound zn id) as Az. + pose proof (CReal_mult_cauchy (fun n => yn (n~0)%positive + zn (n~0)%positive)%Q (fun n => yn n + zn n)%Q xn (Ay + Az) Ax - (fun p => Pos.to_nat (2 * p)) H limx). - exists (fun p : positive => (Pos.to_nat (2 * (2 * Pos.max (Ay + Az) Ax * p)))). + (fun p:positive => 2 * p)%positive H limx). + exists (fun p : positive => (2 * (2 * Pos.max (Ay + Az) Ax * p))%positive). intros p n k H1 H2. - setoid_replace (xn n * (yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) - xn k * (yn k + zn k))%Q - with ((yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) * xn n - (yn k + zn k) * xn k)%Q. + setoid_replace (xn n * (yn (n~0)%positive + zn (n~0)%positive) - xn k * (yn k + zn k))%Q + with ((yn (n~0)%positive + zn (n~0)%positive) * xn n - (yn k + zn k) * xn k)%Q. 2: ring. - assert (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p) <= - Pos.to_nat 2 * Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))%nat. - { rewrite (Pos2Nat.inj_mul 2). - rewrite <- (mult_1_l (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))). - rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. - simpl. auto. apply le_0_n. apply le_refl. } - apply H0. intro n0. apply (Qle_lt_trans _ (Qabs (yn n0) + Qabs (zn n0))). - apply Qabs_triangle. rewrite Pos2Z.inj_add. - rewrite <- Qinv_plus_distr. apply Qplus_lt_le_compat. - apply majy. apply Qlt_le_weak. apply majz. - apply majx. rewrite max_l. - apply H1. rewrite (Pos2Nat.inj_mul 2). apply H3. - rewrite max_l. apply H2. rewrite (Pos2Nat.inj_mul 2). - apply H3. + assert ((2 * Pos.max (Ay + Az) Ax * p) <= + 2 * (2 * Pos.max (Ay + Az) Ax * p))%positive. + { rewrite <- Pos.mul_assoc. + apply Pos.mul_le_mono_l. + apply (Pos.le_trans _ (1*(Pos.max (Ay + Az) Ax * p))). + apply Pos.le_refl. apply Pos.mul_le_mono_r. discriminate. } + apply H0. intros n0 H4. + apply (Qle_lt_trans _ _ _ (Qabs_triangle _ _)). + rewrite Pos2Z.inj_add, <- Qinv_plus_distr. apply Qplus_lt_le_compat. + apply majy. exact limy. + refine (Pos.le_trans _ _ _ _ H4); discriminate. + apply Qlt_le_weak. apply majz. exact limz. + refine (Pos.le_trans _ _ _ _ H4); discriminate. + apply majx. exact limx. refine (Pos.le_trans _ _ _ _ H1). + rewrite Pos.max_l. rewrite Pos.max_r. apply Pos.le_refl. + rewrite <- (Pos.mul_le_mono_l 2). + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max (Ay + Az) Ax * p)%positive; discriminate. + apply (Pos.le_trans _ (2 * (2 * Pos.max (Ay + Az) Ax * p))). + 2: apply Pos.le_max_r. + rewrite <- Pos.mul_assoc. rewrite (Pos.mul_assoc 2 2). + rewrite <- Pos.mul_le_mono_r. discriminate. + refine (Pos.le_trans _ _ _ _ H2). rewrite <- Pos.max_comm. + rewrite Pos.max_assoc. rewrite Pos.max_r. apply Pos.le_refl. + apply Pos.max_lub. apply H3. + rewrite <- Pos.mul_le_mono_l. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max (Ay + Az) Ax * p)%positive; discriminate. - destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - simpl. - exists (fun p : positive => (Pos.to_nat (2 * (Pos.max (Pos.max Ax Ay) Az) * (2 * p)))). + pose proof (QCauchySeq_bounded_prop xn id) as majx. + pose proof (QCauchySeq_bounded_prop yn id) as majy. + pose proof (QCauchySeq_bounded_prop zn id) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + remember (QCauchySeq_bound zn id) as Az. + exists (fun p : positive => (2 * (Pos.max (Pos.max Ax Ay) Az) * (2 * p))%positive). intros p n k H H0. setoid_replace (xn n * (yn n + zn n) - - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * - yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat + - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * - zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q - with (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * - yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat) - + (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * - zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q. + (xn ((Pos.max Ax Ay)~0 * k)%positive * + yn ((Pos.max Ax Ay)~0 * k)%positive + + xn ((Pos.max Ax Az)~0 * k)%positive * + zn ((Pos.max Ax Az)~0 * k)%positive))%Q + with (xn n * yn n - (xn ((Pos.max Ax Ay)~0 * k)%positive * + yn ((Pos.max Ax Ay)~0 * k)%positive) + + (xn n * zn n - xn ((Pos.max Ax Az)~0 * k)%positive * + zn ((Pos.max Ax Az)~0 * k)%positive))%Q. 2: ring. - apply (Qle_lt_trans _ (Qabs (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * - yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)) - + Qabs (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * - zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))). + apply (Qle_lt_trans _ (Qabs (xn n * yn n - (xn ((Pos.max Ax Ay)~0 * k)%positive * + yn ((Pos.max Ax Ay)~0 * k)%positive)) + + Qabs (xn n * zn n - xn ((Pos.max Ax Az)~0 * k)%positive * + zn ((Pos.max Ax Az)~0 * k)%positive))). apply Qabs_triangle. setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. apply Qplus_lt_le_compat. - + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy). - apply H1. apply majx. apply majy. rewrite max_l. - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H. apply le_refl. - rewrite max_l. apply (le_trans _ k). - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H0. - rewrite <- (mult_1_l k). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. - rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. - apply le_refl. apply le_refl. + + apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). + intros. apply majx. exact limx. + refine (Pos.le_trans _ _ _ _ H1). discriminate. + apply majy. exact limy. + rewrite <- Pos.max_assoc. + rewrite (Pos.max_l ((2 * Pos.max Ax Ay * (2 * p)))). + 2: apply Pos.le_refl. + refine (Pos.le_trans _ _ _ _ H). apply Pos.max_lub. + apply (Pos.le_trans _ (2*1)). + apply Pos.le_refl. rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max (Pos.max Ax Ay) Az * (2 * p))%positive; discriminate. + rewrite <- Pos.mul_assoc, <- Pos.mul_assoc. + rewrite <- Pos.mul_le_mono_l, <- Pos.mul_le_mono_r. + apply Pos.le_max_l. + rewrite <- Pos.max_assoc. + rewrite (Pos.max_l ((2 * Pos.max Ax Ay * (2 * p)))). + 2: apply Pos.le_refl. + rewrite Pos.max_r. apply (Pos.le_trans _ (1*k)). + rewrite Pos.mul_1_l. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.mul_assoc, <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + rewrite <- Pos.mul_le_mono_r. + apply Pos.le_max_l. apply Pos.mul_le_mono_r. discriminate. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max Ax Ay * (2 * p))%positive; discriminate. + apply Qlt_le_weak. - pose proof (CReal_mult_cauchy xn xn zn Ax Az Pos.to_nat limx limz). - apply H1. apply majx. apply majz. rewrite max_l. 2: apply le_refl. - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). - rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H. - rewrite max_l. apply (le_trans _ k). - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). - rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H0. - rewrite <- (mult_1_l k). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. - rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. - apply le_refl. apply le_refl. + apply (CReal_mult_cauchy xn xn zn Ax Az id limx limz). + intros. apply majx. exact limx. + refine (Pos.le_trans _ _ _ _ H1). discriminate. + intros. apply majz. exact limz. exact H1. + rewrite <- Pos.max_assoc. + rewrite (Pos.max_l ((2 * Pos.max Ax Az * (2 * p)))). + 2: apply Pos.le_refl. + refine (Pos.le_trans _ _ _ _ H). apply Pos.max_lub. + apply (Pos.le_trans _ (2*1)). + apply Pos.le_refl. rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max (Pos.max Ax Ay) Az * (2 * p))%positive; discriminate. + rewrite <- Pos.mul_assoc, <- Pos.mul_assoc. + rewrite <- Pos.mul_le_mono_l, <- Pos.mul_le_mono_r. + rewrite <- Pos.max_assoc, (Pos.max_comm Ay Az), Pos.max_assoc. + apply Pos.le_max_l. + rewrite <- Pos.max_assoc. + rewrite (Pos.max_l ((2 * Pos.max Ax Az * (2 * p)))). + 2: apply Pos.le_refl. + rewrite Pos.max_r. apply (Pos.le_trans _ (1*k)). + rewrite Pos.mul_1_l. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.mul_assoc, <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + rewrite <- Pos.mul_le_mono_r. + rewrite <- Pos.max_assoc, (Pos.max_comm Ay Az), Pos.max_assoc. + apply Pos.le_max_l. apply Pos.mul_le_mono_r. discriminate. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max Ax Az * (2 * p))%positive; discriminate. + rewrite Qinv_plus_distr. unfold Qeq. reflexivity. Qed. @@ -500,34 +538,38 @@ Lemma CReal_mult_1_l : forall r: CReal, 1 * r == r. Proof. intros [rn limr]. split. - intros [m maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). - destruct (QCauchySeq_bounded rn Pos.to_nat limr). - simpl in maj. rewrite Qmult_1_l in maj. + rewrite Qmult_1_l in maj. + pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) id (ConstCauchy 1)). + pose proof (QCauchySeq_bounded_prop rn id limr). + remember (QCauchySeq_bound (fun _ : positive => 1%Q) id) as x. + remember (QCauchySeq_bound rn id) as x0. specialize (limr m). apply (Qlt_not_le (2 # m) (1 # m)). - apply (Qlt_trans _ (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat)). + apply (Qlt_trans _ (rn m + - rn ((Pos.max x x0)~0 * m)%positive)). apply maj. - apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat))). - apply Qle_Qabs. apply limr. apply le_refl. - rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. - apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply (Qle_lt_trans _ (Qabs (rn m - rn ((Pos.max x x0)~0 * m)%positive))). + apply Qle_Qabs. apply limr. apply Pos.le_refl. + rewrite <- (Pos.mul_1_l m). rewrite Pos.mul_assoc. unfold id. + apply Pos.mul_le_mono_r. discriminate. apply Z.mul_le_mono_nonneg. discriminate. discriminate. discriminate. apply Z.le_refl. - intros [m maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). - destruct (QCauchySeq_bounded rn Pos.to_nat limr). + pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) id (ConstCauchy 1)). + pose proof (QCauchySeq_bounded_prop rn id limr). + remember (QCauchySeq_bound (fun _ : positive => 1%Q) id) as x. + remember (QCauchySeq_bound rn id) as x0. simpl in maj. rewrite Qmult_1_l in maj. specialize (limr m). apply (Qlt_not_le (2 # m) (1 # m)). - apply (Qlt_trans _ (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m))). + apply (Qlt_trans _ (rn ((Pos.max x x0)~0 * m)%positive - rn m)). apply maj. - apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m)))). + apply (Qle_lt_trans _ (Qabs (rn ((Pos.max x x0)~0 * m)%positive - rn m))). apply Qle_Qabs. apply limr. - rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. - apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. - apply le_refl. apply Z.mul_le_mono_nonneg. discriminate. discriminate. + rewrite <- (Pos.mul_1_l m). rewrite Pos.mul_assoc. unfold id. + apply Pos.mul_le_mono_r. discriminate. + apply Pos.le_refl. + apply Z.mul_le_mono_nonneg. discriminate. discriminate. discriminate. apply Z.le_refl. Qed. @@ -684,11 +726,11 @@ Proof. Qed. Lemma CReal_abs_appart_zero : forall (x : CReal) (n : positive), - Qlt (2#n) (Qabs (proj1_sig x (Pos.to_nat n))) + Qlt (2#n) (Qabs (proj1_sig x n)) -> 0 # x. Proof. intros. destruct x as [xn xcau]. simpl in H. - destruct (Qlt_le_dec 0 (xn (Pos.to_nat n))). + destruct (Qlt_le_dec 0 (xn n)). - left. exists n; simpl. rewrite Qabs_pos in H. ring_simplify. exact H. apply Qlt_le_weak. exact q. - right. exists n; simpl. rewrite Qabs_neg in H. @@ -705,39 +747,40 @@ Lemma CRealArchimedean Proof. (* Locate x within 1/4 and pick the first integer above this interval. *) intros [xn limx]. - pose proof (Qlt_floor (xn 4%nat + (1#4))). unfold inject_Z in H. - pose proof (Qfloor_le (xn 4%nat + (1#4))). unfold inject_Z in H0. - remember (Qfloor (xn 4%nat + (1#4)))%Z as n. + pose proof (Qlt_floor (xn 4%positive + (1#4))). unfold inject_Z in H. + pose proof (Qfloor_le (xn 4%positive + (1#4))). unfold inject_Z in H0. + remember (Qfloor (xn 4%positive + (1#4)))%Z as n. exists (n+1)%Z. split. - - assert (Qlt 0 ((n + 1 # 1) - (xn 4%nat + (1 # 4)))) as epsPos. + - assert (Qlt 0 ((n + 1 # 1) - (xn 4%positive + (1 # 4)))) as epsPos. { unfold Qminus. rewrite <- Qlt_minus_iff. exact H. } - destruct (Qarchimedean (/((1#2)*((n + 1 # 1) - (xn 4%nat + (1 # 4)))))) as [k kmaj]. + destruct (Qarchimedean (/((1#2)*((n + 1 # 1) - (xn 4%positive + (1 # 4)))))) as [k kmaj]. exists (Pos.max 4 k). simpl. - apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%nat + (1 # 4)))). + apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%positive + (1 # 4)))). + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. rewrite <- Qinv_lt_contravar in kmaj. 2: reflexivity. apply (Qle_lt_trans _ (2#k)). rewrite <- (Qmult_le_l _ _ (1#2)). setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. 2: reflexivity. - setoid_replace ((1 # 2) * (2 # Pos.max 4 k))%Q with (1#Pos.max 4 k)%Q. 2: reflexivity. + setoid_replace ((1 # 2) * (2 # Pos.max 4 k))%Q with (1#Pos.max 4 k)%Q. + 2: reflexivity. unfold Qle; simpl. apply Pos2Z.pos_le_pos. apply Pos.le_max_r. reflexivity. rewrite <- (Qmult_lt_l _ _ (1#2)). setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. exact kmaj. reflexivity. reflexivity. rewrite <- (Qmult_0_r (1#2)). rewrite Qmult_lt_l. exact epsPos. reflexivity. - + rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat (Pos.max 4 k)) - (n + 1 # 1) + (1#4))). + + rewrite <- (Qplus_lt_r _ _ (xn (Pos.max 4 k) - (n + 1 # 1) + (1#4))). ring_simplify. - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max 4 k)) - xn 4%nat))). + apply (Qle_lt_trans _ (Qabs (xn (Pos.max 4 k) - xn 4%positive))). apply Qle_Qabs. apply limx. - rewrite Pos2Nat.inj_max. apply Nat.le_max_l. apply le_refl. + apply Pos.le_max_l. apply Pos.le_refl. - apply (CReal_plus_lt_reg_l (-(2))). ring_simplify. exists 4%positive. simpl. rewrite <- Qinv_plus_distr. rewrite <- (Qplus_lt_r _ _ ((n#1) - (1#2))). ring_simplify. - apply (Qle_lt_trans _ (xn 4%nat + (1 # 4)) _ H0). + apply (Qle_lt_trans _ (xn 4%positive + (1 # 4)) _ H0). unfold Pos.to_nat; simpl. - rewrite <- (Qplus_lt_r _ _ (-xn 4%nat)). ring_simplify. + rewrite <- (Qplus_lt_r _ _ (-xn 4%positive)). ring_simplify. reflexivity. Defined. @@ -757,9 +800,10 @@ Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b + CRealLt c d. Proof. intros. + (* Convert to nat to use indefinite description. *) assert (exists n : nat, n <> O /\ - (Qlt (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n) - \/ Qlt (2 # Pos.of_nat n) (proj1_sig d n - proj1_sig c n))). + (Qlt (2 # Pos.of_nat n) (proj1_sig b (Pos.of_nat n) - proj1_sig a (Pos.of_nat n)) + \/ Qlt (2 # Pos.of_nat n) (proj1_sig d (Pos.of_nat n) - proj1_sig c (Pos.of_nat n)))). { destruct H. destruct H as [n maj]. exists (Pos.to_nat n). split. intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. inversion abs. left. rewrite Pos2Nat.id. apply maj. @@ -769,72 +813,73 @@ Proof. apply constructive_indefinite_ground_description_nat in H0. - destruct H0 as [n [nPos maj]]. destruct (Qlt_le_dec (2 # Pos.of_nat n) - (proj1_sig b n - proj1_sig a n)). - left. exists (Pos.of_nat n). rewrite Nat2Pos.id. apply q. apply nPos. - assert (2 # Pos.of_nat n < proj1_sig d n - proj1_sig c n)%Q. + (proj1_sig b (Pos.of_nat n) - proj1_sig a (Pos.of_nat n))). + left. exists (Pos.of_nat n). apply q. + assert (2 # Pos.of_nat n < proj1_sig d (Pos.of_nat n) - proj1_sig c (Pos.of_nat n))%Q. destruct maj. exfalso. - apply (Qlt_not_le (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n)); assumption. - assumption. clear maj. right. exists (Pos.of_nat n). rewrite Nat2Pos.id. - apply H0. apply nPos. + apply (Qlt_not_le (2 # Pos.of_nat n) (proj1_sig b (Pos.of_nat n) - proj1_sig a (Pos.of_nat n))); assumption. + assumption. clear maj. right. exists (Pos.of_nat n). + apply H0. - clear H0. clear H. intro n. destruct n. right. intros [abs _]. exact (abs (eq_refl O)). - destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig b (S n) - proj1_sig a (S n))). + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig b (Pos.of_nat (S n)) - proj1_sig a (Pos.of_nat (S n)))). left. split. discriminate. left. apply q. - destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig d (S n) - proj1_sig c (S n))). + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig d (Pos.of_nat (S n)) - proj1_sig c (Pos.of_nat (S n)))). left. split. discriminate. right. apply q0. right. intros [_ [abs|abs]]. apply (Qlt_not_le (2 # Pos.of_nat (S n)) - (proj1_sig b (S n) - proj1_sig a (S n))); assumption. + (proj1_sig b (Pos.of_nat (S n)) - proj1_sig a (Pos.of_nat (S n)))); assumption. apply (Qlt_not_le (2 # Pos.of_nat (S n)) - (proj1_sig d (S n) - proj1_sig c (S n))); assumption. + (proj1_sig d (Pos.of_nat (S n)) - proj1_sig c (Pos.of_nat (S n)))); assumption. Qed. -Lemma CRealShiftReal : forall (x : CReal) (k : nat), - QCauchySeq (fun n => proj1_sig x (plus n k)) Pos.to_nat. +Lemma CRealShiftReal : forall (x : CReal) (k : positive), + QCauchySeq (fun n => proj1_sig x (Pos.add n k)) id. Proof. - intros x k n p q H H0. + assert (forall p k : positive, (p <= p + k)%positive). + { intros. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_add. + apply (le_trans _ (Pos.to_nat p + 0)). + rewrite plus_0_r. apply le_refl. apply Nat.add_le_mono_l. + apply le_0_n. } + intros x k n p q H0 H1. destruct x as [xn cau]; unfold proj1_sig. - destruct k. rewrite plus_0_r. rewrite plus_0_r. apply cau; assumption. - specialize (cau (n + Pos.of_nat (S k))%positive (p + S k)%nat (q + S k)%nat). - apply (Qlt_trans _ (1 # n + Pos.of_nat (S k))). - apply cau. rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. - apply Nat.add_le_mono_r. apply H. discriminate. - rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. - apply Nat.add_le_mono_r. apply H0. discriminate. - apply Pos2Nat.inj_lt; simpl. rewrite Pos2Nat.inj_add. - rewrite <- (plus_0_r (Pos.to_nat n)). rewrite <- plus_assoc. - apply Nat.add_lt_mono_l. apply Pos2Nat.is_pos. + apply cau. apply (Pos.le_trans _ _ _ H0). apply H. + apply (Pos.le_trans _ _ _ H1). apply H. Qed. -Lemma CRealShiftEqual : forall (x : CReal) (k : nat), - CRealEq x (exist _ (fun n => proj1_sig x (plus n k)) (CRealShiftReal x k)). +Lemma CRealShiftEqual : forall (x : CReal) (k : positive), + CRealEq x (exist _ (fun n => proj1_sig x (Pos.add n k)) (CRealShiftReal x k)). Proof. intros. split. - intros [n maj]. destruct x as [xn cau]; simpl in maj. - specialize (cau n (Pos.to_nat n + k)%nat (Pos.to_nat n)). + specialize (cau n (n + k)%positive n). apply Qlt_not_le in maj. apply maj. clear maj. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat n + k)%nat - xn (Pos.to_nat n)))). + apply (Qle_trans _ (Qabs (xn (n + k)%positive - xn n))). apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. - apply cau. rewrite <- (plus_0_r (Pos.to_nat n)). - rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. - apply le_refl. apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. - discriminate. + apply cau. unfold id. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_add. + apply (le_trans _ (Pos.to_nat n + 0)). + rewrite plus_0_r. apply le_refl. apply Nat.add_le_mono_l. + apply le_0_n. apply Pos.le_refl. + apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. discriminate. - intros [n maj]. destruct x as [xn cau]; simpl in maj. - specialize (cau n (Pos.to_nat n) (Pos.to_nat n + k)%nat). + specialize (cau n n (n + k)%positive). apply Qlt_not_le in maj. apply maj. clear maj. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat n + k)%nat))). + apply (Qle_trans _ (Qabs (xn n - xn (n + k)%positive))). apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. - apply cau. apply le_refl. rewrite <- (plus_0_r (Pos.to_nat n)). - rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. + apply cau. apply Pos.le_refl. + apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_add. + apply (le_trans _ (Pos.to_nat n + 0)). + rewrite plus_0_r. apply le_refl. apply Nat.add_le_mono_l. + apply le_0_n. apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. discriminate. Qed. (* Find an equal negative real number, which rational sequence stays below 0, so that it can be inversed. *) Definition CRealNegShift (x : CReal) - : CRealLt x (inject_Q 0) - -> { y : prod positive CReal | CRealEq x (snd y) - /\ forall n:nat, Qlt (proj1_sig (snd y) n) (-1 # fst y) }. + : x < inject_Q 0 + -> { y : prod positive CReal + | x == (snd y) /\ forall n:positive, Qlt (proj1_sig (snd y) n) (-1 # fst y) }. Proof. intro xNeg. pose proof (CRealLt_aboveSig x (inject_Q 0)). @@ -842,36 +887,26 @@ Proof. pose proof (CRealShiftEqual x). destruct xNeg as [n maj], x as [xn cau]; simpl in maj. specialize (H n maj); simpl in H. - destruct (Qarchimedean (/ (0 - xn (Pos.to_nat n) - (2 # n)))) as [a _]. + destruct (Qarchimedean (/ (0 - xn n - (2 # n)))) as [a _]. remember (Pos.max n a~0) as k. clear Heqk. clear maj. clear n. - exists (pair k - (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + exists (pair k (exist _ (fun n => xn (Pos.add n k)) (H0 k))). split. apply H1. intro n. simpl. apply Qlt_minus_iff. - destruct n. - - specialize (H k). - unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. - unfold Qminus. rewrite Qplus_comm. - apply (Qlt_trans _ (- xn (Pos.to_nat k)%nat - (2 #k))). apply H. - unfold Qminus. simpl. apply Qplus_lt_r. - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. apply Pos.le_refl. - - apply (Qlt_trans _ (-(2 # k) - xn (S n + Pos.to_nat k)%nat)). - rewrite <- (Nat2Pos.id (S n)). rewrite <- Pos2Nat.inj_add. - specialize (H (Pos.of_nat (S n) + k)%positive). - unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. - unfold Qminus. rewrite Qplus_comm. apply H. apply Pos2Nat.inj_le. - rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. - apply Nat.add_le_mono_r. apply le_0_n. discriminate. - apply Qplus_lt_l. - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. + apply (Qlt_trans _ (-(2 # k) - xn (n + k)%positive)). + specialize (H (n + k)%positive). + unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. + unfold Qminus. rewrite Qplus_comm. apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. + apply Qplus_lt_l. + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. Qed. Definition CRealPosShift (x : CReal) : inject_Q 0 < x - -> { y : prod positive CReal | CRealEq x (snd y) - /\ forall n:nat, Qlt (1 # fst y) (proj1_sig (snd y) n) }. + -> { y : prod positive CReal + | x == (snd y) /\ forall n:positive, Qlt (1 # fst y) (proj1_sig (snd y) n) }. Proof. intro xPos. pose proof (CRealLt_aboveSig (inject_Q 0) x). @@ -879,66 +914,57 @@ Proof. pose proof (CRealShiftEqual x). destruct xPos as [n maj], x as [xn cau]; simpl in maj. simpl in H. specialize (H n). - destruct (Qarchimedean (/ (xn (Pos.to_nat n) - 0 - (2 # n)))) as [a _]. + destruct (Qarchimedean (/ (xn n - 0 - (2 # n)))) as [a _]. specialize (H maj); simpl in H. remember (Pos.max n a~0) as k. clear Heqk. clear maj. clear n. - exists (pair k - (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + exists (pair k (exist _ (fun n => xn (Pos.add n k)) (H0 k))). split. apply H1. intro n. simpl. apply Qlt_minus_iff. - destruct n. - - specialize (H k). - unfold Qminus in H. rewrite Qplus_0_r in H. - simpl. rewrite <- Qlt_minus_iff. - apply (Qlt_trans _ (2 #k)). - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. apply H. apply Pos.le_refl. - - rewrite <- Qlt_minus_iff. apply (Qlt_trans _ (2 # k)). - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. specialize (H (Pos.of_nat (S n) + k)%positive). - unfold Qminus in H. rewrite Qplus_0_r in H. - rewrite Pos2Nat.inj_add in H. rewrite Nat2Pos.id in H. - apply H. apply Pos2Nat.inj_le. - rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. - apply Nat.add_le_mono_r. apply le_0_n. discriminate. + rewrite <- Qlt_minus_iff. apply (Qlt_trans _ (2 # k)). + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. specialize (H (n + k)%positive). + unfold Qminus in H. rewrite Qplus_0_r in H. + apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. Qed. -Lemma CReal_inv_neg : forall (yn : nat -> Q) (k : positive), - (QCauchySeq yn Pos.to_nat) - -> (forall n : nat, yn n < -1 # k)%Q - -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Lemma CReal_inv_neg : forall (yn : positive -> Q) (k : positive), + (QCauchySeq yn id) + -> (forall n : positive, yn n < -1 # k)%Q + -> QCauchySeq (fun n : positive => / yn (k ^ 2 * n)%positive) id. Proof. (* Prove the inverse sequence is Cauchy *) intros yn k cau maj n p q H0 H1. - setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - - / yn (Pos.to_nat k ^ 2 * q)%nat)%Q - with ((yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) - / (yn (Pos.to_nat k ^ 2 * q)%nat * - yn (Pos.to_nat k ^ 2 * p)%nat)). - + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) + setoid_replace (/ yn (k ^ 2 * p)%positive - + / yn (k ^ 2 * q)%positive)%Q + with ((yn (k ^ 2 * q)%positive - + yn (k ^ 2 * p)%positive) + / (yn (k ^ 2 * q)%positive * + yn (k ^ 2 * p)%positive)). + + apply (Qle_lt_trans _ (Qabs (yn (k ^ 2 * q)%positive + - yn (k ^ 2 * p)%positive) / (1 # (k^2)))). assert (1 # k ^ 2 - < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + < Qabs (yn (k ^ 2 * q)%positive * yn (k ^ 2 * p)%positive))%Q. { rewrite Qabs_Qmult. unfold "^"%positive; simpl. rewrite factorDenom. rewrite Pos.mul_1_r. - apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply (Qlt_trans _ ((1#k) * Qabs (yn (k * (k * 1) * p)%positive))). apply Qmult_lt_l. reflexivity. rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + specialize (maj (k * (k * 1) * p)%positive). apply Qlt_minus_iff in maj. apply Qlt_minus_iff. rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. - apply maj. discriminate. + apply maj. discriminate. rewrite Pos.mul_1_r. apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + specialize (maj (k * k * p)%positive). apply Qlt_minus_iff in maj. apply Qlt_minus_iff. - rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. - reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. + apply maj. reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. apply maj. discriminate. rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + specialize (maj (k * k * q)%positive). apply Qlt_minus_iff in maj. apply Qlt_minus_iff. rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. @@ -952,66 +978,56 @@ Proof. reflexivity. rewrite Qmult_1_l. apply H. apply Qabs_nonneg. simpl in maj. specialize (cau (n * (k^2))%positive - (Pos.to_nat k ^ 2 * q)%nat - (Pos.to_nat k ^ 2 * p)%nat). + (k ^ 2 * q)%positive + (k ^ 2 * p)%positive). apply Qlt_shift_div_r. reflexivity. apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. + rewrite Pos.mul_comm. + unfold "^"%positive. simpl. + unfold id. rewrite Pos.mul_1_r. + rewrite <- Pos.mul_le_mono_l. exact H1. + unfold id. rewrite Pos.mul_comm. + apply Pos.mul_le_mono_l. exact H0. rewrite factorDenom. apply Qle_refl. + field. split. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + specialize (maj (k ^ 2 * p)%positive). rewrite abs in maj. inversion maj. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + specialize (maj (k ^ 2 * q)%positive). rewrite abs in maj. inversion maj. Qed. -Lemma CReal_inv_pos : forall (yn : nat -> Q) (k : positive), - (QCauchySeq yn Pos.to_nat) - -> (forall n : nat, 1 # k < yn n)%Q - -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Lemma CReal_inv_pos : forall (yn : positive -> Q) (k : positive), + (QCauchySeq yn id) + -> (forall n : positive, 1 # k < yn n)%Q + -> QCauchySeq (fun n : positive => / yn (k ^ 2 * n)%positive) id. Proof. intros yn k cau maj n p q H0 H1. - setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - - / yn (Pos.to_nat k ^ 2 * q)%nat)%Q - with ((yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) - / (yn (Pos.to_nat k ^ 2 * q)%nat * - yn (Pos.to_nat k ^ 2 * p)%nat)). - + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) + setoid_replace (/ yn (k ^ 2 * p)%positive - + / yn (k ^ 2 * q)%positive)%Q + with ((yn (k ^ 2 * q)%positive - + yn (k ^ 2 * p)%positive) + / (yn (k ^ 2 * q)%positive * + yn (k ^ 2 * p)%positive)). + + apply (Qle_lt_trans _ (Qabs (yn (k ^ 2 * q)%positive + - yn (k ^ 2 * p)%positive) / (1 # (k^2)))). assert (1 # k ^ 2 - < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + < Qabs (yn (k ^ 2 * q)%positive * yn (k ^ 2 * p)%positive))%Q. { rewrite Qabs_Qmult. unfold "^"%positive; simpl. rewrite factorDenom. rewrite Pos.mul_1_r. - apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply (Qlt_trans _ ((1#k) * Qabs (yn (k * k * p)%positive))). apply Qmult_lt_l. reflexivity. rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + specialize (maj (k * k * p)%positive). apply maj. apply (Qle_trans _ (1 # k)). discriminate. apply Zlt_le_weak. apply maj. apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + specialize (maj (k * k * p)%positive). apply maj. apply (Qle_trans _ (1 # k)). discriminate. apply Zlt_le_weak. apply maj. rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + specialize (maj (k * k * q)%positive). apply maj. apply (Qle_trans _ (1 # k)). discriminate. apply Zlt_le_weak. apply maj. } unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. @@ -1023,32 +1039,20 @@ Proof. reflexivity. rewrite Qmult_1_l. apply H. apply Qabs_nonneg. simpl in maj. specialize (cau (n * (k^2))%positive - (Pos.to_nat k ^ 2 * q)%nat - (Pos.to_nat k ^ 2 * p)%nat). + (k ^ 2 * q)%positive + (k ^ 2 * p)%positive). apply Qlt_shift_div_r. reflexivity. apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. + rewrite Pos.mul_comm. unfold id. + apply Pos.mul_le_mono_l. exact H1. + unfold id. rewrite Pos.mul_comm. + apply Pos.mul_le_mono_l. exact H0. rewrite factorDenom. apply Qle_refl. + field. split. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + specialize (maj (k ^ 2 * p)%positive). rewrite abs in maj. inversion maj. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + specialize (maj (k ^ 2 * q)%positive). rewrite abs in maj. inversion maj. Qed. @@ -1057,11 +1061,11 @@ Proof. destruct xnz as [xNeg | xPos]. - destruct (CRealNegShift x xNeg) as [[k y] [_ maj]]. destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. - exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + exists (fun n:positive => Qinv (yn (Pos.mul (k^2) n)%positive)). apply (CReal_inv_neg yn). apply cau. apply maj. - destruct (CRealPosShift x xPos) as [[k y] [_ maj]]. destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. - exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + exists (fun n => Qinv (yn (Pos.mul (k^2) n))). apply (CReal_inv_pos yn). apply cau. apply maj. Defined. @@ -1077,19 +1081,20 @@ Proof. - destruct (CRealPosShift r c) as [[k rpos] [req maj]]. clear req. destruct rpos as [rn cau]; simpl in maj. unfold CRealLt; simpl. - destruct (Qarchimedean (rn 1%nat)) as [A majA]. + destruct (Qarchimedean (rn 1%positive)) as [A majA]. exists (2 * (A + 1))%positive. unfold Qminus. rewrite Qplus_0_r. - rewrite <- (Qmult_1_l (Qinv (rn (Pos.to_nat k * (Pos.to_nat k * 1) * Pos.to_nat (2 * (A + 1)))%nat))). + rewrite <- (Qmult_1_l (Qinv (rn (k * (k * 1) * (2 * (A + 1)))%positive))). apply Qlt_shift_div_l. apply (Qlt_trans 0 (1#k)). reflexivity. apply maj. rewrite <- (Qmult_inv_r (Z.pos A + 1 # 1)). setoid_replace (2 # 2 * (A + 1))%Q with (Qinv (Z.pos A + 1 # 1)). 2: reflexivity. rewrite Qmult_comm. apply Qmult_lt_r. reflexivity. - rewrite mult_1_r. rewrite <- Pos2Nat.inj_mul. rewrite <- Pos2Nat.inj_mul. - rewrite <- (Qplus_lt_l _ _ (- rn 1%nat)). - apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (k * k * (2 * (A + 1)))) + - rn 1%nat))). + rewrite Pos.mul_1_r. + rewrite <- (Qplus_lt_l _ _ (- rn 1%positive)). + apply (Qle_lt_trans _ (Qabs (rn (k * k * (2 * (A + 1)))%positive + - rn 1%positive))). apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau. - apply Pos2Nat.is_pos. apply le_refl. + destruct (k * k * (2 * (A + 1)))%positive; discriminate. + apply Pos.le_refl. rewrite <- Qinv_plus_distr. rewrite <- (Qplus_comm 1). rewrite <- Qplus_0_r. rewrite <- Qplus_assoc. rewrite <- Qplus_assoc. rewrite Qplus_le_r. rewrite Qplus_0_l. apply Qlt_le_weak. @@ -1097,32 +1102,30 @@ Proof. intro abs. inversion abs. Qed. -Lemma CReal_linear_shift : forall (x : CReal) (k : nat), - le 1 k -> QCauchySeq (fun n => proj1_sig x (k * n)%nat) Pos.to_nat. -Proof. - intros [xn limx] k lek p n m H H0. unfold proj1_sig. - apply limx. apply (le_trans _ n). apply H. - rewrite <- (mult_1_l n). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg_r. apply le_0_n. - rewrite mult_1_r. apply lek. apply (le_trans _ m). apply H0. - rewrite <- (mult_1_l m). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg_r. apply le_0_n. - rewrite mult_1_r. apply lek. +Lemma CReal_linear_shift : forall (x : CReal) (k : positive), + QCauchySeq (fun n => proj1_sig x (k * n)%positive) id. +Proof. + intros [xn limx] k p n m H H0. unfold proj1_sig. + apply limx. apply (Pos.le_trans _ n). apply H. + rewrite <- (Pos.mul_1_l n). rewrite Pos.mul_assoc. + apply Pos.mul_le_mono_r. destruct (k*1)%positive; discriminate. + apply (Pos.le_trans _ (1*m)). exact H0. + apply Pos.mul_le_mono_r. destruct k; discriminate. Qed. -Lemma CReal_linear_shift_eq : forall (x : CReal) (k : nat) (kPos : le 1 k), +Lemma CReal_linear_shift_eq : forall (x : CReal) (k : positive), CRealEq x - (exist (fun n : nat -> Q => QCauchySeq n Pos.to_nat) - (fun n : nat => proj1_sig x (k * n)%nat) (CReal_linear_shift x k kPos)). + (exist (fun n : positive -> Q => QCauchySeq n id) + (fun n : positive => proj1_sig x (k * n)%positive) (CReal_linear_shift x k)). Proof. intros. apply CRealEq_diff. intro n. destruct x as [xn limx]; unfold proj1_sig. - specialize (limx n (Pos.to_nat n) (k * Pos.to_nat n)%nat). + specialize (limx n n (k * n)%positive). apply (Qle_trans _ (1 # n)). apply Qlt_le_weak. apply limx. - apply le_refl. rewrite <- (mult_1_l (Pos.to_nat n)). - rewrite mult_assoc. apply Nat.mul_le_mono_nonneg_r. apply le_0_n. - rewrite mult_1_r. apply kPos. apply Z.mul_le_mono_nonneg_r. - discriminate. discriminate. + apply Pos.le_refl. rewrite <- (Pos.mul_1_l n). + rewrite Pos.mul_assoc. apply Pos.mul_le_mono_r. + destruct (k*1)%positive; discriminate. + apply Z.mul_le_mono_nonneg_r. discriminate. discriminate. Qed. Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), @@ -1135,51 +1138,55 @@ Proof. apply (QSeqEquivEx_trans _ (proj1_sig (CReal_mult ((let (yn, cau) as s - return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in - fun maj0 : forall n : nat, yn n < -1 # k => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n))%nat) + return ((forall n : positive, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : positive, yn n < -1 # k => + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => Qinv (yn (k * (k * 1) * n))%positive) (CReal_inv_neg yn k cau maj0)) maj) rneg)))%Q. + apply CRealEq_modindep. apply CRealEq_diff. apply CReal_mult_proper_l. apply req. - + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. - rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. - apply (QSeqEquivEx_trans _ + + apply (QSeqEquivEx_trans _ (proj1_sig (CReal_mult ((let (yn, cau) as s - return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in - fun maj0 : forall n : nat, yn n < -1 # k => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + return ((forall n : positive, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : positive, yn n < -1 # k => + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => Qinv (yn (k * (k * 1) * n)%positive)) (CReal_inv_neg yn k cau maj0)) maj) - (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + (exist _ (fun n => proj1_sig rneg (k * (k * 1) * n)%positive) (CReal_linear_shift rneg _)))))%Q. apply CRealEq_modindep. apply CRealEq_diff. apply CReal_mult_proper_l. apply CReal_linear_shift_eq. destruct r as [rn limr], rneg as [rnn limneg]; simpl. - destruct (QCauchySeq_bounded - (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) - Pos.to_nat (CReal_inv_neg rnn k limneg maj)). - destruct (QCauchySeq_bounded - (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) - Pos.to_nat + pose proof (QCauchySeq_bounded_prop + (fun n : positive => Qinv (rnn (k * (k * 1) * n)%positive)) + id (CReal_inv_neg rnn k limneg maj)). + pose proof (QCauchySeq_bounded_prop + (fun n : positive => rnn (k * (k * 1) * n)%positive) + id (CReal_linear_shift - (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) - (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. - exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + (exist (fun x0 : positive -> Q => QCauchySeq x0 id) rnn limneg) + (k * (k * 1)))) ; simpl. + remember (QCauchySeq_bound + (fun n0 : positive => / rnn (k * (k * 1) * n0)%positive)%Q + id) as x. + remember (QCauchySeq_bound + (fun n0 : positive => rnn (k * (k * 1) * n0)%positive) + id) as x0. + exists (fun n => 1%positive). intros p n m H2 H3. rewrite Qmult_comm. rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. reflexivity. intro abs. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) - * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). - simpl in maj. rewrite abs in maj. inversion maj. + unfold snd,fst, proj1_sig in maj. + specialize (maj (k * (k * 1) * (Pos.max x x0 * n)~0)%positive). + rewrite abs in maj. inversion maj. - (* r > 0 *) destruct (CRealPosShift r c) as [[k rneg] [req maj]]. simpl in req. apply CRealEq_diff. apply CRealEq_modindep. apply (QSeqEquivEx_trans _ (proj1_sig (CReal_mult ((let (yn, cau) as s - return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in - fun maj0 : forall n : nat, 1 # k < yn n => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + return ((forall n : positive, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : positive, 1 # k < yn n => + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => Qinv (yn (k * (k * 1) * n)%positive)) (CReal_inv_pos yn k cau maj0)) maj) rneg)))%Q. + apply CRealEq_modindep. apply CRealEq_diff. apply CReal_mult_proper_l. apply req. @@ -1188,29 +1195,34 @@ Proof. apply (QSeqEquivEx_trans _ (proj1_sig (CReal_mult ((let (yn, cau) as s - return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in - fun maj0 : forall n : nat, 1 # k < yn n => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + return ((forall n : positive, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : positive, 1 # k < yn n => + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => Qinv (yn (k * (k * 1) * n)%positive)) (CReal_inv_pos yn k cau maj0)) maj) - (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + (exist _ (fun n => proj1_sig rneg (k * (k * 1) * n)%positive) (CReal_linear_shift rneg _)))))%Q. apply CRealEq_modindep. apply CRealEq_diff. apply CReal_mult_proper_l. apply CReal_linear_shift_eq. destruct r as [rn limr], rneg as [rnn limneg]; simpl. - destruct (QCauchySeq_bounded - (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) - Pos.to_nat (CReal_inv_pos rnn k limneg maj)). - destruct (QCauchySeq_bounded - (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) - Pos.to_nat + pose proof (QCauchySeq_bounded_prop + (fun n : positive => Qinv (rnn (k * (k * 1) * n)%positive)) + id (CReal_inv_pos rnn k limneg maj)). + pose proof (QCauchySeq_bounded_prop + (fun n : positive => rnn (k * (k * 1) * n)%positive) + id (CReal_linear_shift - (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) - (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. - exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + (exist (fun x0 : positive -> Q => QCauchySeq x0 id) rnn limneg) + (k * (k * 1)))) ; simpl. + remember (QCauchySeq_bound + (fun n0 : positive => / rnn (k * (k * 1) * n0)%positive) + id)%Q as x. + remember (QCauchySeq_bound + (fun n0 : positive => rnn (k * (k * 1) * n0)%positive) + id) as x0. + exists (fun n => 1%positive). intros p n m H2 H3. rewrite Qmult_comm. rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. reflexivity. intro abs. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) - * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). + specialize (maj ((k * (k * 1) * (Pos.max x x0 * n)~0)%positive)). simpl in maj. rewrite abs in maj. inversion maj. Qed. @@ -1293,12 +1305,13 @@ Proof. apply CRealLt_above in c. destruct c as [i imaj]. simpl in imaj. apply CRealLt_above in c0. destruct c0 as [j jmaj]. simpl in jmaj. pose proof (CReal_abs_appart_zero y). - destruct x as [xn xcau], y as [yn ycau]. simpl in kmaj. - destruct (QCauchySeq_bounded xn Pos.to_nat xcau) as [a amaj], - (QCauchySeq_bounded yn Pos.to_nat ycau) as [b bmaj]; simpl in kmaj. - clear amaj bmaj. simpl in imaj, jmaj. simpl in H0. + destruct x as [xn xcau], y as [yn ycau]. + unfold CReal_mult, proj1_sig in kmaj. + remember (QCauchySeq_bound xn id) as a. + remember (QCauchySeq_bound yn id) as b. + simpl in imaj, jmaj. simpl in H0. specialize (kmaj (Pos.max k (Pos.max i j)) (Pos.le_max_l _ _)). - destruct (H0 ((Pos.max a b)~0 * (Pos.max k (Pos.max i j)))%positive). + destruct (H0 (2*(Pos.max a b) * (Pos.max k (Pos.max i j)))%positive). - apply (Qlt_trans _ (2#k)). + unfold Qlt. rewrite <- Z.mul_lt_mono_pos_l. 2: reflexivity. unfold Qden. apply Pos2Z.pos_lt_pos. @@ -1309,11 +1322,8 @@ Proof. fold (2*Pos.max a b)%positive. rewrite Pos2Nat.inj_mul. apply Nat.lt_1_mul_pos. auto. apply Pos2Nat.is_pos. + apply (Qlt_le_trans _ _ _ kmaj). unfold Qminus. rewrite Qplus_0_r. - rewrite <- (Qmult_1_l (Qabs (yn (Pos.to_nat ((Pos.max a b)~0 * Pos.max k (Pos.max i j)))))). + rewrite <- (Qmult_1_l (Qabs (yn (2*(Pos.max a b) * Pos.max k (Pos.max i j))%positive))). apply (Qle_trans _ _ _ (Qle_Qabs _)). rewrite Qabs_Qmult. - replace (Pos.to_nat (Pos.max a b)~0 * Pos.to_nat (Pos.max k (Pos.max i j)))%nat - with (Pos.to_nat ((Pos.max a b)~0 * Pos.max k (Pos.max i j))). - 2: apply Pos2Nat.inj_mul. apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply Qabs_Qle_condition. split. apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#j)). @@ -1322,18 +1332,14 @@ Proof. rewrite Pos.mul_1_l. apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_r _ _)). apply Pos.le_max_r. - apply Pos2Nat.inj_le. do 2 rewrite Pos2Nat.inj_mul. - rewrite <- Nat.mul_le_mono_pos_r. 2: apply Pos2Nat.is_pos. - apply Pos2Nat.is_pos. + rewrite <- Pos.mul_le_mono_r. discriminate. apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#i)). reflexivity. apply imaj. apply (Pos.le_trans _ (1 * Pos.max k (Pos.max i j))). rewrite Pos.mul_1_l. apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_l _ _)). apply Pos.le_max_r. - apply Pos2Nat.inj_le. do 2 rewrite Pos2Nat.inj_mul. - rewrite <- Nat.mul_le_mono_pos_r. 2: apply Pos2Nat.is_pos. - apply Pos2Nat.is_pos. + rewrite <- Pos.mul_le_mono_r. discriminate. - left. apply (CReal_mult_lt_reg_r (exist _ yn ycau) _ _ c). rewrite CReal_mult_0_l. exact H. - right. apply (CReal_mult_lt_reg_r (CReal_opp (exist _ yn ycau))). @@ -1357,16 +1363,14 @@ Proof. Qed. Lemma CReal_invQ : forall (b : positive) (pos : Qlt 0 (Z.pos b # 1)), - CRealEq (CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos))) - (inject_Q (1 # b)). + CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos)) + == inject_Q (1 # b). Proof. intros. apply (CReal_mult_eq_reg_l (inject_Q (Z.pos b # 1))). - right. apply CReal_injectQPos. exact pos. - rewrite CReal_mult_comm, CReal_inv_l. - apply CRealEq_diff. intro n. simpl; - destruct (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))), - (QCauchySeq_bounded (fun _ : nat => Z.pos b # 1)%Q Pos.to_nat (ConstCauchy (Z.pos b # 1))); simpl. + apply CRealEq_diff. intro n. simpl. do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. discriminate. Qed. @@ -1376,11 +1380,11 @@ Proof. (* Locate a and b at the index given by a<b, and pick the middle rational number. *) intros [p pmaj]. - exists ((proj1_sig a (Pos.to_nat p) + proj1_sig b (Pos.to_nat p)) * (1#2))%Q. + exists ((proj1_sig a p + proj1_sig b p) * (1#2))%Q. split. - apply (CReal_le_lt_trans _ _ _ (inject_Q_compare a p)). apply inject_Q_lt. apply (Qmult_lt_l _ _ 2). reflexivity. - apply (Qplus_lt_l _ _ (-2*proj1_sig a (Pos.to_nat p))). + apply (Qplus_lt_l _ _ (-2*proj1_sig a p)). field_simplify. field_simplify in pmaj. setoid_replace (-2#2)%Q with (-1)%Q. 2: reflexivity. setoid_replace (2*(1#p))%Q with (2#p)%Q. 2: reflexivity. @@ -1388,12 +1392,12 @@ Proof. - apply (CReal_plus_lt_reg_l (-b)). rewrite CReal_plus_opp_l. apply (CReal_plus_lt_reg_r - (-inject_Q ((proj1_sig a (Pos.to_nat p) + proj1_sig b (Pos.to_nat p)) * (1 # 2)))). + (-inject_Q ((proj1_sig a p + proj1_sig b p) * (1 # 2)))). rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r, CReal_plus_0_l. rewrite <- opp_inject_Q. apply (CReal_le_lt_trans _ _ _ (inject_Q_compare (-b) p)). apply inject_Q_lt. apply (Qmult_lt_l _ _ 2). reflexivity. - apply (Qplus_lt_l _ _ (2*proj1_sig b (Pos.to_nat p))). + apply (Qplus_lt_l _ _ (2*proj1_sig b p)). destruct b as [bn bcau]; simpl. simpl in pmaj. field_simplify. field_simplify in pmaj. setoid_replace (-2#2)%Q with (-1)%Q. 2: reflexivity. @@ -1405,12 +1409,8 @@ Lemma inject_Q_mult : forall q r : Q, Proof. split. - intros [n maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => q) Pos.to_nat (ConstCauchy q)). - destruct (QCauchySeq_bounded (fun _ : nat => r) Pos.to_nat (ConstCauchy r)). simpl in maj. ring_simplify in maj. discriminate maj. - intros [n maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => q) Pos.to_nat (ConstCauchy q)). - destruct (QCauchySeq_bounded (fun _ : nat => r) Pos.to_nat (ConstCauchy r)). simpl in maj. ring_simplify in maj. discriminate maj. Qed. diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index 51fd0dd7f9..6f36e888ed 100644 --- a/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -47,44 +47,6 @@ Proof. intros. apply (seq_cv_proper un y). exact H0. symmetry. exact H. Qed. -Lemma growing_transit : forall un : nat -> CReal, - (forall n:nat, un n <= un (S n)) - -> forall n p : nat, le n p -> un n <= un p. -Proof. - induction p. - - intros. inversion H0. apply CRealLe_refl. - - intros. apply Nat.le_succ_r in H0. destruct H0. - apply (CReal_le_trans _ (un p)). apply IHp, H0. apply H. - subst n. apply CRealLe_refl. -Qed. - -Lemma growing_infinite : forall un : nat -> nat, - (forall n:nat, lt (un n) (un (S n))) - -> forall n : nat, le n (un n). -Proof. - induction n. - - apply le_0_n. - - specialize (H n). unfold lt in H. - apply (le_trans _ (S (un n))). apply le_n_S, IHn. exact H. -Qed. - -Lemma Un_cv_growing : forall (un : nat -> CReal) (l : CReal), - (forall n:nat, un n <= un (S n)) - -> (forall n:nat, un n <= l) - -> (forall p : positive, { n : nat | l - un n <= inject_Q (1#p) }) - -> seq_cv un l. -Proof. - intros. intro p. - specialize (H1 p) as [n nmaj]. exists n. - intros. rewrite CReal_abs_minus_sym, CReal_abs_right. - apply (CReal_le_trans _ (l - un n)). apply CReal_plus_le_compat_l. - apply CReal_opp_ge_le_contravar. - exact (growing_transit _ H n i H1). exact nmaj. - rewrite <- (CReal_plus_opp_r (un i)). apply CReal_plus_le_compat. - apply H0. apply CRealLe_refl. -Qed. - - (* Sharpen the archimedean property : constructive versions of the usual floor and ceiling functions. *) @@ -157,15 +119,6 @@ Proof. unfold Qeq; simpl. rewrite Pos.mul_1_r, Z.mul_1_r. reflexivity. Qed. -Definition RQ_limit : forall (x : CReal) (n:nat), - { q:Q & x < inject_Q q < x + inject_Q (1 # Pos.of_nat n) }. -Proof. - intros x n. apply (FQ_dense x (x + inject_Q (1 # Pos.of_nat n))). - rewrite <- (CReal_plus_0_r x). rewrite CReal_plus_assoc. - apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. apply inject_Q_lt. - reflexivity. -Qed. - Lemma Qabs_Rabs : forall q : Q, inject_Q (Qabs q) == CReal_abs (inject_Q q). Proof. @@ -176,173 +129,86 @@ Proof. apply inject_Q_le, H. Qed. -Definition Un_cauchy_Q (xn : nat -> Q) : Set - := forall n : positive, - { k : nat | forall p q : nat, le k p -> le k q - -> (Qabs (xn p - xn q) <= 1#n)%Q }. - -Lemma CReal_smaller_interval : forall a b c d : CReal, - a <= c -> c <= b - -> a <= d -> d <= b - -> CReal_abs (d - c) <= b-a. -Proof. - intros. apply CReal_abs_le. split. - - apply (CReal_plus_le_reg_l (b+c)). ring_simplify. - apply CReal_plus_le_compat; assumption. - - apply (CReal_plus_le_reg_l (a+c)). ring_simplify. - apply CReal_plus_le_compat; assumption. -Qed. - -Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), - Un_cauchy_mod xn - -> Un_cauchy_Q (fun n:nat => let (l,_) := RQ_limit (xn n) n in l). -Proof. - intros xn H p. specialize (H (2 * p)%positive) as [k cv]. - exists (max k (2 * Pos.to_nat p)). intros. - specialize (cv p0 q - (le_trans _ _ _ (Nat.le_max_l _ _) H) - (le_trans _ _ _ (Nat.le_max_l _ _) H0)). - destruct (RQ_limit (xn p0) p0) as [r rmaj]. - destruct (RQ_limit (xn q) q) as [s smaj]. - apply Qabs_Qle_condition. split. - - apply le_inject_Q. unfold Qminus. - apply (CReal_le_trans _ (xn p0 - (xn q + inject_Q (1 # 2 * p)))). - + unfold CReal_minus. rewrite CReal_opp_plus_distr. - rewrite <- CReal_plus_assoc. - apply (CReal_plus_le_reg_r (xn q - xn p0 - inject_Q (-(1#p)))). - ring_simplify. unfold CReal_minus. do 2 rewrite <- opp_inject_Q. - rewrite <- inject_Q_plus. - setoid_replace (- - (1 # p) + - (1 # 2 * p))%Q with (1 # 2 * p)%Q. - rewrite CReal_abs_minus_sym in cv. - exact (CReal_le_trans _ _ _ (CReal_le_abs _ ) cv). - rewrite Qopp_involutive. - setoid_replace (1#p)%Q with (2 # 2 *p)%Q. rewrite Qinv_minus_distr. - reflexivity. reflexivity. - + rewrite inject_Q_plus. apply CReal_plus_le_compat. - apply CRealLt_asym. - destruct (RQ_limit (xn p0) p0); simpl. apply rmaj. - apply CRealLt_asym. - rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. - destruct smaj. apply (CReal_lt_le_trans _ _ _ c0). - apply CReal_plus_le_compat_l. apply inject_Q_le. - apply Z2Nat.inj_le. discriminate. discriminate. - simpl. assert ((Pos.to_nat p~0 <= q)%nat). - { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). - 2: apply H0. replace (p~0)%positive with (2*p)%positive. - 2: reflexivity. rewrite Pos2Nat.inj_mul. - apply Nat.le_max_r. } - rewrite Nat2Pos.id. apply H1. intro abs. subst q. - inversion H1. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H3 in H2. inversion H2. - - apply le_inject_Q. unfold Qminus. - apply (CReal_le_trans _ (xn p0 + inject_Q (1 # 2 * p) - xn q)). - + rewrite inject_Q_plus. apply CReal_plus_le_compat. - apply CRealLt_asym. - destruct (RQ_limit (xn p0) p0); unfold proj1_sig. - apply (CReal_lt_le_trans _ (xn p0 + inject_Q (1 # Pos.of_nat p0))). - apply rmaj. apply CReal_plus_le_compat_l. apply inject_Q_le. - apply Z2Nat.inj_le. discriminate. discriminate. - simpl. assert ((Pos.to_nat p~0 <= p0)%nat). - { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). - 2: apply H. replace (p~0)%positive with (2*p)%positive. - 2: reflexivity. rewrite Pos2Nat.inj_mul. - apply Nat.le_max_r. } - rewrite Nat2Pos.id. apply H1. intro abs. subst p0. - inversion H1. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H3 in H2. inversion H2. - apply CRealLt_asym. - rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. - destruct (RQ_limit (xn q) q); simpl. apply smaj. - + unfold CReal_minus. rewrite (CReal_plus_comm (xn p0)). - rewrite CReal_plus_assoc. - apply (CReal_plus_le_reg_l (- inject_Q (1 # 2 * p))). - rewrite <- CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_l. - rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. - setoid_replace (- (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. - exact (CReal_le_trans _ _ _ (CReal_le_abs _) cv). - rewrite Qplus_comm. - setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. - reflexivity. reflexivity. -Qed. - -Lemma CReal_absSmall : forall (x y : CReal) (n : positive), - (Qlt (2 # n) - (proj1_sig x (Pos.to_nat n) - Qabs (proj1_sig y (Pos.to_nat n)))) - -> CReal_abs y <= x. -Proof. - intros x y n maj. apply CReal_abs_le. split. - - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. - simpl in maj. unfold Qminus. rewrite Qopp_involutive. - rewrite Qplus_comm. - apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). - apply maj. apply Qplus_le_r. - rewrite <- (Qopp_involutive (yn (Pos.to_nat n))). - apply Qopp_le_compat. rewrite Qabs_opp. apply Qle_Qabs. - - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. - simpl in maj. - apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). - apply maj. apply Qplus_le_r. apply Qopp_le_compat. apply Qle_Qabs. -Qed. - -(* An element of CReal is a Cauchy sequence of rational numbers, - show that it converges to itself in CReal. *) -Lemma CReal_cv_self : forall (qn : nat -> Q) (x : CReal) (cvmod : positive -> nat), - QSeqEquiv qn (fun n => proj1_sig x n) cvmod - -> seq_cv (fun n => inject_Q (qn n)) x. +(* For instance the rational sequence 1/n converges to 0. *) +Lemma CReal_cv_self : forall (x : CReal) (n : positive), + CReal_abs (x - inject_Q (proj1_sig x n)) <= inject_Q (1#n). Proof. - intros qn x cvmod H p. - specialize (H (2*p)%positive). exists (cvmod (2*p)%positive). - intros p0 H0. - apply (CReal_absSmall - _ _ (Pos.max (4 * p)%positive (Pos.of_nat (cvmod (2 * p)%positive)))). - setoid_replace (proj1_sig (inject_Q (1 # p)) (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))) - with (1 # p)%Q. - 2: reflexivity. - setoid_replace (proj1_sig (CReal_plus (inject_Q (qn p0)) (CReal_opp x)) (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))) - with (qn p0 - proj1_sig x (2 * (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive)))))%nat)%Q. - 2: destruct x; reflexivity. - apply (Qle_lt_trans _ (1 # 2 * p)). - unfold Qle; simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. - rewrite <- (Qplus_lt_r - _ _ (Qabs - (qn p0 - - proj1_sig x - (2 * Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))%nat) - -(1#2*p))). - ring_simplify. - setoid_replace (-1 * (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. - apply H. apply H0. rewrite Pos2Nat.inj_max. - apply (le_trans _ (1 * Nat.max (Pos.to_nat (4 * p)) (Pos.to_nat (Pos.of_nat (cvmod (2 * p)%positive))))). - destruct (cvmod (2*p)%positive). apply le_0_n. rewrite mult_1_l. - rewrite Nat2Pos.id. 2: discriminate. apply Nat.le_max_r. - apply Nat.mul_le_mono_nonneg_r. apply le_0_n. auto. - setoid_replace (1 # p)%Q with (2 # 2 * p)%Q. - rewrite Qplus_comm. rewrite Qinv_minus_distr. - reflexivity. reflexivity. + intros x n [k kmaj]. + destruct x as [xn cau]. + unfold CReal_abs, CReal_minus, CReal_plus, CReal_opp, inject_Q, proj1_sig in kmaj. + apply (Qlt_not_le _ _ kmaj). clear kmaj. + unfold QCauchySeq, QSeqEquiv in cau. + rewrite <- (Qplus_le_l _ _ (1#n)). ring_simplify. unfold id in cau. + destruct (Pos.lt_total (2*k) n). 2: destruct H. + - specialize (cau k (2*k)%positive n). + assert (k <= 2 * k)%positive. + { apply (Pos.le_trans _ (1*k)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. } + apply (Qle_trans _ (1#k)). apply Qlt_le_weak, cau. + exact H0. apply (Pos.le_trans _ _ _ H0). apply Pos.lt_le_incl, H. + rewrite <- (Qinv_plus_distr 1 1). + apply (Qplus_le_l _ _ (-(1#k))). ring_simplify. discriminate. + - subst n. rewrite Qplus_opp_r. discriminate. + - specialize (cau n (2*k)%positive n). + apply (Qle_trans _ (1#n)). apply Qlt_le_weak, cau. + apply Pos.lt_le_incl, H. apply Pos.le_refl. + apply (Qplus_le_l _ _ (-(1#n))). ring_simplify. discriminate. Qed. -(* Q is dense in Archimedean fields, so all real numbers - are limits of rational sequences. - The biggest computable such field has all rational limits. *) -Lemma R_has_all_rational_limits : forall qn : nat -> Q, - Un_cauchy_Q qn - -> { r : CReal & seq_cv (fun n:nat => inject_Q (qn n)) r }. +(* We can probably reduce the factor 4. *) +Lemma Rcauchy_limit : forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn), + QCauchySeq + (fun n : positive => + let (p, _) := xcau (4 * n)%positive in proj1_sig (xn p) (4 * n)%positive) id. Proof. - (* qn is an element of CReal. Show that inject_Q qn - converges to it in CReal. *) - intros. - destruct (standard_modulus qn (fun p => proj1_sig (H (Pos.succ p)))). - - intros p n k H0 H1. destruct (H (Pos.succ p)%positive) as [x a]; simpl in H0,H1. - specialize (a n k H0 H1). - apply (Qle_lt_trans _ (1#Pos.succ p) _ a). - apply Pos2Z.pos_lt_pos. simpl. apply Pos.lt_succ_diag_r. - - exists (exist _ (fun n : nat => - qn (increasing_modulus (fun p : positive => proj1_sig (H (Pos.succ p))) n)) H0). - apply (CReal_cv_self qn (exist _ (fun n : nat => - qn (increasing_modulus (fun p : positive => proj1_sig (H (Pos.succ p))) n)) H0) - (fun p : positive => Init.Nat.max (proj1_sig (H (Pos.succ p))) (Pos.to_nat p))). - apply H1. + intros xn xcau n p q H0 H1. + destruct (xcau (4 * p)%positive) as [i imaj], + (xcau (4 * q)%positive) as [j jmaj]. + assert (CReal_abs (xn i - xn j) <= inject_Q (1 # 4 * n)). + { destruct (le_lt_dec i j). + apply (CReal_le_trans _ _ _ (imaj i j (le_refl _) l)). + apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos.mul_le_mono_l, H0. apply le_S, le_S_n in l. + apply (CReal_le_trans _ _ _ (jmaj i j l (le_refl _))). + apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos.mul_le_mono_l, H1. } + clear jmaj imaj. + setoid_replace (1#n)%Q with ((1#(3*n)) + ((1#(3*n)) + (1#(3*n))))%Q. + 2: rewrite Qinv_plus_distr, Qinv_plus_distr; reflexivity. + apply lt_inject_Q. rewrite inject_Q_plus. + rewrite Qabs_Rabs. + apply (CReal_le_lt_trans _ (CReal_abs (inject_Q (proj1_sig (xn i) (4 * p)%positive) - xn i) + CReal_abs (xn i - inject_Q(proj1_sig (xn j) (4 * q)%positive)))). + unfold Qminus. + rewrite inject_Q_plus, opp_inject_Q. + setoid_replace (inject_Q (proj1_sig (xn i) (4 * p)%positive) + + - inject_Q (proj1_sig (xn j) (4 * q)%positive)) + with (inject_Q (proj1_sig (xn i) (4 * p)%positive) - xn i + + (xn i - inject_Q (proj1_sig (xn j) (4 * q)%positive))). + 2: ring. + apply CReal_abs_triang. apply CReal_plus_le_lt_compat. + rewrite CReal_abs_minus_sym. apply (CReal_le_trans _ (inject_Q (1# 4*p))). + apply CReal_cv_self. apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (4*n)). + apply Pos.mul_le_mono_r. discriminate. + apply Pos.mul_le_mono_l. exact H0. + apply (CReal_le_lt_trans + _ (CReal_abs (xn i - xn j + (xn j - inject_Q (proj1_sig (xn j) (4 * q)%positive))))). + apply CReal_abs_morph. ring. + apply (CReal_le_lt_trans _ _ _ (CReal_abs_triang _ _)). + rewrite inject_Q_plus. apply CReal_plus_le_lt_compat. + apply (CReal_le_trans _ _ _ H). apply inject_Q_le. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos. apply Pos.mul_le_mono_r. discriminate. + apply (CReal_le_lt_trans _ (inject_Q (1#4*q))). + apply CReal_cv_self. apply inject_Q_lt. unfold Qlt, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_lt_pos. apply (Pos.lt_le_trans _ (4*n)). + apply Pos.mul_lt_mono_r. reflexivity. + apply Pos.mul_le_mono_l. exact H1. Qed. Lemma Rcauchy_complete : forall (xn : nat -> CReal), @@ -350,49 +216,63 @@ Lemma Rcauchy_complete : forall (xn : nat -> CReal), -> { l : CReal & seq_cv xn l }. Proof. intros xn cau. - destruct (R_has_all_rational_limits (fun n => let (l,_) := RQ_limit (xn n) n in l) - (Rdiag_cauchy_sequence xn cau)) - as [l cv]. - exists l. intro p. specialize (cv (2*p)%positive) as [k cv]. - exists (max k (2 * Pos.to_nat p)). intros p0 H. - specialize (cv p0 (le_trans _ _ _ (Nat.le_max_l _ _) H)). - destruct (RQ_limit (xn p0) p0) as [q maj]. - apply CReal_abs_le. split. - - apply (CReal_le_trans _ (inject_Q q - inject_Q (1 # 2 * p) - l)). - + unfold CReal_minus. rewrite (CReal_plus_comm (inject_Q q)). - apply (CReal_plus_le_reg_r (inject_Q (1 # p) + l - inject_Q q)). - ring_simplify. unfold CReal_minus. - rewrite <- (opp_inject_Q (1# 2*p)), <- inject_Q_plus. - setoid_replace ((1 # p) + - (1 # 2* p))%Q with (1#2*p)%Q. - rewrite CReal_abs_minus_sym in cv. - exact (CReal_le_trans _ _ _ (CReal_le_abs _) cv). - setoid_replace (1#p)%Q with (2 # 2*p)%Q. - rewrite Qinv_minus_distr. reflexivity. reflexivity. - + unfold CReal_minus. - do 2 rewrite <- (CReal_plus_comm (-l)). apply CReal_plus_le_compat_l. - apply (CReal_plus_le_reg_r (inject_Q (1 # 2 * p))). - ring_simplify. rewrite CReal_plus_comm. - apply (CReal_le_trans _ (xn p0 + inject_Q (1 # Pos.of_nat p0))). - apply CRealLt_asym, maj. apply CReal_plus_le_compat_l. - apply inject_Q_le. - apply Z2Nat.inj_le. discriminate. discriminate. - simpl. assert ((Pos.to_nat p~0 <= p0)%nat). - { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). - 2: apply H. replace (p~0)%positive with (2*p)%positive. - 2: reflexivity. rewrite Pos2Nat.inj_mul. - apply Nat.le_max_r. } - rewrite Nat2Pos.id. apply H0. intro abs. subst p0. - inversion H0. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H2 in H1. inversion H1. - - apply (CReal_le_trans _ (inject_Q q - l)). - + unfold CReal_minus. do 2 rewrite <- (CReal_plus_comm (-l)). - apply CReal_plus_le_compat_l. apply CRealLt_asym, maj. - + apply (CReal_le_trans _ (inject_Q (1 # 2 * p))). - exact (CReal_le_trans _ _ _ (CReal_le_abs _) cv). - apply inject_Q_le. rewrite <- Qplus_0_r. - setoid_replace (1#p)%Q with ((1#2*p)+(1#2*p))%Q. - apply Qplus_le_r. discriminate. - rewrite Qinv_plus_distr. reflexivity. + exists (exist _ (fun n : positive => + let (p, _) := cau (4 * n)%positive in + proj1_sig (xn p) (4 * n)%positive) + (Rcauchy_limit xn cau)). + intro p. + pose proof (CReal_cv_self (exist _ (fun n : positive => + let (p, _) := cau (4 * n)%positive in + proj1_sig (xn p) (4 * n)%positive) + (Rcauchy_limit xn cau)) (2*p)) as H. + simpl (inject_Q + (proj1_sig + (exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => + let (p, _) := cau (4 * n)%positive in + proj1_sig (xn p) (4 * n)%positive) (Rcauchy_limit xn cau)) + (2 * p)%positive)) in H. + pose proof (cau (2*p)%positive) as [k cv]. + destruct (cau (p~0~0~0)%positive) as [i imaj]. + (* The convergence modulus does not matter here, because a converging Cauchy + sequence always converges to its limit with twice the Cauchy modulus. *) + exists (max k i). + intros j H0. + setoid_replace (xn j - + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => + let (p0, _) := cau (4 * n)%positive in proj1_sig (xn p0) (4 * n)%positive) + (Rcauchy_limit xn cau)) + with (xn j - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive) + + (inject_Q (proj1_sig (xn i) (p~0~0~0)%positive) - + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => + let (p0, _) := cau (4 * n)%positive in proj1_sig (xn p0) (4 * n)%positive) + (Rcauchy_limit xn cau))). + 2: ring. apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)). + apply (CReal_le_trans _ (inject_Q (1#2*p) + inject_Q (1#2*p))). + apply CReal_plus_le_compat. + 2: rewrite CReal_abs_minus_sym; exact H. + specialize (imaj j i (le_trans _ _ _ (Nat.le_max_r _ _) H0) (le_refl _)). + apply (CReal_le_trans _ (inject_Q (1 # 4 * p) + inject_Q (1 # 4 * p))). + setoid_replace (xn j - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive)) + with (xn j - xn i + + (xn i - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive))). + 2: ring. apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)). + apply CReal_plus_le_compat. apply (CReal_le_trans _ _ _ imaj). + apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos. + apply (Pos.mul_le_mono_r p 4 8). discriminate. + apply (CReal_le_trans _ _ _ (CReal_cv_self (xn i) (8*p))). + apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos. + apply (Pos.mul_le_mono_r p 4 8). discriminate. + rewrite <- inject_Q_plus. rewrite (inject_Q_morph _ (1#2*p)). + apply CRealLe_refl. rewrite Qinv_plus_distr; reflexivity. + rewrite <- inject_Q_plus. rewrite (inject_Q_morph _ (1#p)). + apply CRealLe_refl. rewrite Qinv_plus_distr; reflexivity. Qed. Lemma CRealLtIsLinear : isLinearOrder CRealLt. diff --git a/theories/Reals/ClassicalDedekindReals.v b/theories/Reals/ClassicalDedekindReals.v index bb1ee93610..21f3a9cfca 100644 --- a/theories/Reals/ClassicalDedekindReals.v +++ b/theories/Reals/ClassicalDedekindReals.v @@ -149,32 +149,31 @@ Definition DRealAbstr : CReal -> DReal. Proof. intro x. assert (forall (q : Q) (n : nat), - {(fun n0 : nat => (proj1_sig x (S n0) <= q + (1 # Pos.of_nat (S n0)))%Q) n} + - {~ (fun n0 : nat => (proj1_sig x (S n0) <= q + (1 # Pos.of_nat (S n0)))%Q) n}). - { intros. destruct (Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (proj1_sig x (S n))). + {(fun n0 : nat => (proj1_sig x (Pos.of_nat (S n0)) <= q + (1 # Pos.of_nat (S n0)))%Q) n} + + {~ (fun n0 : nat => (proj1_sig x (Pos.of_nat (S n0)) <= q + (1 # Pos.of_nat (S n0)))%Q) n}). + { intros. destruct (Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (proj1_sig x (Pos.of_nat (S n)))). right. apply (Qlt_not_le _ _ q0). left. exact q0. } - exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (proj1_sig x (S n)) (q + (1#Pos.of_nat (S n)))) (H q) + exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (proj1_sig x (Pos.of_nat (S n))) (q + (1#Pos.of_nat (S n)))) (H q) then true else false). repeat split. - intros. - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= q + (1 # Pos.of_nat (S n)))%Q) + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q) (H q)). reflexivity. exfalso. - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= r + (1 # Pos.of_nat (S n)))%Q) + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= r + (1 # Pos.of_nat (S n)))%Q) (H r)). destruct s. apply n. apply (Qle_trans _ _ _ (q0 x0)). apply Qplus_le_l. exact H0. discriminate. - intro abs. destruct (Rfloor x) as [z [_ zmaj]]. specialize (abs (z+3 # 1)%Q). - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= (z+3 # 1) + (1 # Pos.of_nat (S n)))%Q) + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= (z+3 # 1) + (1 # Pos.of_nat (S n)))%Q) (H (z+3 # 1)%Q)). 2: exfalso; discriminate. clear abs. destruct s as [n nmaj]. apply nmaj. rewrite <- (inject_Q_plus (z#1) 2) in zmaj. apply CRealLt_asym in zmaj. rewrite <- CRealLe_not_lt in zmaj. specialize (zmaj (Pos.of_nat (S n))). unfold inject_Q, proj1_sig in zmaj. - rewrite Nat2Pos.id in zmaj. 2: discriminate. destruct x as [xn xcau]; unfold proj1_sig. rewrite Qinv_plus_distr in zmaj. apply (Qplus_le_l _ _ (-(z + 2 # 1))). apply (Qle_trans _ _ _ zmaj). @@ -187,7 +186,7 @@ Proof. replace (z + 3 + - (z + 2))%Z with 1%Z. apply Qle_refl. ring. - intro abs. destruct (Rfloor x) as [z [zmaj _]]. specialize (abs (z-4 # 1)%Q). - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= (z-4 # 1) + (1 # Pos.of_nat (S n)))%Q) + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= (z-4 # 1) + (1 # Pos.of_nat (S n)))%Q) (H (z-4 # 1)%Q)). exfalso; discriminate. clear abs. apply CRealLt_asym in zmaj. apply zmaj. clear zmaj. @@ -195,30 +194,30 @@ Proof. specialize (q O). destruct x as [xn xcau]; unfold proj1_sig; unfold proj1_sig in q. unfold Pos.of_nat in q. rewrite Qinv_plus_distr in q. - unfold Pos.to_nat; simpl. apply (Qplus_lt_l _ _ (xn 1%nat - 2)). + apply (Qplus_lt_l _ _ (xn 1%positive - 2)). ring_simplify. rewrite Qinv_plus_distr. apply (Qle_lt_trans _ _ _ q). apply Qlt_minus_iff. unfold Qopp, Qnum, Qden. rewrite Qinv_plus_distr. replace (z + -2 + - (z - 4 + 1))%Z with 1%Z. 2: ring. reflexivity. - intros q H0 abs. - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= q + (1 # Pos.of_nat (S n)))%Q) (H q)). + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q) (H q)). 2: exfalso; discriminate. clear H0. destruct x as [xn xcau]; unfold proj1_sig in abs, s. destruct s as [n nmaj]. (* We have that q < x as real numbers. The middle (q + xSn - 1/Sn)/2 is also lower than x, witnessed by the same index n. *) - specialize (abs ((q + xn (S n) - (1 # Pos.of_nat (S n))%Q)/2)%Q). + specialize (abs ((q + xn (Pos.of_nat (S n)) - (1 # Pos.of_nat (S n))%Q)/2)%Q). destruct abs. + apply (Qmult_le_r _ _ 2) in H0. field_simplify in H0. apply (Qplus_le_r _ _ ((1 # Pos.of_nat (S n)) - q)) in H0. ring_simplify in H0. apply nmaj. rewrite Qplus_comm. exact H0. reflexivity. + destruct (sig_forall_dec (fun n0 : nat => - (xn (S n0) <= (q + xn (S n) - (1 # Pos.of_nat (S n))) / 2 + (1 # Pos.of_nat (S n0)))%Q) - (H ((q + xn (S n) - (1 # Pos.of_nat (S n))) / 2)%Q)). + (xn (Pos.of_nat (S n0)) <= (q + xn (Pos.of_nat (S n)) - (1 # Pos.of_nat (S n))) / 2 + (1 # Pos.of_nat (S n0)))%Q) + (H ((q + xn (Pos.of_nat (S n)) - (1 # Pos.of_nat (S n))) / 2)%Q)). discriminate. clear H0. specialize (q0 n). apply (Qmult_le_l _ _ 2) in q0. field_simplify in q0. - apply (Qplus_le_l _ _ (-xn (S n))) in q0. ring_simplify in q0. + apply (Qplus_le_l _ _ (-xn (Pos.of_nat (S n)))) in q0. ring_simplify in q0. contradiction. reflexivity. Defined. @@ -234,23 +233,24 @@ Qed. Definition DRealRepr : DReal -> CReal. Proof. - intro x. exists (fun n => proj1_sig (DRealQlim x n)). + intro x. exists (fun n:positive => proj1_sig (DRealQlim x (Pos.to_nat n))). intros n p q H H0. - destruct (DRealQlim x p), (DRealQlim x q); unfold proj1_sig. + destruct (DRealQlim x (Pos.to_nat p)), (DRealQlim x (Pos.to_nat q)) + ; unfold proj1_sig. destruct x as [f low]; unfold proj1_sig in a0, a. apply Qabs_case. - - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S q))). + - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S (Pos.to_nat q)))). apply (Qplus_lt_l _ _ x1). ring_simplify. apply (UpperAboveLower f). exact low. apply a. apply a0. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. - apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (le_trans _ _ _ H0), le_S, le_refl. - discriminate. - - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S p))). + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, Pos2Nat.inj_le, H0. discriminate. + - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S (Pos.to_nat p)))). apply (Qplus_lt_l _ _ x0). ring_simplify. apply (UpperAboveLower f). exact low. apply a0. apply a. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. - apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (le_trans _ _ _ H), le_S, le_refl. - discriminate. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, Pos2Nat.inj_le, H. discriminate. Defined. Definition Rle (x y : DReal) @@ -390,15 +390,15 @@ Qed. Lemma DRealAbstrFalse : forall (x : CReal) (q : Q) (n : nat), proj1_sig (DRealAbstr x) q = false - -> (proj1_sig x (S n) <= q + (1 # Pos.of_nat (S n)))%Q. + -> (proj1_sig x (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q. Proof. intros. destruct x as [xn xcau]. unfold DRealAbstr, proj1_sig in H. destruct ( - sig_forall_dec (fun n : nat => (xn (S n) <= q + (1 # Pos.of_nat (S n)))%Q) + sig_forall_dec (fun n : nat => (xn (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q) (fun n : nat => - match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (S n)) with - | left q0 => right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (S n)) q0) + match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) with + | left q0 => right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) q0) | right q0 => left q0 end)). discriminate. apply q0. @@ -417,9 +417,10 @@ Proof. unfold proj1_sig in qmaj. rewrite Nat.succ_pred in qmaj. apply (Qlt_not_le _ _ pmaj), (Qplus_le_l _ _ q). - ring_simplify. apply (Qle_trans _ _ _ qmaj). + ring_simplify. rewrite Pos2Nat.id in qmaj. + apply (Qle_trans _ _ _ qmaj). rewrite <- Qplus_assoc. apply Qplus_le_r. - rewrite Pos2Nat.id. apply (Qle_trans _ ((1#p)+(1#p))). + apply (Qle_trans _ ((1#p)+(1#p))). apply Qplus_le_l. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. @@ -434,30 +435,32 @@ Proof. (* By pmaj, x < q - 1/p *) unfold DRealAbstr, proj1_sig in qmaj. destruct ( - sig_forall_dec (fun n : nat => (xn (S n) <= q + (1 # Pos.of_nat (S n)))%Q) + sig_forall_dec (fun n : nat => (xn (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q) (fun n : nat => - match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (S n)) with + match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) with | left q0 => - right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (S n)) q0) + right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) q0) | right q0 => left q0 end)). 2: discriminate. clear qmaj. destruct s as [n nmaj]. apply nmaj. - apply (Qplus_lt_l _ _ (xn (Pos.to_nat p) + (1#Pos.of_nat (S n)))) in pmaj. + apply (Qplus_lt_l _ _ (xn p + (1#Pos.of_nat (S n)))) in pmaj. ring_simplify in pmaj. apply Qlt_le_weak. rewrite Qplus_comm. - apply (Qlt_trans _ ((2 # p) + xn (Pos.to_nat p) + (1 # Pos.of_nat (S n)))). + apply (Qlt_trans _ ((2 # p) + xn p + (1 # Pos.of_nat (S n)))). 2: exact pmaj. - apply (Qplus_lt_l _ _ (-xn (Pos.to_nat p))). + apply (Qplus_lt_l _ _ (-xn p)). apply (Qle_lt_trans _ _ _ (Qle_Qabs _)). destruct (le_lt_dec (S n) (Pos.to_nat p)). - + specialize (xcau (Pos.of_nat (S n)) (S n) (Pos.to_nat p)). + + specialize (xcau (Pos.of_nat (S n)) (Pos.of_nat (S n)) p). apply (Qlt_trans _ (1# Pos.of_nat (S n))). apply xcau. - rewrite Nat2Pos.id. apply le_refl. discriminate. + apply Pos.le_refl. unfold id. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. exact l. discriminate. apply (Qplus_lt_l _ _ (-(1#Pos.of_nat (S n)))). ring_simplify. reflexivity. + apply (Qlt_trans _ (1#p)). apply xcau. - apply le_S_n in l. apply le_S, l. apply le_refl. + apply le_S_n in l. unfold id. apply Pos2Nat.inj_le. + rewrite Nat2Pos.id. + apply le_S, l. discriminate. apply Pos.le_refl. ring_simplify. apply (Qlt_trans _ (2#p)). unfold Qlt, Qnum, Qden. apply Z.mul_lt_mono_pos_r. reflexivity. reflexivity. diff --git a/theories/Sorting/CPermutation.v b/theories/Sorting/CPermutation.v new file mode 100644 index 0000000000..fac9cd1d6d --- /dev/null +++ b/theories/Sorting/CPermutation.v @@ -0,0 +1,283 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * Circular Shifts (aka Cyclic Permutations) *) + +(** The main inductive [CPermutation] relates lists up to circular shifts of their elements. + +For example: [CPermutation [a1;a2;a3;a4;a5] [a4;a5;a1;a2;a3]] + +Note: Terminology does not seem to be strongly fixed in English. For the record, it is "permutations circulaires" in French. +*) + +Require Import List Permutation Morphisms PeanoNat. +Import ListNotations. (* For notations [] and [a;b;c] *) +Set Implicit Arguments. + +Section CPermutation. + +Variable A:Type. + +(** Definition *) + +Inductive CPermutation : list A -> list A -> Prop := +| cperm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). + +Instance CPermutation_Permutation : Proper (CPermutation ==> (@Permutation A)) id. +Proof. intros ? ? [? ?]; apply Permutation_app_comm. Qed. + +(** Some facts about [CPermutation] *) + +Theorem CPermutation_nil : forall l, CPermutation [] l -> l = []. +Proof. +intros l HC; inversion HC as [l1 l2 Heq]; subst. +now apply app_eq_nil in Heq; destruct Heq; subst. +Qed. + +Theorem CPermutation_nil_cons : forall l a, ~ CPermutation [] (a :: l). +Proof. intros l a HC; apply CPermutation_nil in HC; inversion HC. Qed. + +Theorem CPermutation_nil_app_cons : forall l1 l2 a, + ~ CPermutation [] (l1 ++ a ::l2). +Proof. +intros l1 l2 a HC; apply CPermutation_nil in HC; destruct l1; inversion HC. +Qed. + +Lemma CPermutation_split : forall l1 l2, + CPermutation l1 l2 <-> exists n, l2 = skipn n l1 ++ firstn n l1. +Proof. +intros l1 l2; split. +- intros [l1' l2']. + exists (length l1'). + rewrite skipn_app, skipn_all, Nat.sub_diag; simpl; f_equal. + now rewrite firstn_app, firstn_all, Nat.sub_diag; simpl; rewrite app_nil_r. +- now intros [n ->]; rewrite <- (firstn_skipn n) at 1. +Qed. + + +(** Equivalence relation *) + +Theorem CPermutation_refl : forall l, CPermutation l l. +Proof. +intros l; now rewrite <- (app_nil_l l) at 1; rewrite <- (app_nil_r l) at 2. +Qed. + +Instance CPermutation_refl' : Proper (Logic.eq ==> CPermutation) id. +Proof. intros ? ? ->; apply CPermutation_refl. Qed. + +Theorem CPermutation_sym : forall l l', CPermutation l l' -> CPermutation l' l. +Proof. now intros ? ? [? ?]. Qed. + +Theorem CPermutation_trans : forall l l' l'', + CPermutation l l' -> CPermutation l' l'' -> CPermutation l l''. +Proof. +intros l l' l'' HC1 HC2. +inversion HC1 as [l1 l2]; inversion HC2 as [l3 l4 Heq Heq']; subst. +clear - Heq; revert l1 l2 l4 Heq; clear; induction l3; simpl; intros. +- now subst; rewrite app_nil_r. +- destruct l2 as [| b]. + + simpl in Heq; subst. + now rewrite app_nil_r, app_comm_cons. + + inversion Heq as [[Heqb Heq']]; subst. + replace (l1 ++ b :: l2) with ((l1 ++ b :: nil) ++ l2) + by now rewrite <- app_assoc, <- app_comm_cons. + replace (l4 ++ b :: l3) with ((l4 ++ b :: nil) ++ l3) + by now rewrite <- app_assoc, <- app_comm_cons. + apply IHl3. + now rewrite 2 app_assoc, Heq'. +Qed. + +End CPermutation. + +Hint Resolve CPermutation_refl : core. + +(* These hints do not reduce the size of the problem to solve and they + must be used with care to avoid combinatoric explosions *) + +Local Hint Resolve cperm CPermutation_sym CPermutation_trans : core. + +Instance CPermutation_Equivalence A : Equivalence (@CPermutation A) | 10 := { + Equivalence_Reflexive := @CPermutation_refl A ; + Equivalence_Symmetric := @CPermutation_sym A ; + Equivalence_Transitive := @CPermutation_trans A }. + + +Section CPermutation_properties. + +Variable A B:Type. + +Implicit Types a b : A. +Implicit Types l : list A. + +(** Compatibility with others operations on lists *) + +Lemma CPermutation_app : forall l1 l2 l3, + CPermutation (l1 ++ l2) l3 -> CPermutation (l2 ++ l1) l3. +Proof. intros l1 l2 l3 HC; now transitivity (l1 ++ l2). Qed. + +Theorem CPermutation_app_comm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). +Proof. apply cperm. Qed. + +Lemma CPermutation_app_rot : forall l1 l2 l3, + CPermutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). +Proof. intros l1 l2 l3; now rewrite (app_assoc l2). Qed. + +Lemma CPermutation_cons_append : forall l a, + CPermutation (a :: l) (l ++ [a]). +Proof. intros l a; now rewrite <- (app_nil_l l), app_comm_cons. Qed. + +Lemma CPermutation_morph_cons : forall P : list A -> Prop, + (forall a l, P (l ++ [a]) -> P (a :: l)) -> + Proper (@CPermutation A ==> iff) P. +Proof. +enough (forall P : list A -> Prop, + (forall a l, P (l ++ [a]) -> P (a :: l)) -> + forall l1 l2, CPermutation l1 l2 -> P l1 -> P l2) + as Himp + by now intros P HP l1 l2 HC; split; [ | symmetry in HC ]; apply Himp. +intros P HP l1 l2 [l1' l2']. +revert l1'; induction l2' using rev_ind; intros l1' HPl. +- now rewrite app_nil_r in HPl. +- rewrite app_assoc in HPl. + apply HP in HPl. + rewrite <- app_assoc, <- app_comm_cons, app_nil_l. + now apply IHl2'. +Qed. + +Lemma CPermutation_length_1 : forall a b, CPermutation [a] [b] -> a = b. +Proof. intros; now apply Permutation_length_1, CPermutation_Permutation. Qed. + +Lemma CPermutation_length_1_inv : forall l a, CPermutation [a] l -> l = [a]. +Proof. intros; now apply Permutation_length_1_inv, CPermutation_Permutation. Qed. + +Lemma CPermutation_swap : forall a b, CPermutation [a; b] [b; a]. +Proof. +intros; now change [a; b] with ([a] ++ [b]); change [b; a] with ([b] ++ [a]). +Qed. + +Lemma CPermutation_length_2 : forall a1 a2 b1 b2, + CPermutation [a1; a2] [b1; b2] -> + a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. +Proof. intros; now apply Permutation_length_2, CPermutation_Permutation. Qed. + +Lemma CPermutation_length_2_inv : forall a b l, + CPermutation [a; b] l -> l = [a; b] \/ l = [b; a]. +Proof. intros; now apply Permutation_length_2_inv, CPermutation_Permutation. Qed. + +Lemma CPermutation_vs_elt_inv : forall l l1 l2 a, + CPermutation l (l1 ++ a :: l2) -> + exists l' l'', l2 ++ l1 = l'' ++ l' /\ l = l' ++ a :: l''. +Proof. +intros l l1 l2 a HC. +inversion HC as [l1' l2' Heq' Heq]; clear HC; subst. +enough (exists l3, (l2' ++ l3 = l1 /\ l1' = l3 ++ a :: l2) + \/ (l2' = l1 ++ a :: l3 /\ l3 ++ l1' = l2)) + as [l3 [[<- ->]|[-> <-]]]. +- exists l3, (l2 ++ l2'); rewrite app_comm_cons; intuition. +- exists (l1' ++ l1), l3; intuition. +- revert l1' l2' l2 Heq; induction l1; simpl; intros l1' l2' l2 Heq. + + destruct l2'; inversion Heq; subst. + * exists nil; intuition. + * exists l2'; intuition. + + destruct l2'; inversion Heq; subst. + * exists (a0 :: l1); intuition. + * apply IHl1 in H1 as [l3 [[<- ->]|[-> <-]]]; exists l3; intuition. +Qed. + +Lemma CPermutation_vs_cons_inv : forall l l0 a, + CPermutation l (a :: l0) -> exists l' l'', l0 = l'' ++ l' /\ l = l' ++ a :: l''. +Proof. intros; rewrite <- (app_nil_r l0); now apply CPermutation_vs_elt_inv. Qed. + +End CPermutation_properties. + + +(** [rev], [in], [map], [Forall], [Exists], etc. *) + +Global Instance CPermutation_rev A : + Proper (@CPermutation A ==> @CPermutation A) (@rev A) | 10. +Proof. +intro l; induction l; intros l' HC. +- now apply CPermutation_nil in HC; subst. +- symmetry in HC. + destruct (CPermutation_vs_cons_inv HC) as [l1 [l2 [-> ->]]]. + simpl; rewrite ? rev_app_distr; simpl. + now rewrite <- app_assoc. +Qed. + +Global Instance CPermutation_in A a : + Proper (@CPermutation A ==> Basics.impl) (In a). +Proof. +intros l l' HC Hin. +now apply Permutation_in with l; [ apply CPermutation_Permutation | ]. +Qed. + +Global Instance CPermutation_in' A : + Proper (Logic.eq ==> @CPermutation A ==> iff) (@In A) | 10. +Proof. intros a a' <- l l' HC; split; now apply CPermutation_in. Qed. + +Global Instance CPermutation_map A B (f : A -> B) : + Proper (@CPermutation A ==> @CPermutation B) (map f) | 10. +Proof. now intros ? ? [l1 l2]; rewrite 2 map_app. Qed. + +Lemma CPermutation_map_inv A B : forall (f : A -> B) m l, + CPermutation m (map f l) -> exists l', m = map f l' /\ CPermutation l l'. +Proof. +induction m as [| b m]; intros l HC. +- exists nil; split; auto. + destruct l; auto. + apply CPermutation_nil in HC; inversion HC. +- symmetry in HC. + destruct (CPermutation_vs_cons_inv HC) as [m1 [m2 [-> Heq]]]. + apply map_eq_app in Heq as [l1 [l1' [-> [-> Heq]]]]. + symmetry in Heq. + apply map_eq_cons in Heq as [a [l1'' [-> [-> ->]]]]. + exists (a :: l1'' ++ l1); split. + + now simpl; rewrite map_app. + + now rewrite app_comm_cons. +Qed. + +Lemma CPermutation_image A B : forall (f : A -> B) a l l', + CPermutation (a :: l) (map f l') -> exists a', a = f a'. +Proof. +intros f a l l' HP. +now apply CPermutation_Permutation, Permutation_image in HP. +Qed. + +Instance CPermutation_Forall A (P : A -> Prop) : + Proper (@CPermutation A ==> Basics.impl) (Forall P). +Proof. +intros ? ? [? ?] HF. +now apply Forall_app in HF; apply Forall_app. +Qed. + +Instance CPermutation_Exists A (P : A -> Prop) : + Proper (@CPermutation A ==> Basics.impl) (Exists P). +Proof. +intros ? ? [? ?] HE. +apply Exists_app in HE; apply Exists_app; intuition. +Qed. + +Lemma CPermutation_Forall2 A B (P : A -> B -> Prop) : + forall l1 l1' l2, CPermutation l1 l1' -> Forall2 P l1 l2 -> exists l2', + CPermutation l2 l2' /\ Forall2 P l1' l2'. +Proof. +intros ? ? ? [? ?] HF. +apply Forall2_app_inv_l in HF as (l2' & l2'' & HF' & HF'' & ->). +exists (l2'' ++ l2'); intuition. +now apply Forall2_app. +Qed. + + +(** As an equivalence relation compatible with some operations, +[CPermutation] can be used through [rewrite]. *) +Example CPermutation_rewrite_rev A (l1 l2 l3: list A) : + CPermutation l1 l2 -> + CPermutation (rev l1) l3 -> CPermutation l3 (rev l2). +Proof. intros HP1 HP2; rewrite <- HP1, HP2; reflexivity. Qed. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 86eebc6b4f..ffef8a216d 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -499,11 +499,13 @@ Proof. rewrite (NoDup_Add AD) in Hl'. tauto. Qed. -Lemma NoDup_Permutation_bis l l' : NoDup l -> NoDup l' -> +Lemma NoDup_Permutation_bis l l' : NoDup l -> length l' <= length l -> incl l l' -> Permutation l l'. Proof. intros. apply NoDup_Permutation; auto. - split; auto. apply NoDup_length_incl; trivial. + - now apply NoDup_incl_NoDup with l. + - split; auto. + apply NoDup_length_incl; trivial. Qed. Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'. diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index 466e2bf994..443931e5bb 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -15,7 +15,7 @@ *) Require Fin. -Require Import VectorDef. +Require Import VectorDef PeanoNat Eqdep_dec. Import VectorNotations. Definition cons_inj {A} {a1 a2} {n} {v1 v2 : t A n} @@ -32,6 +32,8 @@ Defined. (** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all is true for the one that use [lt] *) +(** ** Properties of [nth] and [nth_order] *) + Lemma eq_nth_iff A n (v1 v2: t A n): (forall p1 p2, p1 = p2 -> v1 [@ p1 ] = v2 [@ p2 ]) <-> v1 = v2. Proof. @@ -44,12 +46,35 @@ split. - intros; now f_equal. Qed. +Lemma nth_order_hd A: forall n (v : t A (S n)) (H : 0 < S n), + nth_order v H = hd v. +Proof. intros; now rewrite (eta v). Qed. + +Lemma nth_order_tl A: forall n k (v : t A (S n)) (H : k < n) (HS : S k < S n), + nth_order (tl v) H = nth_order v HS. +Proof. +induction n; intros. +- inversion H. +- rewrite (eta v). + unfold nth_order; simpl. + now rewrite (Fin.of_nat_ext H (Lt.lt_S_n _ _ HS)). +Qed. + Lemma nth_order_last A: forall n (v: t A (S n)) (H: n < S n), nth_order v H = last v. Proof. unfold nth_order; refine (@rectS _ _ _ _); now simpl. Qed. +Lemma nth_order_ext A: forall n k (v : t A n) (H1 H2 : k < n), + nth_order v H1 = nth_order v H2. +Proof. +intros; unfold nth_order. +now rewrite (Fin.of_nat_ext H1 H2). +Qed. + +(** ** Properties of [shiftin] and [shiftrepeat] *) + Lemma shiftin_nth A a n (v: t A n) k1 k2 (eq: k1 = k2): nth (shiftin a v) (Fin.L_R 1 k1) = nth v k2. Proof. @@ -82,11 +107,99 @@ Proof. refine (@rectS _ _ _ _); now simpl. Qed. +(** ** Properties of [replace] *) + +Lemma nth_order_replace_eq A: forall n k (v : t A n) a (H1 : k < n) (H2 : k < n), + nth_order (replace v (Fin.of_nat_lt H2) a) H1 = a. +Proof. +intros n k; revert n; induction k; intros; + (destruct n; [ inversion H1 | subst ]). +- now rewrite nth_order_hd, (eta v). +- rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) H1)), (eta v). + apply IHk. +Qed. + +Lemma nth_order_replace_neq A: forall n k1 k2, k1 <> k2 -> + forall (v : t A n) a (H1 : k1 < n) (H2 : k2 < n), + nth_order (replace v (Fin.of_nat_lt H2) a) H1 = nth_order v H1. +Proof. +intros n k1; revert n; induction k1; intros; + (destruct n ; [ inversion H1 | subst ]). +- rewrite 2 nth_order_hd. + destruct k2; intuition. + now rewrite 2 (eta v). +- rewrite <- 2 (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) H1)), (eta v). + destruct k2; auto. + apply IHk1. + intros Hk; apply H; now subst. +Qed. + +Lemma replace_id A: forall n p (v : t A n), + replace v p (nth v p) = v. +Proof. +induction p; intros; rewrite 2 (eta v); simpl; auto. +now rewrite IHp. +Qed. + +Lemma replace_replace_eq A: forall n p (v : t A n) a b, + replace (replace v p a) p b = replace v p b. +Proof. +intros. +induction p; rewrite 2 (eta v); simpl; auto. +now rewrite IHp. +Qed. + +Lemma replace_replace_neq A: forall n p1 p2 (v : t A n) a b, p1 <> p2 -> + replace (replace v p1 a) p2 b = replace (replace v p2 b) p1 a. +Proof. +apply (Fin.rect2 (fun n p1 p2 => forall v a b, + p1 <> p2 -> replace (replace v p1 a) p2 b = replace (replace v p2 b) p1 a)). +- intros n v a b Hneq. + now contradiction Hneq. +- intros n p2 v; revert n v p2. + refine (@rectS _ _ _ _); auto. +- intros n p1 v; revert n v p1. + refine (@rectS _ _ _ _); auto. +- intros n p1 p2 IH v; revert n v p1 p2 IH. + refine (@rectS _ _ _ _); simpl; do 6 intro; [ | do 3 intro ]; intro Hneq; + f_equal; apply IH; intros Heq; apply Hneq; now subst. +Qed. + +(** ** Properties of [const] *) + Lemma const_nth A (a: A) n (p: Fin.t n): (const a n)[@ p] = a. Proof. now induction p. Qed. +(** ** Properties of [map] *) + +Lemma map_id A: forall n (v : t A n), + map (fun x => x) v = v. +Proof. +induction v; simpl; [ | rewrite IHv ]; auto. +Qed. + +Lemma map_map A B C: forall (f:A->B) (g:B->C) n (v : t A n), + map g (map f v) = map (fun x => g (f x)) v. +Proof. +induction v; simpl; [ | rewrite IHv ]; auto. +Qed. + +Lemma map_ext_in A B: forall (f g:A->B) n (v : t A n), + (forall a, In a v -> f a = g a) -> map f v = map g v. +Proof. +induction v; simpl; auto. +intros; rewrite H by constructor; rewrite IHv; intuition. +apply H; now constructor. +Qed. + +Lemma map_ext A B: forall (f g:A->B), (forall a, f a = g a) -> + forall n (v : t A n), map f v = map g v. +Proof. +intros; apply map_ext_in; auto. +Qed. + Lemma nth_map {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2): (map f v) [@ p1] = f (v [@ p2]). Proof. @@ -105,6 +218,8 @@ refine (@rect2 _ _ _ _ _); simpl. now simpl. Qed. +(** ** Properties of [fold_left] *) + Lemma fold_left_right_assoc_eq {A B} {f: A -> B -> A} (assoc: forall a b c, f (f a b) c = f (f a c) b) {n} (v: t B n): forall a, fold_left f a v = fold_right (fun x y => f y x) v a. @@ -118,6 +233,8 @@ assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). + simpl. intros; now rewrite<- (IHv). Qed. +(** ** Properties of [to_list] *) + Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l. Proof. induction l. @@ -125,6 +242,8 @@ induction l. - unfold to_list; simpl. now f_equal. Qed. +(** ** Properties of [take] *) + Lemma take_O : forall {A} {n} le (v:t A n), take 0 le v = []. Proof. reflexivity. @@ -153,10 +272,14 @@ Proof. - destruct v. inversion le. simpl. apply f_equal. apply IHp. Qed. +(** ** Properties of [uncons] and [splitat] *) + Lemma uncons_cons {A} : forall {n : nat} (a : A) (v : t A n), uncons (a::v) = (a,v). Proof. reflexivity. Qed. +(* [append] *) + Lemma append_comm_cons {A} : forall {n m : nat} (v : t A n) (w : t A m) (a : A), a :: (v ++ w) = (a :: v) ++ w. Proof. reflexivity. Qed. @@ -187,3 +310,80 @@ Proof with auto. f_equal... apply IHv... Qed. + +(** ** Properties of [Forall] and [Forall2] *) + +Lemma Forall_impl A: forall (P Q : A -> Prop), (forall a, P a -> Q a) -> + forall n (v : t A n), Forall P v -> Forall Q v. +Proof. +induction v; intros HP; constructor; inversion HP as [| ? ? ? ? ? Heq1 [Heq2 He]]; + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He; subst; intuition. +Qed. + +Lemma Forall_forall A: forall P n (v : t A n), + Forall P v <-> forall a, In a v -> P a. +Proof. +intros P n v; split. +- intros HP a Hin. + revert HP; induction Hin; intros HP; + inversion HP as [| ? ? ? ? ? Heq1 [Heq2 He]]; subst; auto. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He; subst; auto. +- induction v; intros Hin; constructor. + + apply Hin; constructor. + + apply IHv; intros a Ha. + apply Hin; now constructor. +Qed. + +Lemma Forall_nth_order A: forall P n (v : t A n), + Forall P v <-> forall i (Hi : i < n), P (nth_order v Hi). +Proof. +split; induction n. +- intros HF i Hi; inversion Hi. +- intros HF i Hi. + rewrite (eta v). + rewrite (eta v) in HF. + inversion HF as [| ? ? ? ? ? Heq1 [Heq2 He]]; subst. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He ; subst. + destruct i. + + now rewrite nth_order_hd. + + rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) Hi) Hi). + now apply IHn. +- intros HP; apply case0; constructor. +- intros HP. + rewrite (eta v) in HP. + rewrite (eta v); constructor. + + specialize HP with 0 (Nat.lt_0_succ n). + now rewrite nth_order_hd in HP. + + apply IHn; intros. + specialize HP with (S i) (proj1 (Nat.succ_lt_mono _ _) Hi). + now rewrite <- (nth_order_tl _ _ _ _ Hi) in HP. +Qed. + +Lemma Forall2_nth_order A: forall P n (v1 v2 : t A n), + Forall2 P v1 v2 + <-> forall i (Hi1 : i < n) (Hi2 : i < n), P (nth_order v1 Hi1) (nth_order v2 Hi2). +Proof. +split; induction n. +- intros HF i Hi1 Hi2; inversion Hi1. +- intros HF i Hi1 Hi2. + rewrite (eta v1), (eta v2). + rewrite (eta v1), (eta v2) in HF. + inversion HF as [| ? ? ? ? ? ? ? Heq [Heq1 He1] [Heq2 He2]]. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He1. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He2; subst. + destruct i. + + now rewrite nth_order_hd. + + rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) Hi1) Hi1). + rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) Hi2) Hi2). + now apply IHn. +- intros _; revert v1; apply case0; revert v2; apply case0; constructor. +- intros HP. + rewrite (eta v1), (eta v2) in HP. + rewrite (eta v1), (eta v2); constructor. + + specialize HP with 0 (Nat.lt_0_succ _) (Nat.lt_0_succ _). + now rewrite nth_order_hd in HP. + + apply IHn; intros. + specialize HP with (S i) (proj1 (Nat.succ_lt_mono _ _) Hi1) + (proj1 (Nat.succ_lt_mono _ _) Hi2). + now rewrite <- (nth_order_tl _ _ _ _ Hi1), <- (nth_order_tl _ _ _ _ Hi2) in HP. +Qed. diff --git a/theories/ltac/Ltac.v b/theories/ltac/Ltac.v deleted file mode 100644 index e69de29bb2..0000000000 --- a/theories/ltac/Ltac.v +++ /dev/null diff --git a/theories/micromega/ZArith_hints.v b/theories/micromega/ZArith_hints.v new file mode 100644 index 0000000000..a6d3d92a99 --- /dev/null +++ b/theories/micromega/ZArith_hints.v @@ -0,0 +1,43 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +Require Import Lia. +Import ZArith_base. + +Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l + Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_r + Z.mul_add_distr_l: zarith. + +Require Export Zhints. + +Hint Extern 10 (_ = _ :>nat) => abstract lia: zarith. +Hint Extern 10 (_ <= _) => abstract lia: zarith. +Hint Extern 10 (_ < _) => abstract lia: zarith. +Hint Extern 10 (_ >= _) => abstract lia: zarith. +Hint Extern 10 (_ > _) => abstract lia: zarith. + +Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith. +Hint Extern 10 (~ _ <= _) => abstract lia: zarith. +Hint Extern 10 (~ _ < _) => abstract lia: zarith. +Hint Extern 10 (~ _ >= _) => abstract lia: zarith. +Hint Extern 10 (~ _ > _) => abstract lia: zarith. + +Hint Extern 10 (_ = _ :>Z) => abstract lia: zarith. +Hint Extern 10 (_ <= _)%Z => abstract lia: zarith. +Hint Extern 10 (_ < _)%Z => abstract lia: zarith. +Hint Extern 10 (_ >= _)%Z => abstract lia: zarith. +Hint Extern 10 (_ > _)%Z => abstract lia: zarith. + +Hint Extern 10 (_ <> _ :>Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ <= _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ < _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ >= _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ > _)%Z) => abstract lia: zarith. + +Hint Extern 10 False => abstract lia: zarith. diff --git a/theories/omega/Omega.v b/theories/omega/Omega.v index 10a5aa47b3..5c52284621 100644 --- a/theories/omega/Omega.v +++ b/theories/omega/Omega.v @@ -19,38 +19,6 @@ Require Export ZArith_base. Require Export OmegaLemmas. Require Export PreOmega. -Require Import Lia. +Require Export ZArith_hints. Declare ML Module "omega_plugin". - -Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l - Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_r - Z.mul_add_distr_l: zarith. - -Require Export Zhints. - -Hint Extern 10 (_ = _ :>nat) => abstract lia: zarith. -Hint Extern 10 (_ <= _) => abstract lia: zarith. -Hint Extern 10 (_ < _) => abstract lia: zarith. -Hint Extern 10 (_ >= _) => abstract lia: zarith. -Hint Extern 10 (_ > _) => abstract lia: zarith. - -Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith. -Hint Extern 10 (~ _ <= _) => abstract lia: zarith. -Hint Extern 10 (~ _ < _) => abstract lia: zarith. -Hint Extern 10 (~ _ >= _) => abstract lia: zarith. -Hint Extern 10 (~ _ > _) => abstract lia: zarith. - -Hint Extern 10 (_ = _ :>Z) => abstract lia: zarith. -Hint Extern 10 (_ <= _)%Z => abstract lia: zarith. -Hint Extern 10 (_ < _)%Z => abstract lia: zarith. -Hint Extern 10 (_ >= _)%Z => abstract lia: zarith. -Hint Extern 10 (_ > _)%Z => abstract lia: zarith. - -Hint Extern 10 (_ <> _ :>Z) => abstract lia: zarith. -Hint Extern 10 (~ (_ <= _)%Z) => abstract lia: zarith. -Hint Extern 10 (~ (_ < _)%Z) => abstract lia: zarith. -Hint Extern 10 (~ (_ >= _)%Z) => abstract lia: zarith. -Hint Extern 10 (~ (_ > _)%Z) => abstract lia: zarith. - -Hint Extern 10 False => abstract lia: zarith. diff --git a/theories/setoid_ring/Rings_Z.v b/theories/setoid_ring/Rings_Z.v index f489b00145..372bba7926 100644 --- a/theories/setoid_ring/Rings_Z.v +++ b/theories/setoid_ring/Rings_Z.v @@ -11,7 +11,6 @@ Require Export Cring. Require Export Integral_domain. Require Export Ncring_initial. -Require Export Omega. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 597351db9b..745bbb7e55 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -66,12 +66,12 @@ VERBOSE ?= TIMED?= TIMECMD?= # Use command time on linux, gtime on Mac OS -TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" +TIMEFMT?="$@ (real: %e, user: %U, sys: %S, mem: %M ko)" ifneq (,$(TIMED)) -ifeq (0,$(shell command time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +ifeq (0,$(shell command time -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=command time -f $(TIMEFMT) else -ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=gtime -f $(TIMEFMT) else STDTIME?=command time diff --git a/tools/coqdoc/coqdoc.css b/tools/coqdoc/coqdoc.css index dbc930f5ec..48096e555a 100644 --- a/tools/coqdoc/coqdoc.css +++ b/tools/coqdoc/coqdoc.css @@ -230,6 +230,10 @@ tr.infrulemiddle hr { color: rgb(40%,0%,40%); } +.id[title="binder"] { + color: rgb(40%,0%,40%); +} + .id[type="definition"] { color: rgb(0%,40%,0%); } @@ -327,3 +331,8 @@ ul.doclist { margin-top: 0em; margin-bottom: 0em; } + +.code :target { + border: 2px solid #D4D4D4; + background-color: #e5eecc; +} diff --git a/tools/coqdoc/coqdoc.sty b/tools/coqdoc/coqdoc.sty index f49f9f0066..aa9c414761 100644 --- a/tools/coqdoc/coqdoc.sty +++ b/tools/coqdoc/coqdoc.sty @@ -72,6 +72,7 @@ \newcommand{\coqdocinductive}[1]{\coqdocind{#1}} \newcommand{\coqdocdefinition}[1]{\coqdoccst{#1}} \newcommand{\coqdocvariable}[1]{\coqdocvar{#1}} +\newcommand{\coqdocbinder}[1]{\coqdocvar{#1}} \newcommand{\coqdocconstructor}[1]{\coqdocconstr{#1}} \newcommand{\coqdoclemma}[1]{\coqdoccst{#1}} \newcommand{\coqdocclass}[1]{\coqdocind{#1}} diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 0f25bc8e12..86d213453b 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -32,6 +32,19 @@ in count 0 0 + let count_newlines s = + let len = String.length s in + let n = ref 0 in + String.iteri (fun i c -> + match c with (* skip "\r\n" *) + | '\r' when i + 1 = len || s.[i+1] = '\n' -> incr n + | '\n' -> incr n + | _ -> ()) s; + !n + + (* Whether a string starts with a newline (used on strings that might match the [nl] regexp) *) + let is_nl s = String.length s = 0 || let c = s.[0] in c = '\n' || c = '\r' + let remove_newline s = let n = String.length s in let rec count i = if i == n || s.[i] <> '\n' then i else count (i + 1) in @@ -65,8 +78,12 @@ let eol = s.[String.length s - 1] = '\n' in (eol, if eol then String.sub s 1 (String.length s - 1) else s) + let is_none x = + match x with + | None -> true + | Some _ -> false - let formatted = ref false + let formatted : position option ref = ref None let brackets = ref 0 let comment_level = ref 0 let in_proof = ref None @@ -124,7 +141,7 @@ (* Reset the globals *) let reset () = - formatted := false; + formatted := None; brackets := 0; comment_level := 0 @@ -252,13 +269,28 @@ let parse_comments () = !Cdglobals.parse_comments && not (only_gallina ()) + (* Advance lexbuf by n lines. Equivalent to calling [Lexing.new_line lexbuf] n times *) + let new_lines n lexbuf = + let lcp = lexbuf.lex_curr_p in + if lcp != dummy_pos then + lexbuf.lex_curr_p <- + { lcp with + pos_lnum = lcp.pos_lnum + n; + pos_bol = lcp.pos_cnum } + + let print_position chan p = + Printf.fprintf chan "%s:%d:%d" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) + + exception MismatchPreformatted of position + + (* let debug lexbuf msg = Printf.printf "%a %s\n" print_position lexbuf.lex_start_p msg *) } (*s Regular expressions *) let space = [' ' '\t'] -let space_nl = [' ' '\t' '\n' '\r'] -let nl = "\r\n" | '\n' +let nl = "\r\n" | '\n' | '\r' +let space_nl = space | nl let firstchar = ['A'-'Z' 'a'-'z' '_'] | @@ -435,12 +467,12 @@ let section = "*" | "**" | "***" | "****" let item_space = " " -let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl -let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl -let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl -let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl +let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* +let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* +let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* +let end_show = "(*" space* "end" space+ "show" space* "*)" space* let begin_details = "(*" space* "begin" space+ "details" space* -let end_details = "(*" space* "end" space+ "details" space* "*)" space* nl +let end_details = "(*" space* "end" space+ "details" space* "*)" space* (* let begin_verb = "(*" space* "begin" space+ "verb" space* "*)" let end_verb = "(*" space* "end" space+ "verb" space* "*)" @@ -449,29 +481,36 @@ let end_verb = "(*" space* "end" space+ "verb" space* "*)" (*s Scanning Coq, at beginning of line *) rule coq_bol = parse - | space* nl+ - { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) + | space* (nl+ as s) + { new_lines (String.length s) lexbuf; + if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) then Output.empty_line_of_code (); coq_bol lexbuf } - | space* "(**" space_nl - { Output.end_coq (); Output.start_doc (); + | space* "(**" (space_nl as s) + { if is_nl s then Lexing.new_line lexbuf; + Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } - | space* "Comments" space_nl - { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); - Output.start_coq (); coq lexbuf } - | space* begin_hide - { skip_hide lexbuf; coq_bol lexbuf } - | space* begin_show - { begin_show (); coq_bol lexbuf } - | space* end_show - { end_show (); coq_bol lexbuf } - | space* begin_details - { let s = details_body lexbuf in + | space* "Comments" (space_nl as s) + { if is_nl s then Lexing.new_line lexbuf; + Output.end_coq (); Output.start_doc (); + comments lexbuf; + Output.end_doc (); Output.start_coq (); + coq lexbuf } + | space* begin_hide nl + { Lexing.new_line lexbuf; skip_hide lexbuf; coq_bol lexbuf } + | space* begin_show nl + { Lexing.new_line lexbuf; begin_show (); coq_bol lexbuf } + | space* end_show nl + { Lexing.new_line lexbuf; end_show (); coq_bol lexbuf } + | space* begin_details nl + { Lexing.new_line lexbuf; + let s = details_body lexbuf in Output.end_coq (); begin_details s; Output.start_coq (); coq_bol lexbuf } - | space* end_details - { Output.end_coq (); end_details (); Output.start_coq (); coq_bol lexbuf } + | space* end_details nl + { Lexing.new_line lexbuf; + Output.end_coq (); end_details (); Output.start_coq (); coq_bol lexbuf } | space* (("Local"|"Global") space+)? gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then @@ -577,9 +616,10 @@ rule coq_bol = parse and coq = parse | nl - { if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } - | "(**" space_nl - { Output.end_coq (); Output.start_doc (); + { Lexing.new_line lexbuf; if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } + | "(**" (space_nl as s) + { if is_nl s then Lexing.new_line lexbuf; + Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } @@ -591,8 +631,9 @@ and coq = parse comment lexbuf end else skipped_comment lexbuf in if eol then coq_bol lexbuf else coq lexbuf } - | nl+ space* "]]" - { if not !formatted then + | (nl+ as s) space* "]]" + { new_lines (count_newlines s) lexbuf; + if is_none !formatted then begin (* Isn't this an anomaly *) let s = lexeme lexbuf in @@ -677,8 +718,9 @@ and coq = parse (*s Scanning documentation, at beginning of line *) and doc_bol = parse - | space* section space+ ([^'\n' '*'] | '*'+ [^'\n' ')' '*'])* ('*'+ '\n')? - { let eol, lex = strip_eol (lexeme lexbuf) in + | space* section space+ ([^'\n' '\r' '*'] | '*'+ [^'\n' '\r' ')' '*'])* ('*'+ (nl as s))? + { if not (is_none s) then Lexing.new_line lexbuf; + let eol, lex = strip_eol (lexeme lexbuf) in let lev, s = sec_title lex in if (!Cdglobals.lib_subtitles) && (subtitle (Output.get_module false) s) then @@ -686,24 +728,20 @@ and doc_bol = parse else Output.section lev (fun () -> ignore (doc None (from_string s))); if eol then doc_bol lexbuf else doc None lexbuf } - | space_nl* '-'+ - { let buf' = lexeme lexbuf in - let bufs = Str.split_delim (Str.regexp "['\n']") buf' in - let lines = (List.length bufs) - 1 in - let line = - match bufs with - | [] -> eprintf "Internal error bad_split1 - please report\n"; - exit 1 - | _ -> List.nth bufs lines - in - match check_start_list line with - | Neither -> backtrack_past_newline lexbuf; doc None lexbuf - | List n -> if lines > 0 then Output.paragraph (); - Output.item 1; doc (Some [n]) lexbuf - | Rule -> Output.rule (); doc None lexbuf + | (space_nl* as s) ('-'+ as line) + { let nl_count = count_newlines s in + match check_start_list line with + | Neither -> backtrack_past_newline lexbuf; Lexing.new_line lexbuf; doc None lexbuf + | List n -> + new_lines nl_count lexbuf; + if nl_count > 0 then Output.paragraph (); + Output.item 1; doc (Some [n]) lexbuf + | Rule -> + new_lines nl_count lexbuf; + Output.rule (); doc None lexbuf } - | space* nl+ - { Output.paragraph (); doc_bol lexbuf } + | (space_nl* nl) as s + { new_lines (count_newlines s) lexbuf; Output.paragraph (); doc_bol lexbuf } | "<<" space* { Output.start_verbatim false; verbatim 0 false lexbuf; doc_bol lexbuf } | eof @@ -711,8 +749,7 @@ and doc_bol = parse | '_' { if !Cdglobals.plain_comments then Output.char '_' else start_emph (); doc None lexbuf } - | _ - { backtrack lexbuf; doc None lexbuf } + | "" { doc None lexbuf } (*s Scanning lists - using whitespace *) and doc_list_bol indents = parse @@ -733,11 +770,11 @@ and doc_list_bol indents = parse verbatim 0 false lexbuf; doc_list_bol indents lexbuf } | "[[" nl - { formatted := true; + { formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); ignore(body_bol lexbuf); Output.end_inline_coq_block (); - formatted := false; + formatted := None; doc_list_bol indents lexbuf } | "[[[" nl { inf_rules (Some indents) lexbuf } @@ -800,10 +837,10 @@ and doc indents = parse | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '['; doc indents lexbuf) - else (formatted := true; + else (formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); let eol = body_bol lexbuf in - Output.end_inline_coq_block (); formatted := false; + Output.end_inline_coq_block (); formatted := None; if eol then match indents with | Some ls -> doc_list_bol ls lexbuf @@ -828,16 +865,15 @@ and doc indents = parse if !Cdglobals.parse_comments then comment lexbuf else skipped_comment lexbuf in if eol then bol_parse lexbuf else doc indents lexbuf } - | '*'* "*)" space_nl* "(**" - {(match indents with + | '*'* "*)" (space_nl* as s) "(**" + { let nl_count = count_newlines s in + new_lines nl_count lexbuf; + (match indents with | Some _ -> Output.stop_item () | None -> ()); (* this says - if there is a blank line between the two comments, insert one in the output too *) - let lines = List.length (Str.split_delim (Str.regexp "['\n']") - (lexeme lexbuf)) - in - if lines > 2 then Output.paragraph (); + if nl_count > 1 then Output.paragraph (); doc_bol lexbuf } | '*'* "*)" space* nl @@ -1029,10 +1065,10 @@ and comment = parse comment lexbuf } | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') - else (formatted := true; + else (formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); let _ = body_bol lexbuf in - Output.end_inline_coq_block (); formatted := false); + Output.end_inline_coq_block (); formatted := None); comment lexbuf } | "$" { if !Cdglobals.plain_comments then Output.char '$' @@ -1095,13 +1131,14 @@ and skip_to_dot_or_brace = parse and body_bol = parse | space+ { Output.indentation (fst (count_spaces (lexeme lexbuf))); body lexbuf } - | _ { backtrack lexbuf; Output.indentation 0; body lexbuf } + | "" { Output.indentation 0; body lexbuf } and body = parse | nl {Tokens.flush_sublexer(); Output.line_break(); Lexing.new_line lexbuf; body_bol lexbuf} - | nl+ space* "]]" space* nl - { Tokens.flush_sublexer(); - if not !formatted then + | (nl+ as s) space* "]]" space* nl + { new_lines (count_newlines s + 1) lexbuf; + Tokens.flush_sublexer(); + if is_none !formatted then begin let s = lexeme lexbuf in let nlsp,s = remove_newline s in @@ -1119,7 +1156,8 @@ and body = parse end } | "]]" space* nl { Tokens.flush_sublexer(); - if not !formatted then + Lexing.new_line lexbuf; + if is_none !formatted then begin let loc = lexeme_start lexbuf in Output.sublexer ']' loc; @@ -1133,13 +1171,19 @@ and body = parse Output.paragraph (); true end } - | eof { Tokens.flush_sublexer(); false } - | '.' space* nl | '.' space* eof - { Tokens.flush_sublexer(); Output.char '.'; Output.line_break(); - if not !formatted then true else body_bol lexbuf } + | eof + { Tokens.flush_sublexer(); + match !formatted with + | None -> false + | Some p -> raise (MismatchPreformatted p) } + | '.' space* (nl as s | eof) + { if not (is_none s) then new_line lexbuf; + Tokens.flush_sublexer(); Output.char '.'; Output.line_break(); + if is_none !formatted then true else body_bol lexbuf } | '.' space* nl "]]" space* nl - { Tokens.flush_sublexer(); Output.char '.'; - if not !formatted then + { new_lines 2 lexbuf; + Tokens.flush_sublexer(); Output.char '.'; + if is_none !formatted then begin eprintf "Error: stray ]] at %d\n" (lexeme_start lexbuf); flush stderr; @@ -1153,9 +1197,10 @@ and body = parse } | '.' space+ { Tokens.flush_sublexer(); Output.char '.'; Output.char ' '; - if not !formatted then false else body lexbuf } - | "(**" space_nl - { Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc (); + if is_none !formatted then false else body lexbuf } + | "(**" (space_nl as s) + { if is_nl s then new_line lexbuf; + Tokens.flush_sublexer(); Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then body_bol lexbuf else body lexbuf } @@ -1220,27 +1265,32 @@ and string = parse | _ { let c = lexeme_char lexbuf 0 in Output.char c; string lexbuf } and skip_hide = parse - | eof | end_hide { () } + | eof | end_hide nl { Lexing.new_line lexbuf; () } | _ { skip_hide lexbuf } (*s Reading token pretty-print *) and printing_token_body = parse - | "*)" nl? | eof - { let s = Buffer.contents token_buffer in + | "*)" (nl as s)? | eof + { if not (is_none s) then Lexing.new_line lexbuf; + let s = Buffer.contents token_buffer in Buffer.clear token_buffer; s } - | _ { Buffer.add_string token_buffer (lexeme lexbuf); + | (nl | _) as s + { if is_nl s then Lexing.new_line lexbuf; + Buffer.add_string token_buffer (lexeme lexbuf); printing_token_body lexbuf } and details_body = parse - | "*)" space* nl? | eof - { None } + | "*)" space* (nl as s)? | eof + { if not (is_none s) then Lexing.new_line lexbuf; + None } | ":" space* { details_body_rec lexbuf } and details_body_rec = parse - | "*)" space* nl? | eof - { let s = Buffer.contents token_buffer in + | "*)" space* (nl as s)? | eof + { if not (is_none s) then Lexing.new_line lexbuf; + let s = Buffer.contents token_buffer in Buffer.clear token_buffer; Some s } | _ { Buffer.add_string token_buffer (lexeme lexbuf); @@ -1343,6 +1393,14 @@ and st_subtitle = parse (*s Applying the scanners to files *) { + (* coq_bol with error handling *) + let coq_bol' f lb = + Lexing.new_line lb; (* Start numbering lines from 1 *) + try coq_bol lb with + | MismatchPreformatted p -> + Printf.eprintf "%a: mismatched \"[[\"\n" print_position { p with pos_fname = f }; + exit 1 + let coq_file f m = reset (); let c = open_in f in @@ -1350,7 +1408,7 @@ and st_subtitle = parse (Index.current_library := m; Output.initialize (); Output.start_module (); - Output.start_coq (); coq_bol lb; Output.end_coq (); + Output.start_coq (); coq_bol' f lb; Output.end_coq (); close_in c) let detect_subtitle f m = diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 4cc82726f1..723918525d 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -31,6 +31,7 @@ type entry_type = | Abbreviation | Notation | Section + | Binder type index_entry = | Def of string * entry_type @@ -177,6 +178,7 @@ let type_name = function | Abbreviation -> "abbreviation" | Notation -> "notation" | Section -> "section" + | Binder -> "binder" let prepare_entry s = function | Notation -> @@ -268,6 +270,7 @@ let type_of_string = function | "mod" | "modtype" -> Module | "tac" -> TacticDefinition | "sec" -> Section + | "binder" -> Binder | s -> invalid_arg ("type_of_string:" ^ s) let ill_formed_glob_file f = diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli index 3426fdd3d3..7a3d401fd7 100644 --- a/tools/coqdoc/index.mli +++ b/tools/coqdoc/index.mli @@ -30,6 +30,7 @@ type entry_type = | Abbreviation | Notation | Section + | Binder val type_name : entry_type -> string diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index dd1b65d294..def1cbbcf8 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -337,11 +337,8 @@ module Latex = struct let id = if fid <> "" then (m ^ "." ^ fid) else m in match find_module m with | Local -> - if typ = Variable then - printf "\\coqdoc%s{%s}" (type_name typ) s - else - (printf "\\coqref{"; label_ident id; - printf "}{\\coqdoc%s{%s}}" (type_name typ) s) + printf "\\coqref{"; label_ident id; + printf "}{\\coqdoc%s{%s}}" (type_name typ) s | External m when !externals -> printf "\\coqexternalref{"; label_ident fid; printf "}{%s}{\\coqdoc%s{%s}}" (escaped m) (type_name typ) s @@ -615,6 +612,7 @@ module Html = struct else match s.[i] with | 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '_' -> loop esc (i-1) | '<' | '>' | '&' | '\'' | '\"' -> loop true (i-1) + | '-' | ':' -> loop esc (i-1) (* should be safe in HTML5 attribute name syntax *) | _ -> (* This name contains complex characters: this is probably a notation string, we simply hash it. *) @@ -661,7 +659,8 @@ module Html = struct let reference s r = match r with | Def (fullid,ty) -> - printf "<a name=\"%s\">" (sanitize_name fullid); + let s' = sanitize_name fullid in + printf "<a id=\"%s\" class=\"idref\" href=\"#%s\">" s' s'; printf "<span class=\"id\" title=\"%s\">%s</span></a>" (type_name ty) s | Ref (m,fullid,ty) -> ident_ref m fullid (type_name ty) s @@ -822,7 +821,7 @@ module Html = struct | Some n -> if lev <= n then add_toc_entry (Toc_section (lev, f, r)) else ()); stop_item (); - printf "<a name=\"%s\"></a><h%d class=\"section\">" lab lev; + printf "<a id=\"%s\"></a><h%d class=\"section\">" lab lev; f (); printf "</h%d>\n" lev @@ -836,7 +835,7 @@ module Html = struct let letter_index category idx (c,l) = if l <> [] then begin let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in - printf "<a name=\"%s_%c\"></a><h2>%s %s</h2>\n" idx c (display_letter c) cat; + printf "<a id=\"%s_%c\"></a><h2>%s %s</h2>\n" idx c (display_letter c) cat; List.iter (fun (id,(text,link,t)) -> let id' = prepare_entry id t in diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index a7a9b77b56..c8b8660b92 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -131,7 +131,7 @@ let set_options = List.iter set_option let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = - let pfs = Vernacstate.Proof_global.get_all_proof_names () [@ocaml.warning "-3"] in + let pfs = Vernacstate.Declare.get_all_proof_names () [@ocaml.warning "-3"] in if not (CList.is_empty pfs) then fatal_error (str "There are pending proofs: " ++ (pfs diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 1988c7cc42..17435c051e 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -44,7 +44,6 @@ type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; toplevel_name : Stm.interactive_top; - cumulative_sprop : bool; } type coqargs_config = { @@ -110,7 +109,6 @@ let default_logic_config = { impredicative_set = Declarations.PredicativeSet; indices_matter = false; toplevel_name = Stm.TopLogical default_toplevel; - cumulative_sprop = false; } let default_config = { @@ -198,6 +196,10 @@ let set_query opts q = | Queries queries -> Queries (queries@[q]) } +let warn_deprecated_sprop_cumul = + CWarnings.create ~name:"deprecated-spropcumul" ~category:"deprecated" + (fun () -> Pp.strbrk "Use the \"Cumulative StrictProp\" flag instead.") + let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") @@ -286,6 +288,30 @@ let parse_option_set opt = let v = String.sub opt (eqi+1) (len - eqi - 1) in to_opt_key (String.sub opt 0 eqi), Some v +let warn_no_native_compiler = + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + Pp.(fun s -> strbrk "Native compiler is disabled," ++ + strbrk " -native-compiler " ++ strbrk s ++ + strbrk " option ignored.") + +let get_native_compiler s = + (* We use two boolean flags because the four states make sense, even if + only three are accessible to the user at the moment. The selection of the + produced artifact(s) (`.vo`, `.vio`, `.coq-native`, ...) should be done by + a separate flag, and the "ondemand" value removed. Once this is done, use + [get_bool] here. *) + let n = match s with + | ("yes" | "on") -> NativeOn {ondemand=false} + | "ondemand" -> NativeOn {ondemand=true} + | ("no" | "off") -> NativeOff + | _ -> + error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") in + if not Coq_config.native_compiler && n <> NativeOff then + let () = warn_no_native_compiler s in + NativeOff + else + n + (* Main parsing routine *) (*s Parsing of the command line *) @@ -455,20 +481,7 @@ let parse_args ~help ~init arglist : t * string list = { oval with config = { oval.config with enable_VM = get_bool opt (next ()) }} |"-native-compiler" -> - - (* We use two boolean flags because the four states make sense, even if - only three are accessible to the user at the moment. The selection of the - produced artifact(s) (`.vo`, `.vio`, `.coq-native`, ...) should be done by - a separate flag, and the "ondemand" value removed. Once this is done, use - [get_bool] here. *) - let native_compiler = - match (next ()) with - | ("yes" | "on") -> NativeOn {ondemand=false} - | "ondemand" -> NativeOn {ondemand=true} - | ("no" | "off") -> NativeOff - | _ -> - error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") - in + let native_compiler = get_native_compiler (next ()) in { oval with config = { oval.config with native_compiler }} | "-set" -> @@ -509,7 +522,9 @@ let parse_args ~help ~init arglist : t * string list = add_set_option oval Vernacentries.allow_sprop_opt_name (OptionSet None) |"-disallow-sprop" -> add_set_option oval Vernacentries.allow_sprop_opt_name OptionUnset - |"-sprop-cumulative" -> set_logic (fun o -> { o with cumulative_sprop = true }) oval + |"-sprop-cumulative" -> + warn_deprecated_sprop_cumul(); + add_set_option oval Vernacentries.cumul_sprop_opt_name (OptionSet None) |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval |"-m"|"--memory" -> { oval with post = { oval.post with memory_stat = true }} |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 8723d21bb4..a51ed6766a 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -20,7 +20,6 @@ type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; toplevel_name : Stm.interactive_top; - cumulative_sprop : bool; } type coqargs_config = { diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index b8acdd3af1..2c5faa4df7 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -191,8 +191,8 @@ end from cycling. *) let make_prompt () = try - (Names.Id.to_string (Vernacstate.Proof_global.get_current_proof_name ())) ^ " < " - with Vernacstate.Proof_global.NoCurrentProof -> + (Names.Id.to_string (Vernacstate.Declare.get_current_proof_name ())) ^ " < " + with Vernacstate.Declare.NoCurrentProof -> "Coq < " [@@ocaml.warning "-3"] @@ -352,7 +352,7 @@ let print_anyway c = let top_goal_print ~doc c oldp newp = try let proof_changed = not (Option.equal cproof oldp newp) in - let print_goals = proof_changed && Vernacstate.Proof_global.there_are_pending_proofs () || + let print_goals = proof_changed && Vernacstate.Declare.there_are_pending_proofs () || print_anyway c in if not !Flags.quiet && print_goals then begin let dproof = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in @@ -375,7 +375,7 @@ let exit_on_error = point we should consolidate the code *) let show_proof_diff_to_pp pstate = let p = Option.get pstate in - let sigma, env = Pfedit.get_proof_context p in + let sigma, env = Proof.get_proof_context p in let pprf = Proof.partial_proof p in Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf @@ -392,7 +392,7 @@ let show_proof_diff_cmd ~state removed = let show_removed = Some removed in Pp_diff.diff_pp_combined ~tokenize_string ?show_removed o_pp n_pp with - | Pfedit.NoSuchGoal + | Proof.NoSuchGoal _ | Option.IsNone -> n_pp | Pp_diff.Diff_Failure msg -> begin (* todo: print the unparsable string (if we know it) *) @@ -403,7 +403,7 @@ let show_proof_diff_cmd ~state removed = else n_pp with - | Pfedit.NoSuchGoal + | Proof.NoSuchGoal _ | Option.IsNone -> CErrors.user_err (str "No goals to show.") diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 1175494bad..7aad856d0a 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -199,7 +199,6 @@ let init_execution opts custom_init = Global.set_VM opts.config.enable_VM; Flags.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); Global.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); - if opts.config.logic.cumulative_sprop then Global.make_sprop_cumulative (); (* Native output dir *) Nativelib.output_dir := opts.config.native_output_dir; diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 076796468f..c4c8492a4a 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -66,7 +66,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = (* Force the command *) let ndoc = if check then Stm.observe ~doc nsid else doc in - let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () [@ocaml.warning "-3"] in + let new_proof = Vernacstate.Declare.give_me_the_proof_opt () [@ocaml.warning "-3"] in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> let (reraise, info) = Exninfo.capture reraise in diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 57d59fc2ef..13c4d667a0 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -145,10 +145,10 @@ GRAMMAR EXTEND Gram { CAst.make ~loc @@ CTacCse (e, bl) } ] | "4" LEFTA [ ] - | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> + | "3" [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> { let el = e0 :: el in CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] - | "::" RIGHTA + | "2" RIGHTA [ e1 = tac2expr; "::"; e2 = tac2expr -> { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } ] diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 72df4d75c8..e77040a8db 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -375,7 +375,7 @@ let () = define1 "constr_kind" constr begin fun c -> | Evar (evk, args) -> v_blk 3 [| Value.of_int (Evar.repr evk); - Value.of_array Value.of_constr args; + Value.of_array Value.of_constr (Array.of_list args); |] | Sort s -> v_blk 4 [|Value.of_ext Value.val_sort s|] @@ -469,7 +469,7 @@ let () = define1 "constr_make" valexpr begin fun knd -> | (3, [|evk; args|]) -> let evk = Evar.unsafe_of_int (Value.to_int evk) in let args = Value.to_array Value.to_constr args in - EConstr.mkEvar (evk, args) + EConstr.mkEvar (evk, Array.to_list args) | (4, [|s|]) -> let s = Value.to_ext Value.val_sort s in EConstr.mkSort (EConstr.Unsafe.to_sorts s) @@ -603,7 +603,7 @@ let () = define3 "constr_in_context" ident constr closure begin fun id t c -> thaw c >>= fun _ -> Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal gl)] >>= fun () -> let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in - let args = Array.of_list (EConstr.mkRel 1 :: args) in + let args = EConstr.mkRel 1 :: args in let ans = EConstr.mkEvar (evk, args) in let ans = EConstr.mkLambda (Context.make_annot (Name id) Sorts.Relevant, t, ans) in return (Value.of_constr ans) @@ -1290,7 +1290,7 @@ let () = let ist = Tac2interp.get_env ist in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let name, poly = Id.of_string "ltac2", poly in - let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in + let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma concl tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_ltac2_constr interp diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index ebc63ddd01..28e877491e 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -91,7 +91,7 @@ let inTacDef : tacdef -> obj = declare_object {(default_object "TAC2-DEFINITION") with cache_function = cache_tacdef; load_function = load_tacdef; - open_function = open_tacdef; + open_function = simple_open open_tacdef; subst_function = subst_tacdef; classify_function = classify_tacdef} @@ -198,7 +198,7 @@ let inTypDef : typdef -> obj = declare_object {(default_object "TAC2-TYPE-DEFINITION") with cache_function = cache_typdef; load_function = load_typdef; - open_function = open_typdef; + open_function = simple_open open_typdef; subst_function = subst_typdef; classify_function = classify_typdef} @@ -268,7 +268,7 @@ let inTypExt : typext -> obj = declare_object {(default_object "TAC2-TYPE-EXTENSION") with cache_function = cache_typext; load_function = load_typext; - open_function = open_typext; + open_function = simple_open open_typext; subst_function = subst_typext; classify_function = classify_typext} @@ -664,7 +664,7 @@ let classify_synext o = let inTac2Notation : synext -> obj = declare_object {(default_object "TAC2-NOTATION") with cache_function = cache_synext; - open_function = open_synext; + open_function = simple_open open_synext; subst_function = subst_synext; classify_function = classify_synext} @@ -694,7 +694,7 @@ let inTac2Abbreviation : abbreviation -> obj = declare_object {(default_object "TAC2-ABBREVIATION") with cache_function = cache_abbreviation; load_function = load_abbreviation; - open_function = open_abbreviation; + open_function = simple_open open_abbreviation; subst_function = subst_abbreviation; classify_function = classify_abbreviation} @@ -747,7 +747,7 @@ let classify_redefinition o = Substitute o let inTac2Redefinition : redefinition -> obj = declare_object {(default_object "TAC2-REDEFINITION") with cache_function = perform_redefinition; - open_function = (fun _ -> perform_redefinition); + open_function = simple_open (fun _ -> perform_redefinition); subst_function = subst_redefinition; classify_function = classify_redefinition } @@ -795,7 +795,7 @@ let perform_eval ~pstate e = Goal_select.SelectAll, Proof.start ~name ~poly sigma [] | Some pstate -> Goal_select.get_default_goal_selector (), - Proof_global.get_proof pstate + Declare.Proof.get_proof pstate in let v = match selector with | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v @@ -899,10 +899,10 @@ let print_ltac qid = (** Calling tactics *) let solve ~pstate default tac = - let pstate, status = Proof_global.map_fold_proof_endline begin fun etac p -> + let pstate, status = Declare.Proof.map_fold_proof_endline begin fun etac p -> let with_end_tac = if default then Some etac else None in let g = Goal_select.get_default_goal_selector () in - let (p, status) = Pfedit.solve g None tac ?with_end_tac p in + let (p, status) = Proof.solve g None tac ?with_end_tac p in (* in case a strict subtree was completed, go back to the top of the prooftree *) let p = Proof.maximal_unfocus Vernacentries.command_focus p in @@ -962,7 +962,7 @@ let inTac2Init : unit -> obj = declare_object {(default_object "TAC2-INIT") with cache_function = cache_ltac2_init; load_function = load_ltac2_init; - open_function = open_ltac2_init; + open_function = simple_open open_ltac2_init; } let _ = Mltop.declare_cache_obj begin fun () -> diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index edad118dc9..fc56a54e3a 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -31,7 +31,7 @@ val register_struct val register_notation : ?local:bool -> sexpr list -> int option -> raw_tacexpr -> unit -val perform_eval : pstate:Proof_global.t option -> raw_tacexpr -> unit +val perform_eval : pstate:Declare.Proof.t option -> raw_tacexpr -> unit (** {5 Notations} *) @@ -53,7 +53,7 @@ val print_ltac : Libnames.qualid -> unit (** {5 Eval loop} *) (** Evaluate a tactic expression in the current environment *) -val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t +val call : pstate:Declare.Proof.t -> default:bool -> raw_tacexpr -> Declare.Proof.t (** {5 Toplevel exceptions} *) diff --git a/vernac/.ocamlformat-enable b/vernac/.ocamlformat-enable new file mode 100644 index 0000000000..ffaa7e70f4 --- /dev/null +++ b/vernac/.ocamlformat-enable @@ -0,0 +1 @@ +comHints.ml diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index f3ad324aa5..215d5d97a0 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -699,7 +699,7 @@ let make_bl_scheme mode mind = let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let bl_goal = EConstr.of_constr bl_goal in - let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal + let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, EConstr.EInstance.empty) lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -829,7 +829,7 @@ let make_lb_scheme mode mind = let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let lb_goal = EConstr.of_constr lb_goal in - let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal + let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -1006,7 +1006,7 @@ let make_eq_decidability mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let side_eff = side_effect_of_mode mode in - let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx + let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:(EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) (compute_dec_tact ind lnamesparrec nparrec) in diff --git a/vernac/canonical.ml b/vernac/canonical.ml index 390ed62bee..eaa6c84791 100644 --- a/vernac/canonical.ml +++ b/vernac/canonical.ml @@ -28,7 +28,7 @@ let discharge_canonical_structure (_,((gref, _ as x), local)) = let inCanonStruc : (GlobRef.t * inductive) * bool -> obj = declare_object {(default_object "CANONICAL-STRUCTURE") with - open_function = open_canonical_structure; + open_function = simple_open open_canonical_structure; cache_function = cache_canonical_structure; subst_function = (fun (subst,(c,local)) -> subst_canonical_structure subst c, local); classify_function = (fun x -> Substitute x); diff --git a/vernac/classes.ml b/vernac/classes.ml index 3d38713e09..eb735b7cdf 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -116,7 +116,7 @@ let instance_input : instance -> obj = { (default_object "type classes instances state") with cache_function = cache_instance; load_function = (fun _ x -> cache_instance x); - open_function = (fun _ x -> cache_instance x); + open_function = simple_open (fun _ x -> cache_instance x); classify_function = classify_instance; discharge_function = discharge_instance; rebuild_function = rebuild_instance; @@ -237,7 +237,7 @@ let class_input : typeclass -> obj = { (default_object "type classes state") with cache_function = cache_class; load_function = (fun _ -> cache_class); - open_function = (fun _ -> cache_class); + open_function = simple_open (fun _ -> cache_class); classify_function = (fun x -> Substitute x); discharge_function = (fun a -> Some (discharge_class a)); rebuild_function = rebuild_class; @@ -485,10 +485,8 @@ let do_instance env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imp interp_props ~program_mode:false env' cty k u ctx ctx' subst sigma props in let termtype, sigma = do_instance_resolve_TC termtype sigma env in - if Evd.has_undefined sigma then - CErrors.user_err Pp.(str "Unsolved obligations remaining.") - else - declare_instance_constant pri global imps ?hook id decl poly sigma term termtype + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + declare_instance_constant pri global imps ?hook id decl poly sigma term termtype let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props = let term, termtype, sigma = diff --git a/vernac/classes.mli b/vernac/classes.mli index 9698c14452..f410cddfef 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -22,7 +22,7 @@ val declare_instance : ?warn:bool -> env -> Evd.evar_map -> Does nothing — or emit a “not-a-class” warning if the [warn] argument is set — when said type is not a registered type class. *) -val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit +val existing_instance : bool -> qualid -> ComHints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) val new_instance_interactive @@ -34,7 +34,7 @@ val new_instance_interactive -> ?generalize:bool -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> (bool * constr_expr) option -> Id.t * Lemmas.t @@ -47,7 +47,7 @@ val new_instance -> (bool * constr_expr) -> ?generalize:bool -> ?hook:(GlobRef.t -> unit) - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> Id.t val new_instance_program @@ -59,7 +59,7 @@ val new_instance_program -> (bool * constr_expr) option -> ?generalize:bool -> ?hook:(GlobRef.t -> unit) - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> Id.t val declare_new_instance @@ -69,7 +69,7 @@ val declare_new_instance -> ident_decl -> local_binder_expr list -> constr_expr - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> unit (** {6 Low level interface used by Add Morphism, do not use } *) diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml index 90791a0906..360e228bfc 100644 --- a/vernac/comArguments.ml +++ b/vernac/comArguments.ml @@ -52,10 +52,10 @@ let warn_arguments_assert = CWarnings.create ~name:"arguments-assert" ~category:"vernacular" Pp.(fun sr -> strbrk "This command is just asserting the names of arguments of " ++ - Printer.pr_global sr ++ strbrk". If this is what you want add " ++ + Printer.pr_global sr ++ strbrk". If this is what you want, add " ++ strbrk "': assert' to silence the warning. If you want " ++ - strbrk "to clear implicit arguments add ': clear implicits'. " ++ - strbrk "If you want to clear notation scopes add ': clear scopes'") + strbrk "to clear implicit arguments, add ': clear implicits'. " ++ + strbrk "If you want to clear notation scopes, add ': clear scopes'") (* [nargs_for_red] is the number of arguments required to trigger reduction, [args] is the main list of arguments statuses, diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 1e2e2e53e2..776ffd6b9f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -91,7 +91,7 @@ let declare_assumptions ~poly ~scope ~kind univs nl l = let () = match scope with | Discharge -> (* declare universes separately for variables *) - Declare.declare_universe_context ~poly (context_set_of_entry (fst univs)) + DeclareUctx.declare_universe_context ~poly (context_set_of_entry (fst univs)) | Global _ -> () in let _, _ = List.fold_left (fun (subst,univs) ((is_coe,idl),typ,imps) -> @@ -161,7 +161,7 @@ let do_assumptions ~program_mode ~poly ~scope ~kind nl l = let env = EConstr.push_named_context (List.map (fun {CAst.v=id} -> LocalAssum (make_annot id r,t)) idl) env in let ienv = List.fold_right (fun {CAst.v=id} ienv -> - let impls = compute_internalization_data env sigma Variable t imps in + let impls = compute_internalization_data env sigma id Variable t imps in Id.Map.add id impls ienv) idl ienv in ((sigma,env,ienv),((is_coe,idl),t,imps))) (sigma,env,empty_internalization_env) l @@ -191,7 +191,7 @@ let context_subst subst (name,b,t,impl) = let context_insection sigma ~poly ctx = let uctx = Evd.universe_context_set sigma in - let () = Declare.declare_universe_context ~poly uctx in + let () = DeclareUctx.declare_universe_context ~poly uctx in let fn subst (name,_,_,_ as d) = let d = context_subst subst d in let () = match d with @@ -226,7 +226,7 @@ let context_nosection sigma ~poly ctx = (* Multiple monomorphic axioms: declare universes separately to avoid redeclaring them. *) let uctx = Evd.universe_context_set sigma in - let () = Declare.declare_universe_context ~poly uctx in + let () = DeclareUctx.declare_universe_context ~poly uctx in Monomorphic_entry Univ.ContextSet.empty in let fn subst d = diff --git a/vernac/comCoercion.ml b/vernac/comCoercion.ml index c339c53a9b..4a8e217fc1 100644 --- a/vernac/comCoercion.ml +++ b/vernac/comCoercion.ml @@ -256,7 +256,7 @@ let classify_coercion obj = let inCoercion : coercion -> obj = declare_object {(default_object "COERCION") with - open_function = open_coercion; + open_function = simple_open open_coercion; cache_function = cache_coercion; subst_function = (fun (subst,c) -> subst_coercion subst c); classify_function = classify_coercion; diff --git a/vernac/comHints.ml b/vernac/comHints.ml new file mode 100644 index 0000000000..5a48e9c16c --- /dev/null +++ b/vernac/comHints.ml @@ -0,0 +1,174 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util + +(** (Partial) implementation of the [Hint] command; some more + functionality still lives in tactics/hints.ml *) + +type hint_info_expr = Constrexpr.constr_pattern_expr Typeclasses.hint_info_gen + +type reference_or_constr = + | HintsReference of Libnames.qualid + | HintsConstr of Constrexpr.constr_expr + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * Libnames.qualid list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of Libnames.qualid list + | HintsTransparency of Libnames.qualid Hints.hints_transparency_target * bool + | HintsMode of Libnames.qualid * Hints.hint_mode list + | HintsConstructors of Libnames.qualid list + | HintsExtern of + int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + +let project_hint ~poly pri l2r r = + let open EConstr in + let open Coqlib in + let gr = Smartlocate.global_with_alias r in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, c = Evd.fresh_global env sigma gr in + let t = Retyping.get_type_of env sigma c in + let t = + Tacred.reduce_to_quantified_ref env sigma (lib_ref "core.iff.type") t + in + let sign, ccl = decompose_prod_assum sigma t in + let a, b = + match snd (decompose_app sigma ccl) with + | [a; b] -> (a, b) + | _ -> assert false + in + let p = if l2r then lib_ref "core.iff.proj1" else lib_ref "core.iff.proj2" in + let sigma, p = Evd.fresh_global env sigma p in + let c = + Reductionops.whd_beta sigma + (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) + in + let c = + it_mkLambda_or_LetIn + (mkApp + ( p + , [| mkArrow a Sorts.Relevant (Vars.lift 1 b) + ; mkArrow b Sorts.Relevant (Vars.lift 1 a) + ; c |] )) + sign + in + let name = + Nameops.add_suffix + (Nametab.basename_of_global gr) + ("_proj_" ^ if l2r then "l2r" else "r2l") + in + let ctx = Evd.univ_entry ~poly sigma in + let c = EConstr.to_constr sigma c in + let cb = + Declare.(DefinitionEntry (definition_entry ~univs:ctx ~opaque:false c)) + in + let c = + Declare.declare_constant ~local:Declare.ImportDefaultBehavior ~name + ~kind:Decls.(IsDefinition Definition) + cb + in + let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in + (info, false, true, Hints.PathAny, Hints.IsGlobRef (Names.GlobRef.ConstRef c)) + +let warn_deprecated_hint_constr = + CWarnings.create ~name:"deprecated-hint-constr" ~category:"deprecated" + (fun () -> + Pp.strbrk + "Declaring arbitrary terms as hints is deprecated; declare a global \ + reference instead") + +let interp_hints ~poly h = + let env = Global.env () in + let sigma = Evd.from_env env in + let f poly c = + let evd, c = Constrintern.interp_open_constr env sigma c in + let env = Global.env () in + let sigma = Evd.from_env env in + let c, diff = Hints.prepare_hint true env sigma (evd, c) in + if poly then (Hints.IsConstr (c, diff) [@ocaml.warning "-3"]) + else + let () = DeclareUctx.declare_universe_context ~poly:false diff in + (Hints.IsConstr (c, Univ.ContextSet.empty) [@ocaml.warning "-3"]) + in + let fref r = + let gr = Smartlocate.global_with_alias r in + Dumpglob.add_glob ?loc:r.CAst.loc gr; + gr + in + let fr r = Tacred.evaluable_of_global_reference env (fref r) in + let fi c = + let open Hints in + match c with + | HintsReference c -> + let gr = Smartlocate.global_with_alias c in + (PathHints [gr], poly, IsGlobRef gr) + | HintsConstr c -> + let () = warn_deprecated_hint_constr () in + (PathAny, poly, f poly c) + in + let fp = Constrintern.intern_constr_pattern env sigma in + let fres (info, b, r) = + let path, poly, gr = fi r in + let info = + { info with + Typeclasses.hint_pattern = Option.map fp info.Typeclasses.hint_pattern + } + in + (info, poly, b, path, gr) + in + let ft = + let open Hints in + function + | HintsVariables -> HintsVariables + | HintsConstants -> HintsConstants + | HintsReferences lhints -> HintsReferences (List.map fr lhints) + in + let fp = Constrintern.intern_constr_pattern (Global.env ()) in + let open Hints in + match h with + | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) + | HintsResolveIFF (l2r, lc, n) -> + HintsResolveEntry (List.map (project_hint ~poly n l2r) lc) + | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) + | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) + | HintsTransparency (t, b) -> HintsTransparencyEntry (ft t, b) + | HintsMode (r, l) -> HintsModeEntry (fref r, l) + | HintsConstructors lqid -> + let constr_hints_of_ind qid = + let ind = Smartlocate.global_inductive_with_alias qid in + let mib, _ = Global.lookup_inductive ind in + Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" + (Libnames.string_of_qualid qid) + "ind"; + List.init (Inductiveops.nconstructors env ind) (fun i -> + let c = (ind, i + 1) in + let gr = Names.GlobRef.ConstructRef c in + ( empty_hint_info + , Declareops.inductive_is_polymorphic mib + , true + , PathHints [gr] + , IsGlobRef gr )) + in + HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) + | HintsExtern (pri, patcom, tacexp) -> + let pat = Option.map (fp sigma) patcom in + let l = match pat with None -> [] | Some (l, _) -> l in + let ltacvars = + List.fold_left + (fun accu x -> Names.Id.Set.add x accu) + Names.Id.Set.empty l + in + let env = Genintern.{(empty_glob_sign env) with ltacvars} in + let _, tacexp = Genintern.generic_intern env tacexp in + HintsExternEntry + ({Typeclasses.hint_priority = Some pri; hint_pattern = pat}, tacexp) diff --git a/vernac/comHints.mli b/vernac/comHints.mli new file mode 100644 index 0000000000..77fbef5387 --- /dev/null +++ b/vernac/comHints.mli @@ -0,0 +1,29 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Typeclasses + +type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen + +type reference_or_constr = + | HintsReference of Libnames.qualid + | HintsConstr of Constrexpr.constr_expr + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * Libnames.qualid list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of Libnames.qualid list + | HintsTransparency of Libnames.qualid Hints.hints_transparency_target * bool + | HintsMode of Libnames.qualid * Hints.hint_mode list + | HintsConstructors of Libnames.qualid list + | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + +val interp_hints : poly:bool -> hints_expr -> Hints.hints_entry diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 80e7e6ab96..bf38088f71 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -195,13 +195,14 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let lift_lets = lift_rel_context 1 letbinders in let sigma, intern_body = let ctx = LocalAssum (make_annot (Name recname) Sorts.Relevant, get_type curry_fun) :: binders_rel in - let (r, impls, scopes) = - Constrintern.compute_internalization_data env sigma + let interning_data = + Constrintern.compute_internalization_data env sigma recname Constrintern.Recursive full_arity impls in let newimpls = Id.Map.singleton recname - (r, impls @ [Some (ExplByName (Id.of_string "recproof"), Impargs.Manual, (true, false))], - scopes @ [None]) in + (Constrintern.extend_internalization_data interning_data + (Some (ExplByName (Id.of_string "recproof"), Impargs.Manual, (true, false))) + None) in interp_casted_constr_evars ~program_mode:true (push_rel_context ctx env) sigma ~impls:newimpls body (lift 1 top_arity) in diff --git a/vernac/declare.ml b/vernac/declare.ml new file mode 100644 index 0000000000..366dd2d026 --- /dev/null +++ b/vernac/declare.ml @@ -0,0 +1,888 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This module is about the low-level declaration of logical objects *) + +open Pp +open Util +open Names +open Safe_typing +module NamedDecl = Context.Named.Declaration + +type opacity_flag = Opaque | Transparent + +type t = + { endline_tactic : Genarg.glob_generic_argument option + ; section_vars : Id.Set.t option + ; proof : Proof.t + ; udecl: UState.universe_decl + (** Initial universe declarations *) + ; initial_euctx : UState.t + (** The initial universe context (for the statement) *) + } + +(*** Proof Global manipulation ***) + +let get_proof ps = ps.proof +let get_proof_name ps = (Proof.data ps.proof).Proof.name + +let get_initial_euctx ps = ps.initial_euctx + +let map_proof f p = { p with proof = f p.proof } +let map_fold_proof f p = let proof, res = f p.proof in { p with proof }, res + +let map_fold_proof_endline f ps = + let et = + match ps.endline_tactic with + | None -> Proofview.tclUNIT () + | Some tac -> + let open Geninterp in + let {Proof.poly} = Proof.data ps.proof in + let ist = { lfun = Id.Map.empty; poly; extra = TacStore.empty } in + let Genarg.GenArg (Genarg.Glbwit tag, tac) = tac in + let tac = Geninterp.interp tag ist tac in + Ftactic.run tac (fun _ -> Proofview.tclUNIT ()) + in + let (newpr,ret) = f et ps.proof in + let ps = { ps with proof = newpr } in + ps, ret + +let compact_the_proof pf = map_proof Proof.compact pf + +(* Sets the tactic to be used when a tactic line is closed with [...] *) +let set_endline_tactic tac ps = + { ps with endline_tactic = Some tac } + +(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of + name [name] with goals [goals] (a list of pairs of environment and + conclusion). The proof is started in the evar map [sigma] (which + can typically contain universe constraints), and with universe + bindings [udecl]. *) +let start_proof ~name ~udecl ~poly sigma goals = + let proof = Proof.start ~name ~poly sigma goals in + let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in + { proof + ; endline_tactic = None + ; section_vars = None + ; udecl + ; initial_euctx + } + +let start_dependent_proof ~name ~udecl ~poly goals = + let proof = Proof.dependent_start ~name ~poly goals in + let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in + { proof + ; endline_tactic = None + ; section_vars = None + ; udecl + ; initial_euctx + } + +let get_used_variables pf = pf.section_vars +let get_universe_decl pf = pf.udecl + +let set_used_variables ps l = + let open Context.Named.Declaration in + let env = Global.env () in + let ids = List.fold_right Id.Set.add l Id.Set.empty in + let ctx = Environ.keep_hyps env ids in + let ctx_set = + List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in + let vars_of = Environ.global_vars_set in + let aux env entry (ctx, all_safe as orig) = + match entry with + | LocalAssum ({Context.binder_name=x},_) -> + if Id.Set.mem x all_safe then orig + else (ctx, all_safe) + | LocalDef ({Context.binder_name=x},bo, ty) as decl -> + if Id.Set.mem x all_safe then orig else + let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in + if Id.Set.subset vars all_safe + then (decl :: ctx, Id.Set.add x all_safe) + else (ctx, all_safe) in + let ctx, _ = + Environ.fold_named_context aux env ~init:(ctx,ctx_set) in + if not (Option.is_empty ps.section_vars) then + CErrors.user_err Pp.(str "Used section variables can be declared only once"); + ctx, { ps with section_vars = Some (Context.Named.to_vars ctx) } + +let get_open_goals ps = + let Proof.{ goals; stack; shelf } = Proof.data ps.proof in + List.length goals + + List.fold_left (+) 0 + (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + + List.length shelf + +(* object_kind , id *) +exception AlreadyDeclared of (string option * Id.t) + +let _ = CErrors.register_handler (function + | AlreadyDeclared (kind, id) -> + Some + (seq [ Pp.pr_opt_no_spc (fun s -> str s ++ spc ()) kind + ; Id.print id; str " already exists."]) + | _ -> + None) + +type import_status = ImportDefaultBehavior | ImportNeedQualified + +(** Declaration of constants and parameters *) + +type constant_obj = { + cst_kind : Decls.logical_kind; + cst_locl : import_status; +} + +type 'a proof_entry = { + proof_entry_body : 'a Entries.const_entry_body; + (* List of section variables *) + proof_entry_secctx : Id.Set.t option; + (* State id on which the completion of type checking is reported *) + proof_entry_feedback : Stateid.t option; + proof_entry_type : Constr.types option; + proof_entry_universes : Entries.universes_entry; + proof_entry_opaque : bool; + proof_entry_inline_code : bool; +} + +let default_univ_entry = Entries.Monomorphic_entry Univ.ContextSet.empty + +let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?types + ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) ?(univsbody=Univ.ContextSet.empty) body = + { proof_entry_body = Future.from_val ?fix_exn ((body,univsbody), eff); + proof_entry_secctx = section_vars; + proof_entry_type = types; + proof_entry_universes = univs; + proof_entry_opaque = opaque; + proof_entry_feedback = feedback_id; + proof_entry_inline_code = inline} + +type proof_object = + { name : Names.Id.t + (* [name] only used in the STM *) + ; entries : Evd.side_effects proof_entry list + ; uctx: UState.t + } + +let private_poly_univs = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Private";"Polymorphic";"Universes"] + ~value:true + +(* XXX: This is still separate from close_proof below due to drop_pt in the STM *) +(* XXX: Unsafe_typ:true is needed by vio files, see bf0499bc507d5a39c3d5e3bf1f69191339270729 *) +let prepare_proof ~unsafe_typ { proof } = + let Proof.{name=pid;entry;poly} = Proof.data proof in + let initial_goals = Proofview.initial_goals entry in + let evd = Proof.return ~pid proof in + let eff = Evd.eval_side_effects evd in + let evd = Evd.minimize_universes evd in + let to_constr_body c = + match EConstr.to_constr_opt evd c with + | Some p -> p + | None -> CErrors.user_err Pp.(str "Some unresolved existential variables remain") + in + let to_constr_typ t = + if unsafe_typ then EConstr.Unsafe.to_constr t else to_constr_body t + in + (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) + (* EJGA: actually side-effects de-duplication and this codepath is + unrelated. Duplicated side-effects arise from incorrect scheme + generation code, the main bulk of it was mostly fixed by #9836 + but duplication can still happen because of rewriting schemes I + think; however the code below is mostly untested, the only + code-paths that generate several proof entries are derive and + equations and so far there is no code in the CI that will + actually call those and do a side-effect, TTBOMK *) + (* EJGA: likely the right solution is to attach side effects to the first constant only? *) + let proofs = List.map (fun (body, typ) -> (to_constr_body body, eff), to_constr_typ typ) initial_goals in + proofs, Evd.evar_universe_context evd + +let close_proof ~opaque ~keep_body_ucst_separate ps = + + let { section_vars; proof; udecl; initial_euctx } = ps in + let { Proof.name; poly } = Proof.data proof in + let unsafe_typ = keep_body_ucst_separate && not poly in + let elist, uctx = prepare_proof ~unsafe_typ ps in + let opaque = match opaque with Opaque -> true | Transparent -> false in + + let make_entry ((body, eff), typ) = + + let allow_deferred = + not poly && + (keep_body_ucst_separate + || not (Safe_typing.is_empty_private_constants eff.Evd.seff_private)) + in + let used_univs_body = Vars.universes_of_constr body in + let used_univs_typ = Vars.universes_of_constr typ in + let used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let utyp, ubody = + if allow_deferred then + let utyp = UState.univ_entry ~poly initial_euctx in + let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in + (* For vi2vo compilation proofs are computed now but we need to + complement the univ constraints of the typ with the ones of + the body. So we keep the two sets distinct. *) + let uctx_body = UState.restrict uctx used_univs in + let ubody = UState.check_mono_univ_decl uctx_body udecl in + utyp, ubody + else if poly && opaque && private_poly_univs () then + let universes = UState.restrict uctx used_univs in + let typus = UState.restrict universes used_univs_typ in + let utyp = UState.check_univ_decl ~poly typus udecl in + let ubody = Univ.ContextSet.diff + (UState.context_set universes) + (UState.context_set typus) + in + utyp, ubody + else + (* Since the proof is computed now, we can simply have 1 set of + constraints in which we merge the ones for the body and the ones + for the typ. We recheck the declaration after restricting with + the actually used universes. + TODO: check if restrict is really necessary now. *) + let ctx = UState.restrict uctx used_univs in + let utyp = UState.check_univ_decl ~poly ctx udecl in + utyp, Univ.ContextSet.empty + in + definition_entry ~opaque ?section_vars ~univs:utyp ~univsbody:ubody ~types:typ ~eff body + in + let entries = CList.map make_entry elist in + { name; entries; uctx } + +type 'a constant_entry = + | DefinitionEntry of 'a proof_entry + | ParameterEntry of Entries.parameter_entry + | PrimitiveEntry of Entries.primitive_entry + +(* At load-time, the segment starting from the module name to the discharge *) +(* section (if Remark or Fact) is needed to access a construction *) +let load_constant i ((sp,kn), obj) = + if Nametab.exists_cci sp then + raise (AlreadyDeclared (None, Libnames.basename sp)); + let con = Global.constant_of_delta_kn kn in + Nametab.push (Nametab.Until i) sp (GlobRef.ConstRef con); + Dumpglob.add_constant_kind con obj.cst_kind + +(* Opening means making the name without its module qualification available *) +let open_constant f i ((sp,kn), obj) = + (* Never open a local definition *) + match obj.cst_locl with + | ImportNeedQualified -> () + | ImportDefaultBehavior -> + let con = Global.constant_of_delta_kn kn in + if Libobject.in_filter_ref (GlobRef.ConstRef con) f then + Nametab.push (Nametab.Exactly i) sp (GlobRef.ConstRef con) + +let exists_name id = + Decls.variable_exists id || Global.exists_objlabel (Label.of_id id) + +let check_exists id = + if exists_name id then + raise (AlreadyDeclared (None, id)) + +let cache_constant ((sp,kn), obj) = + (* Invariant: the constant must exist in the logical environment, except when + redefining it when exiting a section. See [discharge_constant]. *) + let kn' = + if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) + then Constant.make1 kn + else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") + in + assert (Constant.equal kn' (Constant.make1 kn)); + Nametab.push (Nametab.Until 1) sp (GlobRef.ConstRef (Constant.make1 kn)); + Dumpglob.add_constant_kind (Constant.make1 kn) obj.cst_kind + +let discharge_constant ((sp, kn), obj) = + Some obj + +(* Hack to reduce the size of .vo: we keep only what load/open needs *) +let dummy_constant cst = { + cst_kind = cst.cst_kind; + cst_locl = cst.cst_locl; +} + +let classify_constant cst = Libobject.Substitute (dummy_constant cst) + +let (objConstant : constant_obj Libobject.Dyn.tag) = + let open Libobject in + declare_object_full { (default_object "CONSTANT") with + cache_function = cache_constant; + load_function = load_constant; + open_function = open_constant; + classify_function = classify_constant; + subst_function = ident_subst_function; + discharge_function = discharge_constant } + +let inConstant v = Libobject.Dyn.Easy.inj v objConstant + +let update_tables c = + Impargs.declare_constant_implicits c; + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstRef c) + +let register_constant kn kind local = + let o = inConstant { + cst_kind = kind; + cst_locl = local; + } in + let id = Label.to_id (Constant.label kn) in + let _ = Lib.add_leaf id o in + update_tables kn + +let register_side_effect (c, role) = + let () = register_constant c Decls.(IsProof Theorem) ImportDefaultBehavior in + match role with + | None -> () + | Some (Evd.Schema (ind, kind)) -> DeclareScheme.declare_scheme kind [|ind,c|] + +let get_roles export eff = + let map c = + let role = try Some (Cmap.find c eff.Evd.seff_roles) with Not_found -> None in + (c, role) + in + List.map map export + +let export_side_effects eff = + let export = Global.export_private_constants eff.Evd.seff_private in + let export = get_roles export eff in + List.iter register_side_effect export + +let record_aux env s_ty s_bo = + let open Environ in + let in_ty = keep_hyps env s_ty in + let v = + String.concat " " + (CList.map_filter (fun decl -> + let id = NamedDecl.get_id decl in + if List.exists (NamedDecl.get_id %> Id.equal id) in_ty then None + else Some (Id.to_string id)) + (keep_hyps env s_bo)) in + Aux_file.record_in_aux "context_used" v + +let pure_definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types + ?(univs=default_univ_entry) body = + { proof_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), ()); + proof_entry_secctx = None; + proof_entry_type = types; + proof_entry_universes = univs; + proof_entry_opaque = opaque; + proof_entry_feedback = None; + proof_entry_inline_code = inline} + +let delayed_definition_entry ~opaque ?feedback_id ~section_vars ~univs ?types body = + { proof_entry_body = body + ; proof_entry_secctx = section_vars + ; proof_entry_type = types + ; proof_entry_universes = univs + ; proof_entry_opaque = opaque + ; proof_entry_feedback = feedback_id + ; proof_entry_inline_code = false + } + +let cast_proof_entry e = + let (body, ctx), () = Future.force e.proof_entry_body in + let univs = + if Univ.ContextSet.is_empty ctx then e.proof_entry_universes + else match e.proof_entry_universes with + | Entries.Monomorphic_entry ctx' -> + (* This can actually happen, try compiling EqdepFacts for instance *) + Entries.Monomorphic_entry (Univ.ContextSet.union ctx' ctx) + | Entries.Polymorphic_entry _ -> + CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition."); + in + { Entries.const_entry_body = body; + const_entry_secctx = e.proof_entry_secctx; + const_entry_feedback = e.proof_entry_feedback; + const_entry_type = e.proof_entry_type; + const_entry_universes = univs; + const_entry_inline_code = e.proof_entry_inline_code; + } + +type ('a, 'b) effect_entry = +| EffectEntry : (private_constants, private_constants Entries.const_entry_body) effect_entry +| PureEntry : (unit, Constr.constr) effect_entry + +let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proof_entry) : b Entries.opaque_entry = + let typ = match e.proof_entry_type with + | None -> assert false + | Some typ -> typ + in + let secctx = match e.proof_entry_secctx with + | None -> + let open Environ in + let env = Global.env () in + let hyp_typ, hyp_def = + if List.is_empty (Environ.named_context env) then + Id.Set.empty, Id.Set.empty + else + let ids_typ = global_vars_set env typ in + let pf, env = match entry with + | PureEntry -> + let (pf, _), () = Future.force e.proof_entry_body in + pf, env + | EffectEntry -> + let (pf, _), eff = Future.force e.proof_entry_body in + let env = Safe_typing.push_private_constants env eff in + pf, env + in + let vars = global_vars_set env pf in + ids_typ, vars + in + let () = if Aux_file.recording () then record_aux env hyp_typ hyp_def in + Environ.really_needed env (Id.Set.union hyp_typ hyp_def) + | Some hyps -> hyps + in + let (body, univs : b * _) = match entry with + | PureEntry -> + let (body, uctx), () = Future.force e.proof_entry_body in + let univs = match e.proof_entry_universes with + | Entries.Monomorphic_entry uctx' -> + Entries.Monomorphic_entry (Univ.ContextSet.union uctx uctx') + | Entries.Polymorphic_entry _ -> + assert (Univ.ContextSet.is_empty uctx); + e.proof_entry_universes + in + body, univs + | EffectEntry -> e.proof_entry_body, e.proof_entry_universes + in + { Entries.opaque_entry_body = body; + opaque_entry_secctx = secctx; + opaque_entry_feedback = e.proof_entry_feedback; + opaque_entry_type = typ; + opaque_entry_universes = univs; + } + +let feedback_axiom () = Feedback.(feedback AddedAxiom) + +let is_unsafe_typing_flags () = + let open Declarations in + let flags = Environ.typing_flags (Global.env()) in + not (flags.check_universes && flags.check_guarded && flags.check_positive) + +let define_constant ~name cd = + (* Logically define the constant and its subproofs, no libobject tampering *) + let decl, unsafe = match cd with + | DefinitionEntry de -> + (* We deal with side effects *) + if not de.proof_entry_opaque then + let body, eff = Future.force de.proof_entry_body in + (* This globally defines the side-effects in the environment + and registers their libobjects. *) + let () = export_side_effects eff in + let de = { de with proof_entry_body = Future.from_val (body, ()) } in + let cd = Entries.DefinitionEntry (cast_proof_entry de) in + ConstantEntry cd, false + else + let map (body, eff) = body, eff.Evd.seff_private in + let body = Future.chain de.proof_entry_body map in + let de = { de with proof_entry_body = body } in + let de = cast_opaque_proof_entry EffectEntry de in + OpaqueEntry de, false + | ParameterEntry e -> + ConstantEntry (Entries.ParameterEntry e), not (Lib.is_modtype_strict()) + | PrimitiveEntry e -> + ConstantEntry (Entries.PrimitiveEntry e), false + in + let kn = Global.add_constant name decl in + if unsafe || is_unsafe_typing_flags() then feedback_axiom(); + kn + +let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = + let () = check_exists name in + let kn = define_constant ~name cd in + (* Register the libobjects attached to the constants *) + let () = register_constant kn kind local in + kn + +let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind de = + let kn, eff = + let de = + if not de.proof_entry_opaque then + DefinitionEff (cast_proof_entry de) + else + let de = cast_opaque_proof_entry PureEntry de in + OpaqueEff de + in + Global.add_private_constant name de + in + let () = register_constant kn kind local in + let seff_roles = match role with + | None -> Cmap.empty + | Some r -> Cmap.singleton kn r + in + let eff = { Evd.seff_private = eff; Evd.seff_roles; } in + kn, eff + +let inline_private_constants ~uctx env ce = + let body, eff = Future.force ce.proof_entry_body in + let cb, ctx = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in + let uctx = UState.merge ~sideff:true Evd.univ_rigid uctx ctx in + cb, uctx + +(** Declaration of section variables and local definitions *) +type variable_declaration = + | SectionLocalDef of Evd.side_effects proof_entry + | SectionLocalAssum of { typ:Constr.types; impl:Glob_term.binding_kind; } + +(* This object is only for things which iterate over objects to find + variables (only Prettyp.print_context AFAICT) *) +let objVariable : unit Libobject.Dyn.tag = + let open Libobject in + declare_object_full { (default_object "VARIABLE") with + classify_function = (fun () -> Dispose)} + +let inVariable v = Libobject.Dyn.Easy.inj v objVariable + +let declare_variable ~name ~kind d = + (* Variables are distinguished by only short names *) + if Decls.variable_exists name then + raise (AlreadyDeclared (None, name)); + + let impl,opaque = match d with (* Fails if not well-typed *) + | SectionLocalAssum {typ;impl} -> + let () = Global.push_named_assum (name,typ) in + impl, true + | SectionLocalDef (de) -> + (* The body should already have been forced upstream because it is a + section-local definition, but it's not enforced by typing *) + let ((body, body_ui), eff) = Future.force de.proof_entry_body in + let () = export_side_effects eff in + let poly, entry_ui = match de.proof_entry_universes with + | Entries.Monomorphic_entry uctx -> false, uctx + | Entries.Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx + in + let univs = Univ.ContextSet.union body_ui entry_ui in + (* We must declare the universe constraints before type-checking the + term. *) + let () = DeclareUctx.declare_universe_context ~poly univs in + let se = { + Entries.secdef_body = body; + secdef_secctx = de.proof_entry_secctx; + secdef_feedback = de.proof_entry_feedback; + secdef_type = de.proof_entry_type; + } in + let () = Global.push_named_def (name, se) in + Glob_term.Explicit, de.proof_entry_opaque + in + Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); + Decls.(add_variable_data name {opaque;kind}); + ignore(Lib.add_leaf name (inVariable ()) : Libobject.object_name); + Impargs.declare_var_implicits ~impl name; + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) + +(* Declaration messages *) + +let pr_rank i = pr_nth (i+1) + +let fixpoint_message indexes l = + Flags.if_verbose Feedback.msg_info (match l with + | [] -> CErrors.anomaly (Pp.str "no recursive definition.") + | [id] -> Id.print id ++ str " is recursively defined" ++ + (match indexes with + | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" + | _ -> mt ()) + | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ + spc () ++ str "are recursively defined" ++ + match indexes with + | Some a -> spc () ++ str "(decreasing respectively on " ++ + prvect_with_sep pr_comma pr_rank a ++ + str " arguments)" + | None -> mt ())) + +let cofixpoint_message l = + Flags.if_verbose Feedback.msg_info (match l with + | [] -> CErrors.anomaly (Pp.str "No corecursive definition.") + | [id] -> Id.print id ++ str " is corecursively defined" + | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ + spc () ++ str "are corecursively defined")) + +let recursive_message isfix i l = + (if isfix then fixpoint_message i else cofixpoint_message) l + +let definition_message id = + Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined") + +let assumption_message id = + (* Changing "assumed" to "declared", "assuming" referring more to + the type of the object than to the name of the object (see + discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) + Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is declared") + +module Internal = struct + + let map_entry_body ~f entry = + { entry with proof_entry_body = Future.chain entry.proof_entry_body f } + + let map_entry_type ~f entry = + { entry with proof_entry_type = f entry.proof_entry_type } + + let set_opacity ~opaque entry = + { entry with proof_entry_opaque = opaque } + + let get_fix_exn entry = Future.fix_exn_of entry.proof_entry_body + + let rec decompose len c t accu = + let open Constr in + let open Context.Rel.Declaration in + if len = 0 then (c, t, accu) + else match kind c, kind t with + | Lambda (na, u, c), Prod (_, _, t) -> + decompose (pred len) c t (LocalAssum (na, u) :: accu) + | LetIn (na, b, u, c), LetIn (_, _, _, t) -> + decompose (pred len) c t (LocalDef (na, b, u) :: accu) + | _ -> assert false + + let rec shrink ctx sign c t accu = + let open Constr in + let open Vars in + match ctx, sign with + | [], [] -> (c, t, accu) + | p :: ctx, decl :: sign -> + if noccurn 1 c && noccurn 1 t then + let c = subst1 mkProp c in + let t = subst1 mkProp t in + shrink ctx sign c t accu + else + let c = Term.mkLambda_or_LetIn p c in + let t = Term.mkProd_or_LetIn p t in + let accu = if Context.Rel.Declaration.is_local_assum p + then mkVar (NamedDecl.get_id decl) :: accu + else accu + in + shrink ctx sign c t accu + | _ -> assert false + + let shrink_entry sign const = + let typ = match const.proof_entry_type with + | None -> assert false + | Some t -> t + in + (* The body has been forced by the call to [build_constant_by_tactic] *) + let () = assert (Future.is_over const.proof_entry_body) in + let ((body, uctx), eff) = Future.force const.proof_entry_body in + let (body, typ, ctx) = decompose (List.length sign) body typ [] in + let (body, typ, args) = shrink ctx sign body typ [] in + { const with + proof_entry_body = Future.from_val ((body, uctx), eff) + ; proof_entry_type = Some typ + }, args + + type nonrec constant_obj = constant_obj + + let objVariable = objVariable + let objConstant = objConstant + +end +(*** Proof Global Environment ***) + +type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t + +let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.computation) = + let { section_vars; proof; udecl; initial_euctx } = ps in + let { Proof.name; poly; entry; sigma } = Proof.data proof in + + (* We don't allow poly = true in this path *) + if poly then + CErrors.anomaly (Pp.str "Cannot delay universe-polymorphic constants."); + + let fpl, uctx = Future.split2 fpl in + (* Because of dependent subgoals at the beginning of proofs, we could + have existential variables in the initial types of goals, we need to + normalise them for the kernel. *) + let subst_evar k = Evd.existential_opt_value0 sigma k in + let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst initial_euctx) in + + (* We only support opaque proofs, this will be enforced by using + different entries soon *) + let opaque = true in + let make_entry p (_, types) = + (* Already checked the univ_decl for the type universes when starting the proof. *) + let univs = UState.univ_entry ~poly:false initial_euctx in + let types = nf (EConstr.Unsafe.to_constr types) in + + Future.chain p (fun (pt,eff) -> + (* Deferred proof, we already checked the universe declaration with + the initial universes, ensure that the final universes respect + the declaration as well. If the declaration is non-extensible, + this will prevent the body from adding universes and constraints. *) + let uctx = Future.force uctx in + let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in + let used_univs = Univ.LSet.union + (Vars.universes_of_constr types) + (Vars.universes_of_constr pt) + in + let univs = UState.restrict uctx used_univs in + let univs = UState.check_mono_univ_decl univs udecl in + (pt,univs),eff) + |> delayed_definition_entry ~opaque ~feedback_id ~section_vars ~univs ~types + in + let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in + { name; entries; uctx = initial_euctx } + +let close_future_proof = close_proof_delayed + +let return_partial_proof { proof } = + let proofs = Proof.partial_proof proof in + let Proof.{sigma=evd} = Proof.data proof in + let eff = Evd.eval_side_effects evd in + (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) + let proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in + proofs, Evd.evar_universe_context evd + +let return_proof ps = + let p, uctx = prepare_proof ~unsafe_typ:false ps in + List.map fst p, uctx + +let update_global_env = + map_proof (fun p -> + let { Proof.sigma } = Proof.data p in + let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in + let p, (status,info), _ = Proof.run_tactic (Global.env ()) tac p in + p) + +let next = let n = ref 0 in fun () -> incr n; !n + +let by tac = map_fold_proof (Proof.solve (Goal_select.SelectNth 1) None tac) + +let build_constant_by_tactic ~name ?(opaque=Transparent) ~uctx ~sign ~poly typ tac = + let evd = Evd.from_ctx uctx in + let goals = [ (Global.env_of_context sign , typ) ] in + let pf = start_proof ~name ~poly ~udecl:UState.default_univ_decl evd goals in + let pf, status = by tac pf in + let { entries; uctx } = close_proof ~opaque ~keep_body_ucst_separate:false pf in + match entries with + | [entry] -> + entry, status, uctx + | _ -> + CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") + +let build_by_tactic ?(side_eff=true) env ~uctx ~poly ~typ tac = + let name = Id.of_string ("temporary_proof"^string_of_int (next())) in + let sign = Environ.(val_of_named_context (named_context env)) in + let ce, status, univs = build_constant_by_tactic ~name ~uctx ~sign ~poly typ tac in + let cb, uctx = + if side_eff then inline_private_constants ~uctx env ce + else + (* GG: side effects won't get reset: no need to treat their universes specially *) + let (cb, ctx), _eff = Future.force ce.proof_entry_body in + cb, UState.merge ~sideff:false Evd.univ_rigid uctx ctx + in + cb, ce.proof_entry_type, status, univs + +let declare_abstract ~name ~poly ~kind ~sign ~secsign ~opaque ~solve_tac sigma concl = + (* EJGA: flush_and_check_evars is only used in abstract, could we + use a different API? *) + let concl = + try Evarutil.flush_and_check_evars sigma concl + with Evarutil.Uninstantiated_evar _ -> + CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials.") + in + let sigma, concl = + (* FIXME: should be done only if the tactic succeeds *) + let sigma = Evd.minimize_universes sigma in + sigma, Evarutil.nf_evars_universes sigma concl + in + let concl = EConstr.of_constr concl in + let uctx = Evd.evar_universe_context sigma in + let (const, safe, uctx) = + try build_constant_by_tactic ~name ~opaque:Transparent ~poly ~uctx ~sign:secsign concl solve_tac + with Logic_monad.TacticFailure e as src -> + (* if the tactic [tac] fails, it reports a [TacticFailure e], + which is an error irrelevant to the proof system (in fact it + means that [e] comes from [tac] failing to yield enough + success). Hence it reraises [e]. *) + let (_, info) = Exninfo.capture src in + Exninfo.iraise (e, info) + in + let sigma = Evd.set_universe_context sigma uctx in + let body, effs = Future.force const.proof_entry_body in + (* We drop the side-effects from the entry, they already exist in the ambient environment *) + let const = Internal.map_entry_body const ~f:(fun _ -> body, ()) in + (* EJGA: Hack related to the above call to + `build_constant_by_tactic` with `~opaque:Transparent`. Even if + the abstracted term is destined to be opaque, if we trigger the + `if poly && opaque && private_poly_univs ()` in `Proof_global` + kernel will boom. This deserves more investigation. *) + let const = Internal.set_opacity ~opaque const in + let const, args = Internal.shrink_entry sign const in + let cst () = + (* do not compute the implicit arguments, it may be costly *) + let () = Impargs.make_implicit_args false in + (* ppedrot: seems legit to have abstracted subproofs as local*) + declare_private_constant ~local:ImportNeedQualified ~name ~kind const + in + let cst, eff = Impargs.with_implicit_protection cst () in + let inst = match const.proof_entry_universes with + | Entries.Monomorphic_entry _ -> EConstr.EInstance.empty + | Entries.Polymorphic_entry (_, ctx) -> + (* We mimic what the kernel does, that is ensuring that no additional + constraints appear in the body of polymorphic constants. Ideally this + should be enforced statically. *) + let (_, body_uctx), _ = Future.force const.proof_entry_body in + let () = assert (Univ.ContextSet.is_empty body_uctx) in + EConstr.EInstance.make (Univ.UContext.instance ctx) + in + let args = List.map EConstr.of_constr args in + let lem = EConstr.mkConstU (cst, inst) in + let effs = Evd.concat_side_effects eff effs in + effs, sigma, lem, args, safe + +let get_goal_context pf i = + let p = get_proof pf in + Proof.get_goal_context_gen p i + +let get_current_goal_context pf = + let p = get_proof pf in + try Proof.get_goal_context_gen p 1 + with + | Proof.NoSuchGoal _ -> + (* spiwack: returning empty evar_map, since if there is no goal, + under focus, there is no accessible evar either. EJGA: this + seems strange, as we have pf *) + let env = Global.env () in + Evd.from_env env, env + +let get_current_context pf = + let p = get_proof pf in + Proof.get_proof_context p + +module Proof = struct + type nonrec t = t + let get_proof = get_proof + let get_proof_name = get_proof_name + let get_used_variables = get_used_variables + let get_universe_decl = get_universe_decl + let get_initial_euctx = get_initial_euctx + let map_proof = map_proof + let map_fold_proof = map_fold_proof + let map_fold_proof_endline = map_fold_proof_endline + let set_endline_tactic = set_endline_tactic + let set_used_variables = set_used_variables + let compact = compact_the_proof + let update_global_env = update_global_env + let get_open_goals = get_open_goals +end + +let declare_definition_scheme ~internal ~univs ~role ~name c = + let kind = Decls.(IsDefinition Scheme) in + let entry = pure_definition_entry ~univs c in + let kn, eff = declare_private_constant ~role ~kind ~name entry in + let () = if internal then () else definition_message name in + kn, eff + +let _ = Ind_tables.declare_definition_scheme := declare_definition_scheme +let _ = Abstract.declare_abstract := declare_abstract + +let declare_universe_context = DeclareUctx.declare_universe_context diff --git a/vernac/declare.mli b/vernac/declare.mli new file mode 100644 index 0000000000..e23e148ddc --- /dev/null +++ b/vernac/declare.mli @@ -0,0 +1,284 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Entries + +(** This module provides the official functions to declare new + variables, parameters, constants and inductive types in the global + environment. It also updates some accesory tables such as [Nametab] + (name resolution), [Impargs], and [Notations]. *) + +(** We provide two kind of fuctions: + + - one go functions, that will register a constant in one go, suited + for non-interactive definitions where the term is given. + + - two-phase [start/declare] functions which will create an + interactive proof, allow its modification, and saving when + complete. + + Internally, these functions mainly differ in that usually, the first + case doesn't require setting up the tactic engine. + + *) + +(** [Declare.Proof.t] Construction of constants using interactive proofs. *) +module Proof : sig + + type t + + (** XXX: These are internal and will go away from publis API once + lemmas is merged here *) + val get_proof : t -> Proof.t + val get_proof_name : t -> Names.Id.t + + (** XXX: These 3 are only used in lemmas *) + val get_used_variables : t -> Names.Id.Set.t option + val get_universe_decl : t -> UState.universe_decl + val get_initial_euctx : t -> UState.t + + val map_proof : (Proof.t -> Proof.t) -> t -> t + val map_fold_proof : (Proof.t -> Proof.t * 'a) -> t -> t * 'a + val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a + + (** Sets the tactic to be used when a tactic line is closed with [...] *) + val set_endline_tactic : Genarg.glob_generic_argument -> t -> t + + (** Sets the section variables assumed by the proof, returns its closure + * (w.r.t. type dependencies and let-ins covered by it) *) + val set_used_variables : t -> + Names.Id.t list -> Constr.named_context * t + + val compact : t -> t + + (** Update the proofs global environment after a side-effecting command + (e.g. a sublemma definition) has been run inside it. Assumes + there_are_pending_proofs. *) + val update_global_env : t -> t + + val get_open_goals : t -> int + +end + +type opacity_flag = Opaque | Transparent + +(** [start_proof ~name ~udecl ~poly sigma goals] starts a proof of + name [name] with goals [goals] (a list of pairs of environment and + conclusion); [poly] determines if the proof is universe + polymorphic. The proof is started in the evar map [sigma] (which + can typically contain universe constraints), and with universe + bindings [udecl]. *) +val start_proof + : name:Names.Id.t + -> udecl:UState.universe_decl + -> poly:bool + -> Evd.evar_map + -> (Environ.env * EConstr.types) list + -> Proof.t + +(** Like [start_proof] except that there may be dependencies between + initial goals. *) +val start_dependent_proof + : name:Names.Id.t + -> udecl:UState.universe_decl + -> poly:bool + -> Proofview.telescope + -> Proof.t + +(** Proof entries represent a proof that has been finished, but still + not registered with the kernel. + + XXX: Scheduled for removal from public API, don't rely on it *) +type 'a proof_entry = private { + proof_entry_body : 'a Entries.const_entry_body; + (* List of section variables *) + proof_entry_secctx : Id.Set.t option; + (* State id on which the completion of type checking is reported *) + proof_entry_feedback : Stateid.t option; + proof_entry_type : Constr.types option; + proof_entry_universes : Entries.universes_entry; + proof_entry_opaque : bool; + proof_entry_inline_code : bool; +} + +(** XXX: Scheduled for removal from public API, don't rely on it *) +type proof_object = private + { name : Names.Id.t + (** name of the proof *) + ; entries : Evd.side_effects proof_entry list + (** list of the proof terms (in a form suitable for definitions). *) + ; uctx: UState.t + (** universe state *) + } + +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Proof.t -> proof_object + +(** Declaration of local constructions (Variable/Hypothesis/Local) *) + +(** XXX: Scheduled for removal from public API, don't rely on it *) +type variable_declaration = + | SectionLocalDef of Evd.side_effects proof_entry + | SectionLocalAssum of { typ:types; impl:Glob_term.binding_kind; } + +(** XXX: Scheduled for removal from public API, don't rely on it *) +type 'a constant_entry = + | DefinitionEntry of 'a proof_entry + | ParameterEntry of parameter_entry + | PrimitiveEntry of primitive_entry + +val declare_variable + : name:variable + -> kind:Decls.logical_kind + -> variable_declaration + -> unit + +(** Declaration of global constructions + i.e. Definition/Theorem/Axiom/Parameter/... + + XXX: Scheduled for removal from public API, use `DeclareDef` instead *) +val definition_entry + : ?fix_exn:Future.fix_exn + -> ?opaque:bool + -> ?inline:bool + -> ?feedback_id:Stateid.t + -> ?section_vars:Id.Set.t + -> ?types:types + -> ?univs:Entries.universes_entry + -> ?eff:Evd.side_effects + -> ?univsbody:Univ.ContextSet.t + (** Universe-constraints attached to the body-only, used in + vio-delayed opaque constants and private poly universes *) + -> constr + -> Evd.side_effects proof_entry + +type import_status = ImportDefaultBehavior | ImportNeedQualified + +(** [declare_constant id cd] declares a global declaration + (constant/parameter) with name [id] in the current section; it returns + the full path of the declaration + + internal specify if the constant has been created by the kernel or by the + user, and in the former case, if its errors should be silent + + XXX: Scheduled for removal from public API, use `DeclareDef` instead *) +val declare_constant + : ?local:import_status + -> name:Id.t + -> kind:Decls.logical_kind + -> Evd.side_effects constant_entry + -> Constant.t + +(** [inline_private_constants ~sideff ~uctx env ce] will inline the + constants in [ce]'s body and return the body plus the updated + [UState.t]. + + XXX: Scheduled for removal from public API, don't rely on it *) +val inline_private_constants + : uctx:UState.t + -> Environ.env + -> Evd.side_effects proof_entry + -> Constr.t * UState.t + +(** Declaration messages *) + +(** XXX: Scheduled for removal from public API, do not use *) +val definition_message : Id.t -> unit +val assumption_message : Id.t -> unit +val fixpoint_message : int array option -> Id.t list -> unit +val recursive_message : bool (** true = fixpoint *) -> + int array option -> Id.t list -> unit + +val check_exists : Id.t -> unit + +(* Used outside this module only in indschemes *) +exception AlreadyDeclared of (string option * Id.t) + +(** {6 For legacy support, do not use} *) + +module Internal : sig + + val map_entry_body : f:('a Entries.proof_output -> 'b Entries.proof_output) -> 'a proof_entry -> 'b proof_entry + val map_entry_type : f:(Constr.t option -> Constr.t option) -> 'a proof_entry -> 'a proof_entry + (* Overriding opacity is indeed really hacky *) + val set_opacity : opaque:bool -> 'a proof_entry -> 'a proof_entry + + (* TODO: This is only used in DeclareDef to forward the fix to + hooks, should eventually go away *) + val get_fix_exn : 'a proof_entry -> Future.fix_exn + + val shrink_entry : EConstr.named_context -> 'a proof_entry -> 'a proof_entry * Constr.constr list + + type constant_obj + + val objConstant : constant_obj Libobject.Dyn.tag + val objVariable : unit Libobject.Dyn.tag + +end + +(* Intermediate step necessary to delegate the future. + * Both access the current proof state. The former is supposed to be + * chained with a computation that completed the proof *) +type closed_proof_output + +(** Requires a complete proof. *) +val return_proof : Proof.t -> closed_proof_output + +(** An incomplete proof is allowed (no error), and a warn is given if + the proof is complete. *) +val return_partial_proof : Proof.t -> closed_proof_output +val close_future_proof : feedback_id:Stateid.t -> Proof.t -> closed_proof_output Future.computation -> proof_object + +(** [by tac] applies tactic [tac] to the 1st subgoal of the current + focused proof. + Returns [false] if an unsafe tactic has been used. *) +val by : unit Proofview.tactic -> Proof.t -> Proof.t * bool + +val build_by_tactic + : ?side_eff:bool + -> Environ.env + -> uctx:UState.t + -> poly:bool + -> typ:EConstr.types + -> unit Proofview.tactic + -> Constr.constr * Constr.types option * bool * UState.t + +(** {6 Helpers to obtain proof state when in an interactive proof } *) + +(** [get_goal_context n] returns the context of the [n]th subgoal of + the current focused proof or raises a [UserError] if there is no + focused proof or if there is no more subgoals *) + +val get_goal_context : Proof.t -> int -> Evd.evar_map * Environ.env + +(** [get_current_goal_context ()] works as [get_goal_context 1] *) +val get_current_goal_context : Proof.t -> Evd.evar_map * Environ.env + +(** [get_current_context ()] returns the context of the + current focused goal. If there is no focused goal but there + is a proof in progress, it returns the corresponding evar_map. + If there is no pending proof then it returns the current global + environment and empty evar_map. *) +val get_current_context : Proof.t -> Evd.evar_map * Environ.env + +(** Temporarily re-exported for 3rd party code; don't use *) +val build_constant_by_tactic : + name:Names.Id.t -> + ?opaque:opacity_flag -> + uctx:UState.t -> + sign:Environ.named_context_val -> + poly:bool -> + EConstr.types -> + unit Proofview.tactic -> + Evd.side_effects proof_entry * bool * UState.t + +val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit +[@@ocaml.deprecated "Use DeclareUctx.declare_universe_context"] diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 1607771598..1809c2bc91 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -112,7 +112,7 @@ let declare_mutually_recursive ~opaque ~scope ~kind ~poly ~uctx ~udecl ~ntns ~re declare_entry ~name ~scope ~kind ~impargs ~uctx entry) fixitems fixdecls in - let isfix = Option.is_empty possible_indexes in + let isfix = Option.has_some possible_indexes in let fixnames = List.map (fun { Recthm.name } -> name) fixitems in Declare.recursive_message isfix indexes fixnames; List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; @@ -171,7 +171,7 @@ let prepare_obligation ?opaque ?inline ~name ~poly ~udecl ~types ~body sigma = let ce = definition_entry ?opaque ?inline ?types ~univs body in let env = Global.env () in let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in - assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); + assert(Safe_typing.is_empty_private_constants sideff.Evd.seff_private); assert(Univ.ContextSet.is_empty ctx); RetrieveObl.check_evars env sigma; let c = EConstr.of_constr c in diff --git a/vernac/declareInd.ml b/vernac/declareInd.ml index 2610f16d92..e22d63b811 100644 --- a/vernac/declareInd.ml +++ b/vernac/declareInd.ml @@ -49,9 +49,12 @@ let load_inductive i ((sp, kn), names) = let names = inductive_names sp kn names in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names -let open_inductive i ((sp, kn), names) = +let open_inductive f i ((sp, kn), names) = let names = inductive_names sp kn names in - List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names + List.iter (fun (sp, ref) -> + if Libobject.in_filter_ref ref f then + Nametab.push (Nametab.Exactly i) sp ref) + names let cache_inductive ((sp, kn), names) = let names = inductive_names sp kn names in @@ -93,38 +96,6 @@ let inPrim : (Projection.Repr.t * Constant.t) -> Libobject.obj = let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) -let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = - let name = Label.to_id label in - let univs, u = match univs with - | Monomorphic_entry _ -> - (* Global constraints already defined through the inductive *) - Monomorphic_entry Univ.ContextSet.empty, Univ.Instance.empty - | Polymorphic_entry (nas, ctx) -> - Polymorphic_entry (nas, ctx), Univ.UContext.instance ctx - in - let term = Vars.subst_instance_constr u term in - let types = Vars.subst_instance_constr u types in - let entry = Declare.definition_entry ~types ~univs term in - let cst = Declare.declare_constant ~name ~kind:Decls.(IsDefinition StructureComponent) (Declare.DefinitionEntry entry) in - let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in - declare_primitive_projection p cst - -let declare_projections univs mind = - let env = Global.env () in - let mib = Environ.lookup_mind mind env in - let open Declarations in - match mib.mind_record with - | PrimRecord info -> - let iter_ind i (_, labs, _, _) = - let ind = (mind, i) in - let projs = Inductiveops.compute_projections env ind in - CArray.iter2_i (declare_one_projection univs ind ~proj_npars:mib.mind_nparams) labs projs - in - let () = Array.iteri iter_ind info in - true - | FakeRecord -> false - | NotRecord -> false - let feedback_axiom () = Feedback.(feedback AddedAxiom) let is_unsafe_typing_flags () = @@ -146,7 +117,7 @@ let declare_mind mie = let (sp,kn as oname) = Lib.add_leaf id (inInductive { ind_names = names }) in if is_unsafe_typing_flags() then feedback_axiom (); let mind = Global.mind_of_delta_kn kn in - let isprim = declare_projections mie.mind_entry_universes mind in + let isprim = Inductive.is_primitive_record (Inductive.lookup_mind_specif (Global.env()) (mind,0)) in Impargs.declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; oname, isprim diff --git a/vernac/declareInd.mli b/vernac/declareInd.mli index ae649634a5..05a1617329 100644 --- a/vernac/declareInd.mli +++ b/vernac/declareInd.mli @@ -30,3 +30,6 @@ type inductive_obj val objInductive : inductive_obj Libobject.Dyn.tag end + +val declare_primitive_projection : + Names.Projection.Repr.t -> Names.Constant.t -> unit diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index 300dfe6c35..89f3503f4d 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -56,7 +56,7 @@ let input_univ_names : universe_name_decl -> Libobject.obj = { (default_object "Global universe name state") with cache_function = cache_univ_names; load_function = load_univ_names; - open_function = open_univ_names; + open_function = simple_open open_univ_names; discharge_function = discharge_univ_names; subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); classify_function = (fun a -> Substitute a) } @@ -94,7 +94,7 @@ let do_universe ~poly l = in let src = if poly then BoundUniv else UnqualifiedUniv in let () = Lib.add_anonymous_leaf (input_univ_names (src, l)) in - Declare.declare_universe_context ~poly ctx + DeclareUctx.declare_universe_context ~poly ctx let do_constraint ~poly l = let open Univ in @@ -107,4 +107,4 @@ let do_constraint ~poly l = Constraint.empty l in let uctx = ContextSet.add_constraints constraints ContextSet.empty in - Declare.declare_universe_context ~poly uctx + DeclareUctx.declare_universe_context ~poly uctx diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index 4f527b73d0..438509e28a 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -81,6 +81,19 @@ module ModSubstObjs : let sobjs_no_functor (mbids,_) = List.is_empty mbids +let subst_filtered sub (f,mp) = + let f = match f with + | Unfiltered -> Unfiltered + | Names ns -> + let module NSet = Globnames.ExtRefSet in + let ns = + NSet.fold (fun n ns -> NSet.add (Globnames.subst_extended_reference sub n) ns) + ns NSet.empty + in + Names ns + in + f, subst_mp sub mp + let rec subst_aobjs sub = function | Objs o as objs -> let o' = subst_objects sub o in @@ -109,7 +122,7 @@ and subst_objects subst seg = let aobjs' = subst_aobjs subst aobjs in if aobjs' == aobjs then node else (id, IncludeObject aobjs') | ExportObject { mpl } -> - let mpl' = List.map (subst_mp subst) mpl in + let mpl' = List.Smart.map (subst_filtered subst) mpl in if mpl'==mpl then node else (id, ExportObject { mpl = mpl' }) | KeepObject _ -> assert false in @@ -285,86 +298,103 @@ and load_keep i ((sp,kn),kobjs) = (** {6 Implementation of Import and Export commands} *) -let mark_object obj (exports,acc) = - (exports, obj::acc) +let mark_object f obj (exports,acc) = + (exports, (f,obj)::acc) -let rec collect_module_objects mp acc = +let rec collect_module_objects (f,mp) acc = (* May raise Not_found for unknown module and for functors *) let modobjs = ModObjs.get mp in let prefix = modobjs.module_prefix in - let acc = collect_objects 1 prefix modobjs.module_keep_objects acc in - collect_objects 1 prefix modobjs.module_substituted_objects acc + let acc = collect_objects f 1 prefix modobjs.module_keep_objects acc in + collect_objects f 1 prefix modobjs.module_substituted_objects acc -and collect_object i (name, obj as o) acc = +and collect_object f i (name, obj as o) acc = match obj with - | ExportObject { mpl; _ } -> collect_export i mpl acc + | ExportObject { mpl } -> collect_export f i mpl acc | AtomicObject _ | IncludeObject _ | KeepObject _ - | ModuleObject _ | ModuleTypeObject _ -> mark_object o acc + | ModuleObject _ | ModuleTypeObject _ -> mark_object f o acc + +and collect_objects f i prefix objs acc = + List.fold_right (fun (id, obj) acc -> collect_object f i (Lib.make_oname prefix id, obj) acc) objs acc + +and collect_one_export f (f',mp) (exports,objs as acc) = + match filter_and f f' with + | None -> acc + | Some f -> + let exports' = MPmap.update mp (function + | None -> Some f + | Some f0 -> Some (filter_or f f0)) + exports + in + (* If the map doesn't change there is nothing new to export. -and collect_objects i prefix objs acc = - List.fold_right (fun (id, obj) acc -> collect_object i (Lib.make_oname prefix id, obj) acc) objs acc + It's possible that [filter_and] or [filter_or] mangled precise + filters such that we repeat uselessly, but the important + [Unfiltered] case is handled correctly. + *) + if exports == exports' then acc + else + collect_module_objects (f,mp) (exports', objs) -and collect_one_export mp (exports,objs as acc) = - if not (MPset.mem mp exports) then - collect_module_objects mp (MPset.add mp exports, objs) - else acc -and collect_export i mpl acc = +and collect_export f i mpl acc = if Int.equal i 1 then - List.fold_right collect_one_export mpl acc + List.fold_right (collect_one_export f) mpl acc else acc -let rec open_object i (name, obj) = +let open_modtype i ((sp,kn),_) = + let mp = mp_of_kn kn in + let mp' = + try Nametab.locate_modtype (qualid_of_path sp) + with Not_found -> + anomaly (pr_path sp ++ str " should already exist!"); + in + assert (ModPath.equal mp mp'); + Nametab.push_modtype (Nametab.Exactly i) sp mp + +let rec open_object f i (name, obj) = match obj with - | AtomicObject o -> Libobject.open_object i (name, o) + | AtomicObject o -> Libobject.open_object f i (name, o) | ModuleObject sobjs -> let dir = dir_of_sp (fst name) in let mp = mp_of_kn (snd name) in - open_module i dir mp sobjs + open_module f i dir mp sobjs | ModuleTypeObject sobjs -> open_modtype i (name, sobjs) - | IncludeObject aobjs -> open_include i (name, aobjs) - | ExportObject { mpl; _ } -> open_export i mpl - | KeepObject objs -> open_keep i (name, objs) + | IncludeObject aobjs -> open_include f i (name, aobjs) + | ExportObject { mpl } -> open_export f i mpl + | KeepObject objs -> open_keep f i (name, objs) -and open_module i obj_dir obj_mp sobjs = +and open_module f i obj_dir obj_mp sobjs = let prefix = Nametab.{ obj_dir ; obj_mp; } in let dirinfo = Nametab.GlobDirRef.DirModule prefix in consistency_checks true obj_dir dirinfo; - Nametab.push_dir (Nametab.Exactly i) obj_dir dirinfo; + (match f with + | Unfiltered -> Nametab.push_dir (Nametab.Exactly i) obj_dir dirinfo + | Names _ -> ()); (* If we're not a functor, let's iter on the internal components *) if sobjs_no_functor sobjs then begin let modobjs = ModObjs.get obj_mp in - open_objects (i+1) modobjs.module_prefix modobjs.module_substituted_objects + open_objects f (i+1) modobjs.module_prefix modobjs.module_substituted_objects end -and open_objects i prefix objs = - List.iter (fun (id, obj) -> open_object i (Lib.make_oname prefix id, obj)) objs - -and open_modtype i ((sp,kn),_) = - let mp = mp_of_kn kn in - let mp' = - try Nametab.locate_modtype (qualid_of_path sp) - with Not_found -> - anomaly (pr_path sp ++ str " should already exist!"); - in - assert (ModPath.equal mp mp'); - Nametab.push_modtype (Nametab.Exactly i) sp mp +and open_objects f i prefix objs = + List.iter (fun (id, obj) -> open_object f i (Lib.make_oname prefix id, obj)) objs -and open_include i ((sp,kn), aobjs) = +and open_include f i ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in - open_objects i prefix o + open_objects f i prefix o -and open_export i mpl = - let _,objs = collect_export i mpl (MPset.empty, []) in - List.iter (open_object 1) objs +and open_export f i mpl = + let _,objs = collect_export f i mpl (MPmap.empty, []) in + List.iter (fun (f,o) -> open_object f 1 o) objs -and open_keep i ((sp,kn),kobjs) = +and open_keep f i ((sp,kn),kobjs) = let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in let prefix = Nametab.{ obj_dir; obj_mp; } in - open_objects i prefix kobjs + open_objects f i prefix kobjs let rec cache_object (name, obj) = match obj with @@ -383,7 +413,7 @@ and cache_include ((sp,kn), aobjs) = let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in load_objects 1 prefix o; - open_objects 1 prefix o + open_objects Unfiltered 1 prefix o and cache_keep ((sp,kn),kobjs) = anomaly (Pp.str "This module should not be cached!") @@ -1023,12 +1053,12 @@ let end_library ?except ~output_native_objects dir = cenv,(substitute,keep),ast let import_modules ~export mpl = - let _,objs = List.fold_right collect_module_objects mpl (MPset.empty, []) in - List.iter (open_object 1) objs; + let _,objs = List.fold_right collect_module_objects mpl (MPmap.empty, []) in + List.iter (fun (f,o) -> open_object f 1 o) objs; if export then Lib.add_anonymous_entry (Lib.Leaf (ExportObject { mpl })) -let import_module ~export mp = - import_modules ~export [mp] +let import_module f ~export mp = + import_modules ~export [f,mp] (** {6 Iterators} *) @@ -1073,6 +1103,6 @@ let debug_print_modtab _ = let mod_ops = { - Printmod.import_module = import_module; + Printmod.import_module = import_module Unfiltered; process_module_binding = process_module_binding; } diff --git a/vernac/declaremods.mli b/vernac/declaremods.mli index e37299aad6..5e45957e83 100644 --- a/vernac/declaremods.mli +++ b/vernac/declaremods.mli @@ -97,11 +97,11 @@ val append_end_library_hook : (unit -> unit) -> unit or when [mp] corresponds to a functor. If [export] is [true], the module is also opened every time the module containing it is. *) -val import_module : export:bool -> ModPath.t -> unit +val import_module : Libobject.open_filter -> export:bool -> ModPath.t -> unit (** Same as [import_module] but for multiple modules, and more optimized than iterating [import_module]. *) -val import_modules : export:bool -> ModPath.t list -> unit +val import_modules : export:bool -> (Libobject.open_filter * ModPath.t) list -> unit (** Include *) diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index 247f80181a..e84fce5504 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -14,7 +14,7 @@ open Glob_term open Constrexpr open Vernacexpr open Hints -open Proof_global +open ComHints open Pcoq open Pcoq.Prim @@ -65,12 +65,12 @@ GRAMMAR EXTEND Gram | IDENT "Existential"; n = natural; c = constr_body -> { VernacSolveExistential (n,c) } | IDENT "Admitted" -> { VernacEndProof Admitted } - | IDENT "Qed" -> { VernacEndProof (Proved (Opaque,None)) } + | IDENT "Qed" -> { VernacEndProof (Proved (Declare.Opaque,None)) } | IDENT "Save"; id = identref -> - { VernacEndProof (Proved (Opaque, Some id)) } - | IDENT "Defined" -> { VernacEndProof (Proved (Transparent,None)) } + { VernacEndProof (Proved (Declare.Opaque, Some id)) } + | IDENT "Defined" -> { VernacEndProof (Proved (Declare.Transparent,None)) } | IDENT "Defined"; id=identref -> - { VernacEndProof (Proved (Transparent,Some id)) } + { VernacEndProof (Proved (Declare.Transparent,Some id)) } | IDENT "Restart" -> { VernacRestart } | IDENT "Undo" -> { VernacUndo 1 } | IDENT "Undo"; n = natural -> { VernacUndo n } diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 1f52641b82..13145d3757 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -566,14 +566,21 @@ GRAMMAR EXTEND Gram | IDENT "From" ; ns = global ; IDENT "Require"; export = export_token ; qidl = LIST1 global -> { VernacRequire (Some ns, export, qidl) } - | IDENT "Import"; qidl = LIST1 global -> { VernacImport (false,qidl) } - | IDENT "Export"; qidl = LIST1 global -> { VernacImport (true,qidl) } + | IDENT "Import"; qidl = LIST1 filtered_import -> { VernacImport (false,qidl) } + | IDENT "Export"; qidl = LIST1 filtered_import -> { VernacImport (true,qidl) } | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr -> { VernacInclude(e::l) } | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type -> { warn_deprecated_include_type ~loc (); VernacInclude(e::l) } ] ] ; + filtered_import: + [ [ m = global -> { (m, ImportAll) } + | m = global; "("; ns = LIST1 one_import_filter_name SEP ","; ")" -> { (m, ImportNames ns) } ] ] + ; + one_import_filter_name: + [ [ n = global; etc = OPT [ "("; ".."; ")" -> { () } ] -> { n, Option.has_some etc } ] ] + ; export_token: [ [ IDENT "Import" -> { Some false } | IDENT "Export" -> { Some true } @@ -931,23 +938,23 @@ GRAMMAR EXTEND Gram | IDENT "Print"; IDENT "Table"; table = option_table -> { VernacPrintOption table } - | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value + | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 table_value -> { VernacAddOption ([table;field], v) } (* A global value below will be hidden by a field above! *) (* In fact, we give priority to secondary tables *) (* No syntax for tertiary tables due to conflict *) (* (but they are unused anyway) *) - | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> + | IDENT "Add"; table = IDENT; v = LIST1 table_value -> { VernacAddOption ([table], v) } - | IDENT "Test"; table = option_table; "for"; v = LIST1 option_ref_value + | IDENT "Test"; table = option_table; "for"; v = LIST1 table_value -> { VernacMemOption (table, v) } | IDENT "Test"; table = option_table -> { VernacPrintOption table } - | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value + | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 table_value -> { VernacRemoveOption ([table;field], v) } - | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> + | IDENT "Remove"; table = IDENT; v = LIST1 table_value -> { VernacRemoveOption ([table], v) } ]] ; query_command: (* TODO: rapprocher Eval et Check *) @@ -1040,9 +1047,9 @@ GRAMMAR EXTEND Gram | n = integer -> { OptionSetInt n } | s = STRING -> { OptionSetString s } ] ] ; - option_ref_value: - [ [ id = global -> { QualidRefValue id } - | s = STRING -> { StringRefValue s } ] ] + table_value: + [ [ id = global -> { Goptions.QualidRefValue id } + | s = STRING -> { Goptions.StringRefValue s } ] ] ; option_table: [ [ fl = LIST1 [ x = IDENT -> { x } ] -> { fl } ]] diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 5555a2c68e..fddc84b398 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -57,16 +57,16 @@ let contract3 env sigma a b c = match contract env sigma [a;b;c] with let contract4 env sigma a b c d = match contract env sigma [a;b;c;d] with | env, [a;b;c;d] -> (env,a,b,c),d | _ -> assert false -let contract1_vect env sigma a v = - match contract env sigma (a :: Array.to_list v) with - | env, a::l -> env,a,Array.of_list l +let contract1 env sigma a v = + match contract env sigma (a :: v) with + | env, a::l -> env,a,l | _ -> assert false let rec contract3' env sigma a b c = function | OccurCheck (evk,d) -> let x,d = contract4 env sigma a b c d in x,OccurCheck(evk, d) | NotClean ((evk,args),env',d) -> - let env',d,args = contract1_vect env' sigma d args in + let env',d,args = contract1 env' sigma d args in contract3 env sigma a b c,NotClean((evk,args),env',d) | ConversionFailed (env',t1,t2) -> let (env',t1,t2) = contract2 env' sigma t1 t2 in @@ -299,9 +299,9 @@ let explain_unification_error env sigma p1 p2 = function [str "cannot instantiate " ++ quote (pr_existential_key sigma evk) ++ strbrk " because " ++ pr_leconstr_env env sigma c ++ strbrk " is not in its scope" ++ - (if Array.is_empty args then mt() else + (if List.is_empty args then mt() else strbrk ": available arguments are " ++ - pr_sequence (pr_leconstr_env env sigma) (List.rev (Array.to_list args)))] + pr_sequence (pr_leconstr_env env sigma) (List.rev args))] | NotSameArgSize | NotSameHead | NoCanonicalStructure -> (* Error speaks from itself *) [] | ConversionFailed (env,t1,t2) -> diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 7260b13ff6..6ffa88874b 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -91,12 +91,11 @@ let () = optwrite = (fun b -> rewriting_flag := b) } (* Util *) - let define ~poly name sigma c types = - let f = declare_constant ~kind:Decls.(IsDefinition Scheme) in let univs = Evd.univ_entry ~poly sigma in let entry = Declare.definition_entry ~univs ?types c in - let kn = f ~name (DefinitionEntry entry) in + let kind = Decls.(IsDefinition Scheme) in + let kn = declare_constant ~kind ~name (DefinitionEntry entry) in definition_message name; kn diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 7f7340bb34..b13e5bf653 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -62,14 +62,14 @@ end (* Proofs with a save constant function *) type t = - { proof : Proof_global.t + { proof : Declare.Proof.t ; info : Info.t } let pf_map f pf = { pf with proof = f pf.proof } let pf_fold f pf = f pf.proof -let set_endline_tactic t = pf_map (Proof_global.set_endline_tactic t) +let set_endline_tactic t = pf_map (Declare.Proof.set_endline_tactic t) (* To be removed *) module Internal = struct @@ -81,7 +81,7 @@ module Internal = struct end let by tac pf = - let proof, res = Pfedit.by tac pf.proof in + let proof, res = Declare.by tac pf.proof in { pf with proof }, res (************************************************************************) @@ -113,7 +113,7 @@ let start_lemma ~name ~poly "opaque", this is a hack tho, see #10446 *) let sign = initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in - let proof = Proof_global.start_proof sigma ~name ~udecl ~poly goals in + let proof = Declare.start_proof sigma ~name ~udecl ~poly goals in let info = add_first_thm ~info ~name ~typ:c ~impargs in { proof; info } @@ -123,7 +123,7 @@ let start_lemma ~name ~poly let start_dependent_lemma ~name ~poly ?(udecl=UState.default_univ_decl) ?(info=Info.make ()) telescope = - let proof = Proof_global.start_dependent_proof ~name ~udecl ~poly telescope in + let proof = Declare.start_dependent_proof ~name ~udecl ~poly telescope in { proof; info } let rec_tac_initializer finite guard thms snl = @@ -173,7 +173,7 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua (* start_lemma has the responsibility to add (name, impargs, typ) to thms, once Info.t is more refined this won't be necessary *) let lemma = start_lemma ~name ~impargs ~poly ~udecl ~info sigma (EConstr.of_constr typ) in - pf_map (Proof_global.map_proof (fun p -> + pf_map (Declare.Proof.map_proof (fun p -> pi1 @@ Proof.run_tactic Global.(env ()) init_tac p)) lemma (************************************************************************) @@ -275,7 +275,7 @@ let get_keep_admitted_vars = let compute_proof_using_for_admitted proof typ pproofs = if not (get_keep_admitted_vars ()) then None - else match Proof_global.get_used_variables proof, pproofs with + else match Declare.Proof.get_used_variables proof, pproofs with | Some _ as x, _ -> x | None, pproof :: _ -> let env = Global.env () in @@ -291,17 +291,17 @@ let finish_admitted ~info ~uctx pe = () let save_lemma_admitted ~(lemma : t) : unit = - let udecl = Proof_global.get_universe_decl lemma.proof in - let Proof.{ poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in + let udecl = Declare.Proof.get_universe_decl lemma.proof in + let Proof.{ poly; entry } = Proof.data (Declare.Proof.get_proof lemma.proof) in let typ = match Proofview.initial_goals entry with | [typ] -> snd typ | _ -> CErrors.anomaly ~label:"Lemmas.save_lemma_admitted" (Pp.str "more than one statement.") in let typ = EConstr.Unsafe.to_constr typ in - let proof = Proof_global.get_proof lemma.proof in + let proof = Declare.Proof.get_proof lemma.proof in let pproofs = Proof.partial_proof proof in let sec_vars = compute_proof_using_for_admitted lemma.proof typ pproofs in - let uctx = Proof_global.get_initial_euctx lemma.proof in + let uctx = Declare.Proof.get_initial_euctx lemma.proof in let univs = UState.check_univ_decl ~poly uctx udecl in finish_admitted ~info:lemma.info ~uctx (sec_vars, (typ, univs), None) @@ -310,7 +310,7 @@ let save_lemma_admitted ~(lemma : t) : unit = (************************************************************************) let finish_proved po info = - let open Proof_global in + let open Declare in match po with | { entries=[const]; uctx } -> let _r : Names.GlobRef.t list = MutualEntry.declare_mutdef ~info ~uctx const in @@ -343,7 +343,7 @@ let finish_derived ~f ~name ~entries = let lemma_pretype typ = match typ with | Some t -> Some (substf t) - | None -> assert false (* Proof_global always sets type here. *) + | None -> assert false (* Declare always sets type here. *) in (* The references of [f] are subsituted appropriately. *) let lemma_def = Declare.Internal.map_entry_type lemma_def ~f:lemma_pretype in @@ -368,12 +368,12 @@ let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in sigma, cst) sigma0 - types proof_obj.Proof_global.entries + types proof_obj.Declare.entries in hook recobls sigma let finalize_proof proof_obj proof_info = - let open Proof_global in + let open Declare in let open Proof_ending in match CEphemeron.default proof_info.Info.proof_ending Regular with | Regular -> @@ -403,7 +403,7 @@ let process_idopt_for_save ~idopt info = let save_lemma_proved ~lemma ~opaque ~idopt = (* Env and sigma are just used for error printing in save_remaining_recthms *) - let proof_obj = Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false lemma.proof in + let proof_obj = Declare.close_proof ~opaque ~keep_body_ucst_separate:false lemma.proof in let proof_info = process_idopt_for_save ~idopt lemma.info in finalize_proof proof_obj proof_info @@ -411,7 +411,7 @@ let save_lemma_proved ~lemma ~opaque ~idopt = (* Special case to close a lemma without forcing a proof *) (***********************************************************************) let save_lemma_admitted_delayed ~proof ~info = - let open Proof_global in + let open Declare in let { entries; uctx } = proof in if List.length entries <> 1 then CErrors.user_err Pp.(str "Admitted does not support multiple statements"); @@ -430,7 +430,7 @@ let save_lemma_proved_delayed ~proof ~info ~idopt = (* vio2vo calls this but with invalid info, we have to workaround that to add the name to the info structure *) if CList.is_empty info.Info.thms then - let info = add_first_thm ~info ~name:proof.Proof_global.name ~typ:EConstr.mkSet ~impargs:[] in + let info = add_first_thm ~info ~name:proof.Declare.name ~typ:EConstr.mkSet ~impargs:[] in finalize_proof proof info else let info = process_idopt_for_save ~idopt info in diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 8a23daa85f..bd2e87ac3a 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -19,10 +19,10 @@ type t val set_endline_tactic : Genarg.glob_generic_argument -> t -> t (** [set_endline_tactic tac lemma] set ending tactic for [lemma] *) -val pf_map : (Proof_global.t -> Proof_global.t) -> t -> t +val pf_map : (Declare.Proof.t -> Declare.Proof.t) -> t -> t (** [pf_map f l] map the underlying proof object *) -val pf_fold : (Proof_global.t -> 'a) -> t -> 'a +val pf_fold : (Declare.Proof.t -> 'a) -> t -> 'a (** [pf_fold f l] fold over the underlying proof object *) val by : unit Proofview.tactic -> t -> t * bool @@ -101,21 +101,21 @@ val start_lemma_with_initialization val save_lemma_admitted : lemma:t -> unit val save_lemma_proved : lemma:t - -> opaque:Proof_global.opacity_flag + -> opaque:Declare.opacity_flag -> idopt:Names.lident option -> unit (** To be removed, don't use! *) module Internal : sig val get_info : t -> Info.t - (** Only needed due to the Proof_global compatibility layer. *) + (** Only needed due to the Declare compatibility layer. *) end (** Special cases for delayed proofs, in this case we must provide the proof information so the proof won't be forced. *) -val save_lemma_admitted_delayed : proof:Proof_global.proof_object -> info:Info.t -> unit +val save_lemma_admitted_delayed : proof:Declare.proof_object -> info:Info.t -> unit val save_lemma_proved_delayed - : proof:Proof_global.proof_object + : proof:Declare.proof_object -> info:Info.t -> idopt:Names.lident option -> unit diff --git a/vernac/library.ml b/vernac/library.ml index 1b0bd4c0f7..35b2a18871 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -20,11 +20,11 @@ open Libobject (*s Low-level interning/externing of libraries to files *) let raw_extern_library f = - System.raw_extern_state Coq_config.vo_magic_number f + ObjFile.open_out ~file:f let raw_intern_library f = System.with_magic_number_check - (System.raw_intern_state Coq_config.vo_magic_number) f + (fun file -> ObjFile.open_in ~file) f (************************************************************************) (** Serialized objects loaded on-the-fly *) @@ -35,7 +35,7 @@ module Delayed : sig type 'a delayed -val in_delayed : string -> in_channel -> 'a delayed * Digest.t +val in_delayed : string -> ObjFile.in_handle -> segment:string -> 'a delayed * Digest.t val fetch_delayed : 'a delayed -> 'a end = @@ -43,14 +43,14 @@ struct type 'a delayed = { del_file : string; - del_off : int; + del_off : int64; del_digest : Digest.t; } -let in_delayed f ch = - let pos = pos_in ch in - let _, digest = System.skip_in_segment f ch in - ({ del_file = f; del_digest = digest; del_off = pos; }, digest) +let in_delayed f ch ~segment = + let seg = ObjFile.get_segment ch ~segment in + let digest = seg.ObjFile.hash in + { del_file = f; del_digest = digest; del_off = seg.ObjFile.pos; }, digest (** Fetching a table of opaque terms at position [pos] in file [f], expecting to find first a copy of [digest]. *) @@ -58,10 +58,10 @@ let in_delayed f ch = let fetch_delayed del = let { del_digest = digest; del_file = f; del_off = pos; } = del in try - let ch = raw_intern_library f in - let () = seek_in ch pos in - let obj, _, digest' = System.marshal_in_segment f ch in - let () = close_in ch in + let ch = open_in_bin f in + let () = LargeFile.seek_in ch pos in + let obj = System.marshal_in f ch in + let digest' = Digest.input ch in if not (String.equal digest digest') then raise (Faulty f); obj with e when CErrors.noncritical e -> raise (Faulty f) @@ -242,12 +242,11 @@ let mk_summary m = { let intern_from_file f = let ch = raw_intern_library f in - let (lsd : seg_sum), _, digest_lsd = System.marshal_in_segment f ch in - let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch in - let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in - let _ = System.skip_in_segment f ch in - let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch in - close_in ch; + let (lsd : seg_sum), digest_lsd = ObjFile.marshal_in_segment ch ~segment:"summary" in + let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch ~segment:"library" in + let (univs : seg_univ option), digest_u = ObjFile.marshal_in_segment ch ~segment:"universes" in + let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch ~segment:"opaques" in + ObjFile.close_in ch; register_library_filename lsd.md_name f; add_opaque_table lsd.md_name (ToFetch del_opaque); let open Safe_typing in @@ -297,7 +296,7 @@ let rec_intern_library ~lib_resolver libs (dir, f) = let native_name_from_filename f = let ch = raw_intern_library f in - let (lmd : seg_sum), pos, digest_lmd = System.marshal_in_segment f ch in + let (lmd : seg_sum), digest_lmd = ObjFile.marshal_in_segment ch ~segment:"summary" in Nativecode.mod_uid_of_dirpath lmd.md_name (**********************************************************************) @@ -335,7 +334,11 @@ let load_require _ (_,(needed,modl,_)) = List.iter register_library needed let open_require i (_,(_,modl,export)) = - Option.iter (fun export -> Declaremods.import_modules ~export @@ List.map (fun m -> MPfile m) modl) export + Option.iter (fun export -> + let mpl = List.map (fun m -> Unfiltered, MPfile m) modl in + (* TODO support filters in Require *) + Declaremods.import_modules ~export mpl) + export (* [needed] is the ordered list of libraries not already loaded *) let cache_require o = @@ -370,16 +373,17 @@ let require_library_from_dirpath ~lib_resolver modrefl export = let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPmap.empty) modrefl in let needed = List.rev_map (fun dir -> DPmap.find dir contents) needed in let modrefl = List.map fst modrefl in - if Lib.is_module_or_modtype () then - begin - warn_require_in_module (); - add_anonymous_leaf (in_require (needed,modrefl,None)); - Option.iter (fun export -> - List.iter (fun m -> Declaremods.import_module ~export (MPfile m)) modrefl) - export - end - else - add_anonymous_leaf (in_require (needed,modrefl,export)); + if Lib.is_module_or_modtype () then + begin + warn_require_in_module (); + add_anonymous_leaf (in_require (needed,modrefl,None)); + Option.iter (fun export -> + (* TODO import filters *) + List.iter (fun m -> Declaremods.import_module Unfiltered ~export (MPfile m)) modrefl) + export + end + else + add_anonymous_leaf (in_require (needed,modrefl,export)); () (************************************************************************) @@ -387,12 +391,12 @@ let require_library_from_dirpath ~lib_resolver modrefl export = let load_library_todo f = let ch = raw_intern_library f in - let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in - let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in - let (s2 : seg_univ option), _, _ = System.marshal_in_segment f ch in - let tasks, _, _ = System.marshal_in_segment f ch in - let (s4 : seg_proofs), _, _ = System.marshal_in_segment f ch in - close_in ch; + let (s0 : seg_sum), _ = ObjFile.marshal_in_segment ch ~segment:"summary" in + let (s1 : seg_lib), _ = ObjFile.marshal_in_segment ch ~segment:"library" in + let (s2 : seg_univ option), _ = ObjFile.marshal_in_segment ch ~segment:"universes" in + let tasks, _ = ObjFile.marshal_in_segment ch ~segment:"tasks" in + let (s4 : seg_proofs), _ = ObjFile.marshal_in_segment ch ~segment:"opaques" in + ObjFile.close_in ch; if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); if snd (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); @@ -428,15 +432,15 @@ let error_recursively_dependent_library dir = let save_library_base f sum lib univs tasks proofs = let ch = raw_extern_library f in try - System.marshal_out_segment f ch (sum : seg_sum); - System.marshal_out_segment f ch (lib : seg_lib); - System.marshal_out_segment f ch (univs : seg_univ option); - System.marshal_out_segment f ch (tasks : 'tasks option); - System.marshal_out_segment f ch (proofs : seg_proofs); - close_out ch + ObjFile.marshal_out_segment ch ~segment:"summary" (sum : seg_sum); + ObjFile.marshal_out_segment ch ~segment:"library" (lib : seg_lib); + ObjFile.marshal_out_segment ch ~segment:"universes" (univs : seg_univ option); + ObjFile.marshal_out_segment ch ~segment:"tasks" (tasks : 'tasks option); + ObjFile.marshal_out_segment ch ~segment:"opaques" (proofs : seg_proofs); + ObjFile.close_out ch with reraise -> let reraise = Exninfo.capture reraise in - close_out ch; + ObjFile.close_out ch; Feedback.msg_warning (str "Removed file " ++ str f); Sys.remove f; Exninfo.iraise reraise diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 475d5c31f7..3b9c771b93 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -877,9 +877,12 @@ let subst_syntax_extension (subst, (local, (pa_sy,pp_sy))) = let classify_syntax_definition (local, _ as o) = if local then Dispose else Substitute o +let open_syntax_extension i o = + if Int.equal i 1 then cache_syntax_extension o + let inSyntaxExtension : syntax_extension_obj -> obj = declare_object {(default_object "SYNTAX-EXTENSION") with - open_function = (fun i o -> if Int.equal i 1 then cache_syntax_extension o); + open_function = simple_open open_syntax_extension; cache_function = cache_syntax_extension; subst_function = subst_syntax_extension; classify_function = classify_syntax_definition} @@ -1454,7 +1457,7 @@ let classify_notation nobj = let inNotation : notation_obj -> obj = declare_object {(default_object "NOTATION") with - open_function = open_notation; + open_function = simple_open open_notation; cache_function = cache_notation; subst_function = subst_notation; load_function = load_notation; @@ -1765,7 +1768,7 @@ let classify_scope_command (local, _, _ as o) = let inScopeCommand : locality_flag * scope_name * scope_command -> obj = declare_object {(default_object "DELIMITERS") with cache_function = cache_scope_command; - open_function = open_scope_command; + open_function = simple_open open_scope_command; load_function = load_scope_command; subst_function = subst_scope_command; classify_function = classify_scope_command} @@ -1831,7 +1834,7 @@ let classify_custom_entry (local,s as o) = let inCustomEntry : locality_flag * string -> obj = declare_object {(default_object "CUSTOM-ENTRIES") with cache_function = cache_custom_entry; - open_function = open_custom_entry; + open_function = simple_open open_custom_entry; load_function = load_custom_entry; subst_function = subst_custom_entry; classify_function = classify_custom_entry} diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 435085793c..060f069419 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -134,7 +134,7 @@ let solve_by_tac ?loc name evi t poly uctx = (* the status is dropped. *) let env = Global.env () in let body, types, _, uctx = - Pfedit.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in + Declare.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in Inductiveops.control_only_guard env (Evd.from_ctx uctx) (EConstr.of_constr body); Some (body, types, uctx) with diff --git a/vernac/pfedit.ml b/vernac/pfedit.ml new file mode 100644 index 0000000000..d6b9592176 --- /dev/null +++ b/vernac/pfedit.ml @@ -0,0 +1,9 @@ +(* Compat API / *) +let get_current_context = Declare.get_current_context +let solve = Proof.solve +let by = Declare.by +let refine_by_tactic = Proof.refine_by_tactic + +(* We don't want to export this anymore, but we do for now *) +let build_by_tactic = Declare.build_by_tactic +let build_constant_by_tactic = Declare.build_constant_by_tactic diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 054b60853f..f1aae239aa 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -86,7 +86,13 @@ open Pputils let pr_module = Libnames.pr_qualid - let pr_import_module = Libnames.pr_qualid + let pr_one_import_filter_name (q,etc) = + Libnames.pr_qualid q ++ if etc then str "(..)" else mt() + + let pr_import_module (m,f) = + Libnames.pr_qualid m ++ match f with + | ImportAll -> mt() + | ImportNames ns -> surround (prlist_with_sep pr_comma pr_one_import_filter_name ns) let sep_end = function | VernacBullet _ @@ -162,8 +168,8 @@ open Pputils keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search sl ++ pr_in_out_modules b let pr_option_ref_value = function - | QualidRefValue id -> pr_qualid id - | StringRefValue s -> qs s + | Goptions.QualidRefValue id -> pr_qualid id + | Goptions.StringRefValue s -> qs s let pr_printoption table b = prlist_with_sep spc str table ++ @@ -179,7 +185,7 @@ open Pputils | [] -> mt() | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z - let pr_reference_or_constr pr_c = let open Hints in function + let pr_reference_or_constr pr_c = let open ComHints in function | HintsReference r -> pr_qualid r | HintsConstr c -> pr_c c @@ -196,6 +202,7 @@ open Pputils let opth = pr_opt_hintbases db in let pph = let open Hints in + let open ComHints in match h with | HintsResolve l -> keyword "Resolve " ++ prlist_with_sep sep @@ -785,7 +792,7 @@ let string_of_definition_object_kind = let open Decls in function return (keyword "Admitted") | VernacEndProof (Proved (opac,o)) -> return ( - let open Proof_global in + let open Declare in match o with | None -> (match opac with | Transparent -> keyword "Defined" diff --git a/vernac/proof_global.ml b/vernac/proof_global.ml new file mode 100644 index 0000000000..b6c07042e2 --- /dev/null +++ b/vernac/proof_global.ml @@ -0,0 +1,7 @@ +(* compatibility module; can be removed once we agree on the API *) + +type t = Declare.Proof.t +let map_proof = Declare.Proof.map_proof +let get_proof = Declare.Proof.get_proof + +type opacity_flag = Declare.opacity_flag = Opaque | Transparent diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 4de12f5e3b..2b6beaf2e3 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -28,7 +28,7 @@ module Vernac_ : val command_entry : vernac_expr Entry.t val main_entry : vernac_control option Entry.t val red_expr : raw_red_expr Entry.t - val hint_info : Hints.hint_info_expr Entry.t + val hint_info : ComHints.hint_info_expr Entry.t end (* To be removed when the parser is made functional wrt the tactic diff --git a/vernac/record.ml b/vernac/record.ml index b9d450044b..9fda98d08e 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -71,7 +71,7 @@ let interp_fields_evars env sigma ~ninds ~nparams impls_env nots l = let impls = match i with | Anonymous -> impls - | Name id -> Id.Map.add id (compute_internalization_data env sigma Constrintern.Method t' impl) impls + | Name id -> Id.Map.add id (compute_internalization_data env sigma id Constrintern.Method t' impl) impls in let d = match b' with | None -> LocalAssum (make_annot i r,t') @@ -320,67 +320,65 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let (_,_,kinds,sp_projs,_) = List.fold_left3 (fun (nfi,i,kinds,sp_projs,subst) flags decl impls -> - let fi = RelDecl.get_name decl in - let ti = RelDecl.get_type decl in - let (sp_projs,i,subst) = - match fi with - | Anonymous -> - (None::sp_projs,i,NoProjection fi::subst) - | Name fid -> try - let kn, term = - if is_local_assum decl && primitive then - let p = Projection.Repr.make indsp - ~proj_npars:mib.mind_nparams - ~proj_arg:i - (Label.of_id fid) - in - (* Already defined by declare_mind silently *) - let kn = Projection.Repr.constant p in - Declare.definition_message fid; - kn, mkProj (Projection.make p false,mkRel 1) - else - let ccl = subst_projection fid subst ti in - let body = match decl with - | LocalDef (_,ci,_) -> subst_projection fid subst ci - | LocalAssum ({binder_relevance=rci},_) -> - (* [ccl] is defined in context [params;x:rp] *) - (* [ccl'] is defined in context [params;x:rp;x:rp] *) - let ccl' = liftn 1 2 ccl in - let p = mkLambda (x, lift 1 rp, ccl') in - let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in - let ci = Inductiveops.make_case_info env indsp rci LetStyle in - (* Record projections have no is *) - mkCase (ci, p, mkRel 1, [|branch|]) - in - let proj = - it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in - let projtyp = - it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in - try - let entry = Declare.definition_entry ~univs:ctx ~types:projtyp proj in - let kind = Decls.IsDefinition kind in - let kn = declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) in - let constr_fip = - let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in - applist (mkConstU (kn,u),proj_args) - in - Declare.definition_message fid; - kn, constr_fip - with Type_errors.TypeError (ctx,te) -> - raise (NotDefinable (BadTypedProj (fid,ctx,te))) - in - let refi = GlobRef.ConstRef kn in - Impargs.maybe_declare_manual_implicits false refi impls; - if flags.pf_subclass then begin - let cl = ComCoercion.class_of_global (GlobRef.IndRef indsp) in - ComCoercion.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl - end; - let i = if is_local_assum decl then i+1 else i in - (Some kn::sp_projs, i, Projection term::subst) - with NotDefinable why -> - warning_or_error flags.pf_subclass indsp why; - (None::sp_projs,i,NoProjection fi::subst) in - (nfi - 1, i, { Recordops.pk_name = fi ; pk_true_proj = is_local_assum decl ; pk_canonical = flags.pf_canonical } :: kinds, sp_projs, subst)) + let fi = RelDecl.get_name decl in + let ti = RelDecl.get_type decl in + let (sp_projs,i,subst) = + match fi with + | Anonymous -> + (None::sp_projs,i,NoProjection fi::subst) + | Name fid -> + try + let ccl = subst_projection fid subst ti in + let body, p_opt = match decl with + | LocalDef (_,ci,_) -> subst_projection fid subst ci, None + | LocalAssum ({binder_relevance=rci},_) -> + (* [ccl] is defined in context [params;x:rp] *) + (* [ccl'] is defined in context [params;x:rp;x:rp] *) + if primitive then + let p = Projection.Repr.make indsp + ~proj_npars:mib.mind_nparams ~proj_arg:i (Label.of_id fid) in + mkProj (Projection.make p true, mkRel 1), Some p + else + let ccl' = liftn 1 2 ccl in + let p = mkLambda (x, lift 1 rp, ccl') in + let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in + let ci = Inductiveops.make_case_info env indsp rci LetStyle in + (* Record projections have no is *) + mkCase (ci, p, mkRel 1, [|branch|]), None + in + let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in + let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in + let entry = Declare.definition_entry ~univs:ctx ~types:projtyp proj in + let kind = Decls.IsDefinition kind in + let kn = + try declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) + with Type_errors.TypeError (ctx,te) when not primitive -> + raise (NotDefinable (BadTypedProj (fid,ctx,te))) + in + Declare.definition_message fid; + let term = match p_opt with + | Some p -> + let _ = DeclareInd.declare_primitive_projection p kn in + mkProj (Projection.make p false,mkRel 1) + | None -> + let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in + match decl with + | LocalDef (_,ci,_) when primitive -> body + | _ -> applist (mkConstU (kn,u),proj_args) + in + let refi = GlobRef.ConstRef kn in + Impargs.maybe_declare_manual_implicits false refi impls; + if flags.pf_subclass then begin + let cl = ComCoercion.class_of_global (GlobRef.IndRef indsp) in + ComCoercion.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl + end; + let i = if is_local_assum decl then i+1 else i in + (Some kn::sp_projs, i, Projection term::subst) + with NotDefinable why -> + warning_or_error flags.pf_subclass indsp why; + (None::sp_projs,i,NoProjection fi::subst) + in + (nfi - 1, i, { Recordops.pk_name = fi ; pk_true_proj = is_local_assum decl ; pk_canonical = flags.pf_canonical } :: kinds, sp_projs, subst)) (List.length fields,0,[],[],[]) flags (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) diff --git a/vernac/retrieveObl.ml b/vernac/retrieveObl.ml index c529972b8d..b8564037e0 100644 --- a/vernac/retrieveObl.ml +++ b/vernac/retrieveObl.ml @@ -72,7 +72,7 @@ let subst_evar_constr evm evs n idf t = *) let args = let n = match chop with None -> 0 | Some c -> c in - let l, r = CList.chop n (List.rev (Array.to_list args)) in + let l, r = CList.chop n (List.rev args) in List.rev r in let args = diff --git a/vernac/search.ml b/vernac/search.ml index 68a30b4231..8b54b696f2 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -61,7 +61,7 @@ let iter_named_context_name_type f = let get_current_or_goal_context ?pstate glnum = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Pfedit.get_goal_context p glnum + | Some p -> Declare.get_goal_context p glnum (* General search over hypothesis of a goal *) let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = diff --git a/vernac/search.mli b/vernac/search.mli index 6dbbff3a8c..d3b8444b5f 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -38,13 +38,13 @@ val search_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_by_head : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_rewrite : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_pattern : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list +val search : ?pstate:Declare.Proof.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = @@ -65,12 +65,12 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : ?pstate:Proof_global.t -> ?glnum:int -> (search_constraint * bool) list -> +val interface_search : ?pstate:Declare.Proof.t -> ?glnum:int -> (search_constraint * bool) list -> constr coq_object list (** {6 Generic search function} *) -val generic_search : ?pstate:Proof_global.t -> int option -> display_function -> unit +val generic_search : ?pstate:Declare.Proof.t -> int option -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 5a2bdb43d4..6d5d16d94a 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -9,6 +9,8 @@ Himsg Locality Egramml Vernacextend +Declare +ComHints Ppvernac Proof_using Egramcoq @@ -44,3 +46,5 @@ ComArguments Vernacentries Vernacstate Vernacinterp +Proof_global +Pfedit diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 3195f339b6..df39c617d3 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -34,12 +34,12 @@ let (f_interp_redexp, interp_redexp_hook) = Hook.make () let get_current_or_global_context ~pstate = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Pfedit.get_current_context p + | Some p -> Declare.get_current_context p let get_goal_or_global_context ~pstate glnum = match pstate with | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Pfedit.get_goal_context p glnum + | Some p -> Declare.get_goal_context p glnum let cl_of_qualid = function | FunClass -> Coercionops.CL_FUN @@ -94,13 +94,13 @@ let show_proof ~pstate = (* spiwack: this would probably be cooler with a bit of polishing. *) try let pstate = Option.get pstate in - let p = Proof_global.get_proof pstate in - let sigma, env = Pfedit.get_current_context pstate in + let p = Declare.Proof.get_proof pstate in + let sigma, env = Declare.get_current_context pstate in let pprf = Proof.partial_proof p in Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf (* We print nothing if there are no goals left *) with - | Pfedit.NoSuchGoal + | Proof.NoSuchGoal _ | Option.IsNone -> user_err (str "No goals to show.") @@ -476,7 +476,7 @@ let program_inference_hook env sigma ev = then None else let c, _, _, ctx = - Pfedit.build_by_tactic ~poly:false env ~uctx:(Evd.evar_universe_context sigma) ~typ:concl tac + Declare.build_by_tactic ~poly:false env ~uctx:(Evd.evar_universe_context sigma) ~typ:concl tac in Some (Evd.set_universe_context sigma ctx, EConstr.of_constr c) with @@ -593,7 +593,7 @@ let vernac_exact_proof ~lemma c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the beginning of a proof. *) let lemma, status = Lemmas.by (Tactics.exact_proof c) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Opaque ~idopt:None in + let () = Lemmas.save_lemma_proved ~lemma ~opaque:Declare.Opaque ~idopt:None in if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = @@ -872,12 +872,62 @@ let vernac_constraint ~poly l = (**********************) (* Modules *) +let add_subnames_of ns full_n n = + let open GlobRef in + let module NSet = Globnames.ExtRefSet in + let add1 r ns = NSet.add (Globnames.TrueGlobal r) ns in + match n with + | Globnames.SynDef _ | Globnames.TrueGlobal (ConstRef _ | ConstructRef _ | VarRef _) -> + CErrors.user_err Pp.(str "Only inductive types can be used with Import (...).") + | Globnames.TrueGlobal (IndRef (mind,i)) -> + let open Declarations in + let dp = Libnames.dirpath full_n in + let mib = Global.lookup_mind mind in + let mip = mib.mind_packets.(i) in + let ns = add1 (IndRef (mind,i)) ns in + let ns = Array.fold_left_i (fun j ns _ -> add1 (ConstructRef ((mind,i),j+1)) ns) + ns mip.mind_consnames + in + List.fold_left (fun ns f -> + let s = Indrec.elimination_suffix f in + let n_elim = Id.of_string (Id.to_string mip.mind_typename ^ s) in + match Nametab.extended_global_of_path (Libnames.make_path dp n_elim) with + | exception Not_found -> ns + | n_elim -> NSet.add n_elim ns) + ns Sorts.all_families + +let interp_filter_in m = function + | ImportAll -> Libobject.Unfiltered + | ImportNames ns -> + let module NSet = Globnames.ExtRefSet in + let dp_m = Nametab.dirpath_of_module m in + let ns = + List.fold_left (fun ns (n,etc) -> + let full_n = + let dp_n,n = repr_qualid n in + make_path (append_dirpath dp_m dp_n) n + in + let n = try Nametab.extended_global_of_path full_n + with Not_found -> + CErrors.user_err + Pp.(str "Cannot find name " ++ pr_qualid n ++ spc() ++ + str "in module " ++ pr_qualid (Nametab.shortest_qualid_of_module m)) + in + let ns = NSet.add n ns in + if etc then add_subnames_of ns full_n n else ns) + NSet.empty ns + in + Libobject.Names ns + let vernac_import export refl = - let import_mod qid = - try Declaremods.import_module ~export @@ Nametab.locate_module qid - with Not_found -> - CErrors.user_err Pp.(str "Cannot find module " ++ pr_qualid qid) - in + let import_mod (qid,f) = + let m = try Nametab.locate_module qid + with Not_found -> + CErrors.user_err Pp.(str "Cannot find module " ++ pr_qualid qid) + in + let f = interp_filter_in m f in + Declaremods.import_module f ~export m + in List.iter import_mod refl let vernac_declare_module export {loc;v=id} binders_ast mty_ast = @@ -893,7 +943,7 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = let mp = Declaremods.declare_module id binders_ast (Declaremods.Enforce mty_ast) [] in Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); - Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export + Option.iter (fun export -> vernac_import export [qualid_of_ident id, ImportAll]) export let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) @@ -914,7 +964,7 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [qualid_of_ident id]) export + (fun export -> vernac_import export [qualid_of_ident id, ImportAll]) export ) argsexport | _::_ -> let binders_ast = List.map @@ -929,14 +979,14 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [qualid_of_ident id]) + Option.iter (fun export -> vernac_import export [qualid_of_ident id, ImportAll]) export let vernac_end_module export {loc;v=id} = let mp = Declaremods.end_module () in Dumpglob.dump_modref ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export + Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id, ImportAll]) export let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = if Global.sections_are_opened () then @@ -957,7 +1007,7 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [qualid_of_ident ?loc id]) export + (fun export -> vernac_import export [qualid_of_ident ?loc id, ImportAll]) export ) argsexport | _ :: _ -> @@ -1117,7 +1167,7 @@ let focus_command_cond = Proof.no_cond command_focus all tactics fail if there are no further goals to prove. *) let vernac_solve_existential ~pstate n com = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> let intern env sigma = Constrintern.intern_constr env sigma com in Proof.V82.instantiate_evar (Global.env ()) n intern p) pstate @@ -1125,12 +1175,12 @@ let vernac_set_end_tac ~pstate tac = let env = Genintern.empty_glob_sign (Global.env ()) in let _, tac = Genintern.generic_intern env tac in (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) - Proof_global.set_endline_tactic tac pstate + Declare.Proof.set_endline_tactic tac pstate -let vernac_set_used_variables ~pstate e : Proof_global.t = +let vernac_set_used_variables ~pstate e : Declare.Proof.t = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in - let tys = List.map snd (initial_goals (Proof_global.get_proof pstate)) in + let tys = List.map snd (initial_goals (Declare.Proof.get_proof pstate)) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in @@ -1139,7 +1189,7 @@ let vernac_set_used_variables ~pstate e : Proof_global.t = user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ Id.print id)) l; - let _, pstate = Proof_global.set_used_variables pstate l in + let _, pstate = Declare.Proof.set_used_variables pstate l in pstate (*****************************) @@ -1225,7 +1275,7 @@ let vernac_hints ~atts dbnames h = "This command does not support the export attribute in sections."); | OptDefault | OptLocal -> () in - Hints.add_hints ~locality dbnames (Hints.interp_hints ~poly h) + Hints.add_hints ~locality dbnames (ComHints.interp_hints ~poly h) let vernac_syntactic_definition ~atts lid x only_parsing = let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in @@ -1252,6 +1302,7 @@ let vernac_generalizable ~local = Implicit_quantifiers.declare_generalizable ~local let allow_sprop_opt_name = ["Allow";"StrictProp"] +let cumul_sprop_opt_name = ["Cumulative";"StrictProp"] let () = declare_bool_option @@ -1263,6 +1314,13 @@ let () = let () = declare_bool_option { optdepr = false; + optkey = cumul_sprop_opt_name; + optread = Global.is_cumulative_sprop; + optwrite = Global.set_cumulative_sprop } + +let () = + declare_bool_option + { optdepr = false; optkey = ["Silent"]; optread = (fun () -> !Flags.quiet); optwrite = ((:=) Flags.quiet) } @@ -1437,21 +1495,21 @@ let () = optread = CWarnings.get_flags; optwrite = CWarnings.set_flags } -let _ = +let () = declare_bool_option { optdepr = false; optkey = ["Guard"; "Checking"]; optread = (fun () -> (Global.typing_flags ()).Declarations.check_guarded); optwrite = (fun b -> Global.set_check_guarded b) } -let _ = +let () = declare_bool_option { optdepr = false; optkey = ["Positivity"; "Checking"]; optread = (fun () -> (Global.typing_flags ()).Declarations.check_positive); optwrite = (fun b -> Global.set_check_positive b) } -let _ = +let () = declare_bool_option { optdepr = false; optkey = ["Universe"; "Checking"]; @@ -1504,26 +1562,11 @@ let vernac_set_option ~locality table v = match v with vernac_set_option0 ~locality table v | _ -> vernac_set_option0 ~locality table v -let vernac_add_option key lv = - let f = function - | StringRefValue s -> (get_string_table key).add (Global.env()) s - | QualidRefValue locqid -> (get_ref_table key).add (Global.env()) locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key +let vernac_add_option = iter_table { aux = fun table -> table.add } -let vernac_remove_option key lv = - let f = function - | StringRefValue s -> (get_string_table key).remove (Global.env()) s - | QualidRefValue locqid -> (get_ref_table key).remove (Global.env()) locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key +let vernac_remove_option = iter_table { aux = fun table -> table.remove } -let vernac_mem_option key lv = - let f = function - | StringRefValue s -> (get_string_table key).mem (Global.env()) s - | QualidRefValue locqid -> (get_ref_table key).mem (Global.env()) locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key +let vernac_mem_option = iter_table { aux = fun table -> table.mem } let vernac_print_option key = try (get_ref_table key).print () @@ -1539,8 +1582,8 @@ let get_current_context_of_args ~pstate = let env = Global.env () in Evd.(from_env env, env) | Some lemma -> function - | Some n -> Pfedit.get_goal_context lemma n - | None -> Pfedit.get_current_context lemma + | Some n -> Declare.get_goal_context lemma n + | None -> Declare.get_current_context lemma let query_command_selector ?loc = function | None -> None @@ -1605,7 +1648,7 @@ let vernac_global_check c = let get_nth_goal ~pstate n = - let pf = Proof_global.get_proof pstate in + let pf = Declare.Proof.get_proof pstate in let Proof.{goals;sigma} = Proof.data pf in let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl @@ -1640,7 +1683,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - let sigma, env = Pfedit.get_current_context pstate in + let sigma, env = Declare.get_current_context pstate in v 0 (Id.print id ++ str":" ++ pr_econstr_env env sigma (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) @@ -1684,7 +1727,8 @@ let vernac_print ~pstate ~atts = | PrintHintGoal -> begin match pstate with | Some pstate -> - Hints.pr_applicable_hint pstate + let pf = Declare.Proof.get_proof pstate in + Hints.pr_applicable_hint pf | None -> str "No proof in progress" end @@ -1843,7 +1887,7 @@ let vernac_register qid r = (* Proof management *) let vernac_focus ~pstate gln = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> match gln with | None -> Proof.focus focus_command_cond () 1 p | Some 0 -> @@ -1854,13 +1898,13 @@ let vernac_focus ~pstate gln = (* Unfocuses one step in the focus stack. *) let vernac_unfocus ~pstate = - Proof_global.map_proof + Declare.Proof.map_proof (fun p -> Proof.unfocus command_focus p ()) pstate (* Checks that a proof is fully unfocused. Raises an error if not. *) let vernac_unfocused ~pstate = - let p = Proof_global.get_proof pstate in + let p = Declare.Proof.get_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." else @@ -1873,7 +1917,7 @@ let subproof_kind = Proof.new_focus_kind () let subproof_cond = Proof.done_cond subproof_kind let vernac_subproof gln ~pstate = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> match gln with | None -> Proof.focus subproof_cond () 1 p | Some (Goal_select.SelectNth n) -> Proof.focus subproof_cond () n p @@ -1883,12 +1927,12 @@ let vernac_subproof gln ~pstate = pstate let vernac_end_subproof ~pstate = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> Proof.unfocus subproof_kind p ()) pstate let vernac_bullet (bullet : Proof_bullet.t) ~pstate = - Proof_global.map_proof (fun p -> + Declare.Proof.map_proof (fun p -> Proof_bullet.put p bullet) pstate (* Stack is needed due to show proof names, should deprecate / remove @@ -1905,7 +1949,7 @@ let vernac_show ~pstate = end (* Show functions that require a proof state *) | Some pstate -> - let proof = Proof_global.get_proof pstate in + let proof = Declare.Proof.get_proof pstate in begin function | ShowGoal goalref -> begin match goalref with @@ -1917,14 +1961,14 @@ let vernac_show ~pstate = | ShowUniverses -> show_universes ~proof (* Deprecate *) | ShowProofNames -> - Id.print (Proof_global.get_proof_name pstate) + Id.print (Declare.Proof.get_proof_name pstate) | ShowIntros all -> show_intro ~proof all | ShowProof -> show_proof ~pstate:(Some pstate) | ShowMatch id -> show_match id end let vernac_check_guard ~pstate = - let pts = Proof_global.get_proof pstate in + let pts = Declare.Proof.get_proof pstate in let pfterm = List.hd (Proof.partial_proof pts) in let message = try diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 2ac8458ad5..cf233248d7 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -26,3 +26,4 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr val command_focus : unit Proof.focus_kind val allow_sprop_opt_name : string list +val cumul_sprop_opt_name : string list diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d6e7a3947a..b65a0da1cc 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -101,7 +101,14 @@ type verbose_flag = bool (* true = Verbose; false = Silent *) type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) + type export_flag = bool (* true = Export; false = Import *) + +type one_import_filter_name = qualid * bool (* import inductive components *) +type import_filter_expr = + | ImportAll + | ImportNames of one_import_filter_name list + type onlyparsing_flag = { onlyparsing : bool } (* Some v = Parse only; None = Print also. If v<>Current, it contains the name of the coq version @@ -114,10 +121,6 @@ type option_setting = | OptionSetInt of int | OptionSetString of string -type option_ref_value = - | StringRefValue of string - | QualidRefValue of qualid - (** Identifier and optional list of bound universes and constraints. *) type sort_expr = Sorts.family @@ -195,7 +198,7 @@ type syntax_modifier = type proof_end = | Admitted (* name in `Save ident` when closing goal *) - | Proved of Proof_global.opacity_flag * lident option + | Proved of Declare.opacity_flag * lident option type scheme = | InductionScheme of bool * qualid or_by_notation * sort_expr @@ -320,7 +323,7 @@ type nonrec vernac_expr = | VernacEndSegment of lident | VernacRequire of qualid option * export_flag option * qualid list - | VernacImport of export_flag * qualid list + | VernacImport of export_flag * (qualid * import_filter_expr) list | VernacCanonical of qualid or_by_notation | VernacCoercion of qualid or_by_notation * class_rawexpr * class_rawexpr @@ -333,18 +336,18 @@ type nonrec vernac_expr = local_binder_expr list * (* binders *) constr_expr * (* type *) (bool * constr_expr) option * (* body (bool=true when using {}) *) - Hints.hint_info_expr + ComHints.hint_info_expr | VernacDeclareInstance of ident_decl * (* name *) local_binder_expr list * (* binders *) constr_expr * (* type *) - Hints.hint_info_expr + ComHints.hint_info_expr | VernacContext of local_binder_expr list | VernacExistingInstance of - (qualid * Hints.hint_info_expr) list (* instances names, priorities and patterns *) + (qualid * ComHints.hint_info_expr) list (* instances names, priorities and patterns *) | VernacExistingClass of qualid (* inductive or definition name *) @@ -384,7 +387,7 @@ type nonrec vernac_expr = (* Commands *) | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * qualid list - | VernacHints of string list * Hints.hints_expr + | VernacHints of string list * ComHints.hints_expr | VernacSyntacticDefinition of lident * (Id.t list * constr_expr) * onlyparsing_flag @@ -399,9 +402,9 @@ type nonrec vernac_expr = | VernacSetStrategy of (Conv_oracle.level * qualid or_by_notation list) list | VernacSetOption of bool (* Export modifier? *) * Goptions.option_name * option_setting - | VernacAddOption of Goptions.option_name * option_ref_value list - | VernacRemoveOption of Goptions.option_name * option_ref_value list - | VernacMemOption of Goptions.option_name * option_ref_value list + | VernacAddOption of Goptions.option_name * Goptions.table_value list + | VernacRemoveOption of Goptions.option_name * Goptions.table_value list + | VernacMemOption of Goptions.option_name * Goptions.table_value list | VernacPrintOption of Goptions.option_name | VernacCheckMayEval of Genredexpr.raw_red_expr option * Goal_select.t option * constr_expr | VernacGlobalCheck of constr_expr diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 1920c276af..d772f274a2 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -57,9 +57,9 @@ type typed_vernac = | VtNoProof of (unit -> unit) | VtCloseProof of (lemma:Lemmas.t -> unit) | VtOpenProof of (unit -> Lemmas.t) - | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) - | VtReadProofOpt of (pstate:Proof_global.t option -> unit) - | VtReadProof of (pstate:Proof_global.t -> unit) + | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) + | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) + | VtReadProof of (pstate:Declare.Proof.t -> unit) type vernac_command = atts:Attributes.vernac_flags -> typed_vernac diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 0d0ebc1086..58c267080a 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -75,9 +75,9 @@ type typed_vernac = | VtNoProof of (unit -> unit) | VtCloseProof of (lemma:Lemmas.t -> unit) | VtOpenProof of (unit -> Lemmas.t) - | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) - | VtReadProofOpt of (pstate:Proof_global.t option -> unit) - | VtReadProof of (pstate:Proof_global.t -> unit) + | VtModifyProof of (pstate:Declare.Proof.t -> Declare.Proof.t) + | VtReadProofOpt of (pstate:Declare.Proof.t option -> unit) + | VtReadProof of (pstate:Declare.Proof.t -> unit) type vernac_command = atts:Attributes.vernac_flags -> typed_vernac diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index eb299222dd..19d41c4770 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -209,7 +209,7 @@ and interp_control ~st ({ CAst.v = cmd } as vernac) = let before_univs = Global.universes () in let pstack = interp_expr ~atts:cmd.attrs ~st cmd.expr in if before_univs == Global.universes () then pstack - else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack) + else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Declare.Proof.update_global_env) pstack) ~st (* XXX: This won't properly set the proof mode, as of today, it is @@ -251,7 +251,7 @@ let interp_gen ~verbosely ~st ~interp_fn cmd = try vernac_timeout (fun st -> let v_mod = if verbosely then Flags.verbosely else Flags.silently in let ontop = v_mod (interp_fn ~st) cmd in - Vernacstate.Proof_global.set ontop [@ocaml.warning "-3"]; + Vernacstate.Declare.set ontop [@ocaml.warning "-3"]; Vernacstate.freeze_interp_state ~marshallable:false ) st with exn -> diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 9f5bfb46ee..e3e708e87d 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -14,7 +14,7 @@ val interp : ?verbosely:bool -> st:Vernacstate.t -> Vernacexpr.vernac_control -> (** Execute a Qed but with a proof_object which may contain a delayed proof and won't be forced *) val interp_qed_delayed_proof - : proof:Proof_global.proof_object + : proof:Declare.proof_object -> info:Lemmas.Info.t -> st:Vernacstate.t -> control:Vernacexpr.control_flag list diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index a4e9c8e1ab..0fca1e9078 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -45,7 +45,7 @@ module LemmaStack = struct | Some (l,ls) -> a, (l :: ls) let get_all_proof_names (pf : t) = - let prj x = Lemmas.pf_fold Proof_global.get_proof x in + let prj x = Lemmas.pf_fold Declare.Proof.get_proof x in let (pn, pns) = map Proof.(function pf -> (data (prj pf)).name) pf in pn :: pns @@ -105,7 +105,7 @@ let make_shallow st = } (* Compatibility module *) -module Proof_global = struct +module Declare = struct let get () = !s_lemmas let set x = s_lemmas := x @@ -126,7 +126,7 @@ module Proof_global = struct end open Lemmas - open Proof_global + open Declare let cc f = match !s_lemmas with | None -> raise NoCurrentProof @@ -145,23 +145,23 @@ module Proof_global = struct | Some x -> s_lemmas := Some (LemmaStack.map_top_pstate ~f x) let there_are_pending_proofs () = !s_lemmas <> None - let get_open_goals () = cc get_open_goals + let get_open_goals () = cc Proof.get_open_goals - let give_me_the_proof_opt () = Option.map (LemmaStack.with_top_pstate ~f:get_proof) !s_lemmas - let give_me_the_proof () = cc get_proof - let get_current_proof_name () = cc get_proof_name + let give_me_the_proof_opt () = Option.map (LemmaStack.with_top_pstate ~f:Proof.get_proof) !s_lemmas + let give_me_the_proof () = cc Proof.get_proof + let get_current_proof_name () = cc Proof.get_proof_name - let map_proof f = dd (map_proof f) + let map_proof f = dd (Proof.map_proof f) let with_current_proof f = match !s_lemmas with | None -> raise NoCurrentProof | Some stack -> - let pf, res = LemmaStack.with_top_pstate stack ~f:(map_fold_proof_endline f) in + let pf, res = LemmaStack.with_top_pstate stack ~f:(Proof.map_fold_proof_endline f) in let stack = LemmaStack.map_top_pstate stack ~f:(fun _ -> pf) in s_lemmas := Some stack; res - type closed_proof = Proof_global.proof_object * Lemmas.Info.t + type closed_proof = Declare.proof_object * Lemmas.Info.t let return_proof () = cc return_proof @@ -169,16 +169,16 @@ module Proof_global = struct let close_future_proof ~feedback_id pf = cc_lemma (fun pt -> pf_fold (fun st -> close_future_proof ~feedback_id st pf) pt, - Internal.get_info pt) + Lemmas.Internal.get_info pt) let close_proof ~opaque ~keep_body_ucst_separate = cc_lemma (fun pt -> pf_fold ((close_proof ~opaque ~keep_body_ucst_separate)) pt, - Internal.get_info pt) + Lemmas.Internal.get_info pt) let discard_all () = s_lemmas := None - let update_global_env () = dd (update_global_env) + let update_global_env () = dd (Proof.update_global_env) - let get_current_context () = cc Pfedit.get_current_context + let get_current_context () = cc Declare.get_current_context let get_all_proof_names () = try cc_stack LemmaStack.get_all_proof_names diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 9c4de7720c..fb6d8b6db6 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -25,8 +25,8 @@ module LemmaStack : sig val pop : t -> Lemmas.t * t option val push : t option -> Lemmas.t -> t - val map_top_pstate : f:(Proof_global.t -> Proof_global.t) -> t -> t - val with_top_pstate : t -> f:(Proof_global.t -> 'a ) -> 'a + val map_top_pstate : f:(Declare.Proof.t -> Declare.Proof.t) -> t -> t + val with_top_pstate : t -> f:(Declare.Proof.t -> 'a ) -> 'a end @@ -50,7 +50,7 @@ val make_shallow : t -> t val invalidate_cache : unit -> unit (* Compatibility module: Do Not Use *) -module Proof_global : sig +module Declare : sig exception NoCurrentProof @@ -65,16 +65,16 @@ module Proof_global : sig val with_current_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a - val return_proof : unit -> Proof_global.closed_proof_output - val return_partial_proof : unit -> Proof_global.closed_proof_output + val return_proof : unit -> Declare.closed_proof_output + val return_partial_proof : unit -> Declare.closed_proof_output - type closed_proof = Proof_global.proof_object * Lemmas.Info.t + type closed_proof = Declare.proof_object * Lemmas.Info.t val close_future_proof : feedback_id:Stateid.t -> - Proof_global.closed_proof_output Future.computation -> closed_proof + Declare.closed_proof_output Future.computation -> closed_proof - val close_proof : opaque:Proof_global.opacity_flag -> keep_body_ucst_separate:bool -> closed_proof + val close_proof : opaque:Declare.opacity_flag -> keep_body_ucst_separate:bool -> closed_proof val discard_all : unit -> unit val update_global_env : unit -> unit @@ -89,7 +89,7 @@ module Proof_global : sig val get : unit -> LemmaStack.t option val set : LemmaStack.t option -> unit - val get_pstate : unit -> Proof_global.t option + val get_pstate : unit -> Declare.Proof.t option val freeze : marshallable:bool -> LemmaStack.t option val unfreeze : LemmaStack.t -> unit |