diff options
377 files changed, 7453 insertions, 4381 deletions
diff --git a/.gitignore b/.gitignore index c30fd850a1..4e02e7617c 100644 --- a/.gitignore +++ b/.gitignore @@ -145,7 +145,9 @@ plugins/ssr/ssrvernac.ml # other auto-generated files +kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +kernel/genOpcodeFiles.exe kernel/copcodes.ml kernel/uint63.ml ide/index_urls.txt diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b6b1b5341b..828380894e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-02-17-V1" + CACHEKEY: "bionic_coq-V2019-03-12-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -55,7 +55,7 @@ after_script: ###################################################### # TODO figure out how to build doc for installed Coq -.build-template: &build-template +.build-template: stage: build artifacts: name: "$CI_JOB_NAME" @@ -91,7 +91,7 @@ after_script: - set +e # Template for building Coq + stdlib, typical use: overload the switch -.dune-template: &dune-template +.dune-template: stage: build dependencies: [] script: @@ -107,7 +107,7 @@ after_script: - _build/ expire_in: 1 week -.dune-ci-template: &dune-ci-template +.dune-ci-template: stage: test dependencies: - build:edge+flambda:dune:dev @@ -117,10 +117,10 @@ after_script: - make -f Makefile.dune "$DUNE_TARGET" - echo 'end:coq.test' - set +e - variables: &dune-ci-template-vars + variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" - artifacts: &dune-ci-template-artifacts + artifacts: name: "$CI_JOB_NAME" expire_in: 1 month @@ -129,7 +129,7 @@ after_script: # purpose, we add a spurious dependency `not-a-real-job` that must be # overridden otherwise the CI will fail. -.doc-template: &doc-template +.doc-template: stage: test dependencies: - not-a-real-job @@ -143,7 +143,7 @@ after_script: - _install_ci/share/doc/coq/ # set dependencies when using -.test-suite-template: &test-suite-template +.test-suite-template: stage: test dependencies: - not-a-real-job @@ -162,7 +162,7 @@ after_script: - test-suite/logs # set dependencies when using -.validate-template: &validate-template +.validate-template: stage: test dependencies: - not-a-real-job @@ -172,7 +172,7 @@ after_script: - for regexp in 's/.vo//' 's:lib/coq/plugins:Coq:' 's:lib/coq/theories:Coq:' 's:/:.:g'; do sed -z -i "$regexp" vofiles; done - xargs -0 --arg-file=vofiles bin/coqchk -silent -o -m -coqlib lib/coq/ -.ci-template: &ci-template +.ci-template: stage: test script: - set -e @@ -183,15 +183,15 @@ after_script: dependencies: - build:base -.ci-template-flambda: &ci-template-flambda - <<: *ci-template +.ci-template-flambda: + extends: .ci-template dependencies: - build:edge+flambda variables: OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" -.windows-template: &windows-template +.windows-template: stage: test artifacts: name: "%CI_JOB_NAME%" @@ -209,8 +209,19 @@ after_script: variables: - $WINDOWS =~ /enabled/ +.deploy-template: + stage: deploy + before_script: + - which ssh-agent || ( apt-get update -y && apt-get install openssh-client -y ) + - eval $(ssh-agent -s) + - mkdir -p ~/.ssh + - chmod 700 ~/.ssh + - ssh-keyscan -t rsa github.com >> ~/.ssh/known_hosts + - git config --global user.name "coqbot" + - git config --global user.email "coqbot@users.noreply.github.com" + build:base: - <<: *build-template + extends: .build-template variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" # coqdoc for stdlib, until we know how to build it from installed Coq @@ -219,13 +230,13 @@ build:base: # no coqide for 32bit: libgtk installation problems build:base+32bit: - <<: *build-template + extends: .build-template variables: OPAM_VARIANT: "+32bit" COQ_EXTRA_CONF: "-native-compiler yes" build:edge+flambda: - <<: *build-template + extends: .build-template variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" @@ -233,28 +244,36 @@ build:edge+flambda: COQ_EXTRA_CONF_QUOTE: "-O3 -unbox-closures" build:edge+flambda:dune:dev: - <<: *dune-template + extends: .dune-template build:base+async: - <<: *build-template + extends: .build-template stage: test variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" + allow_failure: true # See https://github.com/coq/coq/issues/9658 + only: + variables: + - $UNRELIABLE =~ /enabled/ build:quick: - <<: *build-template + extends: .build-template variables: COQ_EXTRA_CONF: "-native-compiler no" QUICK: "1" + allow_failure: true # See https://github.com/coq/coq/issues/9637 + only: + variables: + - $UNRELIABLE =~ /enabled/ windows64: - <<: *windows-template + extends: .windows-template variables: ARCH: "64" windows32: - <<: *windows-template + extends: .windows-template variables: ARCH: "32" except: @@ -287,7 +306,7 @@ pkg:opam: OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" -.nix-template: &nix-template +.nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git stage: test variables: @@ -315,7 +334,7 @@ pkg:opam: - nix-build-coq.drv-0/*/test-suite/logs pkg:nix:deploy: - <<: *nix-template + extends: .nix-template environment: name: cachix url: https://coq.cachix.org @@ -326,29 +345,51 @@ pkg:nix:deploy: - master - /^v.*\..*$/ +pkg:nix:deploy:channel: + extends: .deploy-template + environment: + name: cachix + url: https://coq.cachix.org + only: + variables: + - $CACHIX_DEPLOYMENT_KEY + dependencies: + - pkg:nix:deploy + script: + - echo "$CACHIX_DEPLOYMENT_KEY" | tr -d '\r' | ssh-add - > /dev/null + - git fetch --unshallow + - git branch -v + - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_REF_NAME}" + pkg:nix: - <<: *nix-template + extends: .nix-template except: - master - /^v.*\..*$/ doc:refman: - <<: *doc-template + extends: .doc-template dependencies: - build:base doc:refman:dune: - <<: *dune-ci-template + extends: .dune-ci-template variables: - <<: *dune-ci-template-vars DUNE_TARGET: refman-html artifacts: - <<: *dune-ci-template-artifacts paths: - _build/default/doc/sphinx_build/html +doc:stdlib:dune: + extends: .dune-ci-template + variables: + DUNE_TARGET: stdlib-html + artifacts: + paths: + - _build/default/doc/stdlib/html + doc:refman:deploy: - stage: deploy + extends: .deploy-template environment: name: deployment url: https://coq.github.io/ @@ -358,15 +399,7 @@ doc:refman:deploy: dependencies: - doc:ml-api:odoc - doc:refman:dune - - doc:refman - before_script: - - which ssh-agent || ( apt-get update -y && apt-get install openssh-client -y ) - - eval $(ssh-agent -s) - - mkdir -p ~/.ssh - - chmod 700 ~/.ssh - - ssh-keyscan -t rsa github.com >> ~/.ssh/known_hosts - - git config --global user.name "coqbot" - - git config --global user.email "coqbot@users.noreply.github.com" + - doc:stdlib:dune script: - echo "$DOCUMENTATION_DEPLOY_KEY" | tr -d '\r' | ssh-add - > /dev/null - git clone git@github.com:coq/doc.git _deploy @@ -376,36 +409,34 @@ doc:refman:deploy: - mkdir -p _deploy/$CI_COMMIT_REF_NAME - cp -rv _build/default/_doc/_html _deploy/$CI_COMMIT_REF_NAME/api - cp -rv _build/default/doc/sphinx_build/html _deploy/$CI_COMMIT_REF_NAME/refman - - cp -rv _install_ci/share/doc/coq/html/stdlib _deploy/$CI_COMMIT_REF_NAME/stdlib + - cp -rv _build/default/doc/stdlib/html _deploy/$CI_COMMIT_REF_NAME/stdlib - cd _deploy/$CI_COMMIT_REF_NAME/ - git add api refman stdlib - git commit -m "Documentation of branch “$CI_COMMIT_REF_NAME” at $CI_COMMIT_SHORT_SHA" - git push # TODO: rebase and retry on failure doc:ml-api:odoc: - <<: *dune-ci-template + extends: .dune-ci-template variables: - <<: *dune-ci-template-vars DUNE_TARGET: apidoc artifacts: - <<: *dune-ci-template-artifacts paths: - _build/default/_doc/ test-suite:base: - <<: *test-suite-template + extends: .test-suite-template dependencies: - build:base test-suite:base+32bit: - <<: *test-suite-template + extends: .test-suite-template dependencies: - build:base+32bit variables: OPAM_VARIANT: "+32bit" test-suite:edge+flambda: - <<: *test-suite-template + extends: .test-suite-template dependencies: - build:edge+flambda variables: @@ -478,26 +509,30 @@ test-suite:edge+trunk+dune: allow_failure: true test-suite:base+async: - <<: *test-suite-template + extends: .test-suite-template dependencies: - build:base variables: COQFLAGS: "-async-proofs on" + allow_failure: true + only: + variables: + - $UNRELIABLE =~ /enabled/ validate:base: - <<: *validate-template + extends: .validate-template dependencies: - build:base validate:base+32bit: - <<: *validate-template + extends: .validate-template dependencies: - build:base+32bit variables: OPAM_VARIANT: "+32bit" validate:edge+flambda: - <<: *validate-template + extends: .validate-template dependencies: - build:edge+flambda variables: @@ -505,98 +540,104 @@ validate:edge+flambda: OPAM_VARIANT: "+flambda" validate:quick: - <<: *validate-template + extends: .validate-template dependencies: - build:quick + only: + variables: + - $UNRELIABLE =~ /enabled/ # Libraries are by convention the projects that depend on Coq # but not on its ML API library:ci-bedrock2: - <<: *ci-template + extends: .ci-template library:ci-color: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-compcert: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-coquelicot: - <<: *ci-template + extends: .ci-template library:ci-cross-crypto: - <<: *ci-template + extends: .ci-template library:ci-fcsl-pcm: - <<: *ci-template + extends: .ci-template library:ci-fiat-crypto: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-fiat-crypto-legacy: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-flocq: - <<: *ci-template + extends: .ci-template library:ci-corn: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-geocoq: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-hott: - <<: *ci-template + extends: .ci-template library:ci-iris-lambda-rust: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-math-comp: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-sf: - <<: *ci-template + extends: .ci-template + +library:ci-stdlib2: + extends: .ci-template-flambda library:ci-unimath: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-verdi-raft: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-vst: - <<: *ci-template-flambda + extends: .ci-template-flambda # Plugins are by definition the projects that depend on Coq's ML API plugin:ci-aac_tactics: - <<: *ci-template + extends: .ci-template plugin:ci-bignums: - <<: *ci-template + extends: .ci-template plugin:ci-coq_dpdgraph: - <<: *ci-template + extends: .ci-template plugin:ci-coqhammer: - <<: *ci-template + extends: .ci-template plugin:ci-elpi: - <<: *ci-template + extends: .ci-template plugin:ci-equations: - <<: *ci-template + extends: .ci-template plugin:ci-fiat_parsers: - <<: *ci-template + extends: .ci-template plugin:ci-ltac2: - <<: *ci-template + extends: .ci-template plugin:ci-mtac2: - <<: *ci-template + extends: .ci-template plugin:ci-paramcoq: - <<: *ci-template + extends: .ci-template plugin:plugin-tutorial: stage: test @@ -606,7 +647,7 @@ plugin:plugin-tutorial: - make -j "$NJOBS" plugin-tutorial plugin:ci-quickchick: - <<: *ci-template-flambda + extends: .ci-template-flambda plugin:ci-relation-algebra: - <<: *ci-template + extends: .ci-template diff --git a/CHANGES.md b/CHANGES.md index af2b7991dd..1e64b78d2e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -17,6 +17,8 @@ OCaml and dependencies Coqide +- CoqIDE now depends on gtk+3 and lablgtk3, rather than gtk+2 and lablgtk2. + - CoqIDE now properly sets the module name for a given file based on its path, see -topfile change entry for more details. @@ -97,6 +99,9 @@ Tactics - Ltac backtraces can be turned on using the "Ltac Backtrace" option. +- The syntax of the `autoapply` tactic was fixed to conform with preexisting + documentation: it now takes a `with` clause instead of a `using` clause. + Vernacular commands - `Combined Scheme` can now work when inductive schemes are generated in sort @@ -172,6 +177,8 @@ Standard Library - The `Coq.Numbers.Cyclic.Int31` library is deprecated. +- Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. + Universes - Added `Print Universes Subgraph` variant of `Print Universes`. @@ -181,6 +188,11 @@ Universes for the "Private Polymorphic Universes" option (and Unset it to get the previous behaviour). +SProp + +- Added a universe "SProp" for definitionally proof irrelevant + propositions. Use with -allow-sprop. See manual for details. + Inductives - An option and attributes to control the automatic decision to diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index bb0e388cdd..31fa3d2c4a 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1,34 +1,72 @@ # Contributing to Coq -Thank you for your interest in contributing to Coq! There are many ways to contribute, and we appreciate all of them. +Thank you for your interest in contributing to Coq! There are many ways to +contribute, and we appreciate all of them. Please make sure you read and +abide by the [Code of Conduct](CODE_OF_CONDUCT.md). ## Bug Reports -Bug reports are enormously useful to identify issues with Coq; we can't fix what we don't know about. To report a bug, please open an issue in the [Coq issue tracker](https://github.com/coq/coq/issues) (you'll need a GitHub account). You can file a bug for any of the following: - -- An anomaly. These are always considered bugs, so Coq will even ask you to file a bug report! -- An error you didn't expect. If you're not sure whether it's a bug or intentional, feel free to file a bug anyway. We may want to improve the documentation or error message. -- Missing documentation. It's helpful to track where the documentation should be improved, so please file a bug if you can't find or don't understand some bit of documentation. -- An error message that wasn't as helpful as you'd like. Bonus points for suggesting what information would have helped you. -- Bugs in CoqIDE should also be filed in the [Coq issue tracker](https://github.com/coq/coq/issues). Bugs in the Emacs plugin should be filed against [ProofGeneral](https://github.com/ProofGeneral/PG/issues), or against [company-coq](https://github.com/cpitclaudel/company-coq/issues) if they are specific to company-coq features. - -It would help if you search the existing issues before reporting a bug. This can be difficult, so consider it extra credit. We don't mind duplicate bug reports. - -When it applies, it's extremely helpful for bug reports to include sample code, and much better if the code is self-contained and complete. It's not necessary to minimize your bug or identify precisely where the issue is, since someone else can often do this if you include a complete example. We tend to include the code in the bug description itself, but if you have a very large input file then you can add it as an attachment. - -If you want to minimize your bug (or help minimize someone else's) for more extra credit, then you can use the [Coq bug minimizer](https://github.com/JasonGross/coq-tools) (specifically, the bug minimizer is the `find-bug.py` script in that repo). +Bug reports are enormously useful to identify issues with Coq; we can't fix +what we don't know about. To report a bug, please open an issue in the +[Coq issue tracker][] (you'll need a GitHub +account). You can file a bug for any of the following: + +- An anomaly. These are always considered bugs, so Coq will even ask you to + file a bug report! +- An error you didn't expect. If you're not sure whether it's a bug or + intentional, feel free to file a bug anyway. We may want to improve the + documentation or error message. +- Missing documentation. It's helpful to track where the documentation should + be improved, so please file a bug if you can't find or don't understand some + bit of documentation. +- An error message that wasn't as helpful as you'd like. Bonus points for + suggesting what information would have helped you. +- Bugs in CoqIDE should also be filed in the + [Coq issue tracker][]. + Bugs in the Emacs plugin should be filed against + [ProofGeneral](https://github.com/ProofGeneral/PG/issues), or against + [company-coq](https://github.com/cpitclaudel/company-coq/issues) if they are + specific to company-coq features. + +It would help if you search the existing issues before reporting a bug. This +can be difficult, so consider it extra credit. We don't mind duplicate bug +reports. If unsure, you are always very welcome to ask on our [Discourse forum][] +or [Gitter chat][] before, after, or while writting a bug report + +When it applies, it's extremely helpful for bug reports to include sample +code, and much better if the code is self-contained and complete. It's not +necessary to minimize your bug or identify precisely where the issue is, +since someone else can often do this if you include a complete example. We +tend to include the code in the bug description itself, but if you have a +very large input file then you can add it as an attachment. + +If you want to minimize your bug (or help minimize someone else's) for more +extra credit, then you can use the +[Coq bug minimizer](https://github.com/JasonGross/coq-tools) (specifically, +the bug minimizer is the `find-bug.py` script in that repo). + +### Triaging bug reports + +Triaging bug reports (adding labels, closing outdated / resolved bugs) +requires you to be granted some permissions. You may request members of the +**@coq/core** team to add you to the contributors team. They can do so using +this link: <https://github.com/orgs/coq/teams/contributors/members?add=true>. ## Pull requests **Beginner's guide to hacking Coq: [`dev/doc/README.md`](dev/doc/README.md)** \ **Development information and tools: [`dev/README.md`](dev/README.md)** -If you want to contribute a bug fix or feature yourself, pull requests on the [GitHub repository](https://github.com/coq/coq) are the way to contribute directly to the Coq implementation. We recommend you create a fork of the repository on GitHub and push your changes to a new "topic branch" in that fork. From there you can follow the [GitHub pull request documentation](https://help.github.com/articles/about-pull-requests/) to get your changes reviewed and pulled into the Coq source repository. +If you want to contribute a bug fix or feature yourself, pull requests on +the [GitHub repository](https://github.com/coq/coq) are the way to contribute +directly to the Coq implementation. We recommend you create a fork of the +repository on GitHub and push your changes to a new "topic branch" in that +fork. From there you can follow the +[GitHub pull request documentation](https://help.github.com/articles/about-pull-requests/) +to get your changes reviewed and pulled into the Coq source repository. Documentation for getting started with the Coq sources is located in various files in [`dev/doc`](dev/doc) (for example, [debugging.md](dev/doc/debugging.md)). -For further help with the Coq sources, feel free to join -the [Coq Gitter chat](https://gitter.im/coq/coq) and ask questions. Please make pull requests against the `master` branch. @@ -41,10 +79,10 @@ get one—, and the year of your contribution). It's helpful to run the Coq test suite with `make test-suite` before submitting your change. Our CI runs this test suite and lots of other tests, including -building external Coq developments, on every pull request, but these results +building external Coq projects, on every pull request, but these results take significantly longer to come back (on the order of a few hours). Running the test suite locally will take somewhere around 10-15 minutes. Refer to -[`dev/ci/README.md`](dev/ci/README.md#information-for-developers) for more +[`dev/ci/README-developers.md`](dev/ci/README-developers.md) for more information on CI tests, including how to run them on your private branches. If your pull request fixes a bug, please consider adding a regression test as @@ -53,19 +91,30 @@ well. See [`test-suite/README.md`](test-suite/README.md) for how to do so. If your pull request fixes a critical bug (a bug allowing a proof of `False`), please add an entry to [`dev/doc/critical-bugs`](/dev/doc/critical-bugs). -Don't be alarmed if the pull request process takes some time. It can take a few days to get feedback, approval on the final changes, and then a merge. Coq doesn't release new versions very frequently so it can take a few months for your change to land in a released version. That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. +Don't be alarmed if the pull request process takes some time. It can take a +few days to get feedback, approval on the final changes, and then a merge. +Do not hesitate to ping the reviewers if it takes longer than this. +Coq doesn't release new versions very frequently so it can take a few months +for your change to land in a released version. That said, you can start using +the latest Coq `master` branch to take advantage of all the new features, +improvements, and fixes. -Whitespace discipline (do not indent using tabs, no trailing spaces, text files end with newlines) is checked by the `lint` job on GitLab CI (using `git diff --check`). We ship a [`dev/tools/pre-commit`](/dev/tools/pre-commit) git hook which fixes these errors at commit time. `configure` automatically sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. +Whitespace discipline (do not indent using tabs, no trailing spaces, text +files end with newlines) is checked by the `lint` job on GitLab CI (using +`git diff --check`). We ship a [`dev/tools/pre-commit`](/dev/tools/pre-commit) +git hook which fixes these errors at commit time. `configure` automatically +sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. -Here are a few tags Coq developers may add to your PR and what they mean. In general feedback and requests for you as the pull request author will be in the comments and tags are only used to organize pull requests. +Here are a few tags Coq developers may add to your PR and what they mean. In +general feedback and requests for you as the pull request author will be in +the comments and tags are only used to organize pull requests. - [needs: rebase][rebase-label] indicates the PR should be rebased on top of the latest base branch (usually `master`). See the [GitHub documentation](https://help.github.com/articles/about-git-rebase/) for a brief introduction to using `git rebase`. - This label will be automatically added if you open or synchronize your PR and - it is not up-to-date with the base branch. So please, do not forget to rebase - your branch every time you update it. + We generally ask you to rebase only when there are merge conflicts or if + the PR has been opened for a long time and we want a fresh CI run. - [needs: fixing][fixing-label] indicates the PR needs a fix, as discussed in the comments. - [needs: benchmarking][benchmarking-label] and [needs: testing][testing-label] indicate the PR needs testing beyond what the test suite can handle. @@ -76,45 +125,86 @@ Here are a few tags Coq developers may add to your PR and what they mean. In gen To learn more about the merging process, you can read the [merging documentation for Coq maintainers](dev/doc/MERGING.md). -## Documentation - -Currently the process for contributing to the documentation is the same as for changing anything else in Coq, so please submit a pull request as described above. +[rebase-label]: https://github.com/coq/coq/pulls?utf8=%E2%9C%93&q=is%3Aopen%20is%3Apr%20label%3A%22needs%3A%20rebase%22 +[fixing-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+fixing%22 +[benchmarking-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+benchmarking%22 +[testing-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+testing%22 -Our issue tracker includes a flag to mark bugs related to documentation. You can view a list of documentation-related bugs using a [GitHub issue search](https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22). Many of these bugs can be fixed by contributing writing, without knowledge of Coq's OCaml source code. +[jenkins-doc]: https://github.com/coq/coq/wiki/Jenkins-(automated-benchmarking) -The sources for the [Coq reference manual](https://coq.inria.fr/distrib/current/refman/) are at [`doc/sphinx`](/doc/sphinx). These are written in reStructuredText and compiled to HTML and PDF with [Sphinx](http://www.sphinx-doc.org/). +## Documentation -You may also contribute to the informal documentation available in [Cocorico](https://github.com/coq/coq/wiki) (the Coq wiki), and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ). Both of these are editable by anyone with a GitHub account. +Currently the process for contributing to the documentation is the same as +for changing anything else in Coq, so please submit a pull request as +described above. -## Following the development +Our issue tracker includes a flag to mark bugs related to documentation. +You can view a list of documentation-related bugs using a +[GitHub issue search](https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22). +Many of these bugs can be fixed by contributing writing, without knowledge +of Coq's OCaml source code. -If you want to follow the development activity around Coq, you are encouraged -to subscribe to the [Coqdev mailing list](https://sympa.inria.fr/sympa/info/coqdev). -This mailing list has reasonably low traffic. +The sources for the [Coq reference manual](https://coq.inria.fr/distrib/current/refman/) +are at [`doc/sphinx`](/doc/sphinx). These are written in reStructuredText +and compiled to HTML and PDF with [Sphinx](http://www.sphinx-doc.org/). -You may also choose to use GitHub feature to -["watch" this repository](https://github.com/coq/coq/subscription), but be -advised that this means receiving a very large number of notifications. -GitHub gives [some advice](https://blog.github.com/2017-07-18-managing-large-numbers-of-github-notifications/#prioritize-the-notifications-you-receive) -on how to configure your e-mail client to filter these notifications. -A possible alternative is to deactivate e-mail notifications and manage your -GitHub web notifications using a tool such as [Octobox](http://octobox.io/). +You will find information on how to build the documentation in +[`doc/README.md`](doc/README.md) and information about the specificities of +the Coq Sphinx format in [`doc/sphinx/README.rst`](doc/sphinx/README.rst). -## Contributing outside this repository +You may also contribute to the informal documentation available in +[Cocorico](https://github.com/coq/coq/wiki) (the Coq wiki), and the +[Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ). Both of these are +editable by anyone with a GitHub account. -There are many useful ways to contribute to the Coq ecosystem that don't involve the Coq repository. +## Where to get help (with the Coq source code, or anything else) -Tutorials to teach Coq, and especially to teach particular advanced features, would be much appreciated. Some tutorials are listed on the [Coq website](https://coq.inria.fr/documentation). If you would like to add a link to this list, please make a pull request against the Coq website repository at https://github.com/coq/www. +We have a [Discourse forum][] (see in particular the [Coq development category][]) +and a [Gitter chat][]. Feel free to join any of them and ask questions. +People are generally happy to help and very reactive. -External plugins / libraries contribute to create a successful ecosystem around Coq. If your external development is mature enough, you may consider submitting it for addition to our CI tests. Refer to [`dev/ci/README.md`](/dev/ci/README.md) for more information. +[Coq development category]: https://coq.discourse.group/c/coq-development -Ask and answer questions on [Stack Exchange](https://stackexchange.com/filters/299857/questions-tagged-coq-on-stackexchange-sites) which has a helpful community of Coq users. +## Watching the repository -Hang out on the Coq IRC channel, `irc://irc.freenode.net/#coq`, and help answer questions. +["Watching" this repository](https://github.com/coq/coq/subscription) +can result in a very large number of notifications. We advise that if +you do, either [confifure your mailbox](https://blog.github.com/2017-07-18-managing-large-numbers-of-github-notifications/#prioritize-the-notifications-you-receive) +to handle incoming notifications efficiently, or you read your +notifications within a web browser. You can configure how you receive +notifications in [your GitHub settings](https://github.com/settings/notifications), +you can use the GitHub interface to mark as read, save for later or +mute threads. You can also manage your GitHub web notifications using +a tool such as [Octobox](http://octobox.io/). -[rebase-label]: https://github.com/coq/coq/pulls?utf8=%E2%9C%93&q=is%3Aopen%20is%3Apr%20label%3A%22needs%3A%20rebase%22 -[fixing-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+fixing%22 -[benchmarking-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+benchmarking%22 -[testing-label]: https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+testing%22 +## Contributing outside this repository -[jenkins-doc]: https://github.com/coq/coq/wiki/Jenkins-(automated-benchmarking) +There are many useful ways to contribute to the Coq ecosystem that don't +involve the Coq repository. + +Tutorials to teach Coq, and especially to teach particular advanced features, +are much appreciated. Some tutorials are listed on the +[Coq website](https://coq.inria.fr/documentation). If you would like to add +a link to this list, please make a pull request against the Coq website +repository at <https://github.com/coq/www>. + +External plugins / libraries contribute to create a successful ecosystem +around Coq. If your external development is mature enough, you may consider +submitting it for addition to our CI tests. Refer to +[`dev/ci/README-users.md`](dev/ci/README-users.md) for more information. + +Some Coq packages are not maintained by their authors anymore even if they +were useful (for instance because they changed jobs). The coq-community +organization is a place for people to take over the maintenance of such +useful packages. If you want to contribute by becoming a maintainer, you can +find a list of packages waiting for a maintainer [here](https://github.com/coq-community/manifesto/issues?q=is%3Aissue+is%3Aopen+label%3Amaintainer-wanted). +You can also propose a package that is not listed. Find out more about +coq-community in [the manifesto's README](https://github.com/coq-community/manifesto). + +Ask and answer questions on our [Discourse forum][], on [Stack Exchange][], +and on the Coq IRC channel (`irc://irc.freenode.net/#coq`). + +[Coq issue tracker]: https://github.com/coq/coq/issues +[Discourse forum]: https://coq.discourse.group/ +[Gitter chat]: https://gitter.im/coq/coq +[Stack Exchange]: https://stackexchange.com/filters/299857/questions-tagged-coq-on-stackexchange-sites @@ -43,8 +43,8 @@ WHAT DO YOU NEED ? - a C compiler - - for CoqIDE, the lablgtk development files (version >= 2.18.5), - and the GTK 2.x libraries including gtksourceview2. + - for CoqIDE, the lablgtk development files (version >= 3.0.0), + and the GTK 3.x libraries including gtksourceview3. Note that num and lablgtk should be properly registered with findlib/ocamlfind as Coq's makefile will use it to locate the @@ -75,16 +75,22 @@ endef ## Files in the source tree +# instead of using "export FOO" do "COQ_EXPORTED += FOO" +# this makes it possible to clean up the environment in the subcall +COQ_EXPORTED := COQ_EXPORTED + LEXFILES := $(call find, '*.mll') YACCFILES := $(call find, '*.mly') -export MLLIBFILES := $(call find, '*.mllib') -export MLPACKFILES := $(call find, '*.mlpack') -export MLGFILES := $(call find, '*.mlg') -export CFILES := $(call findindir, 'kernel/byterun', '*.c') +MLLIBFILES := $(call find, '*.mllib') +MLPACKFILES := $(call find, '*.mlpack') +MLGFILES := $(call find, '*.mlg') +CFILES := $(call findindir, 'kernel/byterun', '*.c') +COQ_EXPORTED +=MLLIBFILES MLPACKFILES MLGFILES CFILES # NB our find wrapper ignores the test suite MERLININFILES := $(call find, '.merlin.in') test-suite/unit-tests/.merlin.in -export MERLINFILES := $(MERLININFILES:.in=) +MERLINFILES := $(MERLININFILES:.in=) +COQ_EXPORTED += MERLINFILES # NB: The lists of currently existing .ml and .mli files will change # before and after a build or a make clean. Hence we do not export @@ -97,17 +103,21 @@ EXISTINGMLI := $(call find, '*.mli') GENMLGFILES:= $(MLGFILES:.mlg=.ml) # GRAMFILES must be in linking order -export GRAMFILES=$(addprefix gramlib/.pack/gramlib__,Ploc Plexing Gramext Grammar) -export GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) -export GENGRAMFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml -export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml -export GENHFILES:=kernel/byterun/coq_jumptbl.h -export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) +GRAMFILES=$(addprefix gramlib/.pack/gramlib__,Ploc Plexing Gramext Grammar) +GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) +GENGRAMFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml +GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml +GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) +COQ_EXPORTED += GRAMFILES GRAMMLFILES GENGRAMFILES GENMLFILES GENHFILES GENFILES ## More complex file lists -export MLSTATICFILES := $(filter-out $(GENMLFILES), $(EXISTINGML)) -export MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI)) +MLSTATICFILES := $(filter-out $(GENMLFILES), $(EXISTINGML)) +MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI)) +COQ_EXPORTED += MLSTATICFILES MLIFILES + +export $(COQ_EXPORTED) include Makefile.common diff --git a/Makefile.build b/Makefile.build index ea356d5f8e..2a071fd820 100644 --- a/Makefile.build +++ b/Makefile.build @@ -11,6 +11,9 @@ # This makefile is normally called by the main Makefile after setting # some variables. +# Cleanup environment (avoids filling it up) +unexport $(COQ_EXPORTED) + ########################################################################### # User-customizable variables ########################################################################### @@ -197,7 +200,7 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # the output format of the unix command time. For instance: # TIME="%C (%U user, %S sys, %e total, %M maxres)" -COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) +COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) -allow-sprop # Beware this depends on the makefile being in a particular dir, we # should pass an absolute path here but windows is tricky # c.f. https://github.com/coq/coq/pull/9560 @@ -316,11 +319,21 @@ $(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) cd $(dir $(LIBCOQRUN)) && \ $(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(notdir $(BYTERUN)) -kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h kernel/byterun/make_jumptbl.sh - kernel/byterun/make_jumptbl.sh $< $@ +kernel/genOpcodeFiles.exe: kernel/genOpcodeFiles.ml + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) -o $@ $< + +kernel/byterun/coq_instruct.h: kernel/genOpcodeFiles.exe + $(SHOW)'WRITE $@' + $(HIDE)$< enum > $@ + +kernel/byterun/coq_jumptbl.h: kernel/genOpcodeFiles.exe + $(SHOW)'WRITE $@' + $(HIDE)$< jump > $@ -kernel/copcodes.ml: kernel/byterun/coq_instruct.h kernel/make_opcodes.sh kernel/make-opcodes - kernel/make_opcodes.sh $< $@ +kernel/copcodes.ml: kernel/genOpcodeFiles.exe + $(SHOW)'WRITE $@' + $(HIDE)$< copml > $@ %.o: %.c $(SHOW)'OCAMLC $<' @@ -607,6 +620,9 @@ gramlib/.pack/gramlib.cmxa: $(GRAMOBJS:.cmo=.cmx) gramlib/.pack/gramlib.cmx $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $^ +# used by install +gramlib/.pack/gramlib_MLLIB_DEPENDENCIES:=$(GRAMFILES) + # Specific rule for kernel.cma, with $(VMBYTEFLAGS). # This helps loading dllcoqrun.so during an ocamldebug kernel/kernel.cma: kernel/kernel.mllib @@ -849,6 +865,18 @@ $(VDFILE).d: $(D_DEPEND_BEFORE_SRC) $(VFILES) $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT ########################################################################### + +# Useful to check that the exported variables are within the win32 limits + +printenv-real: + @env + @echo + @echo -n "Maxsize (win32 limit is 8k) : " + @env | wc -L + @echo -n "Total (win32 limit is 32k) : " + @env | wc -m + + # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles Makefile $(wildcard Makefile.*) config/Makefile : ; @@ -863,5 +891,5 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; # For emacs: # Local Variables: -# mode: makefile +# mode: makefile-gmake # End: diff --git a/Makefile.ci b/Makefile.ci index 0307d39d54..9180d51bee 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -40,6 +40,7 @@ CI_TARGETS= \ ci-relation-algebra \ ci-sf \ ci-simple-io \ + ci-stdlib2 \ ci-tlc \ ci-unimath \ ci-verdi-raft \ diff --git a/Makefile.dune b/Makefile.dune index 29f6fed974..4609c563d9 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -3,8 +3,9 @@ .PHONY: help voboot states world watch check # Main developer targets .PHONY: coq coqide coqide-server # Package targets -.PHONY: quickbyte quickopt # Partial / quick developer targets -.PHONY: test-suite refman-html apidoc release # Accesory targets +.PHONY: quickbyte quickopt quickide # Partial / quick developer targets +.PHONY: refman-html stdlib-html apidoc # Documentation targets +.PHONY: test-suite release # Accesory targets .PHONY: ocheck trunk ireport clean # Maintenance targets # use DUNEOPT=--display=short for a more verbose build @@ -26,9 +27,11 @@ help: @echo "" @echo " - quickbyte: build main ML files [coqtop + plugins + ide + printers] using the bytecode compiler" @echo " - quickopt: build main ML files [coqtop + plugins + ide + printers] using the optimizing compiler" + @echo " - quickide: build main IDE files [client + server + prelude] using the optimizing compiler" @echo "" @echo " - test-suite: run Coq's test suite" @echo " - refman-html: build Coq's reference manual [HTML version]" + @echo " - stdlib-html: build Coq's Stdlib documentation [HTML version]" @echo " - apidoc: build ML API documentation" @echo " - release: build Coq in release mode" @echo "" @@ -38,12 +41,14 @@ help: @echo " - clean: remove build directory and autogenerated files" @echo " - help: show this message" +# We need to bootstrap with a dummy coq.plugins.ltac so install targets do work. voboot: + @echo "(library (name ltac_plugin) (public_name coq.plugins.ltac) (modules_without_implementation extraargs extratactics))" > plugins/ltac/dune dune build $(DUNEOPT) @vodeps dune exec ./tools/coq_dune.exe $(BUILD_CONTEXT)/.vfiles.d states: voboot - dune build $(DUNEOPT) theories/Init/Prelude.vo + dune build --display=short $(DUNEOPT) dev/shim/coqtop-prelude world: voboot dune build $(DUNEOPT) @install @@ -75,12 +80,18 @@ quickbyte: voboot quickopt: voboot dune build $(DUNEOPT) $(QUICKOPT_TARGETS) +quickide: states + dune build $(DUNEOPT) dev/shim/coqide-prelude + test-suite: voboot dune runtest --no-buffer $(DUNEOPT) refman-html: voboot dune build @refman-html +stdlib-html: voboot + dune build @stdlib-html + apidoc: voboot dune build $(DUNEOPT) @doc diff --git a/Makefile.ide b/Makefile.ide index 23ce83d263..778863d1fc 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -17,7 +17,6 @@ ## Coqide-related variables set by ./configure in config/Makefile -#COQIDEINCLUDES : something like -I +lablgtk2 #HASCOQIDE : opt / byte / no #IDEFLAGS : some extra cma, for instance #IDEOPTCDEPS : on windows, ide/ide_win32_stubs.o ide/coq_icon.o @@ -41,7 +40,11 @@ COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide IDESRCDIRS:= $(CORESRCDIRS) ide ide/protocol -COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES) +ifeq ($(HASCOQIDE),no) +COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) +else +COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) -package lablgtk3-sourceview3 +endif IDEDEPS:=config/config.cma clib/clib.cma lib/lib.cma ide/protocol/ideprotocol.cma IDECMA:=ide/ide.cma @@ -56,11 +59,11 @@ IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_ ## GTK for Coqide MacOS bundle -GTKSHARE=$(shell pkg-config --variable=prefix gtk+-2.0)/share -GTKBIN=$(shell pkg-config --variable=prefix gtk+-2.0)/bin -GTKLIBS=$(shell pkg-config --variable=libdir gtk+-2.0) -PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-2.0)/bin -SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-2.0)/share +GTKSHARE=$(shell pkg-config --variable=prefix gtk+-3.0)/share +GTKBIN=$(shell pkg-config --variable=prefix gtk+-3.0)/bin +GTKLIBS=$(shell pkg-config --variable=libdir gtk+-3.0) +PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-3.0)/bin +SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-3.0)/share ########################################################################### # CoqIde special targets @@ -70,7 +73,7 @@ SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-2.0)/share .PHONY: ide-toploop ide-byteloop ide-optloop # target to build CoqIde (native version) and the stuff needed to lauch it -coqide: coqide-files coqide-opt theories/Init/Prelude.$(VO) +coqide: coqide-files coqide-opt theories/Init/Prelude.$(VO) $(TOPBIN) # target to build CoqIde (in native and byte versions), and no more # NB: this target is used in the opam package coq-coqide @@ -98,7 +101,7 @@ ifeq ($(HASCOQIDE),opt) $(COQIDE): $(LINKIDEOPT) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 -linkall $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ else $(COQIDE): $(COQIDEBYTE) @@ -108,7 +111,7 @@ endif $(COQIDEBYTE): $(LINKIDE) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile @rm -f $@ @@ -128,7 +131,7 @@ ide/%.cmx: ide/%.ml $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -c $< # We need to compile this file without -safe-string due mess with -# lablgtk API. Other option is to require lablgtk >= 2.8.16 +# lablgtk API. Other option is to require lablgtk >= 3.0.0 ide/ideutils.cmo: ide/ideutils.ml $(SHOW)'OCAMLC $<' $(HIDE)$(filter-out -safe-string,$(OCAMLC)) $(COQIDEFLAGS) $(BYTEFLAGS) -c $< @@ -228,7 +231,7 @@ $(COQIDEAPP)/Contents: $(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3.sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents @@ -68,25 +68,25 @@ and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ), for additional user-contributed documentation. ## Changes + There is a file named [`CHANGES.md`](CHANGES.md) that explains the differences and the incompatibilities since last versions. If you upgrade Coq, please read it carefully. -## The Coq Club -The Coq Club moderated mailing list is meant to be a standard way -to discuss questions about the Coq system and related topics. The -subscription link can be found at [coq.inria.fr/community](http://coq.inria.fr/community). +## Questions and discussion + +We have a number of channels to reach the user community and the +development team: -The topics to be discussed in the club should include: +- Our [Discourse forum](https://coq.discourse.group). +- Our mailing list, the [Coq-Club](https://sympa.inria.fr/sympa/info/coq-club). +- Our [Gitter channel][gitter-link], which is a good way to reach + developers for quick chat and development questions. -* technical problems; -* questions about proof developments; -* suggestions and questions about the implementation; -* announcements of proofs; -* theoretical questions about typed lambda-calculi which are - closely related to Coq. +See also [coq.inria.fr/community](https://coq.inria.fr/community.html). ## Bugs report + Please report any bug / feature request in [our issue tracker](https://github.com/coq/coq/issues). To be effective, bug reports should mention the OCaml version used diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 4329b2d743..4f4527ca12 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -25,7 +25,7 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = let nparams = List.length mb.mind_params_ctxt in (* include letins *) let mind_entry_record = match mb.mind_record with | NotRecord -> None | FakeRecord -> Some None - | PrimRecord data -> Some (Some (Array.map pi1 data)) + | PrimRecord data -> Some (Some (Array.map (fun (x,_,_,_) -> x) data)) in let mind_entry_universes = match mb.mind_universes with | Monomorphic univs -> Monomorphic_entry univs @@ -89,11 +89,14 @@ let eq_recarg a1 a2 = match a1, a2 with let eq_reloc_tbl = Array.equal (fun x y -> Int.equal (fst x) (fst y) && Int.equal (snd x) (snd y)) +let eq_in_context (ctx1, t1) (ctx2, t2) = + Context.Rel.equal Constr.equal ctx1 ctx2 && Constr.equal t1 t2 + let check_packet env mind ind { mind_typename; mind_arity_ctxt; mind_arity; mind_consnames; mind_user_lc; mind_nrealargs; mind_nrealdecls; mind_kelim; mind_nf_lc; - mind_consnrealargs; mind_consnrealdecls; mind_recargs; mind_nb_constant; - mind_nb_args; mind_reloc_tbl } = + mind_consnrealargs; mind_consnrealdecls; mind_recargs; mind_relevance; + mind_nb_constant; mind_nb_args; mind_reloc_tbl } = let check = check mind in ignore mind_typename; (* passed through *) @@ -105,7 +108,7 @@ let check_packet env mind ind check "mind_nrealdecls" Int.(equal ind.mind_nrealdecls mind_nrealdecls); check "mind_kelim" (check_kelim ind.mind_kelim mind_kelim); - check "mind_nf_lc" (Array.equal Constr.equal ind.mind_nf_lc mind_nf_lc); + check "mind_nf_lc" (Array.equal eq_in_context ind.mind_nf_lc mind_nf_lc); (* NB: here syntactic equality is not just an optimisation, we also care about the shape of the terms *) @@ -114,6 +117,8 @@ let check_packet env mind ind check "mind_recargs" (Rtree.equal eq_recarg ind.mind_recargs mind_recargs); + check "mind_relevant" (Sorts.relevance_equal ind.mind_relevance mind_relevance); + check "mind_nb_args" Int.(equal ind.mind_nb_args mind_nb_args); check "mind_nb_constant" Int.(equal ind.mind_nb_constant mind_nb_constant); check "mind_reloc_tbl" (eq_reloc_tbl ind.mind_reloc_tbl mind_reloc_tbl); @@ -125,7 +130,8 @@ let check_same_record r1 r2 = match r1, r2 with | PrimRecord r1, PrimRecord r2 -> (* The kernel doesn't care about the names, we just need to check that the saved types are correct. *) - Array.for_all2 (fun (_,_,tys1) (_,_,tys2) -> + Array.for_all2 (fun (_,_,r1,tys1) (_,_,r2,tys2) -> + Array.equal Sorts.relevance_equal r1 r2 && Array.equal Constr.equal tys1 tys2) r1 r2 | (NotRecord | FakeRecord | PrimRecord _), _ -> false diff --git a/checker/checker.ml b/checker/checker.ml index 3c93ef7d36..cbac9cb570 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -146,6 +146,7 @@ let make_senv () = let senv = Safe_typing.set_engagement !impredicative_set senv in let senv = Safe_typing.set_indices_matter !indices_matter senv in let senv = Safe_typing.set_VM false senv in + let senv = Safe_typing.set_allow_sprop true senv in (* be smarter later *) Safe_typing.set_native_compiler false senv let admit_list = ref ([] : object_file list) @@ -273,6 +274,7 @@ let explain_exn = function | IllFormedBranch _ -> str"IllFormedBranch" | Generalization _ -> str"Generalization" | ActualType _ -> str"ActualType" + | IncorrectPrimitive _ -> str"IncorrectPrimitive" | CantApplyBadType ((n,a,b),{uj_val = hd; uj_type = hdty},args) -> let pp_arg i judge = hv 1 (str"arg " ++ int (i+1) ++ str"= " ++ @@ -295,6 +297,8 @@ let explain_exn = function | IllFormedRecBody _ -> str"IllFormedRecBody" | IllTypedRecBody _ -> str"IllTypedRecBody" | UnsatisfiedConstraints _ -> str"UnsatisfiedConstraints" + | DisallowedSProp -> str"DisallowedSProp" + | BadRelevance -> str"BadRelevance" | UndeclaredUniverse _ -> str"UndeclaredUniverse")) | InductiveError e -> @@ -382,6 +386,7 @@ let init_with_argv argv = let _fhandle = Feedback.(add_feeder (console_feedback_listener Format.err_formatter)) in try parse_args argv; + CWarnings.set_flags ("+"^Typeops.warn_bad_relevance_name); if !Flags.debug then Printexc.record_backtrace true; Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); Flags.if_verbose print_header (); diff --git a/checker/dune b/checker/dune index ee427d26c5..73cbbc8d19 100644 --- a/checker/dune +++ b/checker/dune @@ -3,8 +3,7 @@ ; If we don't pack checker we will have a problem here due to ; duplicate module names in the whole build. (library - (name checklib) - (public_name coq.checklib) + (name coq_checklib) (synopsis "Coq's Standalone Proof Checker") (modules :standard \ coqchk votour) (wrapped true) @@ -15,14 +14,14 @@ (public_name coqchk) (package coq) (modules coqchk) - (flags :standard -open Checklib) - (libraries coq.checklib)) + (flags :standard -open Coq_checklib) + (libraries coq_checklib)) (executable (name votour) (public_name votour) (package coq) (modules votour) - (flags :standard -open Checklib) - (libraries coq.checklib)) + (flags :standard -open Coq_checklib) + (libraries coq_checklib)) diff --git a/checker/values.ml b/checker/values.ml index 66467fa8f5..5cbf0ff298 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -95,9 +95,9 @@ let v_cons = v_tuple "constructor" [|v_ind;Int|] (** kernel/univ *) let v_level_global = v_tuple "Level.Global.t" [|v_dp;Int|] -let v_raw_level = v_sum "raw_level" 2 (* Prop, Set *) +let v_raw_level = v_sum "raw_level" 3 (* SProp, Prop, Set *) [|(*Level*)[|v_level_global|]; (*Var*)[|Int|]|] -let v_level = v_tuple "level" [|Int;v_raw_level|] +let v_level = v_tuple "level" [|Int;v_raw_level|] let v_expr = v_tuple "levelexpr" [|v_level;Int|] let v_univ = List v_expr @@ -116,8 +116,11 @@ let v_context_set = v_tuple "universe_context_set" [|v_hset v_level;v_cstrs|] (** kernel/term *) -let v_sort = v_sum "sort" 2 (*Prop, Set*) [|[|v_univ(*Type*)|]|] -let v_sortfam = v_enum "sorts_family" 3 +let v_sort = v_sum "sort" 3 (*SProp, Prop, Set*) [|[|v_univ(*Type*)|]|] +let v_sortfam = v_enum "sorts_family" 4 + +let v_relevance = v_sum "relevance" 2 [||] +let v_binder_annot x = v_tuple "binder_annot" [|x;v_relevance|] let v_puniverses v = v_tuple "punivs" [|v;v_instance|] @@ -126,7 +129,7 @@ let v_boollist = List v_bool let v_caseinfo = let v_cstyle = v_enum "case_style" 5 in let v_cprint = v_tuple "case_printing" [|v_boollist;Array v_boollist;v_cstyle|] in - v_tuple "case_info" [|v_ind;Int;Array Int;Array Int;v_cprint|] + v_tuple "case_info" [|v_ind;Int;Array Int;Array Int;v_relevance;v_cprint|] let v_cast = v_enum "cast_kind" 4 @@ -141,9 +144,9 @@ let rec v_constr = [|Fail "Evar"|]; (* Evar *) [|v_sort|]; (* Sort *) [|v_constr;v_cast;v_constr|]; (* Cast *) - [|v_name;v_constr;v_constr|]; (* Prod *) - [|v_name;v_constr;v_constr|]; (* Lambda *) - [|v_name;v_constr;v_constr;v_constr|]; (* LetIn *) + [|v_binder_annot v_name;v_constr;v_constr|]; (* Prod *) + [|v_binder_annot v_name;v_constr;v_constr|]; (* Lambda *) + [|v_binder_annot v_name;v_constr;v_constr;v_constr|]; (* LetIn *) [|v_constr;Array v_constr|]; (* App *) [|v_puniverses v_cst|]; (* Const *) [|v_puniverses v_ind|]; (* Ind *) @@ -156,12 +159,13 @@ let rec v_constr = |]) and v_prec = Tuple ("prec_declaration", - [|Array v_name; Array v_constr; Array v_constr|]) + [|Array (v_binder_annot v_name); Array v_constr; Array v_constr|]) and v_fix = Tuple ("pfixpoint", [|Tuple ("fix2",[|Array Int;Int|]);v_prec|]) and v_cofix = Tuple ("pcofixpoint",[|Int;v_prec|]) -let v_rdecl = v_sum "rel_declaration" 0 [| [|v_name; v_constr|]; (* LocalAssum *) - [|v_name; v_constr; v_constr|] |] (* LocalDef *) +let v_rdecl = v_sum "rel_declaration" 0 + [| [|v_binder_annot v_name; v_constr|]; (* LocalAssum *) + [|v_binder_annot v_name; v_constr; v_constr|] |] (* LocalDef *) let v_rctxt = List v_rdecl let v_section_ctxt = v_enum "emptylist" 1 @@ -231,6 +235,7 @@ let v_cb = v_tuple "constant_body" [|v_section_ctxt; v_cst_def; v_constr; + v_relevance; Any; v_univs; Opt v_context_set; @@ -261,10 +266,11 @@ let v_one_ind = v_tuple "one_inductive_body" Int; Int; List v_sortfam; - Array v_constr; + Array (v_pair v_rctxt v_constr); Array Int; Array Int; v_wfp; + v_relevance; Int; Int; Any|] @@ -273,7 +279,7 @@ let v_finite = v_enum "recursivity_kind" 3 let v_record_info = v_sum "record_info" 2 - [| [| Array (v_tuple "record" [| v_id; Array v_id; Array v_constr |]) |] |] + [| [| Array (v_tuple "record" [| v_id; Array v_id; Array v_relevance; Array v_constr |]) |] |] let v_ind_pack = v_tuple "mutual_inductive_body" [|Array v_one_ind; diff --git a/clib/cArray.ml b/clib/cArray.ml index e0a1859184..774e3a56a6 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -52,6 +52,8 @@ sig val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map3 : ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array + val map3_i : + (int -> 'a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array val iter2_i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array @@ -66,6 +68,7 @@ sig module Smart : sig val map : ('a -> 'a) -> 'a array -> 'a array + val map_i : (int -> 'a -> 'a) -> 'a array -> 'a array val map2 : ('a -> 'b -> 'b) -> 'a array -> 'b array -> 'b array val fold_left_map : ('a -> 'b -> 'a * 'b) -> 'a -> 'b array -> 'a * 'b array val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'c) -> 'a -> 'b array -> 'c array -> 'a * 'c array @@ -358,6 +361,21 @@ let map3 f v1 v2 v3 = res end +let map3_i f v1 v2 v3 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + let len3 = Array.length v3 in + let () = if not (Int.equal len1 len2 && Int.equal len1 len3) then invalid_arg "Array.map3_i" in + if Int.equal len1 0 then + [| |] + else begin + let res = Array.make len1 (f 0 (uget v1 0) (uget v2 0) (uget v3 0)) in + for i = 1 to pred len1 do + Array.unsafe_set res i (f i (uget v1 i) (uget v2 i) (uget v3 i)) + done; + res + end + let map_left f a = (* Ocaml does not guarantee Array.map is LR *) let l = Array.length a in (* (even if so), then we rewrite it *) if Int.equal l 0 then [||] else begin @@ -465,6 +483,36 @@ struct ans end else ar + (* Same as map_i but smart *) + let map_i f (ar : 'a array) = + let len = Array.length ar in + let i = ref 0 in + let break = ref true in + let temp = ref None in + while !break && (!i < len) do + let v = Array.unsafe_get ar !i in + let v' = f !i v in + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end + done; + if !i < len then begin + (* The array is not the same as the original one *) + let ans : 'a array = Array.copy ar in + let v = match !temp with None -> assert false | Some x -> x in + Array.unsafe_set ans !i v; + incr i; + while !i < len do + let v = Array.unsafe_get ans !i in + let v' = f !i v in + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + ans + end else ar + let map2 f aux_ar ar = let len = Array.length ar in let aux_len = Array.length aux_ar in diff --git a/clib/cArray.mli b/clib/cArray.mli index 21479d2b45..c1b29bb9d3 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -83,6 +83,8 @@ sig val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map3 : ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array + val map3_i : + (int -> 'a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array (** As [map] but guaranteed to be left-to-right. *) @@ -127,6 +129,8 @@ sig (** [Smart.map f a] behaves as [map f a] but returns [a] instead of a copy when [f x == x] for all [x] in [a]. *) + val map_i : (int -> 'a -> 'a) -> 'a array -> 'a array + val map2 : ('a -> 'b -> 'b) -> 'a array -> 'b array -> 'b array (** [Smart.map2 f a b] behaves as [map2 f a b] but returns [a] instead of a copy when [f x y == y] for all [x] in [a] and [y] in [b] pointwise. *) diff --git a/clib/cList.ml b/clib/cList.ml index 524945ef23..aa01f6e5b5 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -98,6 +98,7 @@ sig val split : ('a * 'b) list -> 'a list * 'b list val combine : 'a list -> 'b list -> ('a * 'b) list val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list + val split4 : ('a * 'b * 'c * 'd) list -> 'a list * 'b list * 'c list * 'd list val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list val add_set : 'a eq -> 'a -> 'a list -> 'a list val eq_set : 'a eq -> 'a list -> 'a list -> bool @@ -846,6 +847,12 @@ let split3 = function split3_loop cp cq cr l; (cast cp, cast cq, cast cr) +(** XXX TODO tailrec *) +let rec split4 = function + | [] -> ([], [], [], []) + | (a,b,c,d)::l -> + let (ra, rb, rc, rd) = split4 l in (a::ra, b::rb, c::rc, d::rd) + let rec combine3_loop p l1 l2 l3 = match l1, l2, l3 with | [], [], [] -> () | x :: l1, y :: l2, z :: l3 -> diff --git a/clib/cList.mli b/clib/cList.mli index 8582e6cd65..a2fe0b759a 100644 --- a/clib/cList.mli +++ b/clib/cList.mli @@ -308,6 +308,9 @@ sig val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list (** Like [split] but for triples *) + val split4 : ('a * 'b * 'c * 'd) list -> 'a list * 'b list * 'c list * 'd list + (** Like [split] but for quads *) + val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list (** Like [combine] but for triples *) diff --git a/clib/cMap.ml b/clib/cMap.ml index e4ce6c7c02..016d8bdeca 100644 --- a/clib/cMap.ml +++ b/clib/cMap.ml @@ -36,6 +36,7 @@ sig val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val height : 'a t -> int val filter_range : (key -> int) -> 'a t -> 'a t + val update: key -> ('a option -> 'a option) -> 'a t -> 'a t module Smart : sig val map : ('a -> 'a) -> 'a t -> 'a t @@ -64,6 +65,7 @@ sig val fold_right : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b val height : 'a map -> int val filter_range : (M.t -> int) -> 'a map -> 'a map + val update: M.t -> ('a option -> 'a option) -> 'a map -> 'a map module Smart : sig val map : ('a -> 'a) -> 'a map -> 'a map @@ -94,8 +96,8 @@ struct type set = S.t type 'a _map = - | MEmpty - | MNode of 'a map * M.t * 'a * 'a map * int + | MEmpty + | MNode of {l:'a map; v:F.key; d:'a; r:'a map; h:int} type _set = | SEmpty @@ -108,41 +110,41 @@ struct let rec set k v (s : 'a map) : 'a map = match map_prj s with | MEmpty -> raise Not_found - | MNode (l, k', v', r, h) -> + | MNode {l; v=k'; d=v'; r; h} -> let c = M.compare k k' in if c < 0 then let l' = set k v l in if l == l' then s - else map_inj (MNode (l', k', v', r, h)) + else map_inj (MNode {l=l'; v=k'; d=v'; r; h}) else if c = 0 then if v' == v then s - else map_inj (MNode (l, k', v, r, h)) + else map_inj (MNode {l; v=k'; d=v; r; h}) else let r' = set k v r in if r == r' then s - else map_inj (MNode (l, k', v', r', h)) + else map_inj (MNode {l; v=k'; d=v'; r=r'; h}) let rec modify k f (s : 'a map) : 'a map = match map_prj s with | MEmpty -> raise Not_found - | MNode (l, k', v, r, h) -> - let c = M.compare k k' in + | MNode {l; v; d; r; h} -> + let c = M.compare k v in if c < 0 then let l' = modify k f l in if l == l' then s - else map_inj (MNode (l', k', v, r, h)) + else map_inj (MNode {l=l'; v; d; r; h}) else if c = 0 then - let v' = f k' v in - if v' == v then s - else map_inj (MNode (l, k', v', r, h)) + let d' = f v d in + if d' == d then s + else map_inj (MNode {l; v; d=d'; r; h}) else let r' = modify k f r in if r == r' then s - else map_inj (MNode (l, k', v, r', h)) + else map_inj (MNode {l; v; d; r=r'; h}) let rec domain (s : 'a map) : set = match map_prj s with | MEmpty -> set_inj SEmpty - | MNode (l, k, _, r, h) -> - set_inj (SNode (domain l, k, domain r, h)) + | MNode {l; v; r; h; _} -> + set_inj (SNode (domain l, v, domain r, h)) (** This function is essentially identity, but OCaml current stdlib does not take advantage of the similarity of the two structures, so we introduce this unsafe loophole. *) @@ -150,31 +152,31 @@ struct let rec bind f (s : set) : 'a map = match set_prj s with | SEmpty -> map_inj MEmpty | SNode (l, k, r, h) -> - map_inj (MNode (bind f l, k, f k, bind f r, h)) + map_inj (MNode { l=bind f l; v=k; d=f k; r=bind f r; h}) (** Dual operation of [domain]. *) let rec fold_left f (s : 'a map) accu = match map_prj s with | MEmpty -> accu - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let accu = f k v (fold_left f l accu) in fold_left f r accu let rec fold_right f (s : 'a map) accu = match map_prj s with | MEmpty -> accu - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let accu = f k v (fold_right f r accu) in fold_right f l accu let height s = match map_prj s with | MEmpty -> 0 - | MNode (_, _, _, _, h) -> h + | MNode {h;_} -> h (* Filter based on a range *) let filter_range in_range m = let rec aux m = function | MEmpty -> m - | MNode (l, k, v, r, _) -> - let vr = in_range k in + | MNode {l; v; d; r; _} -> + let vr = in_range v in (* the range is below the current value *) if vr < 0 then aux m (map_prj l) (* the range is above the current value *) @@ -183,29 +185,102 @@ struct else let m = aux m (map_prj l) in let m = aux m (map_prj r) in - F.add k v m + F.add v d m in aux F.empty (map_prj m) + (* Imported from OCaml upstream until we can bump the version *) + let create l x d r = + let hl = height l and hr = height r in + map_inj @@ MNode{l; v=x; d; r; h=(if hl >= hr then hl + 1 else hr + 1)} + + let bal l x d r = + let hl = match map_prj l with MEmpty -> 0 | MNode {h} -> h in + let hr = match map_prj r with MEmpty -> 0 | MNode {h} -> h in + if hl > hr + 2 then begin + match map_prj l with + | MEmpty -> invalid_arg "Map.bal" + | MNode{l=ll; v=lv; d=ld; r=lr} -> + if height ll >= height lr then + create ll lv ld (create lr x d r) + else begin + match map_prj lr with + | MEmpty -> invalid_arg "Map.bal" + | MNode{l=lrl; v=lrv; d=lrd; r=lrr}-> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + end + end else if hr > hl + 2 then begin + match map_prj r with + | MEmpty -> invalid_arg "Map.bal" + | MNode{l=rl; v=rv; d=rd; r=rr} -> + if height rr >= height rl then + create (create l x d rl) rv rd rr + else begin + match map_prj rl with + | MEmpty -> invalid_arg "Map.bal" + | MNode{l=rll; v=rlv; d=rld; r=rlr} -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + end + end else + map_inj @@ MNode{l; v=x; d; r; h=(if hl >= hr then hl + 1 else hr + 1)} + + let rec remove_min_binding m = match map_prj m with + | MEmpty -> invalid_arg "Map.remove_min_elt" + | MNode {l;v;d;r;_} -> + match map_prj l with + | MEmpty -> r + | _ -> bal (remove_min_binding l) v d r + + let merge t1 t2 = + match (map_prj t1, map_prj t2) with + (MEmpty, t) -> map_inj t + | (t, MEmpty) -> map_inj t + | (_, _) -> + let (x, d) = F.min_binding t2 in + bal t1 x d (remove_min_binding t2) + + let rec update x f m = match map_prj m with + | MEmpty -> + begin match f None with + | None -> map_inj MEmpty + | Some data -> map_inj @@ MNode{l=map_inj MEmpty; v=x; d=data; r=map_inj MEmpty; h=1} + end + | MNode {l; v; d; r; h} as m -> + let c = M.compare x v in + if c = 0 then begin + match f (Some d) with + | None -> merge l r + | Some data -> + if d == data then map_inj m else + map_inj @@ MNode{l; v=x; d=data; r; h} + end else if c < 0 then + let ll = update x f l in + if l == ll then map_inj m else bal ll v d r + else + let rr = update x f r in + if r == rr then map_inj m else bal l v d rr + + (* End of Imported OCaml *) + module Smart = struct let rec map f (s : 'a map) = match map_prj s with | MEmpty -> map_inj MEmpty - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let l' = map f l in let r' = map f r in let v' = f v in if l == l' && r == r' && v == v' then s - else map_inj (MNode (l', k, v', r', h)) + else map_inj (MNode {l=l'; v=k; d=v'; r=r'; h}) let rec mapi f (s : 'a map) = match map_prj s with | MEmpty -> map_inj MEmpty - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let l' = mapi f l in let r' = mapi f r in let v' = f k v in if l == l' && r == r' && v == v' then s - else map_inj (MNode (l', k, v', r', h)) + else map_inj (MNode {l=l'; v=k; d=v'; r=r'; h}) end @@ -214,9 +289,9 @@ struct let rec map f (s : 'a map) : 'b map = match map_prj s with | MEmpty -> map_inj MEmpty - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> let (k, v) = f k v in - map_inj (MNode (map f l, k, v, map f r, h)) + map_inj (MNode {l=map f l; v=k; d=v; r=map f r; h}) end @@ -227,14 +302,14 @@ struct let rec fold_left f s accu = match map_prj s with | MEmpty -> return accu - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> fold_left f l accu >>= fun accu -> f k v accu >>= fun accu -> fold_left f r accu let rec fold_right f s accu = match map_prj s with | MEmpty -> return accu - | MNode (l, k, v, r, h) -> + | MNode {l; v=k; d=v; r; h} -> fold_right f r accu >>= fun accu -> f k v accu >>= fun accu -> fold_right f l accu diff --git a/clib/cMap.mli b/clib/cMap.mli index ca6ddb2f4e..9bbb8d50dd 100644 --- a/clib/cMap.mli +++ b/clib/cMap.mli @@ -66,6 +66,18 @@ sig [filter_range] returns the submap of [m] whose keys are in range. Note that [in_range] has to define a continouous range. *) + val update: key -> ('a option -> 'a option) -> 'a t -> 'a t + (** [update x f m] returns a map containing the same bindings as + [m], except for the binding of [x]. Depending on the value of + [y] where [y] is [f (find_opt x m)], the binding of [x] is + added, removed or updated. If [y] is [None], the binding is + removed if it exists; otherwise, if [y] is [Some z] then [x] + is associated to [z] in the resulting map. If [x] was already + bound in [m] to a value that is physically equal to [z], [m] + is returned unchanged (the result of the function is then + physically equal to [m]). + *) + module Smart : sig val map : ('a -> 'a) -> 'a t -> 'a t diff --git a/clib/hMap.ml b/clib/hMap.ml index 5d634b7af0..09ffb39c21 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -408,6 +408,18 @@ struct let filter_range f s = filter (fun x _ -> f x = 0) s + let update k f m = + let aux = function + | None -> (match f None with + | None -> None + | Some v -> Some (Map.singleton k v)) + | Some m -> + let m = Map.update k f m in + if Map.is_empty m then None + else Some m + in + Int.Map.update (M.hash k) aux m + module Unsafe = struct let map f s = diff --git a/configure.ml b/configure.ml index ef38651a4d..5b99851f83 100644 --- a/configure.ml +++ b/configure.ml @@ -150,7 +150,11 @@ let numeric_prefix_list s = let max = String.length s in let i = ref 0 in while !i < max && isnum s.[!i] do incr i done; - string_split '.' (String.sub s 0 !i) + match string_split '.' (String.sub s 0 !i) with + | [v] -> [v;"0";"0"] + | [v1;v2] -> [v1;v2;"0"] + | [v1;v2;""] -> [v1;v2;"0"] (* e.g. because it ends with ".beta" *) + | v -> v (** Combined existence and directory tests *) @@ -226,7 +230,6 @@ type preferences = { docdir : string option; coqdocdir : string option; ocamlfindcmd : string option; - lablgtkdir : string option; arch : string option; natdynlink : bool; coqide : ide option; @@ -263,7 +266,6 @@ let default = { docdir = None; coqdocdir = None; ocamlfindcmd = None; - lablgtkdir = None; arch = None; natdynlink = true; coqide = None; @@ -368,8 +370,6 @@ let args_options = Arg.align [ "<dir> Where to install Coqdoc style files"; "-ocamlfind", arg_string_option (fun p ocamlfindcmd -> { p with ocamlfindcmd }), "<dir> Specifies the ocamlfind command to use"; - "-lablgtkdir", arg_string_option (fun p lablgtkdir -> { p with lablgtkdir }), - "<dir> Specifies the path to the Lablgtk library"; "-flambda-opts", arg_string_list ' ' (fun p flambda_flags -> { p with flambda_flags }), "<flags> Specifies additional flags to be passed to the flambda optimizing compiler"; "-arch", arg_string_option (fun p arch -> { p with arch }), @@ -697,75 +697,31 @@ let check_for_numlib () = let numlib = check_for_numlib () -(** * lablgtk2 and CoqIDE *) +(** * lablgtk3 and CoqIDE *) -type source = Manual | OCamlFind | Stdlib - -let get_source = function -| Manual -> "manually provided" -| OCamlFind -> "via ocamlfind" -| Stdlib -> "in OCaml library" - -(** Is some location a suitable LablGtk2 installation ? *) - -let check_lablgtkdir ?(fatal=false) src dir = - let yell msg = if fatal then die msg else (warn "%s" msg; false) in - let msg = get_source src in - if not (dir_exists dir) then - yell (sprintf "No such directory '%s' (%s)." dir msg) - else if not (Sys.file_exists (dir/"gSourceView2.cmi")) then - yell (sprintf "Incomplete LablGtk2 (%s): no %s/gSourceView2.cmi." msg dir) - else if not (Sys.file_exists (dir/"glib.mli")) then - yell (sprintf "Incomplete LablGtk2 (%s): no %s/glib.mli." msg dir) - else true - -(** Detect and/or verify the Lablgtk2 location *) +(** Detect and/or verify the Lablgtk3 location *) let get_lablgtkdir () = - match !prefs.lablgtkdir with - | Some dir -> - let msg = Manual in - if check_lablgtkdir ~fatal:true msg dir then dir, msg - else "", msg - | None -> - let msg = OCamlFind in - let d1,_ = tryrun camlexec.find ["query";"lablgtk2.sourceview2"] in - if d1 <> "" && check_lablgtkdir msg d1 then d1, msg - else - (* In debian wheezy, ocamlfind knows only of lablgtk2 *) - let d2,_ = tryrun camlexec.find ["query";"lablgtk2"] in - if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg - else - let msg = Stdlib in - let d3 = camllib^"/lablgtk2" in - if check_lablgtkdir msg d3 then d3, msg - else "", msg + tryrun camlexec.find ["query";"lablgtk3-sourceview3"] (** Detect and/or verify the Lablgtk2 version *) -let check_lablgtk_version src dir = match src with -| Manual | Stdlib -> - warn "Could not check the version of lablgtk2.\nMake sure your version is at least 2.18.3."; - (true, "an unknown version") -| OCamlFind -> - let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk2"] in - try - let vi = List.map s2i (numeric_prefix_list v) in - if vi < [2; 16; 0] then +let check_lablgtk_version () = + let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk3"] in + (true, v) + +(* ejgallego: we wait to do version checks until an official release is out *) +(* try + let vi = numeric_prefix_list v in + (* Temporary hack *) + if vi = ["3";"0";"beta3"] then (false, v) else + let vi = List.map s2i vi in + if vi < [3; 0; 0] then (false, v) - else if vi < [2; 18; 3] then - begin - (* Version 2.18.3 is known to report incorrectly as 2.18.0, and Launchpad packages report as version 2.16.0 due to a misconfigured META file; see https://bugs.launchpad.net/ubuntu/+source/lablgtk2/+bug/1577236 *) - warn "Your installed lablgtk reports as %s.\n\ -It is possible that the installed version is actually more recent\n\ -but reports an incorrect version. If the installed version is\n\ -actually more recent than 2.18.3, that's fine; if it is not,\n -CoqIDE will compile but may be very unstable." v; - (true, "an unknown version") - end else (true, v) with _ -> (false, v) +*) let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native" @@ -788,19 +744,19 @@ let lablgtkdir = ref "" let check_coqide () = if !prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in - if dir = "" then set_ide No "LablGtk2 not found"; - let (ok, version) = check_lablgtk_version via dir in - let found = sprintf "LablGtk2 found (%s, %s)" (get_source via) version in - if not ok then set_ide No (found^", but too old (required >= 2.18.3, found " ^ version ^ ")"); - (* We're now sure to produce at least one kind of coqide *) - lablgtkdir := shorten_camllib dir; - if !prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); - if best_compiler<>"opt" then set_ide Byte (found^", but no native compiler"); - if not (Sys.file_exists (dir/"gtkThread.cmx")) then - set_ide Byte (found^", but no native LablGtk2"); - if not (Sys.file_exists (camllib/"threads"/"threads.cmxa")) then - set_ide Byte (found^", but no native threads"); - set_ide Opt (found^", with native threads") + if dir = "" + then set_ide No "LablGtk3 not found" + else + let (ok, version) = check_lablgtk_version () in + let found = sprintf "LablGtk3 found (%s)" version in + if not ok then set_ide No (found^", but too old (required >= 3.0, found " ^ version ^ ")"); + (* We're now sure to produce at least one kind of coqide *) + lablgtkdir := shorten_camllib dir; + if !prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); + if best_compiler <> "opt" then set_ide Byte (found^", but no native compiler"); + if not (Sys.file_exists (camllib/"threads"/"threads.cmxa")) then + set_ide Byte (found^", but no native threads"); + set_ide Opt (found^", with native threads") let coqide = try check_coqide () @@ -808,19 +764,16 @@ let coqide = (** System-specific CoqIde flags *) -let lablgtkincludes = ref "" let idearchflags = ref "" let idearchfile = ref "" let idecdepsflags = ref "" let idearchdef = ref "X11" let coqide_flags () = - if !lablgtkdir <> "" then lablgtkincludes := sprintf "-I %S" !lablgtkdir; match coqide, arch with | "opt", "Darwin" when !prefs.macintegration -> let osxdir,_ = tryrun camlexec.find ["query";"lablgtkosx"] in if osxdir <> "" then begin - lablgtkincludes := sprintf "%s -I %S" !lablgtkincludes osxdir; idearchflags := "lablgtkosx.cma"; idearchdef := "QUARTZ" end @@ -1011,7 +964,7 @@ let print_summary () = if best_compiler = "opt" then pr " Native dynamic link support : %B\n" hasnatdynlink; if coqide <> "no" then - pr " Lablgtk2 library in : %s\n" (esc !lablgtkdir); + pr " Lablgtk3 library in : %s\n" (esc !lablgtkdir); if !idearchdef = "QUARTZ" then pr " Mac OS integration is on\n"; pr " CoqIde : %s\n" coqide; @@ -1101,7 +1054,7 @@ let write_configml f = pr_b "native_compiler" !prefs.nativecompiler; let core_src_dirs = [ "config"; "lib"; "clib"; "kernel"; "library"; - "engine"; "pretyping"; "interp"; "gramlib/.pack"; "parsing"; "proofs"; + "engine"; "pretyping"; "interp"; "gramlib"; "gramlib/.pack"; "parsing"; "proofs"; "tactics"; "toplevel"; "printing"; "ide"; "stm"; "vernac" ] in let core_src_dirs = List.fold_left (fun acc core_src_subdir -> acc ^ " \"" ^ core_src_subdir ^ "\";\n") "" @@ -1203,7 +1156,6 @@ let write_makefile f = pr "# Unix systems and no profiling: strip\n"; pr "STRIP=%s\n\n" strip; pr "# LablGTK\n"; - pr "COQIDEINCLUDES=%s\n\n" !lablgtkincludes; pr "# CoqIde (no/byte/opt)\n"; pr "HASCOQIDE=%s\n" coqide; pr "IDEFLAGS=%s\n" !idearchflags; diff --git a/coqide.opam b/coqide.opam index 314943a881..c82fa72564 100644 --- a/coqide.opam +++ b/coqide.opam @@ -17,10 +17,10 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.4.0" } + "dune" { build & >= "1.4.0" } "coqide-server" - "conf-gtksourceview" - "lablgtk" { >= "2.18.5" } + "lablgtk3" { >= "3.0.beta5" } + "lablgtk3-sourceview3" { >= "3.0.beta5" } ] build-env: [ diff --git a/default.nix b/default.nix index d6cdc7c42d..1e2cb3625d 100644 --- a/default.nix +++ b/default.nix @@ -21,11 +21,7 @@ # Once the build is finished, you will find, in the current directory, # a symlink to where Coq was installed. -{ pkgs ? - (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/11cf7d6e1ffd5fbc09a51b76d668ad0858a772ed.tar.gz"; - sha256 = "0zcg4mgfdk3ryiqj1j5iv5bljjvsgi6q6j9z1vkq383c4g4clc72"; - }) {}) +{ pkgs ? import ./dev/nixpkgs.nix {} , ocamlPackages ? pkgs.ocamlPackages , buildIde ? true , buildDoc ? true @@ -49,7 +45,10 @@ stdenv.mkDerivation rec { dune ] ++ (with ocamlPackages; [ ocaml findlib num ]) - ++ optional buildIde ocamlPackages.lablgtk + ++ optionals buildIde [ + ocamlPackages.lablgtk3-sourceview3 + glib gnome3.defaultIconTheme wrapGAppsHook + ] ++ optionals buildDoc [ # Sphinx doc dependencies pkgconfig (python3.withPackages @@ -78,7 +77,6 @@ stdenv.mkDerivation rec { !elem (baseNameOf path) [".git" "result" "bin" "_build" "_build_ci"]) ./.; preConfigure = '' - patchShebangs kernel/ patchShebangs dev/tools/ ''; diff --git a/dev/README.md b/dev/README.md index d9fdd230d3..9761f7b96f 100644 --- a/dev/README.md +++ b/dev/README.md @@ -25,7 +25,6 @@ | [`dev/doc/universes.txt`](doc/universes.txt) | Help for debugging universes | | [`dev/doc/extensions.txt`](doc/extensions.txt) | Some help about TACTIC EXTEND | | [`dev/doc/perf-analysis`](doc/perf-analysis)| Analysis of perfs measured on the compilation of user contribs | -| [`dev/doc/cic.dtd`](doc/cic.dtd) | Official dtd of the calc. of ind. constr. for im/ex-portation | | [`dev/doc/econstr.md`](doc/econstr.md) | Describes `Econstr`, implementation of treatment of `evar` in the engine | | [`dev/doc/primproj.md`](doc/primproj.md) | Describes primitive projections | | [`dev/doc/proof-engine.md`](doc/proof-engine.md) | Tutorial on new proof engine | diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 8489bcfc3a..c3f3a97ff5 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -331,7 +331,7 @@ IF "%CYGWIN_QUIET%" == "Y" ( )
IF "%GTK_FROM_SOURCES%"=="N" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0
+ SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk3,mingw64-%ARCH%-gtksourceview3.0
)
REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
@@ -373,7 +373,8 @@ IF "%RUNSETUP%"=="Y" ( -P make,unzip ^
-P gdb,liblzma5 ^
-P patch,automake1.14 ^
- -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^
+ -P pkg-config ^
+ -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-windows_default_manifest ^
-P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^
-P libiconv-devel,libunistring-devel,libncurses-devel ^
-P gettext-devel,libgettextpo-devel ^
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 2e934ff0c0..4c5bd29236 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -742,7 +742,7 @@ function make_fontconfig { ##### ICONV ##### function make_libiconv { - build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.14 tar.gz true + build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.15 tar.gz true } ##### UNISTRING ##### @@ -816,7 +816,9 @@ function make_glib { make_gettext make_libffi make_libpcre + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.57 glib-2.57.1 tar.xz true + } ##### ATK ##### @@ -824,7 +826,7 @@ function make_glib { function make_atk { make_gettext make_glib - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.29 atk-2.29.1 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.30 atk-2.30.0 tar.xz true } ##### PIXBUF ##### @@ -837,7 +839,7 @@ function make_gdk-pixbuf { # CONFIGURE PARAMETERS # --with-included-loaders=yes statically links the image file format handlers # This avoids "Cannot open pixbuf loader module file '/usr/x86_64-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache': No such file or directory" - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.36 gdk-pixbuf-2.36.12 tar.xz true --with-included-loaders=yes + build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.38 gdk-pixbuf-2.38.0 tar.xz true --with-included-loaders=yes } ##### CAIRO ##### @@ -848,7 +850,7 @@ function make_cairo { make_glib make_pixman make_fontconfig - build_conf_make_inst http://cairographics.org/releases rcairo-1.15.13 tar.xz true + build_conf_make_inst http://cairographics.org/releases rcairo-1.16.2 tar.xz true } ##### PANGO ##### @@ -857,37 +859,23 @@ function make_pango { make_cairo make_glib make_fontconfig - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.1 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.4 tar.xz true } -##### GTK2 ##### +##### GTK3 ##### -function patch_gtk2 { - rm gtk/gtk.def -} +function make_gtk3 { -function make_gtk2 { - # Cygwin packet dependencies: gtk-update-icon-cache if [ "$GTK_FROM_SOURCES" == "Y" ]; then - make_glib - make_atk - make_pango - make_gdk-pixbuf - make_cairo - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/2.24 gtk+-2.24.32 tar.xz patch_gtk2 - fi -} - -##### GTK3 ##### -function make_gtk3 { - make_glib - make_atk - make_pango - make_gdk-pixbuf - make_cairo - make_libepoxy - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.22 gtk+-3.22.30 tar.xz true + make_glib + make_atk + make_pango + make_gdk-pixbuf + make_cairo + make_libepoxy + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.24 gtk+-3.24.5 tar.xz true + fi # make all incl. tests and examples runs through fine # make install fails with issue with @@ -918,17 +906,17 @@ function make_libxml2 { fi } -##### GTK-SOURCEVIEW2 ##### +##### GTK-SOURCEVIEW3 ##### -function make_gtk_sourceview2 { +function make_gtk_sourceview3 { # Cygwin packet dependencies: intltool # gtksourceview-2.11.2 requires GTK2 # gtksourceview-2.91.9 requires GTK3 # => We use gtksourceview-2.11.2 which seems to be the newest GTK2 based one if [ "$GTK_FROM_SOURCES" == "Y" ]; then - make_gtk2 + make_gtk3 make_libxml2 - build_conf_make_inst https://download.gnome.org/sources/gtksourceview/2.11 gtksourceview-2.11.2 tar.bz2 true + build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.9 tar.bz2 true fi } @@ -977,7 +965,7 @@ function get_flex_dll_link_bin { # Build flexdll and flexlink from sources after building OCaml function make_flex_dll_link { - if build_prep https://github.com/alainfrisch/flexdll/releases/download/0.37/ flexdll-bin-0.37 zip ; then + if build_prep https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 ; then if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then # shellcheck disable=SC2086 log1 make $MAKE_OPT build_mingw flexlink.exe @@ -1014,11 +1002,21 @@ function make_ln { fi } +##### ARCH-pkg-config replacement ##### + +# cygwin replaced ARCH-pkg-config with a shell script, which doesn't work e.g. for dune on Windows. +# This builds a binary replacement for the shell script and puts it into the bin_special folder. +# There is no global installation since it is module specific what pkg-config is needed under what name. + +function make_arch_pkg_config { + gcc -DARCH="$TARGET_ARCH" -o bin_special/pkg-config.exe $PATCHES/pkg-config.c +} + ##### OCAML ##### function make_ocaml { get_flex_dll_link_bin - if build_prep https://github.com/ocaml/ocaml/archive 4.07.0 tar.gz 1 ocaml-4.07.0 ; then + if build_prep https://github.com/ocaml/ocaml/archive 4.07.1 tar.gz 1 ocaml-4.07.1 ; then # See README.win32.adoc cp config/m-nt.h byterun/caml/m.h cp config/s-nt.h byterun/caml/s.h @@ -1073,7 +1071,6 @@ function make_ocaml { function make_ocaml_tools { make_findlib - # make_camlp5 } ##### OCAML EXTRA LIBRARIES ##### @@ -1082,7 +1079,6 @@ function make_ocaml_libs { make_num make_findlib make_lablgtk - # make_stdint } ##### Ocaml num library ##### @@ -1130,6 +1126,20 @@ function make_findlib { fi } +##### Dune build system ##### + +function make_dune { + make_ocaml + + if build_prep https://github.com/ocaml/dune/archive/ 1.6.3 tar.gz 1 dune-1.6.3 ; then + + log2 make release + log2 make install + + build_post + fi +} + ##### MENHIR Ocaml Parser Generator ##### function make_menhir { @@ -1144,108 +1154,44 @@ function make_menhir { fi } -##### CAMLP4 Ocaml Preprocessor ##### - -function make_camlp4 { - # OCaml up to 4.01 includes camlp4, from 4.02 it isn't included - # Check if command camlp4 exists, if not build camlp4 - if ! command camlp4 ; then - make_ocaml - make_findlib - if build_prep https://github.com/ocaml/camlp4/archive 4.06+2 tar.gz 1 camlp4-4.06+2 ; then - # See https://github.com/ocaml/camlp4/issues/41#issuecomment-112018910 - logn configure ./configure - # Note: camlp4 doesn't support -j 8, so don't pass MAKE_OPT - log2 make all - log2 make install - log2 make clean - build_post - fi - fi -} - -##### CAMLP5 Ocaml Preprocessor ##### - -function make_camlp5 { - make_ocaml - make_findlib - - if build_prep https://github.com/camlp5/camlp5/archive rel706 tar.gz 1 camlp5-rel706; then - logn configure ./configure - # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success - sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile - # shellcheck disable=SC2086 - log1 make world.opt $MAKE_OPT - log2 make install - # For some reason gramlib.a is not copied, but it is required by Coq - cp lib/gramlib.a "$PREFIXOCAML/libocaml/camlp5/" - # For some reason META is not copied, but it is required by coq_makefile - log2 make -C etc META - mkdir -p "$PREFIXOCAML/libocaml/site-lib/camlp5/" - cp etc/META "$PREFIXOCAML/libocaml/site-lib/camlp5/" - log2 make clean - build_post - fi -} - ##### LABLGTK Ocaml GTK binding ##### # Note: when rebuilding lablgtk by deleting the .finished file, # also delete <root>\usr\x86_64-w64-mingw32\sys-root\mingw\lib\site-lib # Otherwise make install fails -function make_lablgtk { - make_ocaml - make_findlib - # make_camlp4 # required by lablgtk-2.18.3 and lablgtk-2.18.5 - make_gtk2 - make_gtk_sourceview2 - if build_prep https://forge.ocamlcore.org/frs/download.php/1726 lablgtk-2.18.6 tar.gz 1 ; then - # configure should be fixed to search for $TARGET_ARCH-pkg-config.exe - cp "/bin/$TARGET_ARCH-pkg-config.exe" bin_special/pkg-config.exe - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXOCAML" - - # lablgtk shows occasional errors with -j, so don't pass $MAKE_OPT - - # lablgtk binary needs to be stripped - otherwise flexdll goes wild - # Fix version 1: explicit strip after failed build - this randomly fails in CI - # See https://sympa.inria.fr/sympa/arc/caml-list/2015-10/msg00204.html - # logn make-world-pre make world || true - # $TARGET_ARCH-strip.exe --strip-unneeded src/dlllablgtk2.dll - - # Fix version 2: Strip by passing linker argument rather than explicit call to strip - # See https://github.com/alainfrisch/flexdll/issues/6 - # Argument to ocamlmklib: -ldopt "-link -Wl,-s" - # -ldopt is the okamlmklib linker prefix option - # -link is the flexlink linker prefix option - # -Wl, is the gcc (linker driver) linker prefix option - # -s is the gnu linker option for stripping symbols - # These changes are included in dev/build/windows/patches_coq/lablgtk-2.18.3.patch - - log2 make world - - # lablgtk does not escape FINDLIBDIR path, which can contain backslashes - sed -i "s|^FINDLIBDIR=.*|FINDLIBDIR=$PREFIXOCAML/libocaml/site-lib|" config.make +function make_ocaml_cairo2 { + if build_prep https://github.com/Chris00/ocaml-cairo/archive 0.6 tar.gz 1 ocaml_cairo2-0.6; then + make_arch_pkg_config - log2 make install - log2 make clean + log2 dune build cairo2.install + log2 dune install cairo2 + log2 dune clean build_post + fi } -##### Ocaml Stdint ##### - -function make_stdint { +function make_lablgtk { make_ocaml make_findlib - if build_prep https://github.com/andrenth/ocaml-stdint/archive 0.3.0 tar.gz 1 Stdint-0.3.0; then - # Note: the setup gets the proper install path from ocamlfind, but for whatever reason it wants - # to create an empty folder in some folder which defaults to C:\Program Files. - # The --preifx overrides this. Id didn't see any files created in /tmp/extra. - log_1_3 ocaml setup.ml -configure --prefix /tmp/extra - log_1_3 ocaml setup.ml -build - log_1_3 ocaml setup.ml -install - log_1_3 ocaml setup.ml -clean + make_dune + make_gtk3 + make_gtk_sourceview3 + make_ocaml_cairo2 + + if build_prep https://github.com/garrigue/lablgtk/archive 3.0.beta5 tar.gz 1 lablgtk-3.0.beta5 ; then + make_arch_pkg_config + + # lablgtk3 includes more packages that are not relevant for Coq, + # such as gtkspell + log2 dune build -p lablgtk3 + log2 dune install lablgtk3 + + log2 dune build -p lablgtk3-sourceview3 + log2 dune install lablgtk3-sourceview3 + + log2 dune clean build_post fi } @@ -1270,42 +1216,44 @@ function copy_coq_dlls { # Select all missing DLLs from the module list, right click "copy filenames" # Delay loaded DLLs from Windows can be ignored (hour-glass icon at begin of line) # Do this recursively until there are no further missing DLLs (File close + reopen) - # For running this quickly, just do "cd coq-<ver> ; call copy_coq_dlls ; cd .." at the end of this script. + # For running this quickly, just do "cd coq-<ver> ; copy_coq_dlls ; cd .." at the end of this script. # Do the same for coqc and ocamlc (usually doesn't result in additional files) - copy_coq_dll LIBATK-1.0-0.DLL copy_coq_dll LIBCAIRO-2.DLL - copy_coq_dll LIBEXPAT-1.DLL - copy_coq_dll LIBFFI-6.DLL copy_coq_dll LIBFONTCONFIG-1.DLL copy_coq_dll LIBFREETYPE-6.DLL - copy_coq_dll LIBGDK-WIN32-2.0-0.DLL + copy_coq_dll LIBGDK-3-0.DLL copy_coq_dll LIBGDK_PIXBUF-2.0-0.DLL - copy_coq_dll LIBGIO-2.0-0.DLL copy_coq_dll LIBGLIB-2.0-0.DLL - copy_coq_dll LIBGMODULE-2.0-0.DLL copy_coq_dll LIBGOBJECT-2.0-0.DLL - copy_coq_dll LIBGTK-WIN32-2.0-0.DLL - copy_coq_dll LIBINTL-8.DLL + copy_coq_dll LIBGTK-3-0.DLL + copy_coq_dll LIBGTKSOURCEVIEW-3.0-1.DLL copy_coq_dll LIBPANGO-1.0-0.DLL + copy_coq_dll LIBATK-1.0-0.DLL + copy_coq_dll LIBBZ2-1.DLL + copy_coq_dll LIBCAIRO-GOBJECT-2.DLL + copy_coq_dll LIBEPOXY-0.DLL + copy_coq_dll LIBEXPAT-1.DLL + copy_coq_dll LIBFFI-6.DLL + copy_coq_dll LIBGIO-2.0-0.DLL + copy_coq_dll LIBGMODULE-2.0-0.DLL + copy_coq_dll LIBINTL-8.DLL copy_coq_dll LIBPANGOCAIRO-1.0-0.DLL copy_coq_dll LIBPANGOWIN32-1.0-0.DLL - copy_coq_dll libpcre-1.dll + copy_coq_dll LIBPCRE-1.DLL copy_coq_dll LIBPIXMAN-1-0.DLL copy_coq_dll LIBPNG16-16.DLL copy_coq_dll LIBXML2-2.DLL copy_coq_dll ZLIB1.DLL + copy_coq_dll ICONV.DLL + copy_coq_dll LIBLZMA-5.DLL + copy_coq_dll LIBPANGOFT2-1.0-0.DLL + copy_coq_dll LIBHARFBUZZ-0.DLL # Depends on if GTK is built from sources if [ "$GTK_FROM_SOURCES" == "Y" ]; then - copy_coq_dll libiconv-2.dll - else - copy_coq_dll ICONV.DLL - copy_coq_dll LIBBZ2-1.DLL - copy_coq_dll LIBGTKSOURCEVIEW-2.0-0.DLL - copy_coq_dll LIBHARFBUZZ-0.DLL - copy_coq_dll LIBLZMA-5.DLL - copy_coq_dll LIBPANGOFT2-1.0-0.DLL + echo "Building GTK from sources is currently not supported" + exit 1 fi; # Architecture dependent files @@ -1335,14 +1283,14 @@ function copy_coq_objects { # Copy required GTK config and suport files -function copq_coq_gtk { - echo 'gtk-theme-name = "MS-Windows"' > "$PREFIX/etc/gtk-2.0/gtkrc" - echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-2.0/gtkrc" +function copy_coq_gtk { + echo 'gtk-theme-name = "Default"' > "$PREFIX/etc/gtk-3.0/gtkrc" + echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-3.0/gtkrc" if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIX/etc/gtk-2.0" '*' "$PREFIXCOQ/gtk-2.0" - install_glob "$PREFIX/share/gtksourceview-2.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - install_glob "$PREFIX/share/gtksourceview-2.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-2.0/styles" + install_glob "$PREFIX/etc/gtk-3.0" '*' "$PREFIXCOQ/gtk-3.0" + install_glob "$PREFIX/share/gtksourceview-3.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-3.0/language-specs" + install_glob "$PREFIX/share/gtksourceview-3.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-3.0/styles" install_rec "$PREFIX/share/themes" '*' "$PREFIXCOQ/share/themes" # This below item look like a bug in make install @@ -1351,10 +1299,7 @@ function copq_coq_gtk { else COQSHARE="$PREFIXCOQ/share/" fi - if [[ ! $COQ_VERSION == 8.4* ]] ; then - mv "$COQSHARE"*.lang "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - mv "$COQSHARE"*.xml "$PREFIXCOQ/share/gtksourceview-2.0/styles" - fi + mkdir -p "$PREFIXCOQ/ide" mv "$COQSHARE"*.png "$PREFIXCOQ/ide" rmdir "$PREFIXCOQ/share/coq" || true @@ -1383,7 +1328,6 @@ function make_coq { make_ocaml make_num make_findlib - # make_camlp5 make_lablgtk if case $COQ_VERSION in @@ -1437,11 +1381,12 @@ function make_coq { log2 make install log1 copy_coq_dlls + log1 copy_coq_gtk + if [ "$INSTALLOCAML" == "Y" ]; then copy_coq_objects fi - log1 copq_coq_gtk log1 copy_coq_license # make clean seems to be broken for 8.5pl2 diff --git a/dev/build/windows/patches_coq/VST.patch b/dev/build/windows/patches_coq/VST.patch index 2c8c46373f..2c8c46373f 100755..100644 --- a/dev/build/windows/patches_coq/VST.patch +++ b/dev/build/windows/patches_coq/VST.patch diff --git a/dev/build/windows/patches_coq/flexdll-0.37.patch b/dev/build/windows/patches_coq/flexdll-0.37.patch new file mode 100644 index 0000000000..82806f9ea4 --- /dev/null +++ b/dev/build/windows/patches_coq/flexdll-0.37.patch @@ -0,0 +1,19 @@ +diff/patch file created on Tue, Feb 19, 2019 9:41:26 PM with: +difftar-folder.sh tarballs/flexdll-0.37.tar.gz flexdll-0.37 1 +TARFILE= tarballs/flexdll-0.37.tar.gz +FOLDER= flexdll-0.37 +TARSTRIP= 1 +TARPREFIX= flexdll-0.37/ +ORIGFOLDER= flexdll-0.37.orig +--- flexdll-0.37.orig/cmdline.ml 2017-10-25 10:40:46.000000000 +0200 ++++ flexdll-0.37/cmdline.ml 2019-02-19 21:41:18.157024900 +0100 +@@ -248,6 +248,9 @@ + String.sub s 0 2 :: String.sub s 2 (String.length s - 2) :: tr rest + | s :: rest when String.length s >= 5 && String.sub s 0 5 = "/link" -> + "-link" :: String.sub s 5 (String.length s - 5) :: tr rest ++ (* Convert gcc linker option prefix -Wl, to flexlink linker prefix -link *) ++ | s :: rest when String.length s >= 6 && String.sub s 0 5 = "-Wl,-" -> ++ "-link" :: String.sub s 4 (String.length s - 4) :: tr rest + | "-arg" :: x :: rest -> + tr (Array.to_list (Arg.read_arg x)) @ rest + | "-arg0" :: x :: rest -> diff --git a/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch b/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch deleted file mode 100644 index 73a098d12a..0000000000 --- a/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch +++ /dev/null @@ -1,213 +0,0 @@ -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c 2015-10-27 14:58:54.422888400 +0100 -*************** -*** 80,86 **** - /* If string contains prefix, check that prefix is not followed - * by a unicode mark symbol, e.g. that trailing 'a' in prefix - * is not part of two-char a-with-hat symbol in string. */ -! return type != G_UNICODE_COMBINING_MARK && - type != G_UNICODE_ENCLOSING_MARK && - type != G_UNICODE_NON_SPACING_MARK; - } ---- 80,86 ---- - /* If string contains prefix, check that prefix is not followed - * by a unicode mark symbol, e.g. that trailing 'a' in prefix - * is not part of two-char a-with-hat symbol in string. */ -! return type != G_UNICODE_SPACING_MARK && - type != G_UNICODE_ENCLOSING_MARK && - type != G_UNICODE_NON_SPACING_MARK; - } -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c 2015-10-27 14:55:30.294477600 +0100 -*************** -*** 274,280 **** - * containg a list of language files directories. - * The array is owned by @lm and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); ---- 274,280 ---- - * containg a list of language files directories. - * The array is owned by @lm and must not be modified. - */ -! const gchar* const * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); -*************** -*** 392,398 **** - * available languages or %NULL if no language is available. The array - * is owned by @lm and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); ---- 392,398 ---- - * available languages or %NULL if no language is available. The array - * is owned by @lm and must not be modified. - */ -! const gchar* const * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h 2009-11-15 00:41:33.000000000 +0100 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h 2015-10-27 14:55:30.518500000 +0100 -*************** -*** 62,74 **** - - GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); - - void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, - gchar **dirs); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); - - GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, ---- 62,74 ---- - - GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); - -! const gchar* const * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); - - void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, - gchar **dirs); - -! const gchar* const * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); - - GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c 2015-10-27 14:55:30.545502700 +0100 -*************** -*** 310,316 **** - * - * Since: 2.0 - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); ---- 310,316 ---- - * - * Since: 2.0 - */ -! const gchar* const * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); -*************** -*** 318,324 **** - if (scheme->priv->authors == NULL) - return NULL; - -! return (G_CONST_RETURN gchar* G_CONST_RETURN *)scheme->priv->authors->pdata; - } - - /** ---- 318,324 ---- - if (scheme->priv->authors == NULL) - return NULL; - -! return (const gchar* const *)scheme->priv->authors->pdata; - } - - /** -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h 2010-03-29 15:02:56.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h 2015-10-27 14:55:30.565504700 +0100 -*************** -*** 61,67 **** - const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); - const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); - - const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); ---- 61,67 ---- - const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); - const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); - -! const gchar* const * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); - - const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c 2015-10-27 14:55:30.583506500 +0100 -*************** -*** 515,521 **** - * of string containing the search path. - * The array is owned by the @manager and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); ---- 515,521 ---- - * of string containing the search path. - * The array is owned by the @manager and must not be modified. - */ -! const gchar* const * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); -*************** -*** 554,560 **** - * of string containing the ids of the available style schemes or %NULL if no - * style scheme is available. The array is owned by the @manager and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); ---- 554,560 ---- - * of string containing the ids of the available style schemes or %NULL if no - * style scheme is available. The array is owned by the @manager and must not be modified. - */ -! const gchar* const * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h 2009-11-15 00:41:33.000000000 +0100 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h 2015-10-27 14:56:24.498897500 +0100 -*************** -*** 73,84 **** - void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, - const gchar *path); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); - - void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); - - GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, ---- 73,84 ---- - void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, - const gchar *path); - -! const gchar* const * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); - - void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); - -! const gchar* const * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); - - GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, diff --git a/dev/build/windows/patches_coq/lablgtk-2.18.6.patch b/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch index 23c303135d..1c6a038da9 100644 --- a/dev/build/windows/patches_coq/lablgtk-2.18.6.patch +++ b/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch @@ -1,33 +1,12 @@ -diff/patch file created on Wed, Apr 25, 2018 11:08:05 AM with: -difftar-folder.sh ../coq-msoegtrop/dev/build/windows/source_cache/lablgtk-2.18.3.tar.gz lablgtk-2.18.3 1 -TARFILE= ../coq-msoegtrop/dev/build/windows/source_cache/lablgtk-2.18.3.tar.gz -FOLDER= lablgtk-2.18.3 +diff/patch file created on Wed, Feb 20, 2019 11:29:48 AM with: +difftar-folder.sh tarballs/lablgtk-3.0.beta4.tar.gz lablgtk-3.0.beta4 1 +TARFILE= tarballs/lablgtk-3.0.beta4.tar.gz +FOLDER= lablgtk-3.0.beta4 TARSTRIP= 1 -TARPREFIX= lablgtk-2.18.3/ -ORIGFOLDER= lablgtk-2.18.3.orig ---- lablgtk-2.18.3.orig/configure 2014-10-29 08:51:05.000000000 +0100 -+++ lablgtk-2.18.3/configure 2018-04-25 10:58:54.454501600 +0200 -@@ -2667,7 +2667,7 @@ - fi - - --if test "`$OCAMLFIND printconf stdlib`" != "`$CAMLC -where`"; then -+if test "`$OCAMLFIND printconf stdlib | tr '\\' '/'`" != "`$CAMLC -where | tr '\\' '/'`"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Ignoring ocamlfind" >&5 - $as_echo "$as_me: WARNING: Ignoring ocamlfind" >&2;} - OCAMLFIND=no ---- lablgtk-2.18.3.orig/src/glib.mli 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/glib.mli 2018-04-25 10:58:54.493555500 +0200 -@@ -75,6 +75,7 @@ - type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] - type id - val channel_of_descr : Unix.file_descr -> channel -+ val channel_of_descr_socket : Unix.file_descr -> channel - val add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id - val remove : id -> unit ---- lablgtk-2.18.3.orig/src/glib.ml 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/glib.ml 2018-04-25 10:58:54.479543500 +0200 +TARPREFIX= lablgtk-3.0.beta4/ +ORIGFOLDER= lablgtk-3.0.beta4.orig +--- lablgtk-3.0.beta4.orig/src/glib.ml 2019-02-11 07:08:17.000000000 +0100 ++++ lablgtk-3.0.beta4/src/glib.ml 2019-02-20 11:28:28.439137100 +0100 @@ -72,6 +72,8 @@ type id external channel_of_descr : Unix.file_descr -> channel @@ -37,22 +16,18 @@ ORIGFOLDER= lablgtk-2.18.3.orig external remove : id -> unit = "ml_g_source_remove" external add_watch : cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id ---- lablgtk-2.18.3.orig/src/Makefile 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/Makefile 2018-04-25 10:58:54.506522500 +0200 -@@ -461,9 +461,9 @@ - do rm -f "$(BINDIR)"/$$f; done - - lablgtk.cma liblablgtk2$(XA): $(COBJS) $(MLOBJS) -- $(LIBRARIAN) -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) -+ $(LIBRARIAN) -ldopt "-link -Wl,-s" -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) - lablgtk.cmxa: $(COBJS) $(MLOBJS:.cmo=.cmx) -- $(LIBRARIAN) -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) -+ $(LIBRARIAN) -ldopt "-link -Wl,-s" -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) - lablgtk.cmxs: DYNLINKLIBS=$(GTK_LIBS) - - lablgtkgl.cma liblablgtkgl2$(XA): $(GLCOBJS) $(GLMLOBJS) ---- lablgtk-2.18.3.orig/src/ml_glib.c 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/ml_glib.c 2018-04-25 10:58:54.539535600 +0200 +--- lablgtk-3.0.beta4.orig/src/glib.mli 2019-02-11 07:08:17.000000000 +0100 ++++ lablgtk-3.0.beta4/src/glib.mli 2019-02-20 11:28:28.423592200 +0100 +@@ -75,6 +75,7 @@ + type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] + type id + val channel_of_descr : Unix.file_descr -> channel ++ val channel_of_descr_socket : Unix.file_descr -> channel + val add_watch : + cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id + val remove : id -> unit +--- lablgtk-3.0.beta4.orig/src/ml_glib.c 2019-02-11 07:08:17.000000000 +0100 ++++ lablgtk-3.0.beta4/src/ml_glib.c 2019-02-20 11:28:28.455395900 +0100 @@ -25,6 +25,8 @@ #include <string.h> #include <locale.h> @@ -74,7 +49,7 @@ ORIGFOLDER= lablgtk-2.18.3.orig #include "wrappers.h" #include "ml_glib.h" #include "glib_tags.h" -@@ -325,14 +332,23 @@ +@@ -326,14 +333,23 @@ #ifndef _WIN32 ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) diff --git a/dev/build/windows/patches_coq/pkg-config.c b/dev/build/windows/patches_coq/pkg-config.c new file mode 100755 index 0000000000..e4fdcd4d7d --- /dev/null +++ b/dev/build/windows/patches_coq/pkg-config.c @@ -0,0 +1,29 @@ +// MinGW personality wrapper for pkgconf +// This is an excutable replacement for the shell scripts /bin/ARCH-pkg-config +// Compile with e.g. +// gcc pkg-config.c -DARCH=x86_64-w64-mingw32 -o pkg-config.exe +// gcc pkg-config.c -DARCH=i686-w64-mingw32 -o pkg-config.exe +// ATTENTION: Do not compile with MinGW-gcc, compile with cygwin gcc! +// +// To test it execute e.g. +// $ ./pkg-config --path zlib +// /usr/x86_64-w64-mingw32/sys-root/mingw/lib/pkgconfig/zlib.pc + +#include <unistd.h> + +#define STRINGIFY1(arg) #arg +#define STRINGIFY(arg) STRINGIFY1(arg) + +int main(int argc, char *argv[]) +{ + // +1 for extra argument, +1 for trailing NULL + char * argvnew[argc+2]; + int id=0, is=0; + + argvnew[id++] = argv[is++]; + argvnew[id++] = "--personality="STRINGIFY(ARCH); + while( is<argc ) argvnew[id++] = argv[is++]; + argvnew[id++] = 0; + + return execv("/usr/bin/pkgconf", argvnew); +} diff --git a/dev/build/windows/patches_coq/quickchick.patch b/dev/build/windows/patches_coq/quickchick.patch index 1afa6e7f95..1afa6e7f95 100755..100644 --- a/dev/build/windows/patches_coq/quickchick.patch +++ b/dev/build/windows/patches_coq/quickchick.patch diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 74e8d3bbaa..deeec3942d 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -289,3 +289,10 @@ : "${verdi_raft_CI_REF:=master}" : "${verdi_raft_CI_GITURL:=https://github.com/uwplse/verdi-raft}" : "${verdi_raft_CI_ARCHIVEURL:=${verdi_raft_CI_GITURL}/archive}" + +######################################################################## +# stdlib2 +######################################################################## +: "${stdlib2_CI_REF:=master}" +: "${stdlib2_CI_GITURL:=https://github.com/coq/stdlib2}" +: "${stdlib2_CI_ARCHIVEURL:=${stdlib2_CI_GITURL}/archive}" diff --git a/dev/ci/ci-bedrock2.sh b/dev/ci/ci-bedrock2.sh index 2ac78d3c2b..2d242d80a4 100755 --- a/dev/ci/ci-bedrock2.sh +++ b/dev/ci/ci-bedrock2.sh @@ -6,4 +6,4 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download bedrock2 -( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make ) +( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make | iconv -t UTF-8 -c `#9767` ) diff --git a/dev/ci/ci-paramcoq.sh b/dev/ci/ci-paramcoq.sh index c641af2abb..d2e0ee89bf 100755 --- a/dev/ci/ci-paramcoq.sh +++ b/dev/ci/ci-paramcoq.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download paramcoq -( cd "${CI_BUILD_DIR}/paramcoq" && make && make install ) +( cd "${CI_BUILD_DIR}/paramcoq" && make && make install && cd test-suite && make examples) diff --git a/dev/ci/ci-stdlib2.sh b/dev/ci/ci-stdlib2.sh new file mode 100755 index 0000000000..ec1c180d7d --- /dev/null +++ b/dev/ci/ci-stdlib2.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download stdlib2 + +( cd "${CI_BUILD_DIR}/stdlib2/src" && ./bootstrap && make && make install) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 43278c37b1..e553cbed1b 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-02-17-V1" +# CACHEKEY: "bionic_coq-V2019-03-12-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -10,7 +10,7 @@ RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ # Dependencies of the image, the test-suite and external projects m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip \ # Dependencies of lablgtk (for CoqIDE) - libgtk2.0-dev libgtksourceview2.0-dev \ + libgtksourceview-3.0-dev \ # Dependencies of stdlib and sphinx doc texlive-latex-extra texlive-fonts-recommended texlive-xetex latexmk \ xindy python3-pip python3-setuptools python3-pexpect python3-bs4 \ @@ -22,7 +22,7 @@ RUN pip3 install sphinx==1.7.8 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.0/opam-2.0.0-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam +RUN wget https://github.com/ocaml/opam/releases/download/2.0.3/opam-2.0.3-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam # Basic OPAM setup ENV NJOBS="2" \ @@ -37,11 +37,14 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.3.0" \ +ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.4.0" \ CI_OPAM="menhir.20181113 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. -ENV COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" +ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" + +# Must add this to COQIDE_OPAM{,_EDGE} when we update the opam +# packages "lablgtk3-gtksourceview3" # base switch RUN opam init -a --disable-sandboxing --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam env) && opam update && \ @@ -53,7 +56,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ # EDGE switch ENV COMPILER_EDGE="4.07.1" \ - COQIDE_OPAM_EDGE="lablgtk.2.18.6 conf-gtksourceview.2" \ + COQIDE_OPAM_EDGE="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" \ BASE_OPAM_EDGE="dune-release.1.1.0" # EDGE+flambda switch, we install CI_OPAM as to be able to use diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 94e0a666e2..17070e66ee 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -1,4 +1,4 @@ -{ pkgs ? import <nixpkgs> {} +{ pkgs ? import ../../nixpkgs.nix {} , branch , wd , project ? "xyz" @@ -20,8 +20,17 @@ let mathcomp = coqPackages.mathcomp.overrideAttrs (o: { let ssreflect = coqPackages.ssreflect.overrideAttrs (o: { inherit (mathcomp) src; }); in -let coq-ext-lib = coqPackages.coq-ext-lib; in -let simple-io = coqPackages.simple-io; in + +let coq-ext-lib = coqPackages.coq-ext-lib.overrideAttrs (o: { + src = fetchTarball "https://github.com/coq-ext-lib/coq-ext-lib/tarball/master"; + }); in + +let simple-io = + (coqPackages.simple-io.override { inherit coq-ext-lib; }) + .overrideAttrs (o: { + src = fetchTarball "https://github.com/Lysxia/coq-simple-io/tarball/master"; + }); in + let bignums = coqPackages.bignums.overrideAttrs (o: if bn == "release" then {} else if bn == "master" then { src = fetchTarball https://github.com/coq/bignums/archive/master.tar.gz; } else diff --git a/dev/ci/nix/quickchick.nix b/dev/ci/nix/quickchick.nix index 46bf02ae3c..b90f1e4f88 100644 --- a/dev/ci/nix/quickchick.nix +++ b/dev/ci/nix/quickchick.nix @@ -1,5 +1,5 @@ { ocamlPackages, ssreflect, coq-ext-lib, simple-io }: { buildInputs = with ocamlPackages; [ ocaml findlib ocamlbuild num ]; - coqBuildInputs = [ ssreflect coq-ext-lib simple-io ]; + coqBuildInputs = [ ssreflect simple-io ]; } diff --git a/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh b/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh new file mode 100644 index 0000000000..2b4c1489ad --- /dev/null +++ b/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh @@ -0,0 +1,13 @@ +_OVERLAY_BRANCH=ho-matching-occ-sel + +if [ "$CI_PULL_REQUEST" = "7819" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then + + unicoq_CI_REF="PR7819-overlay" + + mtac2_CI_REF="PR7819-overlay" + mtac2_CI_GITURL=https://github.com/mattam82/Mtac2 + + equations_CI_GITURL=https://github.com/mattam82/Coq-Equations + equations_CI_REF="PR7819-overlay" + +fi diff --git a/dev/ci/user-overlays/08817-sprop.sh b/dev/ci/user-overlays/08817-sprop.sh new file mode 100644 index 0000000000..81e18226ed --- /dev/null +++ b/dev/ci/user-overlays/08817-sprop.sh @@ -0,0 +1,34 @@ +if [ "$CI_PULL_REQUEST" = "8817" ] || [ "$CI_BRANCH" = "sprop" ]; then + aac_tactics_CI_REF=sprop + aac_tactics_CI_GITURL=https://github.com/SkySkimmer/aac-tactics + + coq_dpdgraph_CI_REF=sprop + coq_dpdgraph_CI_GITURL=https://github.com/SkySkimmer/coq-dpdgraph + + coqhammer_CI_REF=sprop + coqhammer_CI_GITURL=https://github.com/SkySkimmer/coqhammer + + elpi_CI_REF=sprop + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + + equations_CI_REF=sprop + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + ltac2_CI_REF=sprop + ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 + + unicoq_CI_REF=sprop + unicoq_CI_GITURL=https://github.com/SkySkimmer/unicoq + + mtac2_CI_REF=sprop + mtac2_CI_GITURL=https://github.com/SkySkimmer/mtac2 + + paramcoq_CI_REF=sprop + paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq + + quickchick_CI_REF=sprop + quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick + + relation_algebra_CI_REF=sprop + relation_algebra_CI_GITURL=https://github.com/SkySkimmer/relation-algebra +fi diff --git a/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh b/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh new file mode 100644 index 0000000000..1110157069 --- /dev/null +++ b/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9389" ] || [ "$CI_BRANCH" = "set-implicits" ]; then + + equations_CI_REF=set-implicits + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + mtac2_CI_REF=set-implicits + mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 + +fi diff --git a/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh b/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh new file mode 100644 index 0000000000..1af8b5430d --- /dev/null +++ b/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9476" ] || [ "$CI_BRANCH" = "context-constructor" ]; then + + quickchick_CI_REF=context-constructor + quickchick_CI_GITURL=https://github.com/ppedrot/QuickChick + + equations_CI_REF=context-constructor + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + +fi diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index 5705857d76..3f1b470878 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -37,6 +37,9 @@ When maintainers receive a review request, they are expected to: REVIEWERS(*) have approved the PR, the assignee is expected to follow the merging process described below. +To know what files you are a code owner of in a large PR, you can run +`dev/tools/check-owners-pr.sh xxxx`. Results are unfortunately imperfect. + When a PR received lots of comments or if the PR has not been opened for long and the assignee thinks that some other developers might want to comment, it is recommended that they announce their intention to merge and wait a full diff --git a/dev/doc/README-V1-V5.asciidoc b/dev/doc/README-V1-V5.asciidoc deleted file mode 100644 index 631fb92c97..0000000000 --- a/dev/doc/README-V1-V5.asciidoc +++ /dev/null @@ -1,378 +0,0 @@ -Notes on the prehistory of Coq -============================== -:author: Thierry Coquand, Gérard Huet & Christine Paulin-Mohring -:revdate: September 2015 -:toc: -:toc-placement: preamble -:toclevels: 1 -:showtitle: - - -This document is a copy within the Coq archive of a document written -in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin -to accompany their public release of the archive of versions 1.10 to 6.2 -of Coq and of its CONSTR ancestor. CONSTR, then Coq, was designed and -implemented in the Formel team, joint between the INRIA Rocquencourt -laboratory and the Ecole Normale Supérieure of Paris, from 1984 -onwards. - -Version 1 ---------- - -This software is a prototype type-checker for a higher-order logical -formalism known as the Theory of Constructions, presented in his PhD -thesis by Thierry Coquand, with influences from Girard's system F and -de Bruijn's Automath. The metamathematical analysis of the system is -the PhD work of Thierry Coquand. The software is mostly the work of -Gérard Huet. Most of the mathematical examples verified with the -software are due to Thierry Coquand. - -The programming language of the CONSTR software (as it was called at -the time) was a version of ML adapted from the Edinburgh LCF system -and running on a LISP backend. The main improvements from the original -LCF ML were that ML was compiled rather than interpreted (Gérard Huet -building on the original translator by Lockwood Morris), and that it -was enriched by recursively defined types (work of Guy -Cousineau). This ancestor of CAML was used and improved by Larry -Paulson for his implementation of Cambridge LCF. - -Software developments of this prototype occurred from late 1983 to -early 1985. - -Version 1.10 was frozen on December 22nd 1984. It is the version used -for the examples in Thierry Coquand's thesis, defended on January 31st -1985. There was a unique binding operator, used both for universal -quantification (dependent product) at the level of types and -functional abstraction (λ) at the level of terms/proofs, in the manner -of Automath. Substitution (λ-reduction) was implemented using de -Bruijn's indexes. - -Version 1.11 was frozen on February 19th, 1985. It is the version used -for the examples in the paper: Th. Coquand, G. Huet. __Constructions: A -Higher Order Proof System for Mechanizing Mathematics__ <<CH85>>. - -Christine Paulin joined the team at this point, for her DEA research -internship. In her DEA memoir (August 1985) she presents developments -for the _lambo_ function – _lambo(f)(n)_ computes the minimal _m_ such -that _f(m)_ is greater than _n_, for _f_ an increasing integer -function, a challenge for constructive mathematics. She also encoded -the majority voting algorithm of Boyer and Moore. - -Version 2 ---------- - -The formal system, now renamed as the _Calculus of Constructions_, was -presented with a proof of consistency and comparisons with proof -systems of Per Martin Löf, Girard, and the Automath family of N. de -Bruijn, in the paper: T. Coquand and G. Huet. __The Calculus of -Constructions__ <<CH88>>. - -An abstraction of the software design, in the form of an abstract -machine for proof checking, and a fuller sequence of mathematical -developments was presented in: Th. Coquand, G. Huet. __Concepts -Mathématiques et Informatiques Formalisés dans le Calcul des -Constructions__<<CH87>>. - -Version 2.8 was frozen on December 16th, 1985, and served for -developing the exemples in the above papers. - -This calculus was then enriched in version 2.9 with a cumulative -hierarchy of universes. Universe levels were initially explicit -natural numbers. Another improvement was the possibility of automatic -synthesis of implicit type arguments, relieving the user of tedious -redundant declarations. - -Christine Paulin wrote an article __Algorithm development in the -Calculus of Constructions__ <<P86>>. Besides _lambo_ and _majority_, -she presents quicksort and a text formatting algorithm. - -Version 2.13 of the Calculus of Constructions with universes was -frozen on June 25th, 1986. - -A synthetic presentation of type theory along constructive lines with -ML algorithms was given by Gérard Huet in his May 1986 CMU course -notes _Formal Structures for Computation and Deduction_. Its chapter -_Induction and Recursion in the Theory of Constructions_ was presented -as an invited paper at the Joint Conference on Theory and Practice of -Software Development TAPSOFT’87 at Pise in March 1987, and published -as __Induction Principles Formalized in the Calculus of -Constructions__ <<H88>>. - -Version 3 ---------- - -This version saw the beginning of proof automation, with a search -algorithm inspired from PROLOG and the applicative logic programming -programs of the course notes _Formal structures for computation and -deduction_. The search algorithm was implemented in ML by Thierry -Coquand. The proof system could thus be used in two modes: proof -verification and proof synthesis, with tactics such as `AUTO`. - -The implementation language was now called CAML, for Categorical -Abstract Machine Language. It used as backend the LLM3 virtual machine -of Le Lisp by Jérôme Chailloux. The main developers of CAML were -Michel Mauny, Ascander Suarez and Pierre Weis. - -V3.1 was started in the summer of 1986, V3.2 was frozen at the end of -November 1986. V3.4 was developed in the first half of 1987. - -Thierry Coquand held a post-doctoral position in Cambrige University -in 1986-87, where he developed a variant implementation in SML, with -which he wrote some developments on fixpoints in Scott's domains. - -Version 4 ---------- - -This version saw the beginning of program extraction from proofs, with -two varieties of the type `Prop` of propositions, indicating -constructive intent. The proof extraction algorithms were implemented -by Christine Paulin-Mohring. - -V4.1 was frozen on July 24th, 1987. It had a first identified library -of mathematical developments (directory exemples), with libraries -Logic (containing impredicative encodings of intuitionistic logic and -algebraic primitives for booleans, natural numbers and list), `Peano` -developing second-order Peano arithmetic, `Arith` defining addition, -multiplication, euclidean division and factorial. Typical developments -were the Knaster-Tarski theorem and Newman's lemma from rewriting -theory. - -V4.2 was a joint development of a team consisting of Thierry Coquand, -Gérard Huet and Christine Paulin-Mohring. A file V4.2.log records the -log of changes. It was frozen on September 1987 as the last version -implemented in CAML 2.3, and V4.3 followed on CAML 2.5, a more stable -development system. - -V4.3 saw the first top-level of the system. Instead of evaluating -explicit quotations, the user could develop his mathematics in a -high-level language called the mathematical vernacular (following -Automath terminology). The user could develop files in the vernacular -notation (with .v extension) which were now separate from the `ml` -sources of the implementation. Gilles Dowek joined the team to -develop the vernacular language as his DEA internship research. - -A notion of sticky constant was introduced, in order to keep names of -lemmas when local hypotheses of proofs were discharged. This gave a -notion of global mathematical environment with local sections. - -Another significant practical change was that the system, originally -developped on the VAX central computer of our lab, was transferred on -SUN personal workstations, allowing a level of distributed -development. The extraction algorithm was modified, with three -annotations `Pos`, `Null` and `Typ` decorating the sorts `Prop` and -`Type`. - -Version 4.3 was frozen at the end of November 1987, and was -distributed to an early community of users (among those were Hugo -Herbelin and Loic Colson). - -V4.4 saw the first version of (encoded) inductive types. Now natural -numbers could be defined as: - -[source, coq] -Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. - -These inductive types were encoded impredicatively in the calculus, -using a subsystem _rec_ due to Christine Paulin. V4.4 was frozen on -March 6th 1988. - -Version 4.5 was the first one to support inductive types and program -extraction. Its banner was _Calcul des Constructions avec -Réalisations et Synthèse_. The vernacular language was enriched to -accommodate extraction commands. - -The verification engine design was presented as: G. Huet. _The -Constructive Engine_. Version 4.5. Invited Conference, 2nd European -Symposium on Programming, Nancy, March 88. The final paper, -describing the V4.9 implementation, appeared in: A perspective in -Theoretical Computer Science, Commemorative Volume in memory of Gift -Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. - -Version 4.5 was demonstrated in June 1988 at the YoP Institute on -Logical Foundations of Functional Programming organized by Gérard Huet -at Austin, Texas. - -Version 4.6 was started during the summer of 1988. Its main -improvement was the complete rehaul of the proof synthesis engine by -Thierry Coquand, with a tree structure of goals. - -Its source code was communicated to Randy Pollack on September 2nd -1988. It evolved progressively into LEGO, proof system for Luo's -formalism of Extended Calculus of Constructions. - -The discharge tactic was modified by Gérard Huet to allow for -inter-dependencies in discharged lemmas. Christine Paulin improved the -inductive definition scheme in order to accommodate predicates of any -arity. - -Version 4.7 was started on September 6th, 1988. - -This version starts exploiting the CAML notion of module in order to -improve the modularity of the implementation. Now the term verifier is -identified as a proper module Machine, which the structure of its -internal data structures being hidden and thus accessible only through -the legitimate operations. This machine (the constructive engine) was -the trusted core of the implementation. The proof synthesis mechanism -was a separate proof term generator. Once a complete proof term was -synthesized with the help of tactics, it was entirely re-checked by -the engine. Thus there was no need to certify the tactics, and the -system took advantage of this fact by having tactics ignore the -universe levels, universe consistency check being relegated to the -final type-checking pass. This induced a certain puzzlement in early -users who saw, after a successful proof search, their `QED` followed -by silence, followed by a failure message due to a universe -inconsistency… - -The set of examples comprise set theory experiments by Hugo Herbelin, -and notably the Schroeder-Bernstein theorem. - -Version 4.8, started on October 8th, 1988, saw a major -re-implementation of the abstract syntax type `constr`, separating -variables of the formalism and metavariables denoting incomplete terms -managed by the search mechanism. A notion of level (with three values -`TYPE`, `OBJECT` and `PROOF`) is made explicit and a type judgement -clarifies the constructions, whose implementation is now fully -explicit. Structural equality is speeded up by using pointer equality, -yielding spectacular improvements. Thierry Coquand adapts the proof -synthesis to the new representation, and simplifies pattern matching -to first-order predicate calculus matching, with important performance -gain. - -A new representation of the universe hierarchy is then defined by -Gérard Huet. Universe levels are now implemented implicitly, through -a hidden graph of abstract levels constrained with an order relation. -Checking acyclicity of the graph insures well-foundedness of the -ordering, and thus consistency. This was documented in a memo _Adding -Type:Type to the Calculus of Constructions_ which was never published. - -The development version is released as a stable 4.8 at the end of -1988. - -Version 4.9 is released on March 1st 1989, with the new ``elastic'' -universe hierarchy. - -The spring of 1989 saw the first attempt at documenting the system -usage, with a number of papers describing the formalism: - -- _Metamathematical Investigations of a Calculus of Constructions_, by - Thierry Coquand <<C90>>, -- _Inductive definitions in the Calculus of Constructions_, by - Christine Paulin-Mohrin, -- _Extracting Fω's programs from proofs in the Calculus of - Constructions_, by Christine Paulin-Mohring <<P89>>, -- _The Constructive Engine_, by Gérard Huet <<H89>>, - -as well as a number of user guides: - -- _A short user's guide for the Constructions_ Version 4.10, by Gérard Huet -- _A Vernacular Syllabus_, by Gilles Dowek. -- _The Tactics Theorem Prover, User's guide_, Version 4.10, by Thierry - Coquand. - -Stable V4.10, released on May 1st, 1989, was then a mature system, -distributed with CAML V2.6. - -In the mean time, Thierry Coquand and Christine Paulin-Mohring had -been investigating how to add native inductive types to the Calculus -of Constructions, in the manner of Per Martin-Löf's Intuitionistic -Type Theory. The impredicative encoding had already been presented in: -F. Pfenning and C. Paulin-Mohring. __Inductively defined types in the -Calculus of Constructions__ <<PP90>>. An extension of the calculus -with primitive inductive types appeared in: Th. Coquand and -C. Paulin-Mohring. __Inductively defined types__ <<CP90>>. - -This led to the Calculus of Inductive Constructions, logical formalism -implemented in Versions 5 upward of the system, and documented in: -C. Paulin-Mohring. __Inductive Definitions in the System Coq - Rules -and Properties__ <<P93>>. - -The last version of CONSTR is Version 4.11, which was last distributed -in the spring of 1990. It was demonstrated at the first workshop of -the European Basic Research Action Logical Frameworks In Sophia -Antipolis in May 1990. - -At the end of 1989, Version 5.1 was started, and renamed as the system -Coq for the Calculus of Inductive Constructions. It was then ported to -the new stand-alone implementation of ML called Caml-light. - -In 1990 many changes occurred. Thierry Coquand left for Chalmers -University in Göteborg. Christine Paulin-Mohring took a CNRS -researcher position at the LIP laboratory of École Normale Supérieure -de Lyon. Project Formel was terminated, and gave rise to two teams: -Cristal at INRIA-Roquencourt, that continued developments in -functional programming with Caml-light then Ocaml, and Coq, continuing -the type theory research, with a joint team headed by Gérard Huet at -INRIA-Rocquencourt and Christine Paulin-Mohring at the LIP laboratory -of CNRS-ENS Lyon. - -Chetan Murthy joined the team in 1991 and became the main software -architect of Version 5. He completely rehauled the implementation for -efficiency. Versions 5.6 and 5.8 were major distributed versions, -with complete documentation and a library of users' developements. The -use of the RCS revision control system, and systematic ChangeLog -files, allow a more precise tracking of the software developments. - -Developments from Version 6 upwards are documented in the credits -section of Coq's Reference Manual. - -==== -September 2015 + -Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. -==== - -[bibliography] -.Bibliographic references - -- [[[CH85]]] Th. Coquand, G. Huet. _Constructions: A Higher Order - Proof System for Mechanizing Mathematics_. Invited paper, EUROCAL85, - April 1985, Linz, Austria. Springer Verlag LNCS 203, pp. 151-184. - -- [[[CH88]]] T. Coquand and G. Huet. _The Calculus of Constructions_. - Submitted on June 30th 1985, accepted on December 5th, 1985, - Information and Computation. Preprint as Rapport de Recherche Inria - n°530, Mai 1986. Final version in Information and Computation - 76,2/3, Feb. 88. - -- [[[CH87]]] Th. Coquand, G. Huet. _Concepts Mathématiques et - Informatiques Formalisés dans le Calcul des Constructions_. Invited - paper, European Logic Colloquium, Orsay, July 1985. Preprint as - Rapport de recherche INRIA n°463, Dec. 85. Published in Logic - Colloquium 1985, North-Holland, 1987. - -- [[[P86]]] C. Paulin. _Algorithm development in the Calculus of - Constructions_, preprint as Rapport de recherche INRIA n°497, - March 86. Final version in Proceedings Symposium on Logic in Computer - Science, Cambridge, MA, 1986 (IEEE Computer Society Press). - -- [[[H88]]] G. Huet. _Induction Principles Formalized in the Calculus - of Constructions_ in Programming of Future Generation Computers, - Ed. K. Fuchi and M. Nivat, North-Holland, 1988. - -- [[[C90]]] Th. Coquand. _Metamathematical Investigations of a - Calculus of Constructions_, by INRIA Research Report N°1088, - Sept. 1989, published in Logic and Computer Science, - ed. P.G. Odifreddi, Academic Press, 1990. - -- [[[P89]]] C. Paulin. _Extracting F ω's programs from proofs in the - calculus of constructions_. 16th Annual ACM Symposium on Principles - of Programming Languages, Austin. 1989. - -- [[[H89]]] G. Huet. _The constructive engine_. A perspective in - Theoretical Computer Science. Commemorative Volume for Gift - Siromoney. World Scientific Publishing (1989). - -- [[[PP90]]] F. Pfenning and C. Paulin-Mohring. _Inductively defined - types in the Calculus of Constructions_. Preprint technical report - CMU-CS-89-209, final version in Proceedings of Mathematical - Foundations of Programming Semantics, volume 442, Lecture Notes in - Computer Science. Springer-Verlag, 1990 - -- [[[CP90]]] Th. Coquand and C. Paulin-Mohring. _Inductively defined - types_. In P. Martin-Löf and G. Mints, editors, Proceedings of - Colog'88, volume 417, Lecture Notes in Computer Science. - Springer-Verlag, 1990. - -- [[[P93]]] C. Paulin-Mohring. _Inductive Definitions in the System - Coq - Rules and Properties_. In M. Bezem and J.-F. Groote, editors, - Proceedings of the conference Typed Lambda Calculi and Applications, - volume 664, Lecture Notes in Computer Science, 1993. diff --git a/dev/doc/SProp.md b/dev/doc/SProp.md new file mode 100644 index 0000000000..f263dbb867 --- /dev/null +++ b/dev/doc/SProp.md @@ -0,0 +1,41 @@ +# Notes on SProp + +(ml API side, see refman for user side) + +## Relevance + +All kernel binders (`Prod`/`Lambda`/`LetIn`/`Context` elements) are +now annotated with a value in `type Sorts.relevance = Relevant | +Irrelevant`. It should verify that the binder's type lives in `SProp` +iff the annotation is `Irrelevant`. + +As a plugin you can generally just use `Relevant` everywhere, the +kernel will fix it if needed when it checks the terms you produce. The +only issue is that if you generate `Relevant` when it should have been +`Irrelevant` you won't be able to use proof irrelevance on that +variable until the kernel fixes it. See refman for examples as Coq +also uses `Relevant` incorrectly in some places. + +This annotation is done by transforming the binder name `'a` into a +`'a Context.binder_annot = { binder_name : 'a; binder_relevance : +Sorts.relevance }`, eg `Prod of Name.t * types * types` becomes `Prod +of Name.t Context.binder_annot * types * types`. + +If you just carry binder names around without looking at them no +change is needed, eg if you have `match foo with Lambda (x, a, b) -> +Prod (x, a, type_of (push_rel (LocalAssum (x,a)) env) b)`. Otherwise +see `context.mli` for a few combinators on the `binder_annot` type. + +When making `Relevant` annotations you can use some convenience +functions from `Context` (eg `annotR x = make_annot x Relevant`), also +`mkArrowR` from `Constr`/`EConstr` which has the signature of the old +`mkArrow`. + +You can enable the debug warning `bad-relevance` to help find places +where you generate incorrect annotations. + +Relevance can be inferred from a well-typed term using functions in +`Retypeops` (for `Constr`) and `Retyping` (for `EConstr`). For `x` a +term, note the difference between its relevance as a term (is `x : +(_ : SProp)`) and as a type (is `x : SProp`), there are functions for +both kinds. diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index da91c85856..b1bfac8cc9 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -44,6 +44,24 @@ Dune will read the file `~/.config/dune/config`; see `man dune-config`. Among others, you can set in this file the custom number of build threads `(jobs N)` and display options `(display _mode_)`. +## Running binaries [coqtop / coqide] + +There are two special targets `states` and `quickide` that will +generate "shims" for running `coqtop` and `coqide` in a fast build. In +order to use them, do: + +``` +$ make -f Makefile.dune voboot # Only once per session +$ dune exec dev/shim/coqtop-prelude +``` + +or `quickide` / `dev/shim/coqide-prelude` for CoqIDE. These targets +enjoy quick incremental compilation thanks to `-opaque` so they tend +to be very fast while developing. + +Note that for a fast developer build of ML files, the `check` target +will be faster. + ## Targets The default dune target is `dune build` (or `dune build @install`), @@ -108,9 +126,9 @@ script again] This will be fixed in the future. ## Dropping from coqtop: -The following sequence is recommended: +After doing `make -f Makefile.dune voboot`, the following commands should work: ``` -dune exec coqtop.byte +dune exec dev/shim/coqbyte-prelude > Drop. # #directory "dev";; # #use "include_dune";; diff --git a/dev/doc/changes.md b/dev/doc/changes.md index e7d4b605c7..d515ec30e8 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -12,6 +12,8 @@ ### ML API +SProp was added, see <SProp.md> + General deprecation - All functions marked [@@ocaml.deprecated] in 8.8 have been @@ -72,6 +74,12 @@ Libobject * `Libobject.superglobal_object` * `Libobject.superglobal_object_nodischarge` +Implicit Arguments + +- `Impargs.declare_manual_implicits` is restricted to only support declaration + of implicit binders at constant declaration time. `Impargs.set_implicits` should + be used for redeclaration of implicit arguments. + ## Changes between Coq 8.8 and Coq 8.9 ### ML API diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix new file mode 100644 index 0000000000..4aa0f04964 --- /dev/null +++ b/dev/nixpkgs.nix @@ -0,0 +1,4 @@ +import (fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/2923bd5d0669f1ec6ab03ddce052e9c5efb46d8f.tar.gz"; + sha256 = "16cn93rpxfql5idhigyjyhc013a3hwzyy2dl1xv7h2p78sk728vw"; +}) diff --git a/dev/shim/dune b/dev/shim/dune new file mode 100644 index 0000000000..39b4ef492c --- /dev/null +++ b/dev/shim/dune @@ -0,0 +1,40 @@ +(rule + (targets coqtop-prelude) + (deps + %{bin:coqtop} + %{project_root}/theories/Init/Prelude.vo) + (action + (with-outputs-to coqtop-prelude + (progn + (echo "#!/usr/bin/env bash\n") + (bash "echo \"$(pwd)/%{bin:coqtop} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (run chmod +x %{targets}))))) + +(rule + (targets coqbyte-prelude) + (deps + %{bin:coqtop.byte} + %{lib:coq.kernel:../../stublibs/dllbyterun_stubs.so} + %{project_root}/theories/Init/Prelude.vo) + (action + (with-outputs-to %{targets} + (progn + (echo "#!/usr/bin/env bash\n") + (bash "echo \"$(pwd)/%{bin:coqtop.byte} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (run chmod +x %{targets}))))) + +(rule + (targets coqide-prelude) + (deps + %{bin:coqqueryworker.opt} + %{bin:coqtacticworker.opt} + %{bin:coqproofworker.opt} + %{project_root}/theories/Init/Prelude.vo + %{project_root}/coqide-server.install + %{project_root}/coqide.install) + (action + (with-outputs-to coqide-prelude + (progn + (echo "#!/usr/bin/env bash\n") + (bash "echo \"$(pwd)/%{bin:coqide} -coqlib $(pwd)/%{project_root}\" \"$@\"") + (run chmod +x %{targets}))))) diff --git a/dev/tools/coqdev.el b/dev/tools/coqdev.el index ec72f96509..c6687b9731 100644 --- a/dev/tools/coqdev.el +++ b/dev/tools/coqdev.el @@ -80,9 +80,8 @@ Note that this function is executed before _Coqproject is read if it exists." (when dir (unless coq-prog-args (setq coq-prog-args - `("-coqlib" ,dir "-R" ,(concat dir "plugins") - "Coq" "-R" ,(concat dir "theories") - "Coq"))) + `("-coqlib" ,dir + "-topfile" ,buffer-file-name))) (setq-local coq-prog-name (concat dir "bin/coqtop"))))) (add-hook 'hack-local-variables-hook #'coqdev-setup-proofgeneral) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index a3d2f33216..0fbb0634a5 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -20,6 +20,7 @@ open Univ open Environ open Printer open Constr +open Context open Genarg open Clenv @@ -306,6 +307,7 @@ let constr_display csr = incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ Level.pr u ++ fnl ()) and sort_display = function + | SProp -> "SProp" | Set -> "Set" | Prop -> "Prop" | Type u -> univ_display u; @@ -315,7 +317,7 @@ let constr_display csr = Array.fold_right (fun x i -> level_display x; (string_of_int !cnt)^(if not(i="") then (" "^i) else "")) (Instance.to_array l) "" - and name_display = function + and name_display x = match x.binder_name with | Name id -> "Name("^(Id.to_string id)^")" | Anonymous -> "Anonymous" @@ -335,13 +337,13 @@ let print_pure_constr csr = | Cast (c,_, t) -> open_hovbox 1; print_string "("; (term_display c); print_cut(); print_string "::"; (term_display t); print_string ")"; close_box() - | Prod (Name(id),t,c) -> + | Prod ({binder_name=Name(id)},t,c) -> open_hovbox 1; print_string"("; print_string (Id.to_string id); print_string ":"; box_display t; print_string ")"; print_cut(); box_display c; close_box() - | Prod (Anonymous,t,c) -> + | Prod ({binder_name=Anonymous},t,c) -> print_string"("; box_display t; print_cut(); print_string "->"; box_display c; print_string ")"; | Lambda (na,t,c) -> @@ -430,12 +432,13 @@ let print_pure_constr csr = Array.iter (fun u -> print_space (); pp (Level.pr u)) (Instance.to_array u) and sort_display = function + | SProp -> print_string "SProp" | Set -> print_string "Set" | Prop -> print_string "Prop" | Type u -> open_hbox(); print_string "Type("; pp (pr_uni u); print_string ")"; close_box() - and name_display = function + and name_display x = match x.binder_name with | Name id -> print_string (Id.to_string id) | Anonymous -> print_string "_" (* Remove the top names for library and Scratch to avoid long names *) diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index dc30793a6e..863d930968 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -25,6 +25,7 @@ let print_vfix_app () = print_string "vfix_app" let print_vswith () = print_string "switch" let ppsort = function + | SProp -> print_string "SProp" | Set -> print_string "Set" | Prop -> print_string "Prop" | Type u -> print_string "Type" diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 927a912fbf..e790d20e00 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -273,6 +273,7 @@ \newcommand{\nS}{\mbox{\textsf{S}}} \newcommand{\node}{\mbox{\textsf{node}}} \newcommand{\Nil}{\mbox{\textsf{nil}}} +\newcommand{\SProp}{\mbox{\textsf{SProp}}} \newcommand{\Prop}{\mbox{\textsf{Prop}}} \newcommand{\Set}{\mbox{\textsf{Set}}} \newcommand{\si}{\mbox{\textsf{if}}} diff --git a/doc/plugin_tutorial/tuto3/src/construction_game.ml b/doc/plugin_tutorial/tuto3/src/construction_game.ml index 9d9f894e18..663113d012 100644 --- a/doc/plugin_tutorial/tuto3/src/construction_game.ml +++ b/doc/plugin_tutorial/tuto3/src/construction_game.ml @@ -1,4 +1,5 @@ open Pp +open Context let find_reference = Coqlib.find_reference [@ocaml.warning "-3"] @@ -32,7 +33,7 @@ let dangling_identity env evd = let evd, arg_type = Evarutil.new_evar env evd type_type in (* Notice the use of a De Bruijn index for the inner occurrence of the bound variable. *) - evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, + evd, EConstr.mkLambda(nameR (Names.Id.of_string "x"), arg_type, EConstr.mkRel 1) let dangling_identity2 env evd = @@ -40,7 +41,7 @@ let dangling_identity2 env evd = is meant to be a type. *) let evd, (arg_type, type_type) = Evarutil.new_type_evar env evd Evd.univ_rigid in - evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, + evd, EConstr.mkLambda(nameR (Names.Id.of_string "x"), arg_type, EConstr.mkRel 1) let example_sort_app_lambda () = diff --git a/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml index 8f2c387d09..2d541087ce 100644 --- a/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml +++ b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml @@ -116,11 +116,11 @@ let repackage i h_hyps_id = Goal.enter begin fun gl -> mkApp (c_U (), [| ty2; mkVar h_hyps_id|]) |]) in Refine.refine ~typecheck:true begin fun evd -> let evd, new_goal = Evarutil.new_evar env evd - (mkProd (Names.Name.Anonymous, - mkApp(c_H (), [| new_packed_type |]), - Vars.lift 1 concl)) in - evd, mkApp (new_goal, - [|mkApp(c_M (), [|new_packed_type; new_packed_value |]) |]) + (mkArrowR (mkApp(c_H (), [| new_packed_type |])) + (Vars.lift 1 concl)) + in + evd, mkApp (new_goal, + [|mkApp(c_M (), [|new_packed_type; new_packed_value |]) |]) end end diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index fac0035de1..881f7a310d 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -234,7 +234,8 @@ In addition to the objects above, the ``coqrst`` Sphinx plugin defines the follo - Behavior options - ``reset``: Send a ``Reset Initial`` command before running this block - - ``fail``: Don't die if a command fails + - ``fail``: Don't die if a command fails, implies ``warn`` (so no need to put both) + - ``warn``: Don't die if a command emits a warning - ``restart``: Send a ``Restart`` command before running this block (only works in proof mode) - ``abort``: Send an ``Abort All`` command after running this block (leaves all pending proofs if any) diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index 3e414a714c..a9d894cab5 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -313,7 +313,9 @@ constructor ``*``. It also tests that they work as expected. Unfortunately, these declarations are very verbose. In the following subsection we show how to make them more compact. -.. coqtop:: all +.. FIXME shouldn't warn + +.. coqtop:: all warn Module Add_instance_attempt. @@ -418,7 +420,9 @@ the reader can refer to :cite:`CSwcu`. The declaration of canonical instances can now be way more compact: -.. coqtop:: all +.. FIXME should not warn + +.. coqtop:: all warn Canonical Structure nat_LEQty := Eval hnf in Pack nat nat_LEQmx. diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index 3ec6c118af..e882ce6e88 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -285,7 +285,7 @@ By default, implicit arguments are omitted in patterns. So we write: .. coqtop:: all - Arguments nil [A]. + Arguments nil {A}. Arguments cons [A] _ _. Check (fun l:List nat => diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst new file mode 100644 index 0000000000..015b84c530 --- /dev/null +++ b/doc/sphinx/addendum/sprop.rst @@ -0,0 +1,236 @@ +.. _sprop: + +SProp (proof irrelevant propositions) +===================================== + +.. warning:: + + The status of strict propositions is experimental. + +This section describes the extension of |Coq| with definitionally +proof irrelevant propositions (types in the sort :math:`\SProp`, also +known as strict propositions). To use :math:`\SProp` you must pass +``-allow-sprop`` to the |Coq| program or use :opt:`Allow StrictProp`. + +.. opt:: Allow StrictProp + :name: Allow StrictProp + + Allows using :math:`\SProp` when set and forbids it when unset. The + initial value depends on whether you used the command line + ``-allow-sprop``. + +.. coqtop:: none + + Set Allow StrictProp. + +Some of the definitions described in this document are available +through ``Coq.Logic.StrictProp``, which see. + +Basic constructs +---------------- + +The purpose of :math:`\SProp` is to provide types where all elements +are convertible: + +.. coqdoc:: + + Definition irrelevance (A:SProp) (P:A -> Prop) (x:A) (v:P x) (y:A) : P y := v. + +Since we have definitional :ref:`eta-expansion` for +functions, the property of being a type of definitionally irrelevant +values is impredicative, and so is :math:`\SProp`: + +.. coqdoc:: + + Check fun (A:Type) (B:A -> SProp) => (forall x:A, B x) : SProp. + +.. warning:: + + Conversion checking through bytecode or native code compilation + currently does not understand proof irrelevance. + +In order to keep conversion tractable, cumulativity for :math:`\SProp` +is forbidden: + +.. coqtop:: all + + Fail Check (fun (A:SProp) => A : Type). + +We can explicitly lift strict propositions into the relevant world by +using a wrapping inductive type. The inductive stops definitional +proof irrelevance from escaping. + +.. coqtop:: in + + Inductive Box (A:SProp) : Prop := box : A -> Box A. + Arguments box {_} _. + +.. coqtop:: all + + Fail Check fun (A:SProp) (x y : Box A) => eq_refl : x = y. + +.. doesn't get merged with the above if coqdoc +.. coqtop:: in + + Definition box_irrelevant (A:SProp) (x y : Box A) : x = y + := match x, y with box x, box y => eq_refl end. + +In the other direction, we can use impredicativity to "squash" a +relevant type, making an irrelevant approximation. + +.. coqdoc:: + + Definition iSquash (A:Type) : SProp + := forall P : SProp, (A -> P) -> P. + Definition isquash A : A -> iSquash A + := fun a P f => f a. + Definition iSquash_sind A (P : iSquash A -> SProp) (H : forall x : A, P (isquash A x)) + : forall x : iSquash A, P x + := fun x => x (P x) (H : A -> P x). + +Or more conveniently (but equivalently) + +.. coqdoc:: + + Inductive Squash (A:Type) : SProp := squash : A -> Squash A. + +Most inductives types defined in :math:`\SProp` are squashed types, +i.e. they can only be eliminated to construct proofs of other strict +propositions. Empty types are the only exception. + +.. coqtop:: in + + Inductive sEmpty : SProp := . + +.. coqtop:: all + + Check sEmpty_rect. + +.. note:: + + Eliminators to strict propositions are called ``foo_sind``, in the + same way that eliminators to propositions are called ``foo_ind``. + +Primitive records in :math:`\SProp` are allowed when fields are strict +propositions, for instance: + +.. coqtop:: in + + Set Primitive Projections. + Record sProd (A B : SProp) : SProp := { sfst : A; ssnd : B }. + +On the other hand, to avoid having definitionally irrelevant types in +non-:math:`\SProp` sorts (through record η-extensionality), primitive +records in relevant sorts must have at least one relevant field. + +.. coqtop:: all + + Set Warnings "+non-primitive-record". + Fail Record rBox (A:SProp) : Prop := rbox { runbox : A }. + +.. coqdoc:: + + Record ssig (A:Type) (P:A -> SProp) : Type := { spr1 : A; spr2 : P spr1 }. + +Note that ``rBox`` works as an emulated record, which is equivalent to +the Box inductive. + +Encodings for strict propositions +--------------------------------- + +The elimination for unit types can be encoded by a trivial function +thanks to proof irrelevance: + +.. coqdoc:: + + Inductive sUnit : SProp := stt. + Definition sUnit_rect (P:sUnit->Type) (v:P stt) (x:sUnit) : P x := v. + +By using empty and unit types as base values, we can encode other +strict propositions. For instance: + +.. coqdoc:: + + Definition is_true (b:bool) : SProp := if b then sUnit else sEmpty. + + Definition is_true_eq_true b : is_true b -> true = b + := match b with + | true => fun _ => eq_refl + | false => sEmpty_ind _ + end. + + Definition eq_true_is_true b (H:true=b) : is_true b + := match H in _ = x return is_true x with eq_refl => stt end. + +Issues with non-cumulativity +---------------------------- + +During normal term elaboration, we don't always know that a type is a +strict proposition early enough. For instance: + +.. coqdoc:: + + Definition constant_0 : ?[T] -> nat := fun _ : sUnit => 0. + +While checking the type of the constant, we only know that ``?[T]`` +must inhabit some sort. Putting it in some floating universe ``u`` +would disallow instantiating it by ``sUnit : SProp``. + +In order to make the system usable without having to annotate every +instance of :math:`\SProp`, we consider :math:`\SProp` to be a subtype +of every universe during elaboration (i.e. outside the kernel). Then +once we have a fully elaborated term it is sent to the kernel which +will check that we didn't actually need cumulativity of :math:`\SProp` +(in the example above, ``u`` doesn't appear in the final term). + +This means that some errors will be delayed until ``Qed``: + +.. coqtop:: in + + Lemma foo : Prop. + Proof. pose (fun A : SProp => A : Type); exact True. + +.. coqtop:: all + + Fail Qed. + +.. coqtop:: in + + Abort. + +.. opt:: Elaboration StrictProp Cumulativity + :name: Elaboration StrictProp Cumulativity + + Unset this option (it's on by default) to be strict with regard to + :math:`\SProp` cumulativity during elaboration. + +The implementation of proof irrelevance uses inferred "relevance" +marks on binders to determine which variables are irrelevant. Together +with non-cumulativity this allows us to avoid retyping during +conversion. However during elaboration cumulativity is allowed and so +the algorithm may miss some irrelevance: + +.. coqtop:: all + + Fail Definition late_mark := fun (A:SProp) (P:A -> Prop) x y (v:P x) => v : P y. + +The binders for ``x`` and ``y`` are created before their type is known +to be ``A``, so they're not marked irrelevant. This can be avoided +with sufficient annotation of binders (see ``irrelevance`` at the +beginning of this chapter) or by bypassing the conversion check in +tactics. + +.. coqdoc:: + + Definition late_mark := fun (A:SProp) (P:A -> Prop) x y (v:P x) => + ltac:(exact_no_check v) : P y. + +The kernel will re-infer the marks on the fully elaborated term, and +so correctly converts ``x`` and ``y``. + +.. warn:: Bad relevance + + This is a developer warning, disabled by default. It is emitted by + 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. diff --git a/doc/sphinx/biblio.bib b/doc/sphinx/biblio.bib index d9eaa2c6c6..0467852b19 100644 --- a/doc/sphinx/biblio.bib +++ b/doc/sphinx/biblio.bib @@ -45,6 +45,58 @@ s}, year = {1972} } +@inproceedings{CH85, + title={Constructions: a higher order proof system for mechanizing mathematics}, + author={Coquand, Thierry and Huet, Gérard}, + booktitle={European Conference on Computer Algebra}, + pages={151--184}, + year={1985}, + issn = {1611-3349}, + doi = {10.1007/3-540-15983-5_13}, + url = {http://dx.doi.org/10.1007/3-540-15983-5_13}, + isbn = 9783540396840, + publisher = {Springer Berlin Heidelberg} +} + +@techreport{CH88 + TITLE = {{The calculus of constructions}}, + AUTHOR = {Coquand, T. and Huet, G{\'e}rard}, + URL = {https://hal.inria.fr/inria-00076024}, + NUMBER = {RR-0530}, + INSTITUTION = {{INRIA}}, + YEAR = {1986}, + MONTH = May, + PDF = {https://hal.inria.fr/inria-00076024/file/RR-0530.pdf}, + HAL_ID = {inria-00076024}, + HAL_VERSION = {v1}, +} + +@techreport{CH87, + TITLE = {{Concepts mathematiques et informatiques formalises dans le calcul des constructions}}, + AUTHOR = {Coquand, T. and Huet, G{\'e}rard}, + URL = {https://hal.inria.fr/inria-00076039}, + NUMBER = {RR-0515}, + INSTITUTION = {{INRIA}}, + YEAR = {1986}, + MONTH = Apr, + PDF = {https://hal.inria.fr/inria-00076039/file/RR-0515.pdf}, + HAL_ID = {inria-00076039}, + HAL_VERSION = {v1}, +} + +@techreport{C90, + TITLE = {{Metamathematical investigations of a calculus of constructions}}, + AUTHOR = {Coquand, T.}, + URL = {https://hal.inria.fr/inria-00075471}, + NUMBER = {RR-1088}, + INSTITUTION = {{INRIA}}, + YEAR = {1989}, + MONTH = Sep, + PDF = {https://hal.inria.fr/inria-00075471/file/RR-1088.pdf}, + HAL_ID = {inria-00075471}, + HAL_VERSION = {v1}, +} + @PhDThesis{Coq85, author = {Th. Coquand}, month = jan, @@ -80,6 +132,19 @@ s}, bibsource = {DBLP, http://dblp.uni-trier.de} } +@inproceedings{CP90, + title={Inductively defined types}, + author={Coquand, Thierry and Paulin, Christine}, + booktitle={COLOG-88}, + pages={50--66}, + year={1990}, + issn = {1611-3349}, + doi = {10.1007/3-540-52335-9_47}, + url = {http://dx.doi.org/10.1007/3-540-52335-9_47}, + isbn = 9783540469636, + publisher = {Springer Berlin Heidelberg} +} + @Book{Cur58, author = {Haskell B. Curry and Robert Feys and William Craig}, title = {Combinatory Logic}, @@ -216,7 +281,19 @@ s}, year = {1980} } -@InProceedings{Hue88, +@inproceedings{H88, + title={Induction principles formalized in the Calculus of Constructions}, + author={Huet, G{\'e}rard}, + booktitle={Programming of Future Generation Computers. Elsevier Science}, + year={1988}, + issn = {1611-3349}, + doi = {10.1007/3-540-17660-8_62}, + url = {http://dx.doi.org/10.1007/3-540-17660-8_62}, + isbn = 9783540477464, + publisher = {Springer Berlin Heidelberg} +} + +@InProceedings{H89, author = {G. Huet}, booktitle = {A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney}, editor = {R. Narasimhan}, @@ -305,6 +382,50 @@ s}, url = {http://www.xmailserver.org/diff2.pdf} } +@inproceedings{P86, + title={Algorithm development in the calculus of constructions}, + author={Mohring, Christine}, + booktitle={LICS}, + pages={84--91}, + year={1986} +} + +@inproceedings{P89, + title={Extracting $\Omega$'s programs from proofs in the calculus of constructions}, + author={Paulin-Mohring, Christine}, + booktitle={Proceedings of the 16th ACM SIGPLAN-SIGACT symposium on Principles of programming languages}, + pages={89--104}, + year={1989}, + doi = {10.1145/75277.75285}, + url = {http://dx.doi.org/10.1145/75277.75285}, + isbn = 0897912942, + organization = {ACM Press} +} + +@inproceedings{P93, + title={Inductive definitions in the system coq rules and properties}, + author={Paulin-Mohring, Christine}, + booktitle={International Conference on Typed Lambda Calculi and Applications}, + pages={328--345}, + year={1993}, + doi = {10.1007/bfb0037116}, + url = {http://dx.doi.org/10.1007/bfb0037116}, + isbn = 3540565175, + organization = {Springer-Verlag} +} + +@inproceedings{PP90, + title={Inductively defined types in the Calculus of Constructions}, + author={Pfenning, Frank and Paulin-Mohring, Christine}, + booktitle={International Conference on Mathematical Foundations of Programming Semantics}, + pages={209--228}, + year={1989}, + doi = {10.1007/bfb0040259}, + url = {http://dx.doi.org/10.1007/bfb0040259}, + isbn = 0387973753, + organization = {Springer-Verlag} +} + @InProceedings{Parent95b, author = {C. Parent}, booktitle = {{Mathematics of Program Construction'95}}, diff --git a/doc/sphinx/credits.rst b/doc/sphinx/credits.rst index 909af6e2f2..5873096523 100644 --- a/doc/sphinx/credits.rst +++ b/doc/sphinx/credits.rst @@ -2,10 +2,13 @@ Credits ------- +Historical roots +---------------- + Coq is a proof assistant for higher-order logic, allowing the development of computer programs consistent with their formal -specification. It is the result of about ten years of research of the -Coq project. We shall briefly survey here three main aspects: the +specification. It is the result of about ten years [#years]_ of research +of the Coq project. We shall briefly survey here three main aspects: the *logical language* in which we write our axiomatizations and specifications, the *proof assistant* which allows the development of verified mathematical proofs, and the *program extractor* which @@ -21,8 +24,8 @@ prompted Russell to restrict predicate calculus with a stratification of *types*. This effort culminated with *Principia Mathematica*, the first systematic attempt at a formal foundation of mathematics. A simplification of this system along the lines of simply typed -:math:`\lambda`-calculus occurred with Church’s *Simple Theory of -Types*. The :math:`\lambda`-calculus notation, originally used for +λ-calculus occurred with Church’s *Simple Theory of +Types*. The λ-calculus notation, originally used for expressing functionality, could also be used as an encoding of natural deduction proofs. This Curry-Howard isomorphism was used by N. de Bruijn in the *Automath* project, the first full-scale attempt to develop and @@ -32,7 +35,7 @@ Exploiting this Curry-Howard isomorphism, notable achievements in proof theory saw the emergence of two type-theoretic frameworks; the first one, Martin-Löf’s *Intuitionistic Theory of Types*, attempts a new foundation of mathematics on constructive principles. The second one, -Girard’s polymorphic :math:`\lambda`-calculus :math:`F_\omega`, is a +Girard’s polymorphic λ-calculus :math:`F_\omega`, is a very strong functional system in which we may represent higher-order logic proof structures. Combining both systems in a higher-order extension of the Automath language, T. Coquand presented in 1985 the @@ -107,15 +110,27 @@ advantage of special hardware, debuggers, and the like. We hope that |Coq| can be of use to researchers interested in experimenting with this new methodology. +.. [#years] At the time of writting, i.e. 1995. + +Brief summary of the versions up to 5.10 +---------------------------------------- + +.. note:: + This summary was written in 1995 together with the previous + section and formed the initial version of the Credits chapter + (that has since then been appended to, at each new release). + A more comprehensive description of these early versions is + available in the next few sections, which were written in 2015. + A first implementation of CoC was started in 1984 by G. Huet and T. Coquand. Its implementation language was CAML, a functional programming language from the ML family designed at INRIA in Rocquencourt. The core of this system was a proof-checker for CoC seen as a typed -:math:`\lambda`-calculus, called the *Constructive Engine*. This engine +λ-calculus, called the *Constructive Engine*. This engine was operated through a high-level notation permitting the declaration of axioms and parameters, the definition of mathematical types and objects, and the explicit construction of proof objects encoded as -:math:`\lambda`-terms. A section mechanism, designed and implemented by +λ-terms. A section mechanism, designed and implemented by G. Dowek, allowed hierarchical developments of mathematical theories. This high-level language was called the *Mathematical Vernacular*. Furthermore, an interactive *Theorem Prover* permitted the incremental @@ -189,8 +204,324 @@ definitions of “inversion predicates”. | Gérard Huet | -Credits: addendum for version 6.1 ---------------------------------- +Version 1 +--------- + +.. note:: + + These additional notes come from a document written + in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin + to accompany their public release of the archive of versions 1.10 to 6.2 + of Coq and of its CONSTR ancestor. CONSTR, then Coq, was designed and + implemented in the Formel team, joint between the INRIA Rocquencourt + laboratory and the Ecole Normale Supérieure of Paris, from 1984 + onwards. + +This software is a prototype type-checker for a higher-order logical +formalism known as the Theory of Constructions, presented in his PhD +thesis by Thierry Coquand, with influences from Girard's system F and +de Bruijn's Automath. The metamathematical analysis of the system is +the PhD work of Thierry Coquand. The software is mostly the work of +Gérard Huet. Most of the mathematical examples verified with the +software are due to Thierry Coquand. + +The programming language of the CONSTR software (as it was called at +the time) was a version of ML adapted from the Edinburgh LCF system +and running on a LISP backend. The main improvements from the original +LCF ML were that ML was compiled rather than interpreted (Gérard Huet +building on the original translator by Lockwood Morris), and that it +was enriched by recursively defined types (work of Guy +Cousineau). This ancestor of CAML was used and improved by Larry +Paulson for his implementation of Cambridge LCF. + +Software developments of this prototype occurred from late 1983 to +early 1985. + +Version 1.10 was frozen on December 22nd 1984. It is the version used +for the examples in Thierry Coquand's thesis, defended on January 31st +1985. There was a unique binding operator, used both for universal +quantification (dependent product) at the level of types and +functional abstraction (λ) at the level of terms/proofs, in the manner +of Automath. Substitution (λ-reduction) was implemented using de +Bruijn's indexes. + +Version 1.11 was frozen on February 19th, 1985. It is the version used +for the examples in the paper: T. Coquand, G. Huet. *Constructions: A +Higher Order Proof System for Mechanizing Mathematics* :cite:`CH85`. + +Christine Paulin joined the team at this point, for her DEA research +internship. In her DEA memoir (August 1985) she presents developments +for the *lambo* function – :math:`\text{lambo}(f)(n)` computes the minimal +:math:`m` such that :math:`f(m)` is greater than :math:`n`, for :math:`f` +an increasing integer function, a challenge for constructive mathematics. +She also encoded the majority voting algorithm of Boyer and Moore. + +Version 2 +--------- + +The formal system, now renamed as the *Calculus of Constructions*, was +presented with a proof of consistency and comparisons with proof +systems of Per Martin Löf, Girard, and the Automath family of N. de +Bruijn, in the paper: T. Coquand and G. Huet. *The Calculus of +Constructions* :cite:`CH88`. + +An abstraction of the software design, in the form of an abstract +machine for proof checking, and a fuller sequence of mathematical +developments was presented in: T. Coquand, G. Huet. *Concepts +Mathématiques et Informatiques Formalisés dans le Calcul des +Constructions* :cite:`CH87`. + +Version 2.8 was frozen on December 16th, 1985, and served for +developing the examples in the above papers. + +This calculus was then enriched in version 2.9 with a cumulative +hierarchy of universes. Universe levels were initially explicit +natural numbers. Another improvement was the possibility of automatic +synthesis of implicit type arguments, relieving the user of tedious +redundant declarations. + +Christine Paulin wrote an article *Algorithm development in the +Calculus of Constructions* :cite:`P86`. Besides *lambo* and *majority*, +she presents *quicksort* and a text formatting algorithm. + +Version 2.13 of the Calculus of Constructions with universes was +frozen on June 25th, 1986. + +A synthetic presentation of type theory along constructive lines with +ML algorithms was given by Gérard Huet in his May 1986 CMU course +notes *Formal Structures for Computation and Deduction*. Its chapter +*Induction and Recursion in the Theory of Constructions* was presented +as an invited paper at the Joint Conference on Theory and Practice of +Software Development TAPSOFT’87 at Pise in March 1987, and published +as *Induction Principles Formalized in the Calculus of +Constructions* :cite:`H88`. + +Version 3 +--------- + +This version saw the beginning of proof automation, with a search +algorithm inspired from PROLOG and the applicative logic programming +programs of the course notes *Formal structures for computation and +deduction*. The search algorithm was implemented in ML by Thierry +Coquand. The proof system could thus be used in two modes: proof +verification and proof synthesis, with tactics such as ``AUTO``. + +The implementation language was now called CAML, for Categorical +Abstract Machine Language. It used as backend the LLM3 virtual machine +of Le Lisp by Jérôme Chailloux. The main developers of CAML were +Michel Mauny, Ascander Suarez and Pierre Weis. + +V3.1 was started in the summer of 1986, V3.2 was frozen at the end of +November 1986. V3.4 was developed in the first half of 1987. + +Thierry Coquand held a post-doctoral position in Cambrige University +in 1986-87, where he developed a variant implementation in SML, with +which he wrote some developments on fixpoints in Scott's domains. + +Version 4 +--------- + +This version saw the beginning of program extraction from proofs, with +two varieties of the type ``Prop`` of propositions, indicating +constructive intent. The proof extraction algorithms were implemented +by Christine Paulin-Mohring. + +V4.1 was frozen on July 24th, 1987. It had a first identified library +of mathematical developments (directory ``exemples``), with libraries +``Logic`` (containing impredicative encodings of intuitionistic logic and +algebraic primitives for booleans, natural numbers and list), ``Peano`` +developing second-order Peano arithmetic, ``Arith`` defining addition, +multiplication, euclidean division and factorial. Typical developments +were the Knaster-Tarski theorem and Newman's lemma from rewriting +theory. + +V4.2 was a joint development of a team consisting of Thierry Coquand, +Gérard Huet and Christine Paulin-Mohring. A file V4.2.log records the +log of changes. It was frozen on September 1987 as the last version +implemented in CAML 2.3, and V4.3 followed on CAML 2.5, a more stable +development system. + +V4.3 saw the first top-level of the system. Instead of evaluating +explicit quotations, the user could develop his mathematics in a +high-level language called the mathematical vernacular (following +Automath terminology). The user could develop files in the vernacular +notation (with ``.v`` extension) which were now separate from the ``ml`` +sources of the implementation. Gilles Dowek joined the team to +develop the vernacular language as his DEA internship research. + +A notion of sticky constant was introduced, in order to keep names of +lemmas when local hypotheses of proofs were discharged. This gave a +notion of global mathematical environment with local sections. + +Another significant practical change was that the system, originally +developped on the VAX central computer of our lab, was transferred on +SUN personal workstations, allowing a level of distributed +development. The extraction algorithm was modified, with three +annotations ``Pos``, ``Null`` and ``Typ`` decorating the sorts ``Prop`` +and ``Type``. + +Version 4.3 was frozen at the end of November 1987, and was +distributed to an early community of users (among those were Hugo +Herbelin and Loic Colson). + +V4.4 saw the first version of (encoded) inductive types. Now natural +numbers could be defined as:: + + [source, coq] + Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. + +These inductive types were encoded impredicatively in the calculus, +using a subsystem *rec* due to Christine Paulin. V4.4 was frozen on +March 6th 1988. + +Version 4.5 was the first one to support inductive types and program +extraction. Its banner was *Calcul des Constructions avec +Réalisations et Synthèse*. The vernacular language was enriched to +accommodate extraction commands. + +The verification engine design was presented as: G. Huet. *The +Constructive Engine*. Version 4.5. Invited Conference, 2nd European +Symposium on Programming, Nancy, March 88. The final paper, +describing the V4.9 implementation, appeared in: A perspective in +Theoretical Computer Science, Commemorative Volume in memory of Gift +Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. + +Version 4.5 was demonstrated in June 1988 at the YoP Institute on +Logical Foundations of Functional Programming organized by Gérard Huet +at Austin, Texas. + +Version 4.6 was started during the summer of 1988. Its main +improvement was the complete rehaul of the proof synthesis engine by +Thierry Coquand, with a tree structure of goals. + +Its source code was communicated to Randy Pollack on September 2nd +1988. It evolved progressively into LEGO, proof system for Luo's +formalism of Extended Calculus of Constructions. + +The discharge tactic was modified by Gérard Huet to allow for +inter-dependencies in discharged lemmas. Christine Paulin improved the +inductive definition scheme in order to accommodate predicates of any +arity. + +Version 4.7 was started on September 6th, 1988. + +This version starts exploiting the CAML notion of module in order to +improve the modularity of the implementation. Now the term verifier is +identified as a proper module Machine, which the structure of its +internal data structures being hidden and thus accessible only through +the legitimate operations. This machine (the constructive engine) was +the trusted core of the implementation. The proof synthesis mechanism +was a separate proof term generator. Once a complete proof term was +synthesized with the help of tactics, it was entirely re-checked by +the engine. Thus there was no need to certify the tactics, and the +system took advantage of this fact by having tactics ignore the +universe levels, universe consistency check being relegated to the +final type-checking pass. This induced a certain puzzlement in early +users who saw, after a successful proof search, their ``QED`` followed +by silence, followed by a failure message due to a universe +inconsistency… + +The set of examples comprise set theory experiments by Hugo Herbelin, +and notably the Schroeder-Bernstein theorem. + +Version 4.8, started on October 8th, 1988, saw a major +re-implementation of the abstract syntax type ``constr``, separating +variables of the formalism and metavariables denoting incomplete terms +managed by the search mechanism. A notion of level (with three values +``TYPE``, ``OBJECT`` and ``PROOF``) is made explicit and a type judgement +clarifies the constructions, whose implementation is now fully +explicit. Structural equality is speeded up by using pointer equality, +yielding spectacular improvements. Thierry Coquand adapts the proof +synthesis to the new representation, and simplifies pattern matching +to first-order predicate calculus matching, with important performance +gain. + +A new representation of the universe hierarchy is then defined by +Gérard Huet. Universe levels are now implemented implicitly, through +a hidden graph of abstract levels constrained with an order relation. +Checking acyclicity of the graph insures well-foundedness of the +ordering, and thus consistency. This was documented in a memo *Adding +Type:Type to the Calculus of Constructions* which was never published. + +The development version is released as a stable 4.8 at the end of +1988. + +Version 4.9 is released on March 1st 1989, with the new "elastic" +universe hierarchy. + +The spring of 1989 saw the first attempt at documenting the system +usage, with a number of papers describing the formalism: + +- *Metamathematical Investigations of a Calculus of Constructions*, by + Thierry Coquand :cite:`C90`, + +- *Inductive definitions in the Calculus of Constructions*, by + Christine Paulin-Mohrin, + +- *Extracting Fω's programs from proofs in the Calculus of + Constructions*, by Christine Paulin-Mohring* :cite:`P89`, + +- *The Constructive Engine*, by Gérard Huet :cite:`H89`, + +as well as a number of user guides: + +- *A short user's guide for the Constructions*, Version 4.10, by Gérard Huet +- *A Vernacular Syllabus*, by Gilles Dowek. +- *The Tactics Theorem Prover, User's guide*, Version 4.10, by Thierry + Coquand. + +Stable V4.10, released on May 1st, 1989, was then a mature system, +distributed with CAML V2.6. + +In the mean time, Thierry Coquand and Christine Paulin-Mohring had +been investigating how to add native inductive types to the Calculus +of Constructions, in the manner of Per Martin-Löf's Intuitionistic +Type Theory. The impredicative encoding had already been presented in: +F. Pfenning and C. Paulin-Mohring. *Inductively defined types in the +Calculus of Constructions* :cite:`PP90`. An extension of the calculus +with primitive inductive types appeared in: T. Coquand and +C. Paulin-Mohring. *Inductively defined types* :cite:`CP90`. + +This led to the Calculus of Inductive Constructions, logical formalism +implemented in Versions 5 upward of the system, and documented in: +C. Paulin-Mohring. *Inductive Definitions in the System Coq - Rules +and Properties* :cite:`P93`. + +The last version of CONSTR is Version 4.11, which was last distributed +in the spring of 1990. It was demonstrated at the first workshop of +the European Basic Research Action Logical Frameworks In Sophia +Antipolis in May 1990. + +Version 5 +--------- + +At the end of 1989, Version 5.1 was started, and renamed as the system +Coq for the Calculus of Inductive Constructions. It was then ported to +the new stand-alone implementation of ML called Caml-light. + +In 1990 many changes occurred. Thierry Coquand left for Chalmers +University in Göteborg. Christine Paulin-Mohring took a CNRS +researcher position at the LIP laboratory of École Normale Supérieure +de Lyon. Project Formel was terminated, and gave rise to two teams: +Cristal at INRIA-Roquencourt, that continued developments in +functional programming with Caml-light then OCaml, and Coq, continuing +the type theory research, with a joint team headed by Gérard Huet at +INRIA-Rocquencourt and Christine Paulin-Mohring at the LIP laboratory +of CNRS-ENS Lyon. + +Chetan Murthy joined the team in 1991 and became the main software +architect of Version 5. He completely rehauled the implementation for +efficiency. Versions 5.6 and 5.8 were major distributed versions, +with complete documentation and a library of users' developements. The +use of the RCS revision control system, and systematic ChangeLog +files, allow a more precise tracking of the software developments. + +| September 2015 + +| Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. +| + +Version 6.1 +----------- The present version 6.1 of |Coq| is based on the V5.10 architecture. It was ported to the new language Objective Caml by Bruno Barras. The @@ -226,8 +557,8 @@ Barras. | Christine Paulin | -Credits: addendum for version 6.2 ---------------------------------- +Version 6.2 +----------- In version 6.2 of |Coq|, the parsing is done using camlp4, a preprocessor and pretty-printer for CAML designed by Daniel de Rauglaudre at INRIA. @@ -271,8 +602,8 @@ Loiseleur. | Christine Paulin | -Credits: addendum for version 6.3 ---------------------------------- +Version 6.3 +----------- The main changes in version V6.3 were the introduction of a few new tactics and the extension of the guard condition for fixpoint @@ -304,8 +635,8 @@ Monin from CNET Lannion. | Christine Paulin | -Credits: versions 7 -------------------- +Versions 7 +---------- The version V7 is a new implementation started in September 1999 by Jean-Christophe Filliâtre. This is a major revision with respect to the @@ -393,8 +724,8 @@ J.-F. Monin from France Telecom R & D. | Hugo Herbelin & Christine Paulin | -Credits: version 8.0 --------------------- +Version 8.0 +----------- Coq version 8 is a major revision of the |Coq| proof assistant. First, the underlying logic is slightly different. The so-called *impredicativity* @@ -495,8 +826,8 @@ under the responsibility of Christine Paulin. | (updated Apr. 2006) | -Credits: version 8.1 --------------------- +Version 8.1 +----------- Coq version 8.1 adds various new functionalities. @@ -574,8 +905,8 @@ and Yale University. | Hugo Herbelin | -Credits: version 8.2 --------------------- +Version 8.2 +----------- Coq version 8.2 adds new features, new libraries and improves on many various aspects. @@ -668,8 +999,8 @@ the Coq-Club mailing list. | Hugo Herbelin | -Credits: version 8.3 --------------------- +Version 8.3 +----------- Coq version 8.3 is before all a transition version with refinements or extensions of the existing features and libraries and a new tactic nsatz @@ -742,8 +1073,8 @@ Pierce for the excellent teaching materials they provided. | Hugo Herbelin | -Credits: version 8.4 --------------------- +Version 8.4 +----------- Coq version 8.4 contains the result of three long-term projects: a new modular library of arithmetic by Pierre Letouzey, a new proof engine by @@ -898,8 +1229,8 @@ Eelis van der Weegen. | Hugo Herbelin | -Credits: version 8.5 --------------------- +Version 8.5 +----------- Coq version 8.5 contains the result of five specific long-term projects: @@ -916,7 +1247,7 @@ Coq version 8.5 contains the result of five specific long-term projects: Matthieu Sozeau. - An implementation of primitive projections with - :math:`\eta`-conversion bringing significant performance improvements + :math:`\eta`\-conversion bringing significant performance improvements when using records by Matthieu Sozeau. The full integration of the proof engine, by Arnaud Spiwack and @@ -967,10 +1298,10 @@ messages in case of inconsistencies and allowing higher-level algorithms like unification to be entirely type safe. The internal representation of universes has been modified but this is invisible to the user. -The underlying logic has been extended with :math:`\eta`-conversion for +The underlying logic has been extended with :math:`\eta`\-conversion for records defined with primitive projections by Matthieu Sozeau. This -additional form of :math:`\eta`-conversion is justified using the same -principle than the previously added :math:`\eta`-conversion for function +additional form of :math:`\eta`\-conversion is justified using the same +principle than the previously added :math:`\eta`\-conversion for function types, based on formulations of the Calculus of Inductive Constructions with typed equality. Primitive projections, which do not carry the parameters of the record and are rigid names (not defined as a @@ -1052,8 +1383,8 @@ Tankink. Maxime Dénès coordinated the release process. | Hugo Herbelin, Matthieu Sozeau and the |Coq| development team | -Credits: version 8.6 --------------------- +Version 8.6 +----------- Coq version 8.6 contains the result of refinements, stabilization of 8.5’s features and cleanups of the internals of the system. Over the @@ -1192,8 +1523,8 @@ Dénès to put together a |Coq| consortium. | Matthieu Sozeau and the |Coq| development team | -Credits: version 8.7 --------------------- +Version 8.7 +----------- |Coq| version 8.7 contains the result of refinements, stabilization of features and cleanups of the internals of the system along with a few new features. The @@ -1298,8 +1629,8 @@ system, is now upcoming and will rely on Inria’s newly created Foundation. | Matthieu Sozeau and the |Coq| development team | -Credits: version 8.8 --------------------- +Version 8.8 +----------- |Coq| version 8.8 contains the result of refinements and stabilization of features and deprecations, cleanups of the internals of the system along @@ -1405,8 +1736,8 @@ The contacts of the Coq Consortium are Yves Bertot and Maxime Dénès. | Matthieu Sozeau for the |Coq| development team | -Credits: version 8.9 --------------------- +Version 8.9 +----------- |Coq| version 8.9 contains the result of refinements and stabilization of features and deprecations or removals of deprecated features, diff --git a/doc/sphinx/index.html.rst b/doc/sphinx/index.html.rst index a652b9e1ca..5a349fcf75 100644 --- a/doc/sphinx/index.html.rst +++ b/doc/sphinx/index.html.rst @@ -74,6 +74,7 @@ Contents addendum/parallel-proof-processing addendum/miscellaneous-extensions addendum/universe-polymorphism + addendum/sprop .. toctree:: :caption: Reference diff --git a/doc/sphinx/index.latex.rst b/doc/sphinx/index.latex.rst index 9e9eb330fe..ff3971aee4 100644 --- a/doc/sphinx/index.latex.rst +++ b/doc/sphinx/index.latex.rst @@ -81,6 +81,7 @@ Addendum addendum/parallel-proof-processing addendum/miscellaneous-extensions addendum/universe-polymorphism + addendum/sprop .. toctree:: zebibliography diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index e05df65c63..ef183174d7 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -36,21 +36,29 @@ Sorts ~~~~~~~~~~~ All sorts have a type and there is an infinite well-founded typing -hierarchy of sorts whose base sorts are :math:`\Prop` and :math:`\Set`. +hierarchy of sorts whose base sorts are :math:`\SProp`, :math:`\Prop` +and :math:`\Set`. The sort :math:`\Prop` intends to be the type of logical propositions. If :math:`M` is a logical proposition then it denotes the class of terms representing proofs of :math:`M`. An object :math:`m` belonging to :math:`M` witnesses the fact that :math:`M` is provable. An object of type :math:`\Prop` is called a proposition. +The sort :math:`\SProp` is like :math:`\Prop` but the propositions in +:math:`\SProp` are known to have irrelevant proofs (all proofs are +equal). Objects of type :math:`\SProp` are called strict propositions. +:math:`\SProp` is rejected except when using the compiler option +``-allow-sprop``. See :ref:`sprop` for information about using +:math:`\SProp`. + The sort :math:`\Set` intends to be the type of small sets. This includes data types such as booleans and naturals, but also products, subsets, and function types over these data types. -:math:`\Prop` and :math:`\Set` themselves can be manipulated as ordinary terms. +:math:`\SProp`, :math:`\Prop` and :math:`\Set` themselves can be manipulated as ordinary terms. Consequently they also have a type. Because assuming simply that :math:`\Set` has type :math:`\Set` leads to an inconsistent theory :cite:`Coq86`, the language of -|Cic| has infinitely many sorts. There are, in addition to :math:`\Set` and :math:`\Prop` +|Cic| has infinitely many sorts. There are, in addition to the base sorts, a hierarchy of universes :math:`\Type(i)` for any integer :math:`i ≥ 1`. Like :math:`\Set`, all of the sorts :math:`\Type(i)` contain small sets such as @@ -63,7 +71,7 @@ Formally, we call :math:`\Sort` the set of sorts which is defined by: .. math:: - \Sort \equiv \{\Prop,\Set,\Type(i)\;|\; i~∈ ℕ\} + \Sort \equiv \{\SProp,\Prop,\Set,\Type(i)\;|\; i~∈ ℕ\} Their properties, such as: :math:`\Prop:\Type(1)`, :math:`\Set:\Type(1)`, and :math:`\Type(i):\Type(i+1)`, are defined in Section :ref:`subtyping-rules`. @@ -113,7 +121,7 @@ language of the *Calculus of Inductive Constructions* is built from the following rules. -#. the sorts :math:`\Set`, :math:`\Prop`, :math:`\Type(i)` are terms. +#. the sorts :math:`\SProp`, :math:`\Prop`, :math:`\Set`, :math:`\Type(i)` are terms. #. variables, hereafter ranged over by letters :math:`x`, :math:`y`, etc., are terms #. constants, hereafter ranged over by letters :math:`c`, :math:`d`, etc., are terms. #. if :math:`x` is a variable and :math:`T`, :math:`U` are terms then @@ -293,6 +301,12 @@ following rules. --------------- \WF{E;~c:=t:T}{} +.. inference:: Ax-SProp + + \WFE{\Gamma} + ---------------------- + \WTEG{\SProp}{\Type(1)} + .. inference:: Ax-Prop \WFE{\Gamma} @@ -325,6 +339,14 @@ following rules. ---------------------------------------------------------- \WTEG{c}{T} +.. inference:: Prod-SProp + + \WTEG{T}{s} + s \in {\Sort} + \WTE{\Gamma::(x:T)}{U}{\SProp} + ----------------------------- + \WTEG{\forall~x:T,U}{\SProp} + .. inference:: Prod-Prop \WTEG{T}{s} @@ -336,14 +358,15 @@ following rules. .. inference:: Prod-Set \WTEG{T}{s} - s \in \{\Prop, \Set\} + s \in \{\SProp, \Prop, \Set\} \WTE{\Gamma::(x:T)}{U}{\Set} ---------------------------- \WTEG{∀ x:T,~U}{\Set} .. inference:: Prod-Type - \WTEG{T}{\Type(i)} + \WTEG{T}{s} + s \in \{\SProp, \Type{i}\} \WTE{\Gamma::(x:T)}{U}{\Type(i)} -------------------------------- \WTEG{∀ x:T,~U}{\Type(i)} @@ -524,6 +547,14 @@ for :math:`x` an arbitrary variable name fresh in :math:`t`. because the type of the reduced term :math:`∀ x:\Type(2),~\Type(1)` would not be convertible to the type of the original term :math:`∀ x:\Type(1),~\Type(1)`. +.. _proof-irrelevance: + +Proof Irrelevance +~~~~~~~~~~~~~~~~~ + +It is legal to identify any two terms whose common type is a strict +proposition :math:`A : \SProp`. Terms in a strict propositions are +therefore called *irrelevant*. .. _convertibility: @@ -540,7 +571,7 @@ We say that two terms :math:`t_1` and :math:`t_2` are global environment :math:`E` and local context :math:`Γ` iff there exist terms :math:`u_1` and :math:`u_2` such that :math:`E[Γ] ⊢ t_1 \triangleright … \triangleright u_1` and :math:`E[Γ] ⊢ t_2 \triangleright … \triangleright u_2` and either :math:`u_1` and -:math:`u_2` are identical, or they are convertible up to η-expansion, +:math:`u_2` are identical up to irrelevant subterms, or they are convertible up to η-expansion, i.e. :math:`u_1` is :math:`λ x:T.~u_1'` and :math:`u_2 x` is recursively convertible to :math:`u_1'`, or, symmetrically, :math:`u_2` is :math:`λx:T.~u_2'` @@ -612,6 +643,7 @@ a *subtyping* relation inductively defined by: #. for any :math:`i`, :math:`E[Γ] ⊢ \Set ≤_{βδιζη} \Type(i)`, #. :math:`E[Γ] ⊢ \Prop ≤_{βδιζη} \Set`, hence, by transitivity, :math:`E[Γ] ⊢ \Prop ≤_{βδιζη} \Type(i)`, for any :math:`i` + (note: :math:`\SProp` is not related by cumulativity to any other term) #. if :math:`E[Γ] ⊢ T =_{βδιζη} U` and :math:`E[Γ::(x:T)] ⊢ T' ≤_{βδιζη} U'` then :math:`E[Γ] ⊢ ∀x:T,~T′ ≤_{βδιζη} ∀ x:U,~U′`. @@ -980,9 +1012,9 @@ provided that the following side conditions hold: One can remark that there is a constraint between the sort of the arity of the inductive type and the sort of the type of its constructors which will always be satisfied for the impredicative -sort :math:`\Prop` but may fail to define inductive type on sort :math:`\Set` and -generate constraints between universes for inductive types in -the Type hierarchy. +sorts :math:`\SProp` and :math:`\Prop` but may fail to define +inductive type on sort :math:`\Set` and generate constraints +between universes for inductive types in the Type hierarchy. .. example:: @@ -1339,14 +1371,15 @@ There is no restriction on the sort of the predicate to be eliminated. The case of Inductive definitions of sort :math:`\Prop` is a bit more complicated, because of our interpretation of this sort. The only -harmless allowed elimination, is the one when predicate :math:`P` is also of -sort :math:`\Prop`. +harmless allowed eliminations, are the ones when predicate :math:`P` +is also of sort :math:`\Prop` or is of the morally smaller sort +:math:`\SProp`. .. inference:: Prop - ~ - --------------- - [I:\Prop|I→\Prop] + s ∈ \{\SProp,\Prop\} + -------------------- + [I:\Prop|I→s] :math:`\Prop` is the type of logical propositions, the proofs of properties :math:`P` in @@ -1434,6 +1467,14 @@ type. An empty definition has no constructors, in that case also, elimination on any sort is allowed. +.. _Eliminaton-for-SProp: + +Inductive types in :math:`\SProp` must have no constructors (i.e. be +empty) to be eliminated to produce relevant values. + +Note that thanks to proof irrelevance elimination functions can be +produced for other types, for instance the elimination for a unit type +is the identity. .. _Type-of-branches: diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index c1eab8a970..d1b95e6203 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -606,7 +606,10 @@ Finally, it gives the definition of the usual orderings ``le``, single: ge (term) single: gt (term) -.. coqtop:: in +.. This emits a notation already used warning but it won't be shown to + the user. + +.. coqtop:: in warn Inductive le (n:nat) : nat -> Prop := | le_n : le n n diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 25f983ac1e..59506a6ff2 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -1575,7 +1575,7 @@ Declaring Implicit Arguments -.. cmd:: Arguments @qualid {* [ @ident ] | @ident } +.. cmd:: Arguments @qualid {* [ @ident ] | { @ident } | @ident } :name: Arguments (implicits) This command is used to set implicit arguments *a posteriori*, @@ -1592,20 +1592,20 @@ Declaring Implicit Arguments This command clears implicit arguments. -.. cmdv:: Global Arguments @qualid {* [ @ident ] | @ident } +.. cmdv:: Global Arguments @qualid {* [ @ident ] | { @ident } | @ident } This command is used to recompute the implicit arguments of :token:`qualid` after ending of the current section if any, enforcing the implicit arguments known from inside the section to be the ones declared by the command. -.. cmdv:: Local Arguments @qualid {* [ @ident ] | @ident } +.. cmdv:: Local Arguments @qualid {* [ @ident ] | { @ident } | @ident } When in a module, tell not to activate the implicit arguments of :token:`qualid` declared by this command to contexts that require the module. -.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ [ @ident ] | @ident } } +.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ [ @ident ] | { @ident } | @ident } } For names of constants, inductive types, constructors, lemmas which can only be applied to a fixed number of @@ -1621,7 +1621,7 @@ Declaring Implicit Arguments .. coqtop:: reset all - Inductive list (A:Type) : Type := + Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. @@ -1629,13 +1629,15 @@ Declaring Implicit Arguments Arguments cons [A] _ _. - Arguments nil [A]. + Arguments nil {A}. Check (cons 3 nil). - Fixpoint map (A B:Type) (f:A->B) (l:list A) : list B := match l with nil => nil | cons a t => cons (f a) (map A B f t) end. + Fixpoint map (A B : Type) (f : A -> B) (l : list A) : list B := + match l with nil => nil | cons a t => cons (f a) (map A B f t) end. - Fixpoint length (A:Type) (l:list A) : nat := match l with nil => 0 | cons _ m => S (length A m) end. + Fixpoint length (A : Type) (l : list A) : nat := + match l with nil => 0 | cons _ m => S (length A m) end. Arguments map [A B] f l. @@ -1651,6 +1653,13 @@ Declaring Implicit Arguments To know which are the implicit arguments of an object, use the command :cmd:`Print Implicit` (see :ref:`displaying-implicit-args`). +.. warn:: Argument number @num is a trailing implicit so must be maximal. + + For instance in + + .. coqtop:: all warn + + Arguments prod _ [_]. Automatic declaration of implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1704,19 +1713,15 @@ of constants. For instance, the variable ``p`` below has type ``forall x,y:U, R x y -> forall z:U, R y z -> R x z``. As the variables ``x``, ``y`` and ``z`` appear strictly in the body of the type, they are implicit. -.. coqtop:: reset none - - Set Warnings "-local-declaration". - .. coqtop:: all - Variable X : Type. + Parameter X : Type. Definition Relation := X -> X -> Prop. Definition Transitivity (R:Relation) := forall x y:X, R x y -> forall z:X, R y z -> R x z. - Variables (R : Relation) (p : Transitivity R). + Parameters (R : Relation) (p : Transitivity R). Arguments p : default implicits. @@ -1724,7 +1729,7 @@ appear strictly in the body of the type, they are implicit. Print Implicit p. - Variables (a b c : X) (r1 : R a b) (r2 : R b c). + Parameters (a b c : X) (r1 : R a b) (r2 : R b c). Check (p r1 r2). @@ -2260,3 +2265,52 @@ expression as described in :ref:`ltac`. This construction is useful when one wants to define complicated terms using highly automated tactics without resorting to writing the proof-term by means of the interactive proof engine. + +.. _primitive-integers: + +Primitive Integers +-------------------------------- + +The language of terms features 63-bit machine integers as values. The type of +such a value is *axiomatized*; it is declared through the following sentence +(excerpt from the :g:`Int63` module): + +.. coqdoc:: + + Primitive int := #int63_type. + +This type is equipped with a few operators, that must be similarly declared. +For instance, equality of two primitive integers can be decided using the :g:`Int63.eqb` function, +declared and specified as follows: + +.. coqdoc:: + + Primitive eqb := #int63_eq. + Notation "m '==' n" := (eqb m n) (at level 70, no associativity) : int63_scope. + + Axiom eqb_correct : forall i j, (i == j)%int63 = true -> i = j. + +The complete set of such operators can be obtained looking at the :g:`Int63` module. + +These primitive declarations are regular axioms. As such, they must be trusted and are listed by the +:g:`Print Assumptions` command, as in the following example. + +.. coqtop:: in reset + + From Coq Require Import Int63. + Lemma one_minus_one_is_zero : (1 - 1 = 0)%int63. + Proof. apply eqb_correct; vm_compute; reflexivity. Qed. + +.. coqtop:: all + + Print Assumptions one_minus_one_is_zero. + +The reduction machines (:tacn:`vm_compute`, :tacn:`native_compute`) implement +dedicated, efficient, rules to reduce the applications of these primitive +operations. + +These primitives, when extracted to OCaml (see :ref:`extraction`), are mapped to +types and functions of a :g:`Uint63` module. Said module is not produced by +extraction. Instead, it has to be provided by the user (if they want to compile +or execute the extracted code). For instance, an implementation of this module +can be taken from the kernel of Coq. diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 9ab3f905e6..02fb9d84ce 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -94,8 +94,8 @@ Keywords employed otherwise:: _ as at cofix else end exists exists2 fix for - forall fun if IF in let match mod Prop return - Set then Type using where with + forall fun if IF in let match mod return + SProp Prop Set Type then using where with Special tokens The following sequences of characters are special tokens:: @@ -159,7 +159,7 @@ is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. : ' `pattern` name : `ident` | _ qualid : `ident` | `qualid` `access_ident` - sort : Prop | Set | Type + sort : SProp | Prop | Set | Type fix_bodies : `fix_body` : `fix_body` with `fix_body` with … with `fix_body` for `ident` cofix_bodies : `cofix_body` @@ -218,13 +218,17 @@ numbers (see :ref:`datatypes`). .. index:: single: Set (sort) + single: SProp single: Prop single: Type Sorts ----- -There are three sorts :g:`Set`, :g:`Prop` and :g:`Type`. +There are four sorts :g:`SProp`, :g:`Prop`, :g:`Set` and :g:`Type`. + +- :g:`SProp` is the universe of *definitionally irrelevant + propositions* (also called *strict propositions*). - :g:`Prop` is the universe of *logical propositions*. The logical propositions themselves are typing the proofs. We denote propositions by :production:`form`. @@ -235,7 +239,7 @@ There are three sorts :g:`Set`, :g:`Prop` and :g:`Type`. specifications by :production:`specif`. This constitutes a semantic subclass of the syntactic class :token:`term`. -- :g:`Type` is the type of :g:`Prop` and :g:`Set` +- :g:`Type` is the type of sorts. More on sorts can be found in Section :ref:`sorts`. @@ -767,9 +771,9 @@ Simple inductive types are the names of its constructors and :token:`type` their respective types. Depending on the universe where the inductive type :token:`ident` lives (e.g. its type :token:`sort`), Coq provides a number of destructors. - Destructors are named :token:`ident`\ ``_ind``, :token:`ident`\ ``_rec`` - or :token:`ident`\ ``_rect`` which respectively correspond to elimination - principles on :g:`Prop`, :g:`Set` and :g:`Type`. + Destructors are named :token:`ident`\ ``_sind``,:token:`ident`\ ``_ind``, + :token:`ident`\ ``_rec`` or :token:`ident`\ ``_rect`` which respectively + correspond to elimination principles on :g:`SProp`, :g:`Prop`, :g:`Set` and :g:`Type`. The type of the destructors expresses structural induction/recursion principles over objects of type :token:`ident`. The constant :token:`ident`\ ``_ind`` is always provided, @@ -1023,7 +1027,7 @@ Mutually defined inductive types .. coqtop:: in - Variables A B : Set. + Parameters A B : Set. Inductive tree : Set := node : A -> forest -> tree @@ -1533,7 +1537,7 @@ the following attributes names are recognized: .. example:: - .. coqtop:: all reset + .. coqtop:: all reset warn From Coq Require Program. #[program] Definition one : nat := S _. diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index 63d6a229ed..b629d15b11 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -33,7 +33,7 @@ example, revisiting the first example of the inversion documentation: | LeO : forall n:nat, Le 0 n | LeS : forall n m:nat, Le n m -> Le (S n) (S m). - Variable P : nat -> nat -> Prop. + Parameter P : nat -> nat -> Prop. Goal forall n m:nat, Le (S n) m -> P n m. @@ -69,7 +69,7 @@ as well in this case, e.g.: .. coqtop:: in - Variable Q : forall (n m : nat), Le n m -> Prop. + Parameter Q : forall (n m : nat), Le n m -> Prop. Goal forall n m (p : Le (S n) m), Q (S n) m p. .. coqtop:: all @@ -124,7 +124,7 @@ the following example on vectors: .. coqtop:: in - Variable A : Set. + Parameter A : Set. .. coqtop:: in @@ -329,7 +329,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Variable Ack : nat -> nat -> nat. + Parameter Ack : nat -> nat -> nat. .. coqtop:: in @@ -357,7 +357,7 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: in - Variable g : nat -> nat -> nat. + Parameter g : nat -> nat -> nat. .. coqtop:: in diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 3e87e8acd8..52e3029b8f 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -200,7 +200,7 @@ following form: :name: [> ... | ... | ... ] (dispatch) The expressions :n:`@expr__i` are evaluated to :n:`v__i`, for - i = 0, ..., n and all have to be tactics. The :n:`v__i` is applied to the + i = 1, ..., n and all have to be tactics. The :n:`v__i` is applied to the i-th goal, for i = 1, ..., n. It fails if the number of focused goals is not exactly n. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 2300a317f1..27360f02d3 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -30,7 +30,7 @@ When a proof is completed, the message ``Proof completed`` is displayed. One can then register this proof as a defined constant in the environment. Because there exists a correspondence between proofs and terms of λ-calculus, known as the *Curry-Howard isomorphism* -:cite:`How80,Bar81,Gir89,Hue88`, |Coq| stores proofs as terms of |Cic|. Those +:cite:`How80,Bar81,Gir89,H89`, |Coq| stores proofs as terms of |Cic|. Those terms are called *proof terms*. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 237b534d67..b240cef40c 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -2094,9 +2094,9 @@ into a closing one (similar to :tacn:`now`). Its general syntax is: :name: by :undocumented: -The Ltac expression :n:`by [@tactic | [@tactic | …]` is equivalent to -:n:`[by @tactic | by @tactic | ...]` and this form should be preferred -to the former. +The Ltac expression :n:`by [@tactic | @tactic | …]` is equivalent to +:n:`do [done | by @tactic | by @tactic | …]`, which corresponds to the +standard Ltac expression :n:`first [done | @tactic; done | @tactic; done | …]`. In the script provided as example in section :ref:`indentation_ssr`, the paragraph corresponding to each sub-case ends with a tactic line prefixed @@ -2902,6 +2902,7 @@ pattern will be used to process its instance. Axiom P : nat -> Prop. Axioms eqn leqn : nat -> nat -> bool. + Declare Scope this_scope. Notation "a != b" := (eqn a b) (at level 70) : this_scope. Notation "a <= b" := (leqn a b) (at level 70) : this_scope. Open Scope this_scope. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index b5e9a902c6..7b395900e9 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -378,7 +378,7 @@ Examples: .. coqtop:: reset none - Variables (A : Prop) (B: nat -> Prop) (C: Prop). + Parameters (A : Prop) (B: nat -> Prop) (C: Prop). .. coqtop:: out @@ -730,15 +730,15 @@ Applying theorems .. coqtop:: reset in - Variable R : nat -> nat -> Prop. + Parameter R : nat -> nat -> Prop. - Hypothesis Rtrans : forall x y z:nat, R x y -> R y z -> R x z. + Axiom Rtrans : forall x y z:nat, R x y -> R y z -> R x z. - Variables n m p : nat. + Parameters n m p : nat. - Hypothesis Rnm : R n m. + Axiom Rnm : R n m. - Hypothesis Rmp : R m p. + Axiom Rmp : R m p. Consider the goal ``(R n p)`` provable using the transitivity of ``R``: @@ -3683,11 +3683,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is Local is useless since hints do not survive anyway to the closure of sections. - .. cmdv:: Local Hint @hint_definition - - Idem for the core database. - - .. cmdv:: Hint Resolve @term {? | {? @num} {? @pattern}} + .. cmdv:: Hint Resolve @term {? | {? @num} {? @pattern}} : @ident :name: Hint Resolve This command adds :n:`simple apply @term` to the hint list with the head @@ -3706,16 +3702,16 @@ The general command to add a hint to some databases :n:`{+ @ident}` is typical example of a hint that is used only by :tacn:`eauto` is a transitivity lemma. - .. exn:: @term cannot be used as a hint + .. exn:: @term cannot be used as a hint - The head symbol of the type of :n:`@term` is a bound variable such that - this tactic cannot be associated to a constant. + The head symbol of the type of :n:`@term` is a bound variable + such that this tactic cannot be associated to a constant. - .. cmdv:: Hint Resolve {+ @term} + .. cmdv:: Hint Resolve {+ @term} : @ident Adds each :n:`Hint Resolve @term`. - .. cmdv:: Hint Resolve -> @term + .. cmdv:: Hint Resolve -> @term : @ident Adds the left-to-right implication of an equivalence as a hint (informally the hint will be used as :n:`apply <- @term`, although as mentionned @@ -3726,7 +3722,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is Adds the right-to-left implication of an equivalence as a hint. - .. cmdv:: Hint Immediate @term + .. cmdv:: Hint Immediate @term : @ident :name: Hint Immediate This command adds :n:`simple apply @term; trivial` to the hint list associated @@ -3742,37 +3738,37 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. exn:: @term cannot be used as a hint :undocumented: - .. cmdv:: Immediate {+ @term} + .. cmdv:: Immediate {+ @term} : @ident Adds each :n:`Hint Immediate @term`. - .. cmdv:: Hint Constructors @ident + .. cmdv:: Hint Constructors @qualid : @ident :name: Hint Constructors - If :n:`@ident` is an inductive type, this command adds all its constructors as + If :token:`qualid` is an inductive type, this command adds all its constructors as hints of type ``Resolve``. Then, when the conclusion of current goal has the form - :n:`(@ident ...)`, :tacn:`auto` will try to apply each constructor. + :n:`(@qualid ...)`, :tacn:`auto` will try to apply each constructor. - .. exn:: @ident is not an inductive type - :undocumented: + .. exn:: @qualid is not an inductive type + :undocumented: - .. cmdv:: Hint Constructors {+ @ident} + .. cmdv:: Hint Constructors {+ @qualid} : @ident - Adds each :n:`Hint Constructors @ident`. + Extends the previous command for several inductive types. - .. cmdv:: Hint Unfold @qualid + .. cmdv:: Hint Unfold @qualid : @ident :name: Hint Unfold This adds the tactic :n:`unfold @qualid` to the hint list that will only be - used when the head constant of the goal is :n:`@ident`. + used when the head constant of the goal is :token:`qualid`. Its cost is 4. - .. cmdv:: Hint Unfold {+ @ident} + .. cmdv:: Hint Unfold {+ @qualid} - Adds each :n:`Hint Unfold @ident`. + Extends the previous command for several defined constants. - .. cmdv:: Hint Transparent {+ @qualid} - Hint Opaque {+ @qualid} + .. cmdv:: Hint Transparent {+ @qualid} : @ident + Hint Opaque {+ @qualid} : @ident :name: Hint Transparent; Hint Opaque This adds transparency hints to the database, making :n:`@qualid` @@ -3781,8 +3777,8 @@ The general command to add a hint to some databases :n:`{+ @ident}` is discrimination network to relax or constrain it in the case of discriminated databases. - .. cmdv:: Hint Variables %( Transparent %| Opaque %) - Hint Constants %( Transparent %| Opaque %) + .. cmdv:: Hint Variables %( Transparent %| Opaque %) : @ident + Hint Constants %( Transparent %| Opaque %) : @ident :name: Hint Variables; Hint Constants This sets the transparency flag used during unification of @@ -3790,7 +3786,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is overwritting the existing settings of opacity. It is advised to use this just after a :cmd:`Create HintDb` command. - .. cmdv:: Hint Extern @num {? @pattern} => @tactic + .. cmdv:: Hint Extern @num {? @pattern} => @tactic : @ident :name: Hint Extern This hint type is to extend :tacn:`auto` with tactics other than :tacn:`apply` and @@ -3801,7 +3797,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. coqtop:: in - Hint Extern 4 (~(_ = _)) => discriminate. + Hint Extern 4 (~(_ = _)) => discriminate : core. Now, when the head of the goal is a disequality, ``auto`` will try discriminate if it does not manage to solve the goal with hints with a @@ -3820,7 +3816,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is Goal forall a b:list (nat * nat), {a = b} + {a <> b}. Info 1 auto with eqdec. - .. cmdv:: Hint Cut @regexp + .. cmdv:: Hint Cut @regexp : @ident :name: Hint Cut .. warning:: @@ -3854,7 +3850,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is semantics of ``Hint Cut e`` is to set the cut expression to ``c | e``, the initial cut expression being `emp`. - .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} + .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} : @ident :name: Hint Mode This sets an optional mode of use of the identifier :n:`@qualid`. When diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index a98a46ba21..3e8dd25ee0 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1213,10 +1213,19 @@ Controlling the locality of commands occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this category. +.. _internal-registration-commands: + +Internal registration commands +-------------------------------- + +Due to their internal nature, the commands that are presented in this section +are not for general use. They are meant to appear only in standard libraries and +in support libraries of plug-ins. + .. _exposing-constants-to-ocaml-libraries: Exposing constants to OCaml libraries ----------------------------------------------------------------- +```````````````````````````````````````````````````````````````` .. cmd:: Register @qualid__1 as @qualid__2 @@ -1225,5 +1234,35 @@ Exposing constants to OCaml libraries calling :n:`Coqlib.lib_ref "@qualid__2"`; i.e., there is no need to known where is the constant defined (file, module, library, etc.). - Due to its internal nature, this command is not for general use. It is meant - to appear only in standard libraries and in support libraries of plug-ins. + As a special case, when the first segment of :n:`@qualid__2` is :g:`kernel`, + the constant is exposed to the kernel. For instance, the `Int63` module + features the following declaration: + + .. coqdoc:: + + Register bool as kernel.ind_bool. + + This makes the kernel aware of what is the type of boolean values. This + information is used for instance to define the return type of the + :g:`#int63_eq` primitive. + + .. seealso:: :ref:`primitive-integers` + +Inlining hints for the fast reduction machines +```````````````````````````````````````````````````````````````` + +.. cmd:: Register Inline @qualid + + This command gives as a hint to the reduction machines (VM and native) that + the body of the constant :n:`@qualid` should be inlined in the generated code. + +Registering primitive operations +```````````````````````````````` + +.. cmd:: Primitive @ident__1 := #@ident__2. + + Declares :n:`@ident__1` as the primitive operator :n:`#@ident__2`. When + running this command, the type of the primitive should be already known by + the kernel (this is achieved through this command for primitive types and + through the :cmd:`Register` command with the :g:`kernel` name-space for other + types). diff --git a/doc/sphinx/refman-preamble.sty b/doc/sphinx/refman-preamble.sty index 8f7b1bb1e8..90a63a5a2d 100644 --- a/doc/sphinx/refman-preamble.sty +++ b/doc/sphinx/refman-preamble.sty @@ -58,6 +58,7 @@ \newcommand{\Pair}{\textsf{pair}} \newcommand{\plus}{\mathsf{plus}} \newcommand{\Prod}{\textsf{prod}} +\newcommand{\SProp}{\textsf{SProp}} \newcommand{\Prop}{\textsf{Prop}} \newcommand{\return}{\kw{return}} \newcommand{\Set}{\textsf{Set}} diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 4f46a80dcf..e5eb7eb4f5 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1115,6 +1115,8 @@ Binding arguments of a constant to an interpretation scope .. coqtop:: all Parameter g : bool -> bool. + Declare Scope mybool_scope. + Notation "@@" := true (only parsing) : bool_scope. Notation "@@" := false (only parsing): mybool_scope. @@ -1151,6 +1153,7 @@ Binding types of arguments to an interpretation scope .. coqtop:: in reset Parameter U : Set. + Declare Scope U_scope. Bind Scope U_scope with U. Parameter Uplus : U -> U -> U. Parameter P : forall T:Set, T -> U -> Prop. @@ -1575,7 +1578,7 @@ Numeral notations For example - .. coqtop:: all + .. coqtop:: all warn Check 90000. diff --git a/doc/stdlib/dune b/doc/stdlib/dune new file mode 100644 index 0000000000..7fe2493fbf --- /dev/null +++ b/doc/stdlib/dune @@ -0,0 +1,36 @@ +; This is an ad-hoc rule to ease the migration, it should be handled +; natively by Dune in the future. +(rule + (targets index-list.html) + (deps + make-library-index index-list.html.template hidden-files + (source_tree %{project_root}/theories) + (source_tree %{project_root}/plugins)) + (action + (chdir %{project_root} + ; On windows run will fail + (bash "doc/stdlib/make-library-index doc/stdlib/index-list.html doc/stdlib/hidden-files")))) + +(rule + (targets html) + (deps + ; This will be replaced soon by `theories/**/*.v` soon, thanks to rgrinberg + (source_tree %{project_root}/theories) + (source_tree %{project_root}/plugins) + (:header %{project_root}/doc/common/styles/html/coqremote/header.html) + (:footer %{project_root}/doc/common/styles/html/coqremote/footer.html) + ; For .glob files, should be gone when Coq Dune is smarter. + (package coq)) + (action + (progn + (run mkdir -p html) + (bash "%{bin:coqdoc} -q -d html --with-header %{header} --with-footer %{footer} --multi-index --html -g -R %{project_root}/theories Coq -R %{project_root}/plugins Coq $(find %{project_root}/theories %{project_root}/plugins -name *.v)") + (run mv html/index.html html/genindex.html) + (with-stdout-to + _index.html + (progn (cat %{header}) (cat index-list.html) (cat %{footer}))) + (run cp _index.html html/index.html)))) + +(alias + (name stdlib-html) + (deps html)) diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 7b21b67eea..fd79996bb7 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -33,6 +33,7 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Logic/SetIsType.v + theories/Logic/StrictProp.v theories/Logic/Classical_Pred_Type.v theories/Logic/Classical_Prop.v (theories/Logic/Classical.v) diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 8df0f2be97..eaf1b2c2ad 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -580,7 +580,8 @@ class CoqtopDirective(Directive): - Behavior options - ``reset``: Send a ``Reset Initial`` command before running this block - - ``fail``: Don't die if a command fails + - ``fail``: Don't die if a command fails, implies ``warn`` (so no need to put both) + - ``warn``: Don't die if a command emits a warning - ``restart``: Send a ``Restart`` command before running this block (only works in proof mode) - ``abort``: Send an ``Abort All`` command after running this block (leaves all pending proofs if any) @@ -835,11 +836,12 @@ class CoqtopBlocksTransform(Transform): # Behavior options opt_reset = 'reset' in options opt_fail = 'fail' in options + opt_warn = 'warn' in options opt_restart = 'restart' in options opt_abort = 'abort' in options - options = options - set(('reset', 'fail', 'restart', 'abort')) + options = options - {'reset', 'fail', 'warn', 'restart', 'abort'} - unexpected_options = list(options - set(('all', 'none', 'in', 'out'))) + unexpected_options = list(options - {'all', 'none', 'in', 'out'}) if unexpected_options: loc = get_node_location(node) raise ExtensionError("{}: Unexpected options for .. coqtop:: {}".format(loc,unexpected_options)) @@ -857,6 +859,9 @@ class CoqtopBlocksTransform(Transform): return { 'reset': opt_reset, 'fail': opt_fail, + # if errors are allowed, then warnings too + # and they should be displayed as warnings, not errors + 'warn': opt_warn or opt_fail, 'restart': opt_restart, 'abort': opt_abort, 'input': opt_input or opt_all, @@ -891,18 +896,22 @@ class CoqtopBlocksTransform(Transform): pairs = [] if options['restart']: - repl.sendone("Restart.") + repl.sendone('Restart.') if options['reset']: - repl.sendone("Reset Initial.") - repl.sendone("Set Coqtop Exit On Error.") + repl.sendone('Reset Initial.') + repl.send_initial_options() if options['fail']: - repl.sendone("Unset Coqtop Exit On Error.") + repl.sendone('Unset Coqtop Exit On Error.') + if options['warn']: + repl.sendone('Set Warnings "default".') for sentence in self.split_sentences(node.rawsource): pairs.append((sentence, repl.sendone(sentence))) if options['abort']: - repl.sendone("Abort All.") + repl.sendone('Abort All.') if options['fail']: - repl.sendone("Set Coqtop Exit On Error.") + repl.sendone('Set Coqtop Exit On Error.') + if options['warn']: + repl.sendone('Set Warnings "+default".') dli = nodes.definition_list_item() for sentence, output in pairs: @@ -923,7 +932,7 @@ class CoqtopBlocksTransform(Transform): Finds nodes to process using is_coqtop_block.""" with CoqTop(color=True) as repl: - repl.sendone("Set Coqtop Exit On Error.") + repl.send_initial_options() for node in self.document.traverse(CoqtopBlocksTransform.is_coqtop_block): try: self.add_coq_output_1(repl, node) diff --git a/doc/tools/coqrst/repl/coqtop.py b/doc/tools/coqrst/repl/coqtop.py index ddba2edd4a..26f6255069 100644 --- a/doc/tools/coqrst/repl/coqtop.py +++ b/doc/tools/coqrst/repl/coqtop.py @@ -87,6 +87,11 @@ class CoqTop: raise CoqTopError(err, sentence, self.coqtop.before) return output + def send_initial_options(self): + """Options to send when starting the toplevel and after a Reset Initial.""" + self.sendone('Set Coqtop Exit On Error.') + self.sendone('Set Warnings "+default".') + def sendmany(*sentences): """A small demo: send each sentence in sentences and print the output""" with CoqTop() as coqtop: @@ -1,12 +1,12 @@ ; Default flags for all Coq libraries. (env - (dev (flags :standard -rectypes -w -9-27+40+60)) + (dev (flags :standard -rectypes -w -9-27+40+60 \ -short-paths)) (release (flags :standard -rectypes) (ocamlopt_flags -O3 -unbox-closures)) (ireport (flags :standard -rectypes -w -9-27-40+60) (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report)) (ocaml409 - (flags :standard -strict-sequence -strict-formats -short-paths -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) + (flags :standard -strict-sequence -strict-formats -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) ; The _ profile could help factoring the above, however it doesn't ; seem to work like we'd expect/like: @@ -19,7 +19,7 @@ (deps (source_tree theories) (source_tree plugins)) - (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep opt -noglob -boot `find theories plugins -type f -name *.v`")))) + (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep both -noglob -boot `find theories plugins -type f -name *.v`")))) (alias (name vodeps) diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 8756ebfdf2..981f9454e4 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -48,9 +48,10 @@ type 'a puniverses = 'a * EInstance.t let in_punivs a = (a, EInstance.empty) +let mkSProp = of_kind (Sort (ESorts.make Sorts.sprop)) let mkProp = of_kind (Sort (ESorts.make Sorts.prop)) let mkSet = of_kind (Sort (ESorts.make Sorts.set)) -let mkType u = of_kind (Sort (ESorts.make (Sorts.Type u))) +let mkType u = of_kind (Sort (ESorts.make (Sorts.sort_of_univ u))) let mkRel n = of_kind (Rel n) let mkVar id = of_kind (Var id) let mkMeta n = of_kind (Meta n) @@ -72,7 +73,8 @@ let mkCase (ci, c, r, p) = of_kind (Case (ci, c, r, p)) let mkFix f = of_kind (Fix f) let mkCoFix f = of_kind (CoFix f) let mkProj (p, c) = of_kind (Proj (p, c)) -let mkArrow t1 t2 = of_kind (Prod (Anonymous, t1, t2)) +let mkArrow t1 r t2 = of_kind (Prod (make_annot Anonymous r, t1, t2)) +let mkArrowR t1 t2 = mkArrow t1 Sorts.Relevant t2 let mkInt i = of_kind (Int i) let mkRef (gr,u) = let open GlobRef in match gr with @@ -81,6 +83,8 @@ let mkRef (gr,u) = let open GlobRef in match gr with | ConstructRef c -> mkConstructU (c,u) | VarRef x -> mkVar x +let type1 = mkSort Sorts.type1 + let applist (f, arg) = mkApp (f, Array.of_list arg) let applistc f arg = mkApp (f, Array.of_list arg) @@ -665,9 +669,9 @@ let mkLambda_or_LetIn decl c = | LocalAssum (na,t) -> mkLambda (na, t, c) | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) -let mkNamedProd id typ c = mkProd (Name id, typ, Vars.subst_var id c) -let mkNamedLambda id typ c = mkLambda (Name id, typ, Vars.subst_var id c) -let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, Vars.subst_var id c2) +let mkNamedProd id typ c = mkProd (map_annot Name.mk_name id, typ, Vars.subst_var id.binder_name c) +let mkNamedLambda id typ c = mkLambda (map_annot Name.mk_name id, typ, Vars.subst_var id.binder_name c) +let mkNamedLetIn id c1 t c2 = mkLetIn (map_annot Name.mk_name id, c1, t, Vars.subst_var id.binder_name c2) let mkNamedProd_or_LetIn decl c = let open Context.Named.Declaration in diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 2f4cf7d5d0..25ceffbd04 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -104,13 +104,14 @@ val mkVar : Id.t -> t val mkMeta : metavariable -> t val mkEvar : t pexistential -> t val mkSort : Sorts.t -> t +val mkSProp : t val mkProp : t val mkSet : t val mkType : Univ.Universe.t -> t val mkCast : t * cast_kind * t -> t -val mkProd : Name.t * t * t -> t -val mkLambda : Name.t * t * t -> t -val mkLetIn : Name.t * t * t * t -> t +val mkProd : Name.t Context.binder_annot * t * t -> t +val mkLambda : Name.t Context.binder_annot * t * t -> t +val mkLetIn : Name.t Context.binder_annot * t * t * t -> t val mkApp : t * t array -> t val mkConst : Constant.t -> t val mkConstU : Constant.t * EInstance.t -> t @@ -123,11 +124,14 @@ val mkConstructUi : (inductive * EInstance.t) * int -> t val mkCase : case_info * t * t * t array -> t val mkFix : (t, t) pfixpoint -> t val mkCoFix : (t, t) pcofixpoint -> t -val mkArrow : t -> t -> t +val mkArrow : t -> Sorts.relevance -> t -> t +val mkArrowR : t -> t -> t val mkInt : Uint63.t -> t val mkRef : GlobRef.t * EInstance.t -> t +val type1 : t + val applist : t * t list -> t val applistc : t -> t list -> t @@ -136,9 +140,9 @@ val mkLambda_or_LetIn : rel_declaration -> t -> t val it_mkProd_or_LetIn : t -> rel_context -> t val it_mkLambda_or_LetIn : t -> rel_context -> t -val mkNamedLambda : Id.t -> types -> constr -> constr -val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr -val mkNamedProd : Id.t -> types -> types -> types +val mkNamedLambda : Id.t Context.binder_annot -> types -> constr -> constr +val mkNamedLetIn : Id.t Context.binder_annot -> constr -> types -> constr -> constr +val mkNamedProd : Id.t Context.binder_annot -> types -> types -> types val mkNamedLambda_or_LetIn : named_declaration -> types -> types val mkNamedProd_or_LetIn : named_declaration -> types -> types @@ -176,9 +180,9 @@ val destMeta : Evd.evar_map -> t -> metavariable val destVar : Evd.evar_map -> t -> Id.t val destSort : Evd.evar_map -> t -> ESorts.t val destCast : Evd.evar_map -> t -> t * cast_kind * t -val destProd : Evd.evar_map -> t -> Name.t * types * types -val destLambda : Evd.evar_map -> t -> Name.t * types * t -val destLetIn : Evd.evar_map -> t -> Name.t * t * types * t +val destProd : Evd.evar_map -> t -> Name.t Context.binder_annot * types * types +val destLambda : Evd.evar_map -> t -> Name.t Context.binder_annot * types * t +val destLetIn : Evd.evar_map -> t -> Name.t Context.binder_annot * t * types * t val destApp : Evd.evar_map -> t -> t * t array val destConst : Evd.evar_map -> t -> Constant.t * EInstance.t val destEvar : Evd.evar_map -> t -> t pexistential @@ -194,7 +198,7 @@ val destRef : Evd.evar_map -> t -> GlobRef.t * EInstance.t val decompose_app : Evd.evar_map -> t -> t * t list (** Pops lambda abstractions until there are no more, skipping casts. *) -val decompose_lam : Evd.evar_map -> t -> (Name.t * t) list * t +val decompose_lam : Evd.evar_map -> t -> (Name.t Context.binder_annot * t) list * t (** Pops lambda abstractions and letins until there are no more, skipping casts. *) val decompose_lam_assum : Evd.evar_map -> t -> rel_context * t @@ -210,10 +214,10 @@ val decompose_lam_n_assum : Evd.evar_map -> int -> t -> rel_context * t @raise UserError if the term doesn't have enough lambdas/letins. *) val decompose_lam_n_decls : Evd.evar_map -> int -> t -> rel_context * t -val compose_lam : (Name.t * t) list -> t -> t +val compose_lam : (Name.t Context.binder_annot * t) list -> t -> t val to_lambda : Evd.evar_map -> int -> t -> t -val decompose_prod : Evd.evar_map -> t -> (Name.t * t) list * t +val decompose_prod : Evd.evar_map -> t -> (Name.t Context.binder_annot * t) list * t val decompose_prod_assum : Evd.evar_map -> t -> rel_context * t val decompose_prod_n_assum : Evd.evar_map -> int -> t -> rel_context * t diff --git a/engine/evarutil.ml b/engine/evarutil.ml index d70c009c6d..96beb72a56 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -11,6 +11,7 @@ open CErrors open Util open Names +open Context open Constr open Environ open Evd @@ -424,8 +425,8 @@ let new_pure_evar_full evd ?typeclass_candidate evi = let evd = Evd.declare_future_goal evk evd in (evd, evk) -let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?candidates ?naming ?typeclass_candidate - ?(principal=false) sign evd typ = +let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?(abstract_arguments = Abstraction.identity) + ?candidates ?naming ?typeclass_candidate ?(principal=false) sign evd typ = let default_naming = IntroAnonymous in let naming = Option.default default_naming naming in let name = match naming with @@ -441,6 +442,7 @@ let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?candidates ? evar_concl = typ; evar_body = Evar_empty; evar_filter = filter; + evar_abstract_arguments = abstract_arguments; evar_source = src; evar_candidates = candidates } in @@ -452,11 +454,12 @@ let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?candidates ? in (evd, newevk) -let new_evar_instance ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal sign evd typ instance = +let new_evar_instance ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate + ?principal sign evd typ instance = let open EConstr in assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); - let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal typ in + let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate ?principal typ in evd, mkEvar (newevk,Array.of_list instance) let new_evar_from_context ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal sign evd typ = @@ -469,7 +472,8 @@ let new_evar_from_context ?src ?filter ?candidates ?naming ?typeclass_candidate (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) -let new_evar ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal ?hypnaming env evd typ = +let new_evar ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate + ?principal ?hypnaming env evd typ = let sign,typ',instance,subst = push_rel_context_to_named_context ?hypnaming env evd typ in let map c = csubst_subst subst c in let candidates = Option.map (fun l -> List.map map l) candidates in @@ -477,7 +481,8 @@ let new_evar ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal ?h match filter with | None -> instance | Some filter -> Filter.filter_list filter instance in - new_evar_instance sign evd typ' ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal instance + new_evar_instance sign evd typ' ?src ?filter ?abstract_arguments ?candidates ?naming + ?typeclass_candidate ?principal instance let new_type_evar ?src ?filter ?naming ?principal ?hypnaming env evd rigid = let (evd', s) = new_sort_variable rigid evd in @@ -777,13 +782,13 @@ let cached_evar_of_hyp cache sigma decl accu = match cache with in NamedDecl.fold_constr fold decl accu | Some cache -> - let id = NamedDecl.get_id decl in + let id = NamedDecl.get_annot decl in let r = - try Id.Map.find id cache.cache + try Id.Map.find id.binder_name cache.cache with Not_found -> (* Dummy value *) let r = ref (NamedDecl.LocalAssum (id, EConstr.mkProp), Evar.Set.empty) in - let () = cache.cache <- Id.Map.add id r cache.cache in + let () = cache.cache <- Id.Map.add id.binder_name r cache.cache in r in let (decl', evs) = !r in @@ -832,7 +837,7 @@ let occur_evar_upto sigma n c = let judge_of_new_Type evd = let open EConstr in let (evd', s) = new_univ_variable univ_rigid evd in - (evd', { uj_val = mkSort (Sorts.Type s); uj_type = mkSort (Sorts.Type (Univ.super s)) }) + (evd', { uj_val = mkType s; uj_type = mkType (Univ.super s) }) let subterm_source evk ?where (loc,k) = let evk = match k with diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 23b240f1a0..bb0da44103 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -42,7 +42,7 @@ type naming_mode = val new_evar : ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?candidates:constr list -> + ?abstract_arguments:Abstraction.t -> ?candidates:constr list -> ?naming:intro_pattern_naming_expr -> ?typeclass_candidate:bool -> ?principal:bool -> ?hypnaming:naming_mode -> @@ -50,7 +50,7 @@ val new_evar : val new_pure_evar : ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?candidates:constr list -> + ?abstract_arguments:Abstraction.t -> ?candidates:constr list -> ?naming:intro_pattern_naming_expr -> ?typeclass_candidate:bool -> ?principal:bool -> @@ -80,7 +80,8 @@ val new_global : evar_map -> GlobRef.t -> evar_map * constr of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : - ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> + ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?abstract_arguments:Abstraction.t -> ?candidates:constr list -> ?naming:intro_pattern_naming_expr -> ?typeclass_candidate:bool -> ?principal:bool -> diff --git a/engine/evd.ml b/engine/evd.ml index f0433d3387..b89222cf8e 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -126,6 +126,19 @@ struct end +module Abstraction = struct + + type abstraction = + | Abstract + | Imitate + + type t = abstraction list + + let identity = [] + + let abstract_last l = Abstract :: l +end + (* The kinds of existential variables are now defined in [Evar_kinds] *) (* The type of mappings for existential variables *) @@ -143,6 +156,7 @@ type evar_info = { evar_hyps : named_context_val; evar_body : evar_body; evar_filter : Filter.t; + evar_abstract_arguments : Abstraction.t; evar_source : Evar_kinds.t Loc.located; evar_candidates : constr list option; (* if not None, list of allowed instances *)} @@ -151,6 +165,7 @@ let make_evar hyps ccl = { evar_hyps = hyps; evar_body = Evar_empty; evar_filter = Filter.identity; + evar_abstract_arguments = Abstraction.identity; evar_source = Loc.tag @@ Evar_kinds.InternalHole; evar_candidates = None; } @@ -883,7 +898,7 @@ let new_univ_variable ?loc ?name rigid evd = let new_sort_variable ?loc ?name rigid d = let (d', u) = new_univ_variable ?loc rigid ?name d in - (d', Type u) + (d', Sorts.sort_of_univ u) let add_global_univ d u = { d with universes = UState.add_global_univ d.universes u } @@ -947,10 +962,10 @@ let normalize_universe_instance evd l = let normalize_sort evars s = match s with - | Prop | Set -> s + | SProp | Prop | Set -> s | Type u -> let u' = normalize_universe evars u in - if u' == u then s else Type u' + if u' == u then s else Sorts.sort_of_univ u' (* FIXME inefficient *) let set_eq_sort env d s1 s2 = diff --git a/engine/evd.mli b/engine/evd.mli index d2d18ca486..b0fcddb068 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -77,6 +77,18 @@ sig end +module Abstraction : sig + type abstraction = + | Abstract + | Imitate + + type t = abstraction list + + val identity : t + + val abstract_last : t -> t +end + (** {6 Evar infos} *) type evar_body = @@ -94,6 +106,10 @@ type evar_info = { (** Boolean mask over {!evar_hyps}. Should have the same length. When filtered out, the corresponding variable is not allowed to occur in the solution *) + evar_abstract_arguments : Abstraction.t; + (** Boolean information over {!evar_hyps}, telling if an hypothesis instance + can be imitated or should stay abstract in HO unification problems + and inversion (see [second_order_matching_with_args] for its use). *) evar_source : Evar_kinds.t located; (** Information about the evar. *) evar_candidates : econstr list option; diff --git a/engine/namegen.ml b/engine/namegen.ml index 7ef4108c22..10ece55a63 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -18,6 +18,7 @@ open Util open Names open Term open Constr +open Context open Environ open EConstr open Vars @@ -117,7 +118,7 @@ let head_name sigma c = (* Find the head constant of a constr if any *) | Const _ | Ind _ | Construct _ | Var _ as c -> Some (Nametab.basename_of_global (global_of_constr c)) | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> - Some (match lna.(i) with Name id -> id | _ -> assert false) + Some (match lna.(i).binder_name with Name id -> id | _ -> assert false) | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) | Int _ -> None in hdrec c @@ -136,6 +137,7 @@ let lowercase_first_char id = (* First character of a constr *) s ^ Unicode.lowercase_first_char s' let sort_hdchar = function + | SProp -> "P" | Prop -> "P" | Set -> "S" | Type _ -> "T" @@ -154,12 +156,12 @@ let hdchar env sigma c = | Rel n -> (if n<=k then "p" (* the initial term is flexible product/function *) else - try match lookup_rel (n-k) env with - | LocalAssum (Name id,_) | LocalDef (Name id,_,_) -> lowercase_first_char id - | LocalAssum (Anonymous,t) | LocalDef (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) + try match let d = lookup_rel (n-k) env in get_name d, get_type d with + | Name id, _ -> lowercase_first_char id + | Anonymous, t -> hdrec 0 (lift (n-k) t) with Not_found -> "y") | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> - let id = match lna.(i) with Name id -> id | _ -> assert false in + let id = match lna.(i).binder_name with Name id -> id | _ -> assert false in lowercase_first_char id | Evar _ (* We could do better... *) | Meta _ | Case (_, _, _, _) -> "y" @@ -175,18 +177,20 @@ let named_hd env sigma a = function | Anonymous -> Name (Id.of_string (hdchar env sigma a)) | x -> x -let mkProd_name env sigma (n,a,b) = mkProd (named_hd env sigma a n, a, b) -let mkLambda_name env sigma (n,a,b) = mkLambda (named_hd env sigma a n, a, b) +let mkProd_name env sigma (n,a,b) = mkProd (map_annot (named_hd env sigma a) n, a, b) +let mkLambda_name env sigma (n,a,b) = mkLambda (map_annot (named_hd env sigma a) n, a, b) let lambda_name = mkLambda_name let prod_name = mkProd_name -let prod_create env sigma (a,b) = mkProd (named_hd env sigma a Anonymous, a, b) -let lambda_create env sigma (a,b) = mkLambda (named_hd env sigma a Anonymous, a, b) +let prod_create env sigma (r,a,b) = + mkProd (make_annot (named_hd env sigma a Anonymous) r, a, b) +let lambda_create env sigma (r,a,b) = + mkLambda (make_annot (named_hd env sigma a Anonymous) r, a, b) let name_assumption env sigma = function - | LocalAssum (na,t) -> LocalAssum (named_hd env sigma t na, t) - | LocalDef (na,c,t) -> LocalDef (named_hd env sigma c na, c, t) + | LocalAssum (na,t) -> LocalAssum (map_annot (named_hd env sigma t) na, t) + | LocalDef (na,c,t) -> LocalDef (map_annot (named_hd env sigma c) na, c, t) let name_context env sigma hyps = snd @@ -456,13 +460,13 @@ let rename_bound_vars_as_displayed sigma avoid env c = | Prod (na,c1,c2) -> let na',avoid' = compute_displayed_name_in sigma - (RenamingElsewhereFor (env,c2)) avoid na c2 in - mkProd (na', c1, rename avoid' (na' :: env) c2) + (RenamingElsewhereFor (env,c2)) avoid na.binder_name c2 in + mkProd ({na with binder_name=na'}, c1, rename avoid' (na' :: env) c2) | LetIn (na,c1,t,c2) -> let na',avoid' = compute_displayed_let_name_in sigma - (RenamingElsewhereFor (env,c2)) avoid na c2 in - mkLetIn (na',c1,t, rename avoid' (na' :: env) c2) + (RenamingElsewhereFor (env,c2)) avoid na.binder_name c2 in + mkLetIn ({na with binder_name=na'},c1,t, rename avoid' (na' :: env) c2) | Cast (c,k,t) -> mkCast (rename avoid env c, k,t) | _ -> c in diff --git a/engine/namegen.mli b/engine/namegen.mli index 3722cbed24..240fd8fa81 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -44,15 +44,15 @@ val id_of_name_using_hdchar : env -> evar_map -> types -> Name.t -> Id.t val named_hd : env -> evar_map -> types -> Name.t -> Name.t val head_name : evar_map -> types -> Id.t option -val mkProd_name : env -> evar_map -> Name.t * types * types -> types -val mkLambda_name : env -> evar_map -> Name.t * types * constr -> constr +val mkProd_name : env -> evar_map -> Name.t Context.binder_annot * types * types -> types +val mkLambda_name : env -> evar_map -> Name.t Context.binder_annot * types * constr -> constr (** Deprecated synonyms of [mkProd_name] and [mkLambda_name] *) -val prod_name : env -> evar_map -> Name.t * types * types -> types -val lambda_name : env -> evar_map -> Name.t * types * constr -> constr +val prod_name : env -> evar_map -> Name.t Context.binder_annot * types * types -> types +val lambda_name : env -> evar_map -> Name.t Context.binder_annot * types * constr -> constr -val prod_create : env -> evar_map -> types * types -> constr -val lambda_create : env -> evar_map -> types * constr -> constr +val prod_create : env -> evar_map -> Sorts.relevance * types * types -> constr +val lambda_create : env -> evar_map -> Sorts.relevance * types * constr -> constr val name_assumption : env -> evar_map -> rel_declaration -> rel_declaration val name_context : env -> evar_map -> rel_context -> rel_context diff --git a/engine/nameops.ml b/engine/nameops.ml index 15e201347c..2047772cfe 100644 --- a/engine/nameops.ml +++ b/engine/nameops.ml @@ -132,6 +132,7 @@ sig val fold_right_map : (Id.t -> 'a -> Id.t * 'a) -> Name.t -> 'a -> Name.t * 'a val get_id : t -> Id.t val pick : t -> t -> t + val pick_annot : t Context.binder_annot -> t Context.binder_annot -> t Context.binder_annot val cons : t -> Id.t list -> Id.t list val to_option : Name.t -> Id.t option @@ -176,6 +177,11 @@ struct | Name _ -> na1 | Anonymous -> na2 + let pick_annot na1 na2 = + let open Context in + match na1.binder_name with + | Name _ -> na1 | Anonymous -> na2 + let cons na l = match na with | Anonymous -> l diff --git a/engine/nameops.mli b/engine/nameops.mli index a5308904f5..0e75fed045 100644 --- a/engine/nameops.mli +++ b/engine/nameops.mli @@ -84,6 +84,9 @@ module Name : sig (** [pick na na'] returns [Anonymous] if both names are [Anonymous]. Pick one of [na] or [na'] otherwise. *) + val pick_annot : Name.t Context.binder_annot -> Name.t Context.binder_annot -> + Name.t Context.binder_annot + val cons : Name.t -> Id.t list -> Id.t list (** [cons na l] returns [id::l] if [na] is [Name id] and [l] otherwise. *) diff --git a/engine/proofview.ml b/engine/proofview.ml index a725444e81..2d693e0259 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -876,9 +876,9 @@ module Progress = struct let eq_named_declaration d1 d2 = match d1, d2 with | LocalAssum (i1,t1), LocalAssum (i2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 + Context.eq_annot Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 + Context.eq_annot Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 && eq_constr sigma1 sigma2 t1 t2 | _ -> false diff --git a/engine/termops.ml b/engine/termops.ml index 2f766afaa6..8e12c9be88 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -15,6 +15,7 @@ open Names open Nameops open Term open Constr +open Context open Vars open Environ @@ -115,8 +116,8 @@ let pr_decl env sigma (decl,ok) = let open NamedDecl in let print_constr = print_kconstr in match decl with - | LocalAssum (id,_) -> if ok then Id.print id else (str "{" ++ Id.print id ++ str "}") - | LocalDef (id,c,_) -> str (if ok then "(" else "{") ++ Id.print id ++ str ":=" ++ + | LocalAssum ({binder_name=id},_) -> if ok then Id.print id else (str "{" ++ Id.print id ++ str "}") + | LocalDef ({binder_name=id},c,_) -> str (if ok then "(" else "{") ++ Id.print id ++ str ":=" ++ print_constr env sigma c ++ str (if ok then ")" else "}") let pr_evar_source env sigma = function @@ -248,8 +249,8 @@ let pr_evar_universe_context ctx = let print_env_short env sigma = let print_constr = print_kconstr in let pr_rel_decl = function - | RelDecl.LocalAssum (n,_) -> Name.print n - | RelDecl.LocalDef (n,b,_) -> str "(" ++ Name.print n ++ str " := " + | RelDecl.LocalAssum (n,_) -> Name.print n.binder_name + | RelDecl.LocalDef (n,b,_) -> str "(" ++ Name.print n.binder_name ++ str " := " ++ print_constr env sigma (EConstr.of_constr b) ++ str ")" in let pr_named_decl = NamedDecl.to_rel_decl %> pr_rel_decl in @@ -459,9 +460,10 @@ let push_named_rec_types (lna,typarray,_) env = let ctxt = Array.map2_i (fun i na t -> - match na with - | Name id -> LocalAssum (id, lift i t) - | Anonymous -> anomaly (Pp.str "Fix declarations must be named.")) + let id = map_annot (function + | Name id -> id + | Anonymous -> anomaly (Pp.str "Fix declarations must be named.")) na + in LocalAssum (id, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_named assum e) env ctxt @@ -469,14 +471,11 @@ let push_named_rec_types (lna,typarray,_) env = let lookup_rel_id id sign = let open RelDecl in let rec lookrec n = function - | [] -> - raise Not_found - | (LocalAssum (Anonymous, _) | LocalDef (Anonymous,_,_)) :: l -> - lookrec (n + 1) l - | LocalAssum (Name id', t) :: l -> - if Names.Id.equal id' id then (n,None,t) else lookrec (n + 1) l - | LocalDef (Name id', b, t) :: l -> - if Names.Id.equal id' id then (n,Some b,t) else lookrec (n + 1) l + | [] -> raise Not_found + | decl :: l -> + if Names.Name.equal (Name id) (get_name decl) + then (n, get_value decl, get_type decl) + else lookrec (n+1) l in lookrec 1 sign @@ -1098,7 +1097,8 @@ let is_template_polymorphic_ind env sigma f = let base_sort_cmp pb s0 s1 = match (s0,s1) with - | Prop, Prop | Set, Set | Type _, Type _ -> true + | SProp, SProp | Prop, Prop | Set, Set | Type _, Type _ -> true + | SProp, _ | _, SProp -> false | Prop, Set | Prop, Type _ | Set, Type _ -> pb == Reduction.CUMUL | Set, Prop | Type _, Prop | Type _, Set -> false @@ -1352,7 +1352,7 @@ let compact_named_context sign = let clear_named_body id env = let open NamedDecl in let aux _ = function - | LocalDef (id',c,t) when Id.equal id id' -> push_named (LocalAssum (id,t)) + | LocalDef (id',c,t) when Id.equal id id'.binder_name -> push_named (LocalAssum (id',t)) | d -> push_named d in fold_named_context aux env ~init:(reset_context env) diff --git a/engine/termops.mli b/engine/termops.mli index dea59e9efc..1dd9941c5e 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -23,9 +23,9 @@ val pr_fix : ('a -> Pp.t) -> ('a, 'a) pfixpoint -> Pp.t [@@ocaml.deprecated "Use [Constr.debug_print_fix]"] (** about contexts *) -val push_rel_assum : Name.t * types -> env -> env -val push_rels_assum : (Name.t * Constr.types) list -> env -> env -val push_named_rec_types : Name.t array * Constr.types array * 'a -> env -> env +val push_rel_assum : Name.t Context.binder_annot * types -> env -> env +val push_rels_assum : (Name.t Context.binder_annot * Constr.types) list -> env -> env +val push_named_rec_types : Name.t Context.binder_annot array * Constr.types array * 'a -> env -> env val lookup_rel_id : Id.t -> ('c, 't) Context.Rel.pt -> int * 'c option * 't (** Associates the contents of an identifier in a [rel_context]. Raise @@ -40,8 +40,8 @@ val rel_list : int -> int -> constr list (** iterators/destructors on terms *) val mkProd_or_LetIn : rel_declaration -> types -> types val mkProd_wo_LetIn : rel_declaration -> types -> types -val it_mkProd : types -> (Name.t * types) list -> types -val it_mkLambda : constr -> (Name.t * types) list -> constr +val it_mkProd : types -> (Name.t Context.binder_annot * types) list -> types +val it_mkLambda : constr -> (Name.t Context.binder_annot * types) list -> constr val it_mkProd_or_LetIn : types -> rel_context -> types val it_mkProd_wo_LetIn : types -> rel_context -> types val it_mkLambda_or_LetIn : Constr.constr -> Constr.rel_context -> Constr.constr @@ -246,7 +246,7 @@ val add_vname : Id.Set.t -> Name.t -> Id.Set.t (** other signature iterators *) val process_rel_context : (rel_declaration -> env -> env) -> env -> env -val assums_of_rel_context : ('c, 't) Context.Rel.pt -> (Name.t * 't) list +val assums_of_rel_context : ('c, 't) Context.Rel.pt -> (Name.t Context.binder_annot * 't) list val lift_rel_context : int -> Constr.rel_context -> Constr.rel_context val substl_rel_context : Constr.constr list -> Constr.rel_context -> Constr.rel_context val smash_rel_context : Constr.rel_context -> Constr.rel_context (** expand lets in context *) diff --git a/engine/uState.ml b/engine/uState.ml index 77d1896683..6f4f40e2c5 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -37,18 +37,25 @@ type t = uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) uctx_weak_constraints : UPairSet.t } - + +let initial_sprop_cumulative = UGraph.make_sprop_cumulative UGraph.initial_universes + let empty = { uctx_names = UNameMap.empty, LMap.empty; uctx_local = ContextSet.empty; uctx_seff_univs = LSet.empty; uctx_univ_variables = LMap.empty; uctx_univ_algebraic = LSet.empty; - uctx_universes = UGraph.initial_universes; - uctx_initial_universes = UGraph.initial_universes; + uctx_universes = initial_sprop_cumulative; + uctx_initial_universes = initial_sprop_cumulative; uctx_weak_constraints = UPairSet.empty; } +let elaboration_sprop_cumul = + Goptions.declare_bool_option_and_ref ~depr:false ~name:"SProp cumulativity during elaboration" + ~key:["Elaboration";"StrictProp";"Cumulativity"] ~value:true + let make u = + let u = if elaboration_sprop_cumul () then UGraph.make_sprop_cumulative u else u in { empty with uctx_universes = u; uctx_initial_universes = u} @@ -710,7 +717,7 @@ let universe_of_name uctx s = UNameMap.find s (fst uctx.uctx_names) let update_sigma_env uctx env = - let univs = Environ.universes env in + let univs = UGraph.make_sprop_cumulative (Environ.universes env) in let eunivs = { uctx with uctx_initial_universes = univs; uctx_universes = univs } diff --git a/engine/univGen.ml b/engine/univGen.ml index 40c4c909fe..c310331b15 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -28,7 +28,7 @@ let fresh_level () = (* TODO: remove *) let new_univ () = Univ.Universe.make (fresh_level ()) let new_Type () = mkType (new_univ ()) -let new_Type_sort () = Type (new_univ ()) +let new_Type_sort () = sort_of_univ (new_univ ()) let fresh_instance auctx = let inst = Array.init (AUContext.size auctx) (fun _ -> fresh_level()) in @@ -128,11 +128,12 @@ let type_of_reference env r = let type_of_global t = type_of_reference (Global.env ()) t let fresh_sort_in_family = function + | InSProp -> Sorts.sprop, ContextSet.empty | InProp -> Sorts.prop, ContextSet.empty | InSet -> Sorts.set, ContextSet.empty | InType -> let u = fresh_level () in - Type (Univ.Universe.make u), ContextSet.singleton u + sort_of_univ (Univ.Universe.make u), ContextSet.singleton u let new_sort_in_family sf = fst (fresh_sort_in_family sf) diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 1619ac3d34..46ff6340b4 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -268,6 +268,7 @@ let minimize_univ_variables ctx us algs left right cstrs = module UPairs = OrderedType.UnorderedPair(Univ.Level) module UPairSet = Set.Make (UPairs) +(* TODO check is_small/sprop *) let normalize_context_set g ctx us algs weak = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in (* Keep the Prop/Set <= i constraints separate for minimization *) @@ -275,7 +276,7 @@ let normalize_context_set g ctx us algs weak = Constraint.partition (fun (l,d,r) -> d == Le && Level.is_small l) csts in let smallles = if get_set_minimization () - then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx) smallles + then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx && not (Level.is_sprop l)) smallles else Constraint.empty in let csts, partition = diff --git a/ide/configwin.ml b/ide/configwin.ml index 24be721631..79a1eae880 100644 --- a/ide/configwin.ml +++ b/ide/configwin.ml @@ -37,8 +37,10 @@ type return_button = | Return_cancel let string = Configwin_ihm.string +(* let strings = Configwin_ihm.strings let list = Configwin_ihm.list +*) let bool = Configwin_ihm.bool let combo = Configwin_ihm.combo let custom = Configwin_ihm.custom diff --git a/ide/configwin.mli b/ide/configwin.mli index 0ee77d69b5..fa22846d19 100644 --- a/ide/configwin.mli +++ b/ide/configwin.mli @@ -69,6 +69,7 @@ val string : ?editable: bool -> ?expand: bool -> ?help: string -> val bool : ?editable: bool -> ?help: string -> ?f: (bool -> unit) -> string -> bool -> parameter_kind +(* (** [strings label value] creates a string list parameter. @param editable indicate if the value is editable (default is [true]). @param help an optional help message. @@ -119,6 +120,7 @@ val list : ?editable: bool -> ?help: string -> ('a -> string list) -> 'a list -> parameter_kind +*) (** [combo label choices value] creates a combo parameter. @param editable indicate if the value is editable (default is [true]). diff --git a/ide/configwin_ihm.ml b/ide/configwin_ihm.ml index 8420d930d5..0f3fd38a7a 100644 --- a/ide/configwin_ihm.ml +++ b/ide/configwin_ihm.ml @@ -27,6 +27,10 @@ open Configwin_types +let set_help_tip wev = function + | None -> () + | Some help -> GtkBase.Widget.Tooltip.set_text wev#as_widget help + let modifiers_to_string m = let rec iter m s = match m with @@ -55,7 +59,7 @@ class type widget = let debug = false let dbg s = if debug then Minilib.log s else () - +(* (** This class builds a frame with a clist and two buttons : one to add items and one to remove the selected items. The class takes in parameter a function used to add items and @@ -71,7 +75,6 @@ class ['a] list_selection_box f_color (eq : 'a -> 'a -> bool) add_function title editable - (tt:GData.tooltips) = let _ = dbg "list_selection_box" in let wev = GBin.event_box () in @@ -94,12 +97,8 @@ class ['a] list_selection_box ~titles_show: true ~packing: wscroll#add () in - let _ = - match help_opt with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in (* the vbox for the buttons *) + let _ = set_help_tip wev help_opt in + (* the vbox for the buttons *) let vbox_buttons = GPack.vbox () in let _ = if editable then @@ -279,10 +278,10 @@ class ['a] list_selection_box (* initialize the clist with the listref *) self#update !listref end;; - +*) (** This class is used to build a box for a string parameter.*) -class string_param_box param (tt:GData.tooltips) = +class string_param_box param = let _ = dbg "string_param_box" in let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in @@ -292,12 +291,7 @@ class string_param_box param (tt:GData.tooltips) = ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) () in - let _ = - match param.string_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in + let _ = set_help_tip wev param.string_help in let _ = we#set_text (param.string_to_string param.string_value) in object (self) @@ -316,17 +310,12 @@ class string_param_box param (tt:GData.tooltips) = end ;; (** This class is used to build a box for a combo parameter.*) -class combo_param_box param (tt:GData.tooltips) = +class combo_param_box param = let _ = dbg "combo_param_box" in let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in - let _ = - match param.combo_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in + let _ = set_help_tip wev param.combo_help in let get_value = if not param.combo_new_allowed then let wc = GEdit.combo_box_text ~strings: param.combo_choices @@ -341,13 +330,13 @@ class combo_param_box param (tt:GData.tooltips) = fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s else let (wc,_) = GEdit.combo_box_entry_text - ~strings: param.combo_choices - ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) - () + ~strings: param.combo_choices + ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) + () in let _ = wc#entry#set_editable param.combo_editable in let _ = wc#entry#set_text param.combo_value in - fun () -> wc#entry#text + fun () -> wc#entry#text in object (self) @@ -365,7 +354,7 @@ object (self) end ;; (** Class used to pack a custom box. *) -class custom_param_box param (tt:GData.tooltips) = +class custom_param_box param = let _ = dbg "custom_param_box" in let top = match param.custom_framed with @@ -381,7 +370,7 @@ class custom_param_box param (tt:GData.tooltips) = end (** This class is used to build a box for a text parameter.*) -class text_param_box param (tt:GData.tooltips) = +class text_param_box param = let _ = dbg "text_param_box" in let wf = GBin.frame ~label: param.string_label ~height: 100 () in let wev = GBin.event_box ~packing: wf#add () in @@ -395,12 +384,7 @@ class text_param_box param (tt:GData.tooltips) = ~packing: wscroll#add () in - let _ = - match param.string_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in + let _ = set_help_tip wev param.string_help in let _ = dbg "text_param_box: buffer creation" in let buffer = GText.buffer () in @@ -427,17 +411,13 @@ class text_param_box param (tt:GData.tooltips) = end ;; (** This class is used to build a box for a boolean parameter.*) -class bool_param_box param (tt:GData.tooltips) = +class bool_param_box param = let _ = dbg "bool_param_box" in let wchk = GButton.check_button ~label: param.bool_label () in - let _ = - match param.bool_help with - None -> () - | Some help -> tt#set_tip ~text: help ~privat: help wchk#coerce - in + let _ = set_help_tip wchk param.bool_help in let _ = wchk#set_active param.bool_value in let _ = wchk#misc#set_sensitive param.bool_editable in @@ -471,14 +451,7 @@ class modifiers_param_box param = else value := List.filter ((<>) modifier) !value))) param.md_allow in - let _ = - match param.md_help with - None -> () - | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wev#coerce ~text: help ~privat: help - in + let _ = set_help_tip wev param.md_help in object (self) (** This method returns the main box ready to be packed. *) @@ -493,9 +466,9 @@ class modifiers_param_box param = else () end ;; - +(* (** This class is used to build a box for a parameter whose values are a list.*) -class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = +class ['a] list_param_box (param : 'a list_param) = let _ = dbg "list_param_box" in let listref = ref param.list_value in let frame_selection = new list_selection_box @@ -520,9 +493,10 @@ class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = param.list_f_apply !listref ; param.list_value <- !listref end ;; +*) (** This class creates a configuration box from a configuration structure *) -class configuration_box (tt : GData.tooltips) conf_struct = +class configuration_box conf_struct = let main_box = GPack.hbox () in @@ -553,27 +527,27 @@ class configuration_box (tt : GData.tooltips) conf_struct = let make_param (main_box : #GPack.box) = function | String_param p -> - let box = new string_param_box p tt in + let box = new string_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Combo_param p -> - let box = new combo_param_box p tt in + let box = new combo_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Text_param p -> - let box = new text_param_box p tt in + let box = new text_param_box p in let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in box | Bool_param p -> - let box = new bool_param_box p tt in + let box = new bool_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | List_param f -> - let box = f tt in + let box = f () in let _ = main_box#pack ~expand: true ~padding: 2 box#box in box | Custom_param p -> - let box = new custom_param_box p tt in + let box = new custom_param_box p in let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in box | Modifiers_param p -> @@ -684,11 +658,9 @@ let edit ?(with_apply=true) ?parent ?height ?width () in - let tooltips = GData.tooltips () in - - let config_box = new configuration_box tooltips conf_struct in + let config_box = new configuration_box conf_struct in - let _ = dialog#vbox#add config_box#box#coerce in + let _ = dialog#vbox#pack ~expand:true config_box#box#coerce in if with_apply then dialog#add_button Configwin_messages.mApply `APPLY; @@ -697,7 +669,6 @@ let edit ?(with_apply=true) dialog#add_button Configwin_messages.mCancel `CANCEL; let destroy () = - tooltips#destroy () ; dialog#destroy (); in let rec iter rep = @@ -714,10 +685,12 @@ let edit ?(with_apply=true) in iter Return_cancel +(* let edit_string l s = match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with None -> s | Some s2 -> s2 +*) (** Create a string param. *) let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = @@ -744,6 +717,7 @@ let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v = bool_f_apply = f ; } +(* (** Create a list param. *) let list ?(editable=true) ?help ?(f=(fun (_:'a list) -> ())) @@ -753,7 +727,7 @@ let list ?(editable=true) ?help ?titles ?(color=(fun (_:'a) -> (None : string option))) label (f_strings : 'a -> string list) v = List_param - (fun tt -> + (fun () -> new list_param_box { list_label = label ; @@ -768,7 +742,6 @@ let list ?(editable=true) ?help list_f_add = add ; list_f_apply = f ; } - tt ) (** Create a strings param. *) @@ -777,6 +750,7 @@ let strings ?(editable=true) ?help ?(eq=Pervasives.(=)) ?(add=(fun () -> [])) label v = list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v +*) (** Create a combo param. *) let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) diff --git a/ide/configwin_ihm.mli b/ide/configwin_ihm.mli index 772a0958ff..ce6cd4d7c1 100644 --- a/ide/configwin_ihm.mli +++ b/ide/configwin_ihm.mli @@ -29,6 +29,7 @@ val string : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind val bool : ?editable: bool -> ?help: string -> ?f: (bool -> unit) -> string -> bool -> parameter_kind +(* val strings : ?editable: bool -> ?help: string -> ?f: (string list -> unit) -> ?eq: (string -> string -> bool) -> @@ -45,6 +46,7 @@ val list : ?editable: bool -> ?help: string -> ('a -> string list) -> 'a list -> parameter_kind +*) val combo : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> ?new_allowed: bool -> ?blank_allowed: bool -> diff --git a/ide/configwin_types.ml b/ide/configwin_types.ml index 9e339d135d..251e3dded3 100644 --- a/ide/configwin_types.ml +++ b/ide/configwin_types.ml @@ -97,7 +97,7 @@ type modifiers_param = { (** This type represents the different kinds of parameters. *) type parameter_kind = String_param of string string_param - | List_param of (GData.tooltips -> <box: GObj.widget ; apply : unit>) + | List_param of (unit -> <box: GObj.widget ; apply : unit>) | Bool_param of bool_param | Text_param of string string_param | Combo_param of combo_param diff --git a/ide/coq.ml b/ide/coq.ml index 91cd448eda..a420a3cbf5 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -119,7 +119,7 @@ let rec filter_coq_opts args = and asks_for_coqtop args = let pb_mes = GWindow.message_dialog - ~message:"Failed to load coqtop. Reset the preference to default ?" + ~message:"Failed to load coqidetop. Reset the preference to default ?" ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in match pb_mes#run () with | `YES -> @@ -128,16 +128,15 @@ and asks_for_coqtop args = let () = pb_mes#destroy () in filter_coq_opts args | `DELETE_EVENT | `NO -> - let () = pb_mes#destroy () in - let cmd_sel = GWindow.file_selection - ~title:"Coqtop to execute (edit your preference then)" - ~filename:(coqtop_path ()) ~urgency_hint:true () in - match cmd_sel#run () with - | `OK -> - let () = custom_coqtop := (Some cmd_sel#filename) in - let () = cmd_sel#destroy () in + let file = select_file_for_open + ~title:"coqidetop to execute (edit your preference then)" + ~filter:false + ~filename:(coqtop_path ()) () in + match file with + | Some _ -> + let () = custom_coqtop := file in filter_coq_opts args - | `CANCEL | `DELETE_EVENT | `HELP -> exit 0 + | None -> exit 0 exception WrongExitStatus of string @@ -419,7 +418,7 @@ let rec respawn_coqtop ?(why=Unexpected) coqtop = let title = "Warning" in let icon = (warn_image ())#coerce in let buttons = ["Reset"; "Save all and quit"; "Quit without saving"] in - let ans = GToolbox.question_box ~title ~buttons ~icon "Coqtop died badly." in + let ans = GToolbox.question_box ~title ~buttons ~icon "coqidetop died badly." in if ans = 2 then (!save_all (); GtkMain.Main.quit ()) else if ans = 3 then GtkMain.Main.quit () | Planned -> () diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 8da9900724..4aa801c2b2 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -250,6 +250,7 @@ object(self) feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback; let md = segment_model document in segment#set_model md; +(* let on_click id = let find _ _ s = Int.equal s.index id in let sentence = Doc.find document find in @@ -266,6 +267,7 @@ object(self) ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) in let _ = segment#connect#clicked ~callback:on_click in +*) () method private tooltip_callback ~x ~y ~kbd tooltip = diff --git a/ide/coqide.ml b/ide/coqide.ml index 48c08899e0..eaeeaa0001 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -193,7 +193,7 @@ let confirm_save ok = let select_and_save ?parent ~saveas ?filename sn = let do_save = if saveas then sn.fileops#saveas ?parent else sn.fileops#save in let title = if saveas then "Save file as" else "Save file" in - match select_file_for_save ~title ?filename () with + match select_file_for_save ~title ?parent ?filename () with |None -> false |Some f -> let ok = do_save f in @@ -213,7 +213,8 @@ let check_save ?parent ~saveas sn = exception DontQuit let check_quit ?parent saveall = - (try save_pref () with _ -> flash_info "Cannot save preferences"); + (try save_pref () + with e -> flash_info ("Cannot save preferences (" ^ Printexc.to_string e ^ ")")); let is_modified sn = sn.buffer#modified in if List.exists is_modified notebook#pages then begin let answ = Configwin_ihm.question_box ~title:"Quit" @@ -271,11 +272,11 @@ let newfile _ = let index = notebook#append_term session in notebook#goto_page index -let load _ = +let load ?parent _ = let filename = try notebook#current_term.fileops#filename with Invalid_argument _ -> None in - match select_file_for_open ~title:"Load file" ?filename () with + match select_file_for_open ~title:"Load file" ?parent ?filename () with | None -> () | Some f -> FileAux.load_file f @@ -359,7 +360,7 @@ let print sn = Filename.quote (Filename.basename f_name) ^ " | " ^ cmd_print#get in let w = GWindow.window ~title:"Print" ~modal:true - ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" () + ~position:`CENTER ~wmclass:("CoqIDE","CoqIDE") () in let v = GPack.vbox ~spacing:10 ~border_width:10 ~packing:w#add () in @@ -812,7 +813,7 @@ let zoom_fit sn = let space = script#misc#allocation.Gtk.width in let cols = script#right_margin_position in let pango_ctx = script#misc#pango_context in - let layout = pango_ctx#create_layout in + let layout = pango_ctx#create_layout#as_layout in let fsize = Pango.Font.get_size (Pango.Font.from_string text_font#get) in Pango.Layout.set_text layout (String.make cols 'X'); let tlen = fst (Pango.Layout.get_pixel_size layout) in @@ -939,7 +940,7 @@ let emit_to_focus window sgn = let build_ui () = let w = GWindow.window - ~wm_class:"CoqIde" ~wm_name:"CoqIde" + ~wmclass:("CoqIde","CoqIde") ~width:window_width#get ~height:window_height#get ~title:"CoqIde" () in @@ -972,7 +973,7 @@ let build_ui () = menu file_menu [ item "File" ~label:"_File"; item "New" ~callback:File.newfile ~stock:`NEW; - item "Open" ~callback:File.load ~stock:`OPEN; + item "Open" ~callback:(File.load ~parent:w) ~stock:`OPEN; item "Save" ~callback:(File.save ~parent:w) ~stock:`SAVE ~tooltip:"Save current buffer"; item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:(File.saveas ~parent:w); item "Save all" ~label:"Sa_ve all" ~callback:File.saveall; @@ -1021,7 +1022,8 @@ let build_ui () = ~callback:(fun _ -> begin try Preferences.configure ~apply:refresh_notebook_pos w - with _ -> flash_info "Cannot save preferences" + with e -> + flash_info ("Editing preferences failed (" ^ Printexc.to_string e ^ ")") end; reset_revert_timer ()); ]; @@ -1182,10 +1184,10 @@ let build_ui () = item "Help" ~label:"_Help"; item "Browse Coq Manual" ~label:"Browse Coq _Manual" ~callback:(fun _ -> - browse notebook#current_term.messages#default_route#add_string (doc_url ())); + browse notebook#current_term.messages#default_route#add_string Coq_config.wwwrefman); item "Browse Coq Library" ~label:"Browse Coq _Library" ~callback:(fun _ -> - browse notebook#current_term.messages#default_route#add_string library_url#get); + browse notebook#current_term.messages#default_route#add_string Coq_config.wwwstdlib); item "Help for keyword" ~label:"Help for _keyword" ~stock:`HELP ~callback:(fun _ -> on_current_term (fun sn -> browse_keyword sn.messages#default_route#add_string (get_current_word sn))); @@ -1220,10 +1222,10 @@ let build_ui () = ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget) in let () = GtkButton.Toolbar.set - ~orientation:`HORIZONTAL ~style:`ICONS ~tooltips:true tbar + ~orientation:`HORIZONTAL ~style:`ICONS tbar in - let toolbar = new GObj.widget tbar in - let () = vbox#pack toolbar in + let toolbar = new GButton.toolbar tbar in + let () = vbox#pack toolbar#coerce in (* Emacs/PG mode *) NanoPG.init w notebook all_menus; @@ -1303,11 +1305,6 @@ let build_ui () = let _ = source_style#connect#changed ~callback:refresh_style in let _ = source_language#connect#changed ~callback:refresh_language in - (* Color configuration *) - Tags.Script.incomplete#set_property - (`BACKGROUND_STIPPLE - (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02")); - (* Showtime ! *) w#show (); w diff --git a/ide/coqide_main.ml b/ide/coqide_main.ml index 21f513b8f4..79420b3857 100644 --- a/ide/coqide_main.ml +++ b/ide/coqide_main.ml @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let _ = GtkMain.Main.init () +let _ = Coqide.set_signal_handlers () (* We handle Gtk warning messages ourselves : - on win32, we don't want them to end on a non-existing console @@ -25,12 +25,11 @@ ; IDE Client (library - (name gui) - (public_name coqide.gui) + (name coqide_gui) (wrapped false) (modules (:standard \ document fake_ide idetop coqide_main)) (optional) - (libraries coqide-server.protocol coqide-server.core lablgtk2.sourceview2)) + (libraries coqide-server.protocol coqide-server.core lablgtk3-sourceview3)) (rule (targets coqide_os_specific.ml) @@ -42,7 +41,7 @@ (public_name coqide) (package coqide) (modules coqide_main) - (libraries coqide.gui)) + (libraries coqide_gui)) ; FIXME: we should install those in share/coqide. We better do this ; once the make-based system has been phased out. diff --git a/ide/ide.mllib b/ide/ide.mllib index a7ade71307..30ac5c9ad7 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -9,7 +9,6 @@ Config_lexer Utf8_convert Preferences Project_file -Topfmt Ideutils Coq Coq_lex diff --git a/ide/ideutils.ml b/ide/ideutils.ml index c14af7d21d..8c5b3fcc5b 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -8,9 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) - open Preferences +let _ = GtkMain.Main.init () + let warn_image () = let img = GMisc.image () in img#set_stock `DIALOG_WARNING; @@ -229,14 +230,17 @@ let current_dir () = match project_path#get with | None -> "" | Some dir -> dir -let select_file_for_open ~title ?filename () = +let select_file_for_open ~title ?(filter=true) ?parent ?filename () = let file_chooser = - GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () + GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title ?parent () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `OPEN `OPEN ; - file_chooser#add_filter (filter_coq_files ()); - file_chooser#add_filter (filter_all_files ()); + if filter then + begin + file_chooser#add_filter (filter_coq_files ()); + file_chooser#add_filter (filter_all_files ()) + end; file_chooser#set_default_response `OPEN; let dir = match filename with | None -> current_dir () @@ -255,10 +259,10 @@ let select_file_for_open ~title ?filename () = file_chooser#destroy (); file -let select_file_for_save ~title ?filename () = +let select_file_for_save ~title ?parent ?filename () = let file = ref None in let file_chooser = - GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title () + GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title ?parent () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `SAVE `SAVE ; @@ -458,15 +462,6 @@ let browse prerr url = in run_command (fun _ -> ()) finally com -let doc_url () = - if doc_url#get = use_default_doc_url || doc_url#get = "" - then - let addr = List.fold_left Filename.concat (Envars.docdir ()) - ["html";"refman";"index.html"] - in - if Sys.file_exists addr then "file://"^addr else Coq_config.wwwrefman - else doc_url#get - let url_for_keyword = let ht = Hashtbl.create 97 in lazy ( @@ -476,13 +471,7 @@ let url_for_keyword = (fun x -> Sys.file_exists (Filename.concat x "index_urls.txt")) (Minilib.coqide_data_dirs ())) "index_urls.txt" in open_in index_urls - with Not_found -> - let doc_url = doc_url () in - let n = String.length doc_url in - if n > 8 && String.sub doc_url 0 7 = "file://" then - open_in (String.sub doc_url 7 (n-7) ^ "index_urls.txt") - else - raise Exit + with Not_found -> raise Exit in try while true do let s = input_line cin in @@ -503,7 +492,7 @@ let url_for_keyword = let browse_keyword prerr text = try let u = Lazy.force url_for_keyword text in - browse prerr (doc_url() ^ u) + browse prerr (Coq_config.wwwrefman ^ u) with Not_found -> prerr ("No documentation found for \""^text^"\".\n") let rec is_valid (s : Pp.t) = match Pp.repr s with diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 0031c59c17..57f59d19fe 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -13,7 +13,6 @@ val warning : string -> unit val cb : GData.clipboard -val doc_url : unit -> string val browse : (string -> unit) -> string -> unit val browse_keyword : (string -> unit) -> string -> unit @@ -31,9 +30,10 @@ val find_tag_limits : GText.tag -> GText.iter -> GText.iter * GText.iter val find_tag_start : GText.tag -> GText.iter -> GText.iter val find_tag_stop : GText.tag -> GText.iter -> GText.iter -val select_file_for_open : title:string -> ?filename:string -> unit -> string option +val select_file_for_open : + title:string -> ?filter:bool -> ?parent:GWindow.window -> ?filename:string -> unit -> string option val select_file_for_save : - title:string -> ?filename:string -> unit -> string option + title:string -> ?parent:GWindow.window -> ?filename:string -> unit -> string option val try_convert : string -> string val try_export : string -> string -> bool val stock_to_widget : diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index f2913b1d1d..d85d87142c 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -52,7 +52,7 @@ let pr_key t = type action = | Action of string * string | Callback of (gui -> unit) - | Edit of (status -> GSourceView2.source_buffer -> GText.iter -> + | Edit of (status -> GSourceView3.source_buffer -> GText.iter -> (string -> string -> unit) -> status) | Motion of (status -> GText.iter -> GText.iter * status) diff --git a/ide/preferences.ml b/ide/preferences.ml index 4aa8c92f73..69dbc0b235 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -12,10 +12,10 @@ open Configwin let pref_file = Filename.concat (Minilib.coqide_config_home ()) "coqiderc" let accel_file = Filename.concat (Minilib.coqide_config_home ()) "coqide.keys" -let lang_manager = GSourceView2.source_language_manager ~default:true +let lang_manager = GSourceView3.source_language_manager ~default:true let () = lang_manager#set_search_path ((Minilib.coqide_data_dirs ())@lang_manager#search_path) -let style_manager = GSourceView2.source_style_scheme_manager ~default:true +let style_manager = GSourceView3.source_style_scheme_manager ~default:true let () = style_manager#set_search_path ((Minilib.coqide_data_dirs ())@style_manager#search_path) @@ -73,11 +73,11 @@ object (self) method default = default end -let stick (pref : 'a preference) (obj : #GObj.widget as 'obj) +let stick (pref : 'a preference) (obj : < connect : #GObj.widget_signals ; .. >) (cb : 'a -> unit) = let _ = cb pref#get in let p_id = pref#connect#changed ~callback:(fun v -> cb v) in - let _ = obj#misc#connect#destroy ~callback:(fun () -> pref#connect#disconnect p_id) in + let _ = obj#connect#destroy ~callback:(fun () -> pref#connect#disconnect p_id) in () (** Useful marshallers *) @@ -366,33 +366,6 @@ let text_font = in new preference ~name:["text_font"] ~init ~repr:Repr.(string) -let is_standard_doc_url url = - let wwwcompatprefix = "http://www.lix.polytechnique.fr/coq/" in - let n = String.length Coq_config.wwwcoq in - let n' = String.length Coq_config.wwwrefman in - url = Coq_config.localwwwrefman || - url = Coq_config.wwwrefman || - url = wwwcompatprefix ^ String.sub Coq_config.wwwrefman n (n'-n) - -let doc_url = -object - inherit [string] preference - ~name:["doc_url"] ~init:Coq_config.wwwrefman ~repr:Repr.(string) - as super - - method! set v = - if not (is_standard_doc_url v) && - v <> use_default_doc_url && - (* Extra hack to support links to last released doc version *) - v <> Coq_config.wwwcoq ^ "doc" && - v <> Coq_config.wwwcoq ^ "doc/" - then super#set v - -end - -let library_url = - new preference ~name:["library_url"] ~init:Coq_config.wwwstdlib ~repr:Repr.(string) - let show_toolbar = new preference ~name:["show_toolbar"] ~init:true ~repr:Repr.(bool) @@ -440,8 +413,11 @@ let attach_fg (pref : string preference) (tag : GText.tag) = let processing_color = new preference ~name:["processing_color"] ~init:"light blue" ~repr:Repr.(string) +let incompletely_processed_color = + new preference ~name:["incompletely_processed_color"] ~init:"light sky blue" ~repr:Repr.(string) + let _ = attach_bg processing_color Tags.Script.to_process -let _ = attach_bg processing_color Tags.Script.incomplete +let _ = attach_bg incompletely_processed_color Tags.Script.incomplete let tags = ref Util.String.Map.empty @@ -602,7 +578,7 @@ object (self) | None -> set#set_active true | Some c -> set#set_active false; - but#set_color (Tags.color_of_string c) + but#set_color (Gdk.Color.color_parse c) in track tag.tag_bg_color bg_color bg_unset; track tag.tag_fg_color fg_color fg_unset; @@ -614,7 +590,7 @@ object (self) method tag = let get but set = if set#active then None - else Some (Tags.string_of_color but#color) + else Some (Gdk.Color.color_to_string but#color) in { tag_bg_color = get bg_color bg_unset; @@ -692,7 +668,7 @@ let configure ?(apply=(fun () -> ())) parent = let cmd_coqtop = string ~f:(fun s -> cmd_coqtop#set (if s = "AUTO" then None else Some s)) - " coqtop" (match cmd_coqtop#get with |None -> "AUTO" | Some x -> x) in + " coqidetop" (match cmd_coqtop#get with |None -> "AUTO" | Some x -> x) in let cmd_coqc = pstring " coqc" cmd_coqc in let cmd_make = pstring " make" cmd_make in let cmd_coqmakefile = pstring "coqmakefile" cmd_coqmakefile in @@ -718,7 +694,7 @@ let configure ?(apply=(fun () -> ())) parent = let config_color = let box = GPack.vbox () in - let table = GPack.table + let grid = GPack.grid ~row_spacings:5 ~col_spacings:5 ~border_width:2 @@ -730,19 +706,19 @@ let configure ?(apply=(fun () -> ())) parent = in let iter i (text, pref) = let label = GMisc.label - ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:i) () + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:i) () in let () = label#set_xalign 0. in let button = GButton.color_button - ~color:(Tags.color_of_string pref#get) - ~packing:(table#attach ~left:1 ~top:i) () + ~color:(Gdk.Color.color_parse pref#get) + ~packing:(grid#attach ~left:1 ~top:i) () in let _ = button#connect#color_set ~callback:begin fun () -> - pref#set (Tags.string_of_color button#color) + pref#set (Gdk.Color.color_to_string button#color) end in let reset _ = pref#reset (); - button#set_color Tags.(color_of_string pref#get) + button#set_color (Gdk.Color.color_parse pref#get) in let _ = reset_button#connect#clicked ~callback:reset in () @@ -751,6 +727,7 @@ let configure ?(apply=(fun () -> ())) parent = ("Background color", background_color); ("Background color of processed text", processed_color); ("Background color of text being processed", processing_color); + ("Background color of incompletely processed Qed", incompletely_processed_color); ("Background color of errors", error_color); ("Foreground color of errors", error_fg_color); ] in @@ -767,7 +744,7 @@ let configure ?(apply=(fun () -> ())) parent = ~packing:(box#pack ~expand:true) () in - let table = GPack.table + let grid = GPack.grid ~row_spacings:5 ~col_spacings:5 ~border_width:2 @@ -777,13 +754,13 @@ let configure ?(apply=(fun () -> ())) parent = let cb = ref [] in let iter text tag = let label = GMisc.label - ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:!i) () + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:!i) () in let () = label#set_xalign 0. in let button = tag_button () in let callback () = tag#set button#tag in button#set_tag tag#get; - table#attach ~left:1 ~top:!i button#coerce; + grid#attach ~left:1 ~top:!i button#coerce; incr i; cb := callback :: !cb; in @@ -948,32 +925,7 @@ let configure ?(apply=(fun () -> ())) parent = else cmd_browse#get]) cmd_browse#get in - let doc_url = - let predefined = [ - "file://"^(List.fold_left Filename.concat (Envars.docdir ()) ["refman";"html"]); - Coq_config.wwwrefman; - use_default_doc_url - ] in - combo - "Manual URL" - ~f:doc_url#set - ~new_allowed: true - (predefined@[if List.mem doc_url#get predefined then "" - else doc_url#get]) - doc_url#get in - let library_url = - let predefined = [ - "file://"^(List.fold_left Filename.concat (Envars.docdir ()) ["stdlib";"html"]); - Coq_config.wwwstdlib - ] in - combo - "Library URL" - ~f:(fun s -> library_url#set s) - ~new_allowed: true - (predefined@[if List.mem library_url#get predefined then "" - else library_url#get]) - library_url#get - in +(* let automatic_tactics = strings ~f:automatic_tactics#set @@ -982,12 +934,14 @@ let configure ?(apply=(fun () -> ())) parent = automatic_tactics#get in +*) let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch; vertical_tabs;opposite_tabs] in +(* let add_user_query () = let input_string l v = match GToolbox.input_string ~title:l v with @@ -1017,6 +971,7 @@ let configure ?(apply=(fun () -> ())) parent = user_queries#get in +*) (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! (shame on Benjamin) *) @@ -1039,13 +994,15 @@ let configure ?(apply=(fun () -> ())) parent = Section("Appearance", Some `PREFERENCES, [window_width; window_height]); Section("Externals", None, [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; - cmd_print;cmd_editor;cmd_browse;doc_url;library_url]); + cmd_print;cmd_editor;cmd_browse]); +(* Section("Tactics Wizard", None, [automatic_tactics]); +*) Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; modifier_for_templates; modifier_for_display; modifier_for_navigation; - modifier_for_queries; user_queries]); + modifier_for_queries (*; user_queries *)]); Section("Misc", Some `ADD, misc)] in diff --git a/ide/preferences.mli b/ide/preferences.mli index 7ed6a40bdb..8745c2ae91 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val lang_manager : GSourceView2.source_language_manager -val style_manager : GSourceView2.source_style_scheme_manager +val lang_manager : GSourceView3.source_language_manager +val style_manager : GSourceView3.source_style_scheme_manager type project_behavior = Ignore_args | Append_args | Subst_args type inputenc = Elocale | Eutf8 | Emanual of string @@ -74,8 +74,6 @@ val modifiers_valid : string preference val cmd_browse : string preference val cmd_editor : string preference val text_font : string preference -val doc_url : string preference -val library_url : string preference val show_toolbar : bool preference val contextual_menus_on_goal : bool preference val window_width : int preference @@ -110,6 +108,6 @@ val load_pref : unit -> unit val configure : ?apply:(unit -> unit) -> GWindow.window -> unit val stick : 'a preference -> - (#GObj.widget as 'obj) -> ('a -> unit) -> unit + < connect : #GObj.widget_signals ; .. > -> ('a -> unit) -> unit val use_default_doc_url : string diff --git a/ide/session.ml b/ide/session.ml index e2427a9b51..fd21515ca5 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -47,7 +47,7 @@ type session = { } let create_buffer () = - let buffer = GSourceView2.source_buffer + let buffer = GSourceView3.source_buffer ~tag_table:Tags.Script.table ~highlight_matching_brackets:true ?language:(lang_manager#language source_language#get) @@ -257,7 +257,7 @@ let make_table_widget ?sort cd cb = ~model:store ~packing:frame#add () in let () = data#set_headers_visible true in let () = data#set_headers_clickable true in - let refresh clr = data#misc#modify_base [`NORMAL, `NAME clr] in + let refresh clr = data#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:refresh in let _ = data#misc#connect#realize ~callback:(fun () -> refresh background_color#get) in let mk_rend c = GTree.cell_renderer_text [], ["text",c] in @@ -442,11 +442,11 @@ let build_layout (sn:session) = let eval_paned = GPack.paned `HORIZONTAL ~border_width:5 ~packing:(session_box#pack ~expand:true) () in let script_frame = GBin.frame ~shadow_type:`IN - ~packing:eval_paned#add1 () in + ~packing:(eval_paned#pack1 ~shrink:false) () in let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in let state_paned = GPack.paned `VERTICAL - ~packing:eval_paned#add2 () in + ~packing:(eval_paned#pack2 ~shrink:false) () in (* Proof buffer. *) diff --git a/ide/tags.ml b/ide/tags.ml index 60195e8acb..e9dbcb9e67 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -24,7 +24,7 @@ struct let error_bg = make_tag table ~name:"error_bg" [] let to_process = make_tag table ~name:"to_process" [] let processed = make_tag table ~name:"processed" [] - let incomplete = make_tag table ~name:"incomplete" [`BACKGROUND_STIPPLE_SET true] + let incomplete = make_tag table ~name:"incomplete" [] let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"] let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *) let ephemere = @@ -48,13 +48,3 @@ struct let warning = make_tag table ~name:"warning" [`FOREGROUND "orange"] let item = make_tag table ~name:"item" [`WEIGHT `BOLD] end - -let string_of_color clr = - let r = Gdk.Color.red clr in - let g = Gdk.Color.green clr in - let b = Gdk.Color.blue clr in - Printf.sprintf "#%04X%04X%04X" r g b - -let color_of_string s = - let colormap = Gdk.Color.get_system_colormap () in - Gdk.Color.alloc ~colormap (`NAME s) diff --git a/ide/tags.mli b/ide/tags.mli index 3194f87971..1df934fddf 100644 --- a/ide/tags.mli +++ b/ide/tags.mli @@ -41,6 +41,3 @@ sig val warning : GText.tag val item : GText.tag end - -val string_of_color : Gdk.color -> string -val color_of_string : string -> Gdk.color diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index 06281d6287..be400a5f2d 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -100,10 +100,10 @@ object(self) router#register_route route_id result; r_bin#add_with_viewport (result :> GObj.widget); views <- (frame#coerce, result, combo#entry) :: views; - let cb clr = result#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in - let cb ft = result#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = result#misc#modify_font (GPango.font_description_from_string ft) in stick text_font result cb; result#misc#set_can_focus true; (* false causes problems for selection *) let callback () = @@ -163,8 +163,8 @@ object(self) frame#visible method private refresh_color clr = - let clr = Tags.color_of_string clr in - let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in + let clr = Gdk.Color.color_parse clr in + let iter (_,view,_) = view#misc#modify_bg [`NORMAL, `COLOR clr] in List.iter iter views initializer diff --git a/ide/wg_Detachable.ml b/ide/wg_Detachable.ml index d753687077..755a42eadd 100644 --- a/ide/wg_Detachable.ml +++ b/ide/wg_Detachable.ml @@ -15,6 +15,9 @@ class type detachable_signals = method detached : callback:(GObj.widget -> unit) -> unit end +(* Cannot do a local warning in 4.05.0, fixme when we use a newer + OCaml to avoid the warning in the method itself. *) +[@@@ocaml.warning "-7"] class detachable (obj : ([> Gtk.box] as 'a) Gobject.obj) = object(self) diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index 7d2d7da570..fe079e8a9e 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -14,10 +14,10 @@ class finder name (view : GText.view) = let widget = Wg_Detachable.detachable ~title:(Printf.sprintf "Find & Replace (%s)" name) () in - let replace_box = GPack.table ~columns:4 ~rows:2 ~homogeneous:false + let replace_box = GPack.grid (* ~columns:4 ~rows:2 *) ~col_homogeneous:false ~row_homogeneous:false ~packing:widget#add () in let hb = GPack.hbox ~packing:(replace_box#attach - ~left:1 ~top:0 ~expand:`X ~fill:`X) () in + ~left:1 ~top:0 (*~expand:`X ~fill:`X*)) () in let use_regex = GButton.check_button ~label:"Regular expression" ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in @@ -26,25 +26,25 @@ class finder name (view : GText.view) = ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in let _ = GMisc.label ~text:"Find:" ~xalign:1.0 ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:0 ~top:1 ~fill:`X) () in + (*~xpadding:3 ~ypadding:3*) ~left:0 ~top:1 (*~fill:`X*)) () in let _ = GMisc.label ~text:"Replace:" ~xalign:1.0 ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:0 ~top:2 ~fill:`X) () in + (* ~xpadding:3 ~ypadding:3*) ~left:0 ~top:2 (*~fill:`X*)) () in let find_entry = GEdit.entry ~editable:true ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:1 ~top:1 ~expand:`X ~fill:`X) () in + (*~xpadding:3 ~ypadding:3*) ~left:1 ~top:1 (*~expand:`X ~fill:`X*)) () in let replace_entry = GEdit.entry ~editable:true ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:1 ~top:2 ~expand:`X ~fill:`X) () in + (*~xpadding:3 ~ypadding:3*) ~left:1 ~top:2 (*~expand:`X ~fill:`X*)) () in let next_button = GButton.button ~label:"_Next" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:1) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:2 ~top:1) () in let previous_button = GButton.button ~label:"_Previous" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:1) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:3 ~top:1) () in let replace_button = GButton.button ~label:"_Replace" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:2) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:2 ~top:2) () in let replace_all_button = GButton.button ~label:"Replace _All" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:2) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:3 ~top:2) () in object (self) val mutable last_found = None @@ -135,13 +135,13 @@ class finder name (view : GText.view) = view#buffer#end_user_action () method private set_not_found () = - find_entry#misc#modify_base [`NORMAL, `NAME "#F7E6E6"]; + find_entry#misc#modify_bg [`NORMAL, `NAME "#F7E6E6"]; method private set_found () = - find_entry#misc#modify_base [`NORMAL, `NAME "#BAF9CE"] + find_entry#misc#modify_bg [`NORMAL, `NAME "#BAF9CE"] method private set_normal () = - find_entry#misc#modify_base [`NORMAL, `NAME "white"] + find_entry#misc#modify_bg [`NORMAL, `NAME "white"] method private find_from backward ?(wrapped=false) (starti : GText.iter) = let found = diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 6b09b344b5..7943b099fc 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -42,7 +42,7 @@ class type message_view = end let message_view () : message_view = - let buffer = GSourceView2.source_buffer + let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true ~tag_table:Tags.Message.table () in @@ -50,7 +50,7 @@ let message_view () : message_view = let box = GPack.vbox () in let scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(box#pack ~expand:true) () in - let view = GSourceView2.source_view + let view = GSourceView3.source_view ~source_buffer:buffer ~packing:scroll#add ~editable:false ~cursor_visible:false ~wrap_mode:`WORD () in @@ -59,10 +59,10 @@ let message_view () : message_view = let _ = buffer#add_selection_clipboard default_clipboard in let () = view#set_left_margin 2 in view#misc#show (); - let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in - let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; (* Inserts at point, advances the mark *) diff --git a/ide/wg_Notebook.mli b/ide/wg_Notebook.mli index 85ecdf6cdd..9447b21c0b 100644 --- a/ide/wg_Notebook.mli +++ b/ide/wg_Notebook.mli @@ -28,11 +28,10 @@ val create : ('a -> GObj.widget option * GObj.widget option * GObj.widget) -> ('a -> unit) -> ?enable_popup:bool -> - ?homogeneous_tabs:bool -> + ?group_name:string -> ?scrollable:bool -> ?show_border:bool -> ?show_tabs:bool -> - ?tab_border:int -> ?tab_pos:Gtk.Tags.position -> ?border_width:int -> ?width:int -> diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 9be562d3ed..596df227b7 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -193,21 +193,21 @@ let display mode (view : #GText.view_skel) goals hints evars = let proof_view () = - let buffer = GSourceView2.source_buffer + let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true ~tag_table:Tags.Proof.table () in let text_buffer = new GText.buffer buffer#as_buffer in - let view = GSourceView2.source_view + let view = GSourceView3.source_view ~source_buffer:buffer ~editable:false ~wrap_mode:`WORD () in let () = Gtk_parsing.fix_double_click view in let default_clipboard = GData.clipboard Gdk.Atom.primary in let _ = buffer#add_selection_clipboard default_clipboard in - let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in - let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; let pf = object diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 5e26c50797..e95176bf4d 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -284,12 +284,12 @@ end class script_view (tv : source_view) (ct : Coq.coqtop) = -let view = new GSourceView2.source_view (Gobject.unsafe_cast tv) in +let view = new GSourceView3.source_view (Gobject.unsafe_cast tv) in let completion = new Wg_Completion.complete_model ct view#buffer in let popup = new Wg_Completion.complete_popup completion (view :> GText.view) in object (self) - inherit GSourceView2.source_view (Gobject.unsafe_cast tv) + inherit GSourceView3.source_view (Gobject.unsafe_cast tv) val undo_manager = new undo_manager view#buffer @@ -461,7 +461,7 @@ object (self) in let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in (* Plug on preferences *) - let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in @@ -484,24 +484,24 @@ object (self) stick tab_length self self#set_tab_width; stick auto_complete self self#set_auto_complete; - let cb ft = self#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = self#misc#modify_font (GPango.font_description_from_string ft) in stick text_font self cb; () end -let script_view ct ?(source_buffer:GSourceView2.source_buffer option) ?draw_spaces = - GtkSourceView2.SourceView.make_params [] ~cont:( +let script_view ct ?(source_buffer:GSourceView3.source_buffer option) ?draw_spaces = + GtkSourceView3.SourceView.make_params [] ~cont:( GtkText.View.make_params ~cont:( GContainer.pack_container ~create: (fun pl -> let w = match source_buffer with - | None -> GtkSourceView2.SourceView.new_ () - | Some buf -> GtkSourceView2.SourceView.new_with_buffer + | None -> GtkSourceView3.SourceView.new_ () + | Some buf -> GtkSourceView3.SourceView.new_with_buffer (Gobject.try_cast buf#as_buffer "GtkSourceBuffer") in let w = Gobject.unsafe_cast w in Gobject.set_params (Gobject.try_cast w "GtkSourceView") pl; - Gaux.may ~f:(GtkSourceView2.SourceView.set_draw_spaces w) draw_spaces; + Gaux.may ~f:(GtkSourceView3.SourceView.set_draw_spaces w) draw_spaces; ((new script_view w ct) : script_view)))) diff --git a/ide/wg_ScriptView.mli b/ide/wg_ScriptView.mli index be6510dbe2..ef7e92ff38 100644 --- a/ide/wg_ScriptView.mli +++ b/ide/wg_ScriptView.mli @@ -14,7 +14,7 @@ type source_view = [ Gtk.text_view | `sourceview ] Gtk.obj class script_view : source_view -> Coq.coqtop -> object - inherit GSourceView2.source_view + inherit GSourceView3.source_view method undo : unit -> unit method redo : unit -> unit method clear_undo : unit -> unit @@ -31,8 +31,8 @@ object end val script_view : Coq.coqtop -> - ?source_buffer:GSourceView2.source_buffer -> - ?draw_spaces:SourceView2Enums.source_draw_spaces_flags list -> + ?source_buffer:GSourceView3.source_buffer -> + ?draw_spaces:SourceView3Enums.source_draw_spaces_flags list -> ?auto_indent:bool -> ?highlight_current_line:bool -> ?indent_on_tab:bool -> @@ -42,7 +42,7 @@ val script_view : Coq.coqtop -> ?show_line_marks:bool -> ?show_line_numbers:bool -> ?show_right_margin:bool -> - ?smart_home_end:SourceView2Enums.source_smart_home_end_type -> + ?smart_home_end:SourceView3Enums.source_smart_home_end_type -> ?tab_width:int -> ?editable:bool -> ?cursor_visible:bool -> diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 3b2572f9d2..2e5de64254 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -8,8 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* open Util open Preferences +*) type color = GDraw.color @@ -22,6 +24,7 @@ object method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a end +(* let i2f = float_of_int let f2i = int_of_float @@ -32,14 +35,14 @@ let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with | `RGB (r1, g1, b1), `RGB (r2, g2, b2) -> r1 = r2 && g1 = g2 && b1 = b2 | `WHITE, `WHITE -> true | _ -> false - +*) class type segment_signals = object inherit GObj.misc_signals inherit GUtil.add_ml_signals method clicked : callback:(int -> unit) -> GtkSignal.id end - +(* class segment_signals_impl obj (clicked : 'a GUtil.signal) : segment_signals = object val after = false @@ -47,11 +50,14 @@ object inherit GUtil.add_ml_signals obj [clicked#disconnect] method clicked = clicked#connect ~after end +*) class segment () = let box = GBin.frame () in +(* let eventbox = GBin.event_box ~packing:box#add () in let draw = GMisc.image ~packing:eventbox#add () in +*) object (self) inherit GObj.widget box#as_widget @@ -60,11 +66,13 @@ object (self) val mutable height = 20 val mutable model : model option = None val mutable default : color = `WHITE +(* val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () +*) val clicked = new GUtil.signal () val mutable need_refresh = false val refresh_timer = Ideutils.mktimer () - +(* initializer box#misc#set_size_request ~height (); let cb rect = @@ -95,17 +103,18 @@ object (self) draw#set_pixmap pixmap; refresh_timer.Ideutils.run ~ms:300 ~callback:(fun () -> if need_refresh then self#refresh (); true) - +*) method set_model md = model <- Some md; let changed_cb = function | `INSERT | `REMOVE -> if self#misc#visible then need_refresh <- true | `SET (i, color) -> - if self#misc#visible then self#fill_range color i (i + 1) + () +(* if self#misc#visible then self#fill_range color i (i + 1)*) in md#changed ~callback:changed_cb - +(* method private fill_range color i j = match model with | None -> () | Some md -> @@ -150,5 +159,6 @@ object (self) method connect = new segment_signals_impl box#as_widget clicked +*) end diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli index 07f545fee7..84d487f35f 100644 --- a/ide/wg_Segment.mli +++ b/ide/wg_Segment.mli @@ -31,7 +31,9 @@ class segment : unit -> inherit GObj.widget val obj : Gtk.widget Gtk.obj method set_model : model -> unit +(* method connect : segment_signals method default_color : color method set_default_color : color -> unit +*) end diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 8e49800982..d5cb25d1fb 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -755,6 +755,7 @@ let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_lo (* mapping glob_constr to constr_expr *) let extern_glob_sort = function + | GSProp -> GSProp | GProp -> GProp | GSet -> GSet | GType _ as s when !print_universes -> s diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 24894fc9f5..5ede9d6a99 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -16,6 +16,7 @@ open Names open Nameops open Namegen open Constr +open Context open Libnames open Globnames open Impargs @@ -1020,6 +1021,7 @@ let sort_info_of_level_info (info: level_info) : (Libnames.qualid * int) option let glob_sort_of_level (level: glob_level) : glob_sort = match level with + | GSProp -> GSProp | GProp -> GProp | GSet -> GSet | GType info -> GType [sort_info_of_level_info info] @@ -1188,7 +1190,6 @@ let check_constructor_length env loc cstr len_pl pl0 = (error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs cstr))) -open Term open Declarations (* Similar to Cases.adjust_local_defs but on RCPat *) @@ -1197,16 +1198,15 @@ let insert_local_defs_in_pattern (ind,j) l = if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then (* Optimisation *) l else - let typi = mip.mind_nf_lc.(j-1) in - let (_,typi) = decompose_prod_n_assum (Context.Rel.length mib.mind_params_ctxt) typi in - let (decls,_) = decompose_prod_assum typi in + let (ctx, _) = mip.mind_nf_lc.(j-1) in + let decls = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in let rec aux decls args = match decls, args with | Context.Rel.Declaration.LocalDef _ :: decls, args -> (DAst.make @@ RCPatAtom None) :: aux decls args | _, [] -> [] (* In particular, if there were trailing local defs, they have been inserted *) | Context.Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args | _ -> assert false in - aux (List.rev decls) l + aux decls l let add_local_defs_and_check_length loc env g pl args = match g with | ConstructRef cstr -> @@ -2184,7 +2184,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (add_name match_acc CAst.(make ?loc x)) (CAst.make ?loc x::var_acc) | _ -> let fresh = - Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names (EConstr.of_constr ty) in + Namegen.next_name_away_with_default_using_types "iV" cano_name.binder_name forbidden_names (EConstr.of_constr ty) in canonize_args t tt (Id.Set.add fresh forbidden_names) ((fresh,c)::match_acc) ((CAst.make ?loc:(cases_pattern_loc c) @@ Name fresh)::var_acc) end @@ -2433,9 +2433,10 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = in let sigma, t = understand_tcc ~flags env sigma ~expected_type:IsType t' in match b with - None -> - let d = LocalAssum (na,t) in - let impls = + None -> + let r = Retyping.relevance_of_type env sigma t in + let d = LocalAssum (make_annot na r,t) in + let impls = if k == Implicit then let na = match na with Name n -> Some n | Anonymous -> None in (ExplByPos (n, na), (true, true, true)) :: impls @@ -2444,7 +2445,8 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = (push_rel d env, sigma, d::params, succ n, impls) | Some b -> let sigma, c = understand_tcc ~flags env sigma ~expected_type:(OfType t) b in - let d = LocalDef (na, c, t) in + let r = Retyping.relevance_of_type env sigma t in + let d = LocalDef (make_annot na r, c, t) in (push_rel d env, sigma, d::params, n, impls)) (env,sigma,[],k+1,[]) (List.rev bl) in sigma, ((env, par), impls) diff --git a/interp/declare.ml b/interp/declare.ml index 4371b15c82..08a6ac5f7b 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -370,7 +370,7 @@ let declare_projections univs mind = let mib = Environ.lookup_mind mind env in match mib.mind_record with | PrimRecord info -> - let iter_ind i (_, labs, _) = + let iter_ind i (_, labs, _, _) = let ind = (mind, i) in let projs = Inductiveops.compute_projections env ind in Array.iter2_i (declare_one_projection univs ind ~proj_npars:mib.mind_nparams) labs projs diff --git a/interp/discharge.ml b/interp/discharge.ml index 353b0f6057..1efd13adb1 100644 --- a/interp/discharge.ml +++ b/interp/discharge.ml @@ -69,7 +69,7 @@ let refresh_polymorphic_type_of_inductive (_,mip) = | RegularArity s -> s.mind_user_arity, false | TemplateArity ar -> let ctx = List.rev mip.mind_arity_ctxt in - mkArity (List.rev ctx, Type ar.template_level), true + mkArity (List.rev ctx, Sorts.sort_of_univ ar.template_level), true let process_inductive info modlist mib = let section_decls = Lib.named_of_variable_context info.Lib.abstr_ctx in @@ -103,7 +103,7 @@ let process_inductive info modlist mib = let (params',inds') = abstract_inductive section_decls' nparamdecls inds in let record = match mib.mind_record with | PrimRecord info -> - Some (Some (Array.map pi1 info)) + Some (Some (Array.map (fun (x,_,_,_) -> x) info)) | FakeRecord -> Some None | NotRecord -> None in diff --git a/interp/impargs.ml b/interp/impargs.ml index 6fd52d98dd..d83a0ce918 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -243,7 +243,7 @@ let compute_implicits_names_gen all env sigma t = let t = whd_all env sigma t in match kind sigma t with | Prod (na,a,b) -> - let na',avoid' = find_displayed_name_in sigma all avoid na (names,b) in + let na',avoid' = find_displayed_name_in sigma all avoid na.Context.binder_name (names,b) in aux (push_rel (LocalAssum (na,a)) env) avoid' (na'::names) b | _ -> List.rev names in aux env Id.Set.empty [] t @@ -445,16 +445,18 @@ let compute_mib_implicits flags kn = (fun i mip -> (* No need to care about constraints here *) let ty, _ = Typeops.type_of_global_in_context env (IndRef (kn,i)) in - Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, ty)) + let r = Inductive.relevance_of_inductive env (kn,i) in + Context.Rel.Declaration.LocalAssum (Context.make_annot (Name mip.mind_typename) r, ty)) mib.mind_packets) in let env_ar = Environ.push_rel_context ar env in let imps_one_inductive i mip = let ind = (kn,i) in let ar, _ = Typeops.type_of_global_in_context env (IndRef ind) in ((IndRef ind,compute_semi_auto_implicits env sigma flags (of_constr ar)), - Array.mapi (fun j c -> + Array.mapi (fun j (ctx, cty) -> + let c = of_constr (Term.it_mkProd_or_LetIn cty ctx) in (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar sigma flags c)) - (Array.map of_constr mip.mind_nf_lc)) + mip.mind_nf_lc) in Array.mapi imps_one_inductive mib.mind_packets @@ -674,7 +676,7 @@ let check_inclusion l = user_err Pp.(str "Sequences of implicit arguments must be of different lengths."); aux nl | _ -> () in - aux (List.map (fun (imps,_) -> List.length imps) l) + aux (List.map snd l) let check_rigidity isrigid = if not isrigid then @@ -685,6 +687,8 @@ let projection_implicits env p impls = CList.skipn_at_least npars impls let declare_manual_implicits local ref ?enriching l = + assert (List.for_all (fun (_, (max, fi, fu)) -> fi && fu) l); + assert (List.for_all (fun (ex, _) -> match ex with ExplByPos (_,_) -> true | _ -> false) l); let flags = !implicit_args in let env = Global.env () in let sigma = Evd.from_env env in @@ -692,29 +696,71 @@ let declare_manual_implicits local ref ?enriching l = let t = of_constr t in let enriching = Option.default flags.auto enriching in let autoimpls = compute_auto_implicits env sigma flags enriching t in + let l = [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] in + let req = + if is_local local ref then ImplLocal + else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + in add_anonymous_leaf (inImplicits (req,[ref,l])) + +let maybe_declare_manual_implicits local ref ?enriching l = + match l with + | [] -> () + | _ -> declare_manual_implicits local ref ?enriching l + +(* TODO: either turn these warnings on and document them, or handle these cases sensibly *) + +let warn_set_maximal_deprecated = + CWarnings.create ~name:"set-maximal-deprecated" ~category:"deprecated" + (fun i -> strbrk ("Argument number " ^ string_of_int i ^ " is a trailing implicit so must be maximal")) + +type implicit_kind = Implicit | MaximallyImplicit | NotImplicit + +let compute_implicit_statuses autoimps l = + let rec aux i = function + | _ :: autoimps, NotImplicit :: manualimps -> None :: aux (i+1) (autoimps, manualimps) + | Name id :: autoimps, MaximallyImplicit :: manualimps -> + Some (id, Manual, (true, true)) :: aux (i+1) (autoimps, manualimps) + | Name id :: autoimps, Implicit :: manualimps -> + let imps' = aux (i+1) (autoimps, manualimps) in + let max = set_maximality imps' false in + if max then warn_set_maximal_deprecated i; + Some (id, Manual, (max, true)) :: imps' + | Anonymous :: _, (Implicit | MaximallyImplicit) :: _ -> + user_err ~hdr:"set_implicits" + (strbrk ("Argument number " ^ string_of_int i ^ " (anonymous in original definition) cannot be declared implicit.")) + | autoimps, [] -> List.map (fun _ -> None) autoimps + | [], _::_ -> assert false + in aux 0 (autoimps, l) + +let set_implicits local ref l = + let flags = !implicit_args in + let env = Global.env () in + let sigma = Evd.from_env env in + let t, _ = Typeops.type_of_global_in_context env ref in + let t = of_constr t in + let autoimpls = compute_implicits_names env sigma t in let l' = match l with | [] -> assert false | [l] -> - [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] + [DefaultImpArgs, compute_implicit_statuses autoimpls l] | _ -> check_rigidity (is_rigid env sigma t); - let l = List.map (fun imps -> (imps,List.length imps)) l in + (* Sort by number of implicits, decreasing *) + let is_implicit = function + | NotImplicit -> false + | _ -> true in + let l = List.map (fun imps -> (imps,List.count is_implicit imps)) l in let l = List.sort (fun (_,n1) (_,n2) -> n2 - n1) l in check_inclusion l; let nargs = List.length autoimpls in List.map (fun (imps,n) -> (LessArgsThan (nargs-n), - set_manual_implicits flags enriching autoimpls imps)) l in + compute_implicit_statuses autoimpls imps)) l in let req = if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l'])) -let maybe_declare_manual_implicits local ref ?enriching l = - match l with - | [] -> () - | _ -> declare_manual_implicits local ref ?enriching [l] - let extract_impargs_data impls = let rec aux p = function | (DefaultImpArgs, imps)::_ -> [None,imps] diff --git a/interp/impargs.mli b/interp/impargs.mli index 43c26b024f..0070423530 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -112,13 +112,20 @@ val declare_implicits : bool -> GlobRef.t -> unit Unsets implicits if [l] is empty. *) val declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> - manual_implicits list -> unit + manual_implicits -> unit (** If the list is empty, do nothing, otherwise declare the implicits. *) val maybe_declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> manual_implicits -> unit +type implicit_kind = Implicit | MaximallyImplicit | NotImplicit + +(** [set_implicits local ref l] + Manual declaration of implicit arguments. + `l` is a list of possible sequences of implicit statuses. *) +val set_implicits : bool -> GlobRef.t -> implicit_kind list list -> unit + val implicits_of_global : GlobRef.t -> implicits_list list val extract_impargs_data : diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 4f3037b1fc..854651e7b7 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -10,6 +10,7 @@ (*i*) open Names +open Context open Decl_kinds open CErrors open Util @@ -175,10 +176,10 @@ let combine_params avoid fn applied needed = match app, need with [], [] -> List.rev ids, avoid - | app, (_, (LocalAssum (Name id, _) | LocalDef (Name id, _, _))) :: need when Id.List.mem_assoc id named -> + | app, (_, (LocalAssum ({binder_name=Name id}, _) | LocalDef ({binder_name=Name id}, _, _))) :: need when Id.List.mem_assoc id named -> aux (Id.List.assoc id named :: ids) avoid app need - | (x, None) :: app, (None, (LocalAssum (Name id, _) | LocalDef (Name id, _, _))) :: need -> + | (x, None) :: app, (None, (LocalAssum ({binder_name=Name id}, _) | LocalDef ({binder_name=Name id}, _, _))) :: need -> aux (x :: ids) avoid app need | _, (Some cl, _ as d) :: need -> diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h deleted file mode 100644 index c7abedaed6..0000000000 --- a/kernel/byterun/coq_instruct.h +++ /dev/null @@ -1,67 +0,0 @@ -/***********************************************************************/ -/* */ -/* Coq Compiler */ -/* */ -/* Benjamin Gregoire, projets Logical and Cristal */ -/* INRIA Rocquencourt */ -/* */ -/* */ -/***********************************************************************/ - -#ifndef _COQ_INSTRUCT_ -#define _COQ_INSTRUCT_ - -/* Nota: this list of instructions is parsed to produce derived files */ -/* coq_jumptbl.h and copcodes.ml. Instructions should be uppercase */ -/* and alone on lines starting by two spaces. */ -/* If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c */ -/* with the arity of the instruction and maybe coq_tcode_of_code. */ - -enum instructions { - ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, - PUSH, - PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, PUSHACC4, - PUSHACC5, PUSHACC6, PUSHACC7, PUSHACC, - POP, - ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, - PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, - PUSH_RETADDR, - APPLY, APPLY1, APPLY2, APPLY3, APPLY4, - APPTERM, APPTERM1, APPTERM2, APPTERM3, - RETURN, RESTART, GRAB, GRABREC, - CLOSURE, CLOSUREREC, CLOSURECOFIX, - OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, - PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, PUSHOFFSETCLOSURE2, - PUSHOFFSETCLOSURE, - GETGLOBAL, PUSHGETGLOBAL, - MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEBLOCK4, - SWITCH, PUSHFIELDS, - GETFIELD0, GETFIELD1, GETFIELD, - SETFIELD0, SETFIELD1, SETFIELD, - PROJ, - ENSURESTACKCAPACITY, - CONST0, CONST1, CONST2, CONST3, CONSTINT, - PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, - ACCUMULATE, - MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, -/* spiwack: */ - BRANCH, - CHECKADDINT63, ADDINT63, CHECKADDCINT63, CHECKADDCARRYCINT63, - CHECKSUBINT63, SUBINT63, CHECKSUBCINT63, CHECKSUBCARRYCINT63, - CHECKMULINT63, CHECKMULCINT63, - CHECKDIVINT63, CHECKMODINT63, CHECKDIVEUCLINT63, CHECKDIV21INT63, - CHECKLXORINT63, CHECKLORINT63, CHECKLANDINT63, - CHECKLSLINT63, CHECKLSRINT63, CHECKADDMULDIVINT63, - CHECKLSLINT63CONST1, CHECKLSRINT63CONST1, - - CHECKEQINT63, CHECKLTINT63, LTINT63, CHECKLEINT63, LEINT63, - CHECKCOMPAREINT63, - - CHECKHEAD0INT63, CHECKTAIL0INT63, - - ISINT, AREINT2, - - STOP -}; - -#endif /* _COQ_INSTRUCT_ */ diff --git a/kernel/byterun/dune b/kernel/byterun/dune index c3c44670be..20bdf28e54 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -5,6 +5,9 @@ (c_names coq_fix_code coq_memory coq_values coq_interp)) (rule + (targets coq_instruct.h) + (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe enum)))) + +(rule (targets coq_jumptbl.h) - (deps (:h-file coq_instruct.h) make_jumptbl.sh) - (action (bash "./make_jumptbl.sh %{h-file} %{targets}"))) + (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe jump)))) diff --git a/kernel/byterun/make_jumptbl.sh b/kernel/byterun/make_jumptbl.sh deleted file mode 100755 index eacd4daac8..0000000000 --- a/kernel/byterun/make_jumptbl.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -sed -n -e '/^ /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' -e '/^}/q' ${1} > ${2} diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 5fec55fea1..412637c4b6 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -29,6 +29,7 @@ open Pp open Names open Constr open Declarations +open Context open Environ open Vars open Esubst @@ -98,7 +99,7 @@ module type RedFlagsSig = sig val red_projection : reds -> Projection.t -> bool end -module RedFlags = (struct +module RedFlags : RedFlagsSig = struct (* [r_const=(true,cl)] means all constants but those in [cl] *) (* [r_const=(false,cl)] means only those in [cl] *) @@ -195,7 +196,7 @@ module RedFlags = (struct if Projection.unfolded p then true else red_set red (fCONST (Projection.constant p)) -end : RedFlagsSig) +end open RedFlags @@ -282,12 +283,63 @@ let assoc_defined id env = match Environ.lookup_named id env with type red_state = Norm | Cstr | Whnf | Red let neutr = function - | (Whnf|Norm) -> Whnf - | (Red|Cstr) -> Red + | Whnf|Norm -> Whnf + | Red|Cstr -> Red + +type optrel = Unknown | KnownR | KnownI + +let opt_of_rel = function + | Sorts.Relevant -> KnownR + | Sorts.Irrelevant -> KnownI + +module Mark : sig + + type t + + val mark : red_state -> optrel -> t + val relevance : t -> optrel + val red_state : t -> red_state + + val neutr : t -> t + + val set_norm : t -> t + +end = struct + type t = int + + let[@inline] of_state = function + | Norm -> 0b00 | Cstr -> 0b01 | Whnf -> 0b10 | Red -> 0b11 + + let[@inline] of_relevance = function + | Unknown -> 0 + | KnownR -> 0b01 + | KnownI -> 0b10 + + let[@inline] mark state relevance = (of_state state) * 4 + (of_relevance relevance) + + let[@inline] relevance x = match x land 0b11 with + | 0b00 -> Unknown + | 0b01 -> KnownR + | 0b10 -> KnownI + | _ -> assert false + + let[@inline] red_state x = match x land 0b1100 with + | 0b0000 -> Norm + | 0b0100 -> Cstr + | 0b1000 -> Whnf + | 0b1100 -> Red + | _ -> assert false + + let[@inline] neutr x = x lor 0b1000 (* Whnf|Norm -> Whnf | Red|Cstr -> Red *) + + let[@inline] set_norm x = x land 0b0011 +end +let mark = Mark.mark type fconstr = { - mutable norm: red_state; - mutable term: fterm } + mutable mark : Mark.t; + mutable term: fterm; +} and fterm = | FRel of int @@ -300,9 +352,9 @@ and fterm = | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * constr * fconstr subs - | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs + | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs + | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs + | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FInt of Uint63.t | FLIFT of int * fconstr @@ -310,20 +362,20 @@ and fterm = | FLOCKED let fterm_of v = v.term -let set_norm v = v.norm <- Norm -let is_val v = match v.norm with Norm -> true | Cstr | Whnf | Red -> false +let set_norm v = v.mark <- Mark.set_norm v.mark +let is_val v = match Mark.red_state v.mark with Norm -> true | Cstr | Whnf | Red -> false -let mk_atom c = {norm=Norm;term=FAtom c} -let mk_red f = {norm=Red;term=f} +let mk_atom c = {mark=mark Norm Unknown;term=FAtom c} +let mk_red f = {mark=mark Red Unknown;term=f} (* Could issue a warning if no is still Red, pointing out that we loose sharing. *) -let update ~share v1 no t = +let update ~share v1 mark t = if share then - (v1.norm <- no; + (v1.mark <- mark; v1.term <- t; v1) - else {norm=no;term=t} + else {mark;term=t;} (** Reduction cache *) @@ -383,16 +435,19 @@ let rec stack_args_size = function lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) let rec lft_fconstr n ft = + let r = Mark.relevance ft.mark in match ft.term with | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FInt _) -> ft - | FRel i -> {norm=Norm;term=FRel(i+n)} - | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))} - | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))} - | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} + | FRel i -> {mark=mark Norm r;term=FRel(i+n)} + | FLambda(k,tys,f,e) -> {mark=mark Cstr r; term=FLambda(k,tys,f,subs_shft(n,e))} + | FFix(fx,e) -> + {mark=mark Cstr r; term=FFix(fx,subs_shft(n,e))} + | FCoFix(cfx,e) -> + {mark=mark Cstr r; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false | FFlex (RelKey _) | FAtom _ | FApp _ | FProj _ | FCaseT _ | FProd _ - | FLetIn _ | FEvar _ | FCLOS _ -> {norm=ft.norm; term=FLIFT(n,ft)} + | FLetIn _ | FEvar _ | FCLOS _ -> {mark=ft.mark; term=FLIFT(n,ft)} let lift_fconstr k f = if Int.equal k 0 then f else lft_fconstr k f let lift_fconstr_vect k v = @@ -401,9 +456,9 @@ let lift_fconstr_vect k v = let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt - | Inr(k,None) -> {norm=Norm; term= FRel k} + | Inr(k,None) -> {mark=mark Norm Unknown; term= FRel k} | Inr(k,Some p) -> - lift_fconstr (k-p) {norm=Red;term=FFlex(RelKey p)} + lift_fconstr (k-p) {mark=mark Red Unknown;term=FFlex(RelKey p)} (* since the head may be reducible, we might introduce lifts of 0 *) let compact_stack head stk = @@ -414,7 +469,7 @@ let compact_stack head stk = lost by the update operation *) let h' = lft_fconstr depth head in (** The stack contains [Zupdate] marks only if in sharing mode *) - let _ = update ~share:true m h'.norm h'.term in + let _ = update ~share:true m h'.mark h'.term in strip_rec depth s | ((ZcaseT _ | Zproj _ | Zfix _ | Zapp _ | Zprimitive _) :: _ | []) as stk -> zshift depth stk in @@ -423,7 +478,7 @@ let compact_stack head stk = (* Put an update mark in the stack, only if needed *) let zupdate info m s = let share = info.i_cache.i_share in - if share && begin match m.norm with Red -> true | Norm | Whnf | Cstr -> false end + if share && begin match Mark.red_state m.mark with Red -> true | Norm | Whnf | Cstr -> false end then let s' = compact_stack m s in let _ = m.term <- FLOCKED in @@ -436,25 +491,25 @@ let mk_lambda env t = let destFLambda clos_fun t = match [@ocaml.warning "-4"] t.term with - | FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) - | FLambda(n,(na,ty)::tys,b,e) -> - (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) - | _ -> assert false -(* t must be a FLambda and binding list cannot be empty *) + FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) + | FLambda(n,(na,ty)::tys,b,e) -> + (na,clos_fun e ty,{mark=t.mark;term=FLambda(n-1,tys,b,subs_lift e)}) + | _ -> assert false + (* t must be a FLambda and binding list cannot be empty *) (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) let mk_clos e t = match kind t with | Rel i -> clos_rel e i - | Var x -> { norm = Red; term = FFlex (VarKey x) } - | Const c -> { norm = Red; term = FFlex (ConstKey c) } - | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } - | Ind kn -> { norm = Norm; term = FInd kn } - | Construct kn -> { norm = Cstr; term = FConstruct kn } - | Int i -> {norm = Cstr; term = FInt i} + | Var x -> {mark = mark Red Unknown; term = FFlex (VarKey x) } + | Const c -> {mark = mark Red Unknown; term = FFlex (ConstKey c) } + | Meta _ | Sort _ -> {mark = mark Norm KnownR; term = FAtom t } + | Ind kn -> {mark = mark Norm KnownR; term = FInd kn } + | Construct kn -> {mark = mark Cstr Unknown; term = FConstruct kn } + | Int i -> {mark = mark Cstr Unknown; term = FInt i} | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> - {norm = Red; term = FCLOS(t,e)} + {mark = mark Red Unknown; term = FCLOS(t,e)} let inject c = mk_clos (subs_id 0) c @@ -606,23 +661,25 @@ let rec fstrong unfreeze_fun lfts v = let rec zip m stk = match stk with | [] -> m - | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s + | Zapp args :: s -> zip {mark=Mark.neutr m.mark; term=FApp(m, args)} s | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in - zip {norm=neutr m.norm; term=t} s + let mark = mark (neutr (Mark.red_state m.mark)) Unknown in + zip {mark; term=t} s | Zproj p :: s -> - zip {norm=neutr m.norm; term=FProj(Projection.make p true,m)} s + let mark = mark (neutr (Mark.red_state m.mark)) Unknown in + zip {mark; term=FProj(Projection.make p true,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> zip (lift_fconstr n m) s | Zupdate(rf)::s -> (** The stack contains [Zupdate] marks only if in sharing mode *) - zip (update ~share:true rf m.norm m.term) s + zip (update ~share:true rf m.mark m.term) s | Zprimitive(_op,c,rargs,kargs)::s -> let args = List.rev_append rargs (m::List.map snd kargs) in - let f = {norm = Red;term = FFlex (ConstKey c)} in - zip {norm=neutr m.norm; term = FApp (f, Array.of_list args)} s + let f = {mark = mark Red Unknown;term = FFlex (ConstKey c)} in + zip {mark=mark (neutr (Mark.red_state m.mark)) KnownR; term = FApp (f, Array.of_list args)} s let fapp_stack (m,stk) = zip m stk @@ -640,21 +697,21 @@ let strip_update_shift_app_red head stk = strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s | (Zapp args :: s) -> strip_rec (Zapp args :: rstk) - {norm=h.norm;term=FApp(h,args)} depth s + {mark=h.mark;term=FApp(h,args)} depth s | Zupdate(m)::s -> (** The stack contains [Zupdate] marks only if in sharing mode *) - strip_rec rstk (update ~share:true m h.norm h.term) depth s + strip_rec rstk (update ~share:true m h.mark h.term) depth s | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> (depth,List.rev rstk, stk) in strip_rec [] head 0 stk let strip_update_shift_app head stack = - assert (match head.norm with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); strip_update_shift_app_red head stack let get_nth_arg head n stk = - assert (match head.norm with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s @@ -662,7 +719,7 @@ let get_nth_arg head n stk = let q = Array.length args in if n >= q then - strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s' + strip_rec (Zapp args::rstk) {mark=h.mark;term=FApp(h,args)} (n-q) s' else let bef = Array.sub args 0 n in let aft = Array.sub args (n+1) (q-n-1) in @@ -671,7 +728,7 @@ let get_nth_arg head n stk = (Some (stk', args.(n)), append_stack aft s') | Zupdate(m)::s -> (** The stack contains [Zupdate] mark only if in sharing mode *) - strip_rec rstk (update ~share:true m h.norm h.term) n s + strip_rec rstk (update ~share:true m h.mark h.term) n s | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as s -> (None, List.rev rstk @ s) in strip_rec [] head n stk @@ -680,7 +737,7 @@ let get_nth_arg head n stk = let rec get_args n tys f e = function | Zupdate r :: s -> (** The stack contains [Zupdate] mark only if in sharing mode *) - let _hd = update ~share:true r Cstr (FLambda(n,tys,f,e)) in + let _hd = update ~share:true r (mark Cstr (Mark.relevance r.mark)) (FLambda(n,tys,f,e)) in get_args n tys f e s | Zshift k :: s -> get_args n tys f (subs_shft (k,e)) s @@ -695,7 +752,7 @@ let rec get_args n tys f e = function let etys = List.skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> - (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) + (Inr {mark=mark Cstr Unknown;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function @@ -703,7 +760,7 @@ let rec eta_expand_stack = function | Zshift _ | Zupdate _ | Zprimitive _ as e) :: s -> e :: eta_expand_stack s | [] -> - [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] + [Zshift 1; Zapp [|{mark=mark Norm Unknown; term= FRel 1}|]] (* Get the arguments of a native operator *) let rec skip_native_args rargs nargs = @@ -731,12 +788,12 @@ let get_native_args op c stk = (skip_native_args [] (List.rev rnargs), Zapp (Array.of_list eargs) :: s') | rnargs, kargs, _ -> - strip_rec rnargs {norm = h.norm;term=FApp(h, args)} depth kargs s' + strip_rec rnargs {mark = h.mark;term=FApp(h, args)} depth kargs s' end | Zupdate(m) :: s -> - strip_rec rnargs (update ~share:true m h.norm h.term) depth kargs s + strip_rec rnargs (update ~share:true m h.mark h.term) depth kargs s | (Zprimitive _ | ZcaseT _ | Zproj _ | Zfix _) :: _ | [] -> assert false - in strip_rec [] {norm = Red;term = FFlex(ConstKey c)} 0 kargs stk + in strip_rec [] {mark = mark Red Unknown;term = FFlex(ConstKey c)} 0 kargs stk let get_native_args1 op c stk = match get_native_args op c stk with @@ -807,7 +864,7 @@ let eta_expand_ind_stack env ind m s (f, s') = (** Try to drop the params, might fail on partially applied constructors. *) let argss = try_drop_parameters depth pars args in let hstack = Array.map (fun p -> - { norm = Red; (* right can't be a constructor though *) + { mark = mark Red Unknown; (* right can't be a constructor though *) term = FProj (Projection.make p true, right) }) projs in @@ -835,13 +892,15 @@ let rec project_nth_arg n = function let contract_fix_vect fix = let (thisbody, make_body, env, nfix) = match [@ocaml.warning "-4"] fix with - | FFix (((reci,i),(_,_,bds as rdcl)),env) -> + | FFix (((reci,i),(nas,_,bds as rdcl)),env) -> (bds.(i), - (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }), + (fun j -> { mark = mark Cstr (opt_of_rel nas.(j).binder_relevance); + term = FFix (((reci,j),rdcl),env) }), env, Array.length bds) - | FCoFix ((i,(_,_,bds as rdcl)),env) -> + | FCoFix ((i,(nas,_,bds as rdcl)),env) -> (bds.(i), - (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }), + (fun j -> { mark = mark Cstr (opt_of_rel nas.(j).binder_relevance); + term = FCoFix ((j,rdcl),env) }), env, Array.length bds) | _ -> assert false in @@ -865,7 +924,7 @@ let rec knh info m stk = | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate info m stk)) | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate info m stk) - | FFix(((ri,n),(_,_,_)),_) -> + | FFix(((ri,n),_),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) @@ -886,18 +945,18 @@ and knht info e t stk = knht info e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> knht info e t (ZcaseT(ci, p, br, e)::stk) - | Fix fx -> knh info { norm = Cstr; term = FFix (fx, e) } stk + | Fix fx -> knh info { mark = mark Cstr Unknown; term = FFix (fx, e) } stk | Cast(a,_,_) -> knht info e a stk | Rel n -> knh info (clos_rel e n) stk - | Proj (p, c) -> knh info { norm = Red; term = FProj (p, mk_clos e c) } stk + | Proj (p, c) -> knh info { mark = mark Red Unknown; term = FProj (p, mk_clos e c) } stk | (Ind _|Const _|Construct _|Var _|Meta _ | Sort _ | Int _) -> (mk_clos e t, stk) - | CoFix cfx -> { norm = Cstr; term = FCoFix (cfx,e) }, stk - | Lambda _ -> { norm = Cstr; term = mk_lambda e t }, stk + | CoFix cfx -> { mark = mark Cstr Unknown; term = FCoFix (cfx,e) }, stk + | Lambda _ -> { mark = mark Cstr Unknown; term = mk_lambda e t }, stk | Prod (n, t, c) -> - { norm = Whnf; term = FProd (n, mk_clos e t, c, e) }, stk + { mark = mark Whnf KnownR; term = FProd (n, mk_clos e t, c, e) }, stk | LetIn (n,b,t,c) -> - { norm = Red; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk - | Evar ev -> { norm = Red; term = FEvar (ev, e) }, stk + { mark = mark Red Unknown; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk + | Evar ev -> { mark = mark Red Unknown; term = FEvar (ev, e) }, stk let inject c = mk_clos (subs_id 0) c @@ -919,7 +978,7 @@ module FNativeEntries = | FInt i -> i | _ -> raise Primred.NativeDestKO - let dummy = {norm = Norm; term = FRel 0} + let dummy = {mark = mark Norm KnownR; term = FRel 0} let current_retro = ref Retroknowledge.empty let defined_int = ref false @@ -929,7 +988,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_int63 with | Some c -> defined_int := true; - fint := { norm = Norm; term = FFlex (ConstKey (Univ.in_punivs c)) } + fint := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } | None -> defined_int := false let defined_bool = ref false @@ -940,8 +999,8 @@ module FNativeEntries = match retro.Retroknowledge.retro_bool with | Some (ct,cf) -> defined_bool := true; - ftrue := { norm = Cstr; term = FConstruct (Univ.in_punivs ct) }; - ffalse := { norm = Cstr; term = FConstruct (Univ.in_punivs cf) } + ftrue := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs ct) }; + ffalse := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cf) } | None -> defined_bool :=false let defined_carry = ref false @@ -952,8 +1011,8 @@ module FNativeEntries = match retro.Retroknowledge.retro_carry with | Some(c0,c1) -> defined_carry := true; - fC0 := { norm = Cstr; term = FConstruct (Univ.in_punivs c0) }; - fC1 := { norm = Cstr; term = FConstruct (Univ.in_punivs c1) } + fC0 := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs c0) }; + fC1 := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs c1) } | None -> defined_carry := false let defined_pair = ref false @@ -963,7 +1022,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_pair with | Some c -> defined_pair := true; - fPair := { norm = Cstr; term = FConstruct (Univ.in_punivs c) } + fPair := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs c) } | None -> defined_pair := false let defined_cmp = ref false @@ -975,9 +1034,9 @@ module FNativeEntries = match retro.Retroknowledge.retro_cmp with | Some (cEq, cLt, cGt) -> defined_cmp := true; - fEq := { norm = Cstr; term = FConstruct (Univ.in_punivs cEq) }; - fLt := { norm = Cstr; term = FConstruct (Univ.in_punivs cLt) }; - fGt := { norm = Cstr; term = FConstruct (Univ.in_punivs cGt) } + fEq := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cEq) }; + fLt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cLt) }; + fGt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cGt) } | None -> defined_cmp := false let defined_refl = ref false @@ -988,7 +1047,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_refl with | Some crefl -> defined_refl := true; - frefl := { norm = Cstr; term = FConstruct (Univ.in_punivs crefl) } + frefl := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs crefl) } | None -> defined_refl := false let init env = @@ -1025,7 +1084,7 @@ module FNativeEntries = let mkInt env i = check_int env; - { norm = Norm; term = FInt i } + { mark = mark Norm KnownR; term = FInt i } let mkBool env b = check_bool env; @@ -1033,12 +1092,12 @@ module FNativeEntries = let mkCarry env b e = check_carry env; - {norm = Cstr; + {mark = mark Cstr KnownR; term = FApp ((if b then !fC1 else !fC0),[|!fint;e|])} let mkIntPair env e1 e2 = check_pair env; - { norm = Cstr; term = FApp(!fPair, [|!fint;!fint;e1;e2|]) } + { mark = mark Cstr KnownR; term = FApp(!fPair, [|!fint;!fint;e1;e2|]) } let mkLt env = check_cmp env; @@ -1124,8 +1183,8 @@ let rec knr info tab m stk = begin match FredNative.red_prim (info_env info) () op args with | Some m -> kni info tab m s | None -> - let f = {norm = Whnf; term = FFlex (ConstKey c)} in - let m = {norm = Whnf; term = FApp(f,args)} in + let f = {mark = mark Whnf KnownR; term = FFlex (ConstKey c)} in + let m = {mark = mark Whnf KnownR; term = FApp(f,args)} in (m,s) end | (kd,a)::nargs -> @@ -1194,12 +1253,12 @@ and norm_head info tab m = if is_val m then (incr prune; term_of_fconstr m) else match m.term with | FLambda(_n,tys,f,e) -> - let (e',rvtys) = - List.fold_left (fun (e,ctxt) (na,ty) -> - (subs_lift e, (na,kl info tab (mk_clos e ty))::ctxt)) - (e,[]) tys in - let bd = kl info tab (mk_clos e' f) in - List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys + let (e',info,rvtys) = + List.fold_left (fun (e,info,ctxt) (na,ty) -> + (subs_lift e, info, (na,kl info tab (mk_clos e ty))::ctxt)) + (e,info,[]) tys in + let bd = kl info tab (mk_clos e' f) in + List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys | FLetIn(na,a,b,f,e) -> let c = mk_clos (subs_lift e) f in mkLetIn(na, kl info tab a, kl info tab b, kl info tab c) @@ -1232,7 +1291,7 @@ let whd_val info tab v = let norm_val info tab v = with_stats (lazy (kl info tab v)) -let whd_stack infos tab m stk = match m.norm with +let whd_stack infos tab m stk = match Mark.red_state m.mark with | Whnf | Norm -> (** No need to perform [kni] nor to unlock updates because every head subterm of [m] is [Whnf] or [Norm] *) @@ -1269,3 +1328,6 @@ let unfold_reference info tab key = ref_value_cache info tab key else Undef None | RelKey _ -> ref_value_cache info tab key + +let relevance_of f = Mark.relevance f.mark +let set_relevance r f = f.mark <- Mark.mark (Mark.red_state f.mark) (opt_of_rel r) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index bd04677374..b1b69dded8 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -114,9 +114,9 @@ type fterm = | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * constr * fconstr subs - | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs + | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs + | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs + | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FInt of Uint63.t | FLIFT of int * fconstr @@ -165,7 +165,12 @@ val mk_red : fterm -> fconstr val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr val destFLambda : - (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t * fconstr * fconstr + (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t Context.binder_annot * fconstr * fconstr + +type optrel = Unknown | KnownR | KnownI + +val relevance_of : fconstr -> optrel +val set_relevance : Sorts.relevance -> fconstr -> unit (** Global and local constant cache *) type clos_infos diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index da5c4fb07b..fdc93cfa89 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -148,7 +148,7 @@ let prim_ind_to_string = function | PIT_cmp -> "cmp" let prim_type_to_string = function - | PT_int63 -> "int63" + | PT_int63 -> "int63_type" let op_or_type_to_string = function | OT_op op -> to_string op diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 718584b3d4..69f004307d 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -550,7 +550,7 @@ let rec compile_lam env cenv lam sz cont = else comp_app compile_structured_constant compile_universe cenv (Const_ind ind) (Univ.Instance.to_array u) sz cont - | Lsort (Sorts.Prop | Sorts.Set as s) -> + | Lsort (Sorts.SProp | Sorts.Prop | Sorts.Set as s) -> compile_structured_constant cenv (Const_sort s) sz cont | Lsort (Sorts.Type u) -> (* We represent universes as a global constant with local universes @@ -562,10 +562,10 @@ let rec compile_lam env cenv lam sz cont = compile_fv_elem cenv (FVuniv_var idx) sz cont in if List.is_empty s then - compile_structured_constant cenv (Const_sort (Sorts.Type u)) sz cont + compile_structured_constant cenv (Const_sort (Sorts.sort_of_univ u)) sz cont else comp_app compile_structured_constant compile_get_univ cenv - (Const_sort (Sorts.Type u)) (Array.of_list s) sz cont + (Const_sort (Sorts.sort_of_univ u)) (Array.of_list s) sz cont | Llet (_id,def,body) -> compile_lam env cenv def sz diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 5c21a5ec25..a764cca354 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -15,8 +15,8 @@ type lambda = | Lvar of Id.t | Levar of Evar.t * lambda array | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Llet of Name.t * lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of pconstant | Lprim of pconstant option * CPrimitives.t * lambda array @@ -38,15 +38,17 @@ type lambda = stored in [extra_branches]. *) and lam_branches = { constant_branches : lambda array; - nonconstant_branches : (Name.t array * lambda) array } + nonconstant_branches : (Name.t Context.binder_annot array * lambda) array } (* extra_branches : (name array * lambda) array } *) -and fix_decl = Name.t array * lambda array * lambda array +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array (** Printing **) +let pr_annot x = Name.print x.Context.binder_name + let pp_names ids = - prlist_with_sep (fun _ -> brk(1,1)) Name.print (Array.to_list ids) + prlist_with_sep (fun _ -> brk(1,1)) pr_annot (Array.to_list ids) let pp_rel name n = Name.print name ++ str "##" ++ int n @@ -55,6 +57,7 @@ let pp_sort s = match Sorts.family s with | InSet -> str "Set" | InProp -> str "Prop" + | InSProp -> str "SProp" | InType -> str "Type" let rec pp_lam lam = @@ -79,7 +82,7 @@ let rec pp_lam lam = str ")") | Llet(id,def,body) -> hov 0 (str "let " ++ - Name.print id ++ + pr_annot id ++ str ":=" ++ pp_lam def ++ str " in" ++ @@ -119,7 +122,7 @@ let rec pp_lam lam = v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> - Name.print na ++ str"/" ++ int i ++ str":" ++ + pr_annot na ++ str"/" ++ int i ++ str":" ++ pp_lam ty ++ cut() ++ str":=" ++ pp_lam bd) (Array.to_list fixl)) ++ str"}") @@ -131,7 +134,7 @@ let rec pp_lam lam = v 0 (prlist_with_sep spc (fun (na,ty,bd) -> - Name.print na ++ str":" ++ pp_lam ty ++ + pr_annot na ++ str":" ++ pp_lam ty ++ cut() ++ str":=" ++ pp_lam bd) (Array.to_list fixl)) ++ str"}") | Lmakeblock(tag, args) -> @@ -393,8 +396,8 @@ and reduce_lapp substf lids body substa largs = Llet(id, a, body) | [], [] -> simplify substf body | _::_, _ -> - Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) - | [], _::_ -> simplify_app substf body substa (Array.of_list largs) + Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) + | [], _ -> simplify_app substf body substa (Array.of_list largs) @@ -511,7 +514,8 @@ let make_args start _end = (* Translation of constructors *) let expand_constructor tag nparams arity = - let ids = Array.make (nparams + arity) Anonymous in + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make (nparams + arity) anon in if arity = 0 then mkLlam ids (Lint tag) else let args = make_args arity 1 in @@ -553,7 +557,8 @@ let prim kn p args = Lprim(Some kn, p, args) let expand_prim kn op arity = - let ids = Array.make arity Anonymous in + (* primitives are always Relevant *) + let ids = Array.make arity Context.anonR in let args = make_args arity 1 in Llam(ids, prim kn op args) @@ -628,7 +633,7 @@ struct construct_tbl = Hashtbl.create 111 } - let push_rel env id = Vect.push env.name_rel id + let push_rel env id = Vect.push env.name_rel id.Context.binder_name let push_rels env ids = Array.iter (push_rel env) ids @@ -678,7 +683,7 @@ let rec lambda_of_constr env c = Renv.push_rel env id; let lc = lambda_of_constr env codom in Renv.pop env; - Lprod(ld, Llam([|id|], lc)) + Lprod(ld, Llam([|id|], lc)) | Lambda _ -> let params, body = decompose_lam c in @@ -725,7 +730,8 @@ let rec lambda_of_constr env c = match b with | Llam(ids, body) when Array.length ids = arity -> (ids, body) | _ -> - let ids = Array.make arity Anonymous in + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make arity anon in let args = make_args arity 1 in let ll = lam_lift arity b in (ids, mkLapp ll args) @@ -800,7 +806,7 @@ let optimize_lambda lam = let lambda_of_constr ~optimize genv c = let env = Renv.make genv in - let ids = List.rev_map Context.Rel.Declaration.get_name (rel_context genv) in + let ids = List.rev_map Context.Rel.Declaration.get_annot (rel_context genv) in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env c in let lam = if optimize then optimize_lambda lam else lam in diff --git a/kernel/clambda.mli b/kernel/clambda.mli index 4d921fd45e..1476bb6e45 100644 --- a/kernel/clambda.mli +++ b/kernel/clambda.mli @@ -8,8 +8,8 @@ type lambda = | Lvar of Id.t | Levar of Evar.t * lambda array | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Llet of Name.t * lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of pconstant | Lprim of pconstant option * CPrimitives.t * lambda array @@ -28,15 +28,15 @@ type lambda = and lam_branches = { constant_branches : lambda array; - nonconstant_branches : (Name.t array * lambda) array } + nonconstant_branches : (Name.t Context.binder_annot array * lambda) array } -and fix_decl = Name.t array * lambda array * lambda array +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array exception TooLargeInductive of Pp.t val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda -val decompose_Llam : lambda -> Name.t array * lambda +val decompose_Llam : lambda -> Name.t Context.binder_annot array * lambda val get_alias : env -> Constant.t -> Constant.t diff --git a/kernel/constr.ml b/kernel/constr.ml index c392494e95..11958c9108 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -28,6 +28,7 @@ open Util open Names open Univ +open Context type existential_key = Evar.t type metavariable = int @@ -60,6 +61,7 @@ type case_info = in addition to the parameters of the related inductive type NOTE: "lets" are therefore excluded from the count NOTE: parameters of the inductive type are also excluded from the count *) + ci_relevance : Sorts.relevance; ci_pp_info : case_printing (* not interpreted by the kernel *) } @@ -71,7 +73,7 @@ type case_info = the same order (i.e. last argument first) *) type 'constr pexistential = existential_key * 'constr array type ('constr, 'types) prec_declaration = - Name.t array * 'types array * 'constr array + Name.t binder_annot array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = @@ -90,9 +92,9 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Evar of 'constr pexistential | Sort of 'sort | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types - | Lambda of Name.t * 'types * 'constr - | LetIn of Name.t * 'constr * 'types * 'constr + | Prod of Name.t binder_annot * 'types * 'types + | Lambda of Name.t binder_annot * 'types * 'constr + | LetIn of Name.t binder_annot * 'constr * 'types * 'constr | App of 'constr * 'constr array | Const of (Constant.t * 'univs) | Ind of (inductive * 'univs) @@ -127,13 +129,15 @@ let rels = let mkRel n = if 0<n && n<=16 then rels.(n-1) else Rel n (* Construct a type *) +let mkSProp = Sort Sorts.sprop let mkProp = Sort Sorts.prop let mkSet = Sort Sorts.set -let mkType u = Sort (Sorts.Type u) +let mkType u = Sort (Sorts.sort_of_univ u) let mkSort = function + | Sorts.SProp -> mkSProp | Sorts.Prop -> mkProp (* Easy sharing *) | Sorts.Set -> mkSet - | s -> Sort s + | Sorts.Type _ as s -> Sort s (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) (* (that means t2 is declared as the type of t1) *) @@ -1181,16 +1185,16 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Prod (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in - (Prod (sh_na na, t, c), combinesmall 4 (combine3 (Name.hash na) ht hc)) + (Prod (sh_na na, t, c), combinesmall 4 (combine3 (hash_annot Name.hash na) ht hc)) | Lambda (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in - (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Name.hash na) ht hc)) + (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (hash_annot Name.hash na) ht hc)) | LetIn (na,b,t,c) -> let b, hb = sh_rec b in let t, ht = sh_rec t in let c, hc = sh_rec c in - (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Name.hash na) hb ht hc)) + (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (hash_annot Name.hash na) hb ht hc)) | App (c,l) -> let c, hc = sh_rec c in let l, hl = hash_term_array l in @@ -1214,24 +1218,24 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let p, hp = sh_rec p and c, hc = sh_rec c in let bl,hbl = hash_term_array bl in - let hbl = combine (combine hc hp) hbl in + let hbl = combine (combine hc hp) hbl in (Case (sh_ci ci, p, c, bl), combinesmall 12 hbl) | Fix (ln,(lna,tl,bl)) -> - let bl,hbl = hash_term_array bl in + let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in - let fold accu na = combine (Name.hash na) accu in + let fold accu na = combine (hash_annot Name.hash na) accu in let hna = Array.fold_left fold 0 lna in let h = combine3 hna hbl htl in - (Fix (ln,(lna,tl,bl)), combinesmall 13 h) + (Fix (ln,(lna,tl,bl)), combinesmall 13 h) | CoFix(ln,(lna,tl,bl)) -> - let bl,hbl = hash_term_array bl in + let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in - let fold accu na = combine (Name.hash na) accu in + let fold accu na = combine (hash_annot Name.hash na) accu in let hna = Array.fold_left fold 0 lna in let h = combine3 hna hbl htl in - (CoFix (ln,(lna,tl,bl)), combinesmall 14 h) + (CoFix (ln,(lna,tl,bl)), combinesmall 14 h) | Meta n -> (t, combinesmall 15 n) | Rel n -> @@ -1322,6 +1326,7 @@ struct info1.style == info2.style let eq ci ci' = ci.ci_ind == ci'.ci_ind && + ci.ci_relevance == ci'.ci_relevance && Int.equal ci.ci_npar ci'.ci_npar && Array.equal Int.equal ci.ci_cstr_ndecls ci'.ci_cstr_ndecls && (* we use [Array.equal] on purpose *) Array.equal Int.equal ci.ci_cstr_nargs ci'.ci_cstr_nargs && (* we use [Array.equal] on purpose *) @@ -1345,7 +1350,7 @@ struct let h3 = Array.fold_left combine 0 ci.ci_cstr_ndecls in let h4 = Array.fold_left combine 0 ci.ci_cstr_nargs in let h5 = hash_pp_info ci.ci_pp_info in - combine5 h1 h2 h3 h4 h5 + combinesmall (Sorts.relevance_hash ci.ci_relevance) (combine5 h1 h2 h3 h4 h5) end module Hcaseinfo = Hashcons.Make(CaseinfoHash) @@ -1354,6 +1359,18 @@ let case_info_hash = CaseinfoHash.hash let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.generate Hcaseinfo.hcons hcons_ind +module Hannotinfo = struct + type t = Name.t binder_annot + type u = Name.t -> Name.t + let hash = hash_annot Name.hash + let eq = eq_annot (fun na1 na2 -> na1 == na2) + let hashcons h {binder_name=na;binder_relevance} = + {binder_name=h na;binder_relevance} + end +module Hannot = Hashcons.Make(Hannotinfo) + +let hcons_annot = Hashcons.simple_hcons Hannot.generate Hannot.hcons Name.hcons + let hcons = hashcons (Sorts.hcons, @@ -1361,7 +1378,7 @@ let hcons = hcons_construct, hcons_ind, hcons_con, - Name.hcons, + hcons_annot, Id.hcons) (* let hcons_types = hcons_constr *) @@ -1377,7 +1394,7 @@ type compacted_context = compacted_declaration list let debug_print_fix pr_constr ((t,i),(lna,tl,bl)) = let open Pp in - let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in + let fixl = Array.mapi (fun i na -> (na.binder_name,t.(i),tl.(i),bl.(i))) lna in hov 1 (str"fix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> @@ -1399,17 +1416,17 @@ let rec debug_print c = | Cast (c,_, t) -> hov 1 (str"(" ++ debug_print c ++ cut() ++ str":" ++ debug_print t ++ str")") - | Prod (Name(id),t,c) -> hov 1 + | Prod ({binder_name=Name id;_},t,c) -> hov 1 (str"forall " ++ Id.print id ++ str":" ++ debug_print t ++ str"," ++ spc() ++ debug_print c) - | Prod (Anonymous,t,c) -> hov 0 + | Prod ({binder_name=Anonymous;_},t,c) -> hov 0 (str"(" ++ debug_print t ++ str " ->" ++ spc() ++ debug_print c ++ str")") | Lambda (na,t,c) -> hov 1 - (str"fun " ++ Name.print na ++ str":" ++ + (str"fun " ++ Name.print na.binder_name ++ str":" ++ debug_print t ++ str" =>" ++ spc() ++ debug_print c) | LetIn (na,b,t,c) -> hov 0 - (str"let " ++ Name.print na ++ str":=" ++ debug_print b ++ + (str"let " ++ Name.print na.binder_name ++ str":=" ++ debug_print b ++ str":" ++ brk(1,2) ++ debug_print t ++ cut() ++ debug_print c) | App (c,l) -> hov 1 @@ -1434,7 +1451,7 @@ let rec debug_print c = hov 1 (str"cofix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,ty,bd) -> - Name.print na ++ str":" ++ debug_print ty ++ + Name.print na.binder_name ++ str":" ++ debug_print ty ++ cut() ++ str":=" ++ debug_print bd) (Array.to_list fixl)) ++ str"}") | Int i -> str"Int("++str (Uint63.to_string i) ++ str")" diff --git a/kernel/constr.mli b/kernel/constr.mli index fdc3296a6a..7fc57cdb8a 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -45,6 +45,7 @@ type case_info = in addition to the parameters of the related inductive type NOTE: "lets" are therefore excluded from the count NOTE: parameters of the inductive type are also excluded from the count *) + ci_relevance : Sorts.relevance; (* relevance of the predicate (not of the inductive!) *) ci_pp_info : case_printing (* not interpreted by the kernel *) } @@ -84,6 +85,7 @@ val mkEvar : existential -> constr (** Construct a sort *) val mkSort : Sorts.t -> types +val mkSProp : types val mkProp : types val mkSet : types val mkType : Univ.Universe.t -> types @@ -97,13 +99,13 @@ type cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast val mkCast : constr * cast_kind * constr -> constr (** Constructs the product [(x:t1)t2] *) -val mkProd : Name.t * types * types -> types +val mkProd : Name.t Context.binder_annot * types * types -> types (** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *) -val mkLambda : Name.t * types * constr -> constr +val mkLambda : Name.t Context.binder_annot * types * constr -> constr (** Constructs the product [let x = t1 : t2 in t3] *) -val mkLetIn : Name.t * constr * types * constr -> constr +val mkLetIn : Name.t Context.binder_annot * constr * types * constr -> constr (** [mkApp (f, [|t1; ...; tN|]] constructs the application {%html:(f t<sub>1</sub> ... t<sub>n</sub>)%} @@ -160,7 +162,7 @@ val mkCase : case_info * constr * constr * constr array -> constr where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) type ('constr, 'types) prec_declaration = - Name.t array * 'types array * 'constr array + Name.t Context.binder_annot array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration (* The array of [int]'s tells for each component of the array of @@ -213,9 +215,9 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Evar of 'constr pexistential | Sort of 'sort | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) - | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) - | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:C := B in D"] is represented as [LetIn (A,B,C,D)]. *) + | Prod of Name.t Context.binder_annot * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) + | Lambda of Name.t Context.binder_annot * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) + | LetIn of Name.t Context.binder_annot * 'constr * 'types * 'constr (** Concrete syntax ["let A:C := B in D"] is represented as [LetIn (A,B,C,D)]. *) | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. The {!mkApp} constructor also enforces the following invariant: @@ -297,13 +299,13 @@ val destSort : constr -> Sorts.t val destCast : constr -> constr * cast_kind * constr (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) -val destProd : types -> Name.t * types * types +val destProd : types -> Name.t Context.binder_annot * types * types (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) -val destLambda : constr -> Name.t * types * constr +val destLambda : constr -> Name.t Context.binder_annot * types * constr (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) -val destLetIn : constr -> Name.t * constr * types * constr +val destLetIn : constr -> Name.t Context.binder_annot * constr * types * constr (** Destructs an application *) val destApp : constr -> constr * constr array diff --git a/kernel/context.ml b/kernel/context.ml index 1cc6e79485..290e85294b 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -31,6 +31,27 @@ open Util open Names +type 'a binder_annot = { binder_name : 'a; binder_relevance : Sorts.relevance } + +let eq_annot eq {binder_name=na1;binder_relevance=r1} {binder_name=na2;binder_relevance=r2} = + eq na1 na2 && Sorts.relevance_equal r1 r2 + +let hash_annot h {binder_name=n;binder_relevance=r} = + Hashset.Combine.combinesmall (Sorts.relevance_hash r) (h n) + +let map_annot f {binder_name=na;binder_relevance} = + {binder_name=f na;binder_relevance} + +let make_annot x r = {binder_name=x;binder_relevance=r} + +let binder_name x = x.binder_name +let binder_relevance x = x.binder_relevance + +let annotR x = make_annot x Sorts.Relevant + +let nameR x = annotR (Name x) +let anonR = annotR Anonymous + (** Representation of contexts that can capture anonymous as well as non-anonymous variables. Individual declarations are then designated by de Bruijn indexes. *) module Rel = @@ -40,13 +61,14 @@ struct struct (* local declaration *) type ('constr, 'types) pt = - | LocalAssum of Name.t * 'types (** name, type *) - | LocalDef of Name.t * 'constr * 'types (** name, value, type *) + | LocalAssum of Name.t binder_annot * 'types (** name, type *) + | LocalDef of Name.t binder_annot * 'constr * 'types (** name, value, type *) + + let get_annot = function + | LocalAssum (na,_) | LocalDef (na,_,_) -> na (** Return the name bound by a given declaration. *) - let get_name = function - | LocalAssum (na,_) - | LocalDef (na,_,_) -> na + let get_name x = (get_annot x).binder_name (** Return [Some value] for local-declarations and [None] for local-assumptions. *) let get_value = function @@ -57,11 +79,13 @@ struct let get_type = function | LocalAssum (_,ty) | LocalDef (_,_,ty) -> ty - + + let get_relevance x = (get_annot x).binder_relevance + (** Set the name that is bound by a given declaration. *) let set_name na = function - | LocalAssum (_,ty) -> LocalAssum (na, ty) - | LocalDef (_,v,ty) -> LocalDef (na, v, ty) + | LocalAssum (x,ty) -> LocalAssum ({x with binder_name=na}, ty) + | LocalDef (x,v,ty) -> LocalDef ({x with binder_name=na}, v, ty) (** Set the type of the bound variable in a given declaration. *) let set_type ty = function @@ -92,20 +116,17 @@ struct let equal eq decl1 decl2 = match decl1, decl2 with | LocalAssum (n1,ty1), LocalAssum (n2, ty2) -> - Name.equal n1 n2 && eq ty1 ty2 + eq_annot Name.equal n1 n2 && eq ty1 ty2 | LocalDef (n1,v1,ty1), LocalDef (n2,v2,ty2) -> - Name.equal n1 n2 && eq v1 v2 && eq ty1 ty2 + eq_annot Name.equal n1 n2 && eq v1 v2 && eq ty1 ty2 | _ -> false (** Map the name bound by a given declaration. *) - let map_name f = function - | LocalAssum (na, ty) as decl -> - let na' = f na in - if na == na' then decl else LocalAssum (na', ty) - | LocalDef (na, v, ty) as decl -> - let na' = f na in - if na == na' then decl else LocalDef (na', v, ty) + let map_name f x = + let na = get_name x in + let na' = f na in + if na == na' then x else set_name na' x (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) @@ -120,7 +141,7 @@ struct | LocalAssum (na, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalAssum (na, ty') - | LocalDef (na, v, ty) as decl -> + | LocalDef (na, v, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalDef (na, v, ty') @@ -250,13 +271,14 @@ struct struct (** local declaration *) type ('constr, 'types) pt = - | LocalAssum of Id.t * 'types (** identifier, type *) - | LocalDef of Id.t * 'constr * 'types (** identifier, value, type *) + | LocalAssum of Id.t binder_annot * 'types (** identifier, type *) + | LocalDef of Id.t binder_annot * 'constr * 'types (** identifier, value, type *) + + let get_annot = function + | LocalAssum (na,_) | LocalDef (na,_,_) -> na (** Return the identifier bound by a given declaration. *) - let get_id = function - | LocalAssum (id,_) -> id - | LocalDef (id,_,_) -> id + let get_id x = (get_annot x).binder_name (** Return [Some value] for local-declarations and [None] for local-assumptions. *) let get_value = function @@ -268,10 +290,14 @@ struct | LocalAssum (_,ty) | LocalDef (_,_,ty) -> ty + let get_relevance x = (get_annot x).binder_relevance + (** Set the identifier that is bound by a given declaration. *) - let set_id id = function - | LocalAssum (_,ty) -> LocalAssum (id, ty) - | LocalDef (_, v, ty) -> LocalDef (id, v, ty) + let set_id id = + let set x = {x with binder_name = id} in + function + | LocalAssum (x,ty) -> LocalAssum (set x, ty) + | LocalDef (x, v, ty) -> LocalDef (set x, v, ty) (** Set the type of the bound variable in a given declaration. *) let set_type ty = function @@ -302,20 +328,17 @@ struct let equal eq decl1 decl2 = match decl1, decl2 with | LocalAssum (id1, ty1), LocalAssum (id2, ty2) -> - Id.equal id1 id2 && eq ty1 ty2 + eq_annot Id.equal id1 id2 && eq ty1 ty2 | LocalDef (id1, v1, ty1), LocalDef (id2, v2, ty2) -> - Id.equal id1 id2 && eq v1 v2 && eq ty1 ty2 + eq_annot Id.equal id1 id2 && eq v1 v2 && eq ty1 ty2 | _ -> false (** Map the identifier bound by a given declaration. *) - let map_id f = function - | LocalAssum (id, ty) as decl -> - let id' = f id in - if id == id' then decl else LocalAssum (id', ty) - | LocalDef (id, v, ty) as decl -> - let id' = f id in - if id == id' then decl else LocalDef (id', v, ty) + let map_id f x = + let id = get_id x in + let id' = f id in + if id == id' then x else set_id id' x (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) @@ -369,15 +392,17 @@ struct let of_rel_decl f = function | Rel.Declaration.LocalAssum (na,t) -> - LocalAssum (f na, t) + LocalAssum (map_annot f na, t) | Rel.Declaration.LocalDef (na,v,t) -> - LocalDef (f na, v, t) - - let to_rel_decl = function + LocalDef (map_annot f na, v, t) + + let to_rel_decl = + let name x = {binder_name=Name x.binder_name;binder_relevance=x.binder_relevance} in + function | LocalAssum (id,t) -> - Rel.Declaration.LocalAssum (Name id, t) + Rel.Declaration.LocalAssum (name id, t) | LocalDef (id,v,t) -> - Rel.Declaration.LocalDef (Name id,v,t) + Rel.Declaration.LocalDef (name id,v,t) end (** Named-context is represented as a list of declarations. @@ -430,7 +455,7 @@ struct gives [Var id1, Var id3]. All [idj] are supposed distinct. *) let to_instance mk l = let filter = function - | Declaration.LocalAssum (id, _) -> Some (mk id) + | Declaration.LocalAssum (id, _) -> Some (mk id.binder_name) | _ -> None in List.map_filter filter l @@ -441,8 +466,8 @@ module Compacted = module Declaration = struct type ('constr, 'types) pt = - | LocalAssum of Id.t list * 'types - | LocalDef of Id.t list * 'constr * 'types + | LocalAssum of Id.t binder_annot list * 'types + | LocalDef of Id.t binder_annot list * 'constr * 'types let map_constr f = function | LocalAssum (ids, ty) as decl -> diff --git a/kernel/context.mli b/kernel/context.mli index 8acae73680..7b67e54ba4 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -24,6 +24,27 @@ open Names +type 'a binder_annot = { binder_name : 'a; binder_relevance : Sorts.relevance } +val eq_annot : ('a -> 'a -> bool) -> 'a binder_annot -> 'a binder_annot -> bool + +val hash_annot : ('a -> int) -> 'a binder_annot -> int + +val map_annot : ('a -> 'b) -> 'a binder_annot -> 'b binder_annot + +val make_annot : 'a -> Sorts.relevance -> 'a binder_annot + +val binder_name : 'a binder_annot -> 'a +val binder_relevance : 'a binder_annot -> Sorts.relevance + +val annotR : 'a -> 'a binder_annot +(** Always Relevant *) + +val nameR : Id.t -> Name.t binder_annot +(** Relevant + Name *) + +val anonR : Name.t binder_annot +(** Relevant + Anonymous *) + (** Representation of contexts that can capture anonymous as well as non-anonymous variables. Individual declarations are then designated by de Bruijn indexes. *) module Rel : @@ -32,8 +53,10 @@ sig sig (* local declaration *) type ('constr, 'types) pt = - | LocalAssum of Name.t * 'types (** name, type *) - | LocalDef of Name.t * 'constr * 'types (** name, value, type *) + | LocalAssum of Name.t binder_annot * 'types (** name, type *) + | LocalDef of Name.t binder_annot * 'constr * 'types (** name, value, type *) + + val get_annot : _ pt -> Name.t binder_annot (** Return the name bound by a given declaration. *) val get_name : ('c, 't) pt -> Name.t @@ -44,6 +67,8 @@ sig (** Return the type of the name bound by a given declaration. *) val get_type : ('c, 't) pt -> 't + val get_relevance : ('c, 't) pt -> Sorts.relevance + (** Set the name that is bound by a given declaration. *) val set_name : Name.t -> ('c, 't) pt -> ('c, 't) pt @@ -87,7 +112,7 @@ sig (** Reduce all terms in a given declaration to a single value. *) val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a - val to_tuple : ('c, 't) pt -> Name.t * 'c option * 't + val to_tuple : ('c, 't) pt -> Name.t binder_annot * 'c option * 't (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) val drop_body : ('c, 't) pt -> ('c, 't) pt @@ -156,8 +181,10 @@ sig module Declaration : sig type ('constr, 'types) pt = - | LocalAssum of Id.t * 'types (** identifier, type *) - | LocalDef of Id.t * 'constr * 'types (** identifier, value, type *) + | LocalAssum of Id.t binder_annot * 'types (** identifier, type *) + | LocalDef of Id.t binder_annot * 'constr * 'types (** identifier, value, type *) + + val get_annot : _ pt -> Id.t binder_annot (** Return the identifier bound by a given declaration. *) val get_id : ('c, 't) pt -> Id.t @@ -168,6 +195,8 @@ sig (** Return the type of the name bound by a given declaration. *) val get_type : ('c, 't) pt -> 't + val get_relevance : ('c, 't) pt -> Sorts.relevance + (** Set the identifier that is bound by a given declaration. *) val set_id : Id.t -> ('c, 't) pt -> ('c, 't) pt @@ -208,8 +237,8 @@ sig (** Reduce all terms in a given declaration to a single value. *) val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a - val to_tuple : ('c, 't) pt -> Id.t * 'c option * 't - val of_tuple : Id.t * 'c option * 't -> ('c, 't) pt + val to_tuple : ('c, 't) pt -> Id.t binder_annot * 'c option * 't + val of_tuple : Id.t binder_annot * 'c option * 't -> ('c, 't) pt (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) val drop_body : ('c, 't) pt -> ('c, 't) pt @@ -276,8 +305,8 @@ sig module Declaration : sig type ('constr, 'types) pt = - | LocalAssum of Id.t list * 'types - | LocalDef of Id.t list * 'constr * 'types + | LocalAssum of Id.t binder_annot list * 'types + | LocalDef of Id.t binder_annot list * 'constr * 'types val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt val of_named_decl : ('c, 't) Named.Declaration.pt -> ('c, 't) pt diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 22de9bfad5..9b974c4ecc 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -21,6 +21,7 @@ open Term open Constr open Declarations open Univ +open Context module NamedDecl = Context.Named.Declaration module RelDecl = Context.Rel.Declaration @@ -134,12 +135,12 @@ let abstract_context hyps = | NamedDecl.LocalDef (id, b, t) -> let b = Vars.subst_vars subst b in let t = Vars.subst_vars subst t in - id, RelDecl.LocalDef (Name id, b, t) + id, RelDecl.LocalDef (map_annot Name.mk_name id, b, t) | NamedDecl.LocalAssum (id, t) -> let t = Vars.subst_vars subst t in - id, RelDecl.LocalAssum (Name id, t) + id, RelDecl.LocalAssum (map_annot Name.mk_name id, t) in - (decl :: ctx, id :: subst) + (decl :: ctx, id.binder_name :: subst) in Context.Named.fold_outside fold hyps ~init:([], []) @@ -159,6 +160,7 @@ type result = { cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; + cook_relevance : Sorts.relevance; cook_inline : inline; cook_context : Constr.named_context option; } @@ -241,6 +243,7 @@ let cook_constant ~hcons { from = cb; info } = cook_type = typ; cook_universes = univs; cook_private_univs = private_univs; + cook_relevance = cb.const_relevance; cook_inline = cb.const_inline_code; cook_context = Some const_hyps; } diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 89b5c60ad5..b0f143c47d 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -22,6 +22,7 @@ type result = { cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; + cook_relevance : Sorts.relevance; cook_inline : inline; cook_context : Constr.named_context option; } diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 6777e0c223..5551742c02 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -91,6 +91,7 @@ type constant_body = { const_hyps : Constr.named_context; (** New: younger hyp at top *) const_body : Constr.t Mod_subst.substituted constant_def; const_type : types; + const_relevance : Sorts.relevance; const_body_code : Cemitcodes.to_patch_substituted option; const_universes : universes; const_private_poly_univs : Univ.ContextSet.t option; @@ -133,7 +134,7 @@ v} type record_info = | NotRecord | FakeRecord -| PrimRecord of (Id.t * Label.t array * types array) array +| PrimRecord of (Id.t * Label.t array * Sorts.relevance array * types array) array type regular_inductive_arity = { mind_user_arity : types; @@ -166,7 +167,7 @@ type one_inductive_body = { mind_kelim : Sorts.family list; (** List of allowed elimination sorts *) - mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) + mind_nf_lc : (rel_context * types) array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) mind_consnrealargs : int array; (** Number of expected proper arguments of the constructors (w/o params) *) @@ -176,6 +177,8 @@ type one_inductive_body = { mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *) + mind_relevance : Sorts.relevance; + (** {8 Datas for bytecode compilation } *) mind_nb_constant : int; (** number of constant constructor *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 9e0230c3ba..de9a052096 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -114,6 +114,7 @@ let subst_const_body sub cb = Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_universes = cb.const_universes; const_private_poly_univs = cb.const_private_poly_univs; + const_relevance = cb.const_relevance; const_inline_code = cb.const_inline_code; const_typing_flags = cb.const_typing_flags } @@ -214,7 +215,7 @@ let subst_mind_packet sub mbp = mind_consnrealdecls = mbp.mind_consnrealdecls; mind_consnrealargs = mbp.mind_consnrealargs; mind_typename = mbp.mind_typename; - mind_nf_lc = Array.Smart.map (subst_mps sub) mbp.mind_nf_lc; + mind_nf_lc = Array.Smart.map (fun (ctx, c) -> Context.Rel.map (subst_mps sub) ctx, subst_mps sub c) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_ind_arity sub mbp.mind_arity; mind_user_lc = Array.Smart.map (subst_mps sub) mbp.mind_user_lc; @@ -222,6 +223,7 @@ let subst_mind_packet sub mbp = mind_nrealdecls = mbp.mind_nrealdecls; mind_kelim = mbp.mind_kelim; mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_relevance = mbp.mind_relevance; mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } @@ -230,10 +232,10 @@ let subst_mind_record sub r = match r with | NotRecord -> NotRecord | FakeRecord -> FakeRecord | PrimRecord infos -> - let map (id, ps, pb as info) = + let map (id, ps, rs, pb as info) = let pb' = Array.Smart.map (subst_mps sub) pb in if pb' == pb then info - else (id, ps, pb') + else (id, ps, rs, pb') in let infos' = Array.Smart.map map infos in if infos' == infos then r else PrimRecord infos' @@ -269,21 +271,32 @@ let inductive_make_projection ind mib ~proj_arg = match mib.mind_record with | NotRecord | FakeRecord -> None | PrimRecord infos -> + let _, labs, _, _ = infos.(snd ind) in Some (Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg - (pi2 infos.(snd ind)).(proj_arg)) + labs.(proj_arg)) let inductive_make_projections ind mib = match mib.mind_record with | NotRecord | FakeRecord -> None | PrimRecord infos -> + let _, labs, _, _ = infos.(snd ind) in let projs = Array.mapi (fun proj_arg lab -> Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab) - (pi2 infos.(snd ind)) + labs in Some projs +let relevance_of_projection_repr mib p = + let _mind,i = Names.Projection.Repr.inductive p in + match mib.mind_record with + | NotRecord | FakeRecord -> + CErrors.anomaly ~label:"relevance_of_projection" Pp.(str "not a projection") + | PrimRecord infos -> + let _,_,rs,_ = infos.(i) in + rs.(Names.Projection.Repr.arg p) + (** {6 Hash-consing of inductive declarations } *) let hcons_regular_ind_arity a = @@ -299,9 +312,8 @@ let hcons_ind_arity = let hcons_mind_packet oib = let user = Array.Smart.map Constr.hcons oib.mind_user_lc in - let nf = Array.Smart.map Constr.hcons oib.mind_nf_lc in - (* Special optim : merge [mind_user_lc] and [mind_nf_lc] if possible *) - let nf = if Array.equal (==) user nf then user else nf in + let map (ctx, c) = Context.Rel.map Constr.hcons ctx, Constr.hcons c in + let nf = Array.Smart.map map oib.mind_nf_lc in { oib with mind_typename = Names.Id.hcons oib.mind_typename; mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt; diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 23a44433b3..54a853fc81 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -70,6 +70,8 @@ val inductive_make_projection : Names.inductive -> mutual_inductive_body -> proj val inductive_make_projections : Names.inductive -> mutual_inductive_body -> Names.Projection.Repr.t array option +val relevance_of_projection_repr : mutual_inductive_body -> Names.Projection.Repr.t -> Sorts.relevance + (** {6 Kernel flags} *) (** A default, safe set of flags for kernel type-checking *) diff --git a/kernel/dune b/kernel/dune index 1f2d696a36..a8a87a3e95 100644 --- a/kernel/dune +++ b/kernel/dune @@ -3,13 +3,16 @@ (synopsis "The Coq Kernel") (public_name coq.kernel) (wrapped false) - (modules (:standard \ uint63_x86 uint63_amd64 write_uint63)) + (modules (:standard \ genOpcodeFiles uint63_x86 uint63_amd64 write_uint63)) (libraries lib byterun)) +(executable + (name genOpcodeFiles) + (modules genOpcodeFiles)) + (rule (targets copcodes.ml) - (deps (:h-file byterun/coq_instruct.h) make-opcodes make_opcodes.sh) - (action (bash "./make_opcodes.sh %{h-file} %{targets}"))) + (action (with-stdout-to %{targets} (run ./genOpcodeFiles.exe copml)))) (executable (name write_uint63) diff --git a/kernel/environ.ml b/kernel/environ.ml index ab046f02f7..97c9f8654a 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -59,7 +59,8 @@ type globals = { type stratification = { env_universes : UGraph.t; - env_engagement : engagement + env_engagement : engagement; + env_sprop_allowed : bool; } type val_kind = @@ -117,7 +118,9 @@ let empty_env = { env_nb_rel = 0; env_stratification = { env_universes = UGraph.initial_universes; - env_engagement = PredicativeSet }; + env_engagement = PredicativeSet; + env_sprop_allowed = false; + }; env_typing_flags = Declareops.safe_flags Conv_oracle.empty; retroknowledge = Retroknowledge.empty; indirect_pterms = Opaqueproof.empty_opaquetab } @@ -243,7 +246,7 @@ let is_impredicative_set env = | _ -> false let is_impredicative_sort env = function - | Sorts.Prop -> true + | Sorts.SProp | Sorts.Prop -> true | Sorts.Set -> is_impredicative_set env | Sorts.Type _ -> false @@ -432,6 +435,14 @@ let set_typing_flags c env = (* Unsafe *) if same_flags env.env_typing_flags c then env else { env with env_typing_flags = c } +let make_sprop_cumulative = map_universes UGraph.make_sprop_cumulative + +let set_allow_sprop b env = + { env with env_stratification = + { env.env_stratification with env_sprop_allowed = b } } + +let sprop_allowed env = env.env_stratification.env_sprop_allowed + (* Global constants *) let no_link_info = NotLinked @@ -537,7 +548,7 @@ let lookup_projection p env = match mib.mind_record with | NotRecord | FakeRecord -> anomaly ~label:"lookup_projection" Pp.(str "not a projection") | PrimRecord infos -> - let _,_,typs = infos.(i) in + let _,_,_,typs = infos.(i) in typs.(Projection.arg p) let get_projection env ind ~proj_arg = diff --git a/kernel/environ.mli b/kernel/environ.mli index 0df9b91c4a..8c6bc105c7 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -51,7 +51,8 @@ type globals type stratification = { env_universes : UGraph.t; - env_engagement : engagement + env_engagement : engagement; + env_sprop_allowed : bool; } type named_context_val = private { @@ -290,6 +291,9 @@ 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_allow_sprop : bool -> env -> env +val sprop_allowed : env -> bool val universes_of_global : env -> GlobRef.t -> AUContext.t diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml new file mode 100644 index 0000000000..6564954dfd --- /dev/null +++ b/kernel/genOpcodeFiles.ml @@ -0,0 +1,193 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** List of opcodes. + + It is used to generate the [coq_instruct.h], [coq_jumptbl.h] and + [copcodes.ml] files. + + If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c + with the arity of the instruction and maybe coq_tcode_of_code. +*) +let opcodes = + [| + "ACC0"; + "ACC1"; + "ACC2"; + "ACC3"; + "ACC4"; + "ACC5"; + "ACC6"; + "ACC7"; + "ACC"; + "PUSH"; + "PUSHACC0"; + "PUSHACC1"; + "PUSHACC2"; + "PUSHACC3"; + "PUSHACC4"; + "PUSHACC5"; + "PUSHACC6"; + "PUSHACC7"; + "PUSHACC"; + "POP"; + "ENVACC1"; + "ENVACC2"; + "ENVACC3"; + "ENVACC4"; + "ENVACC"; + "PUSHENVACC1"; + "PUSHENVACC2"; + "PUSHENVACC3"; + "PUSHENVACC4"; + "PUSHENVACC"; + "PUSH_RETADDR"; + "APPLY"; + "APPLY1"; + "APPLY2"; + "APPLY3"; + "APPLY4"; + "APPTERM"; + "APPTERM1"; + "APPTERM2"; + "APPTERM3"; + "RETURN"; + "RESTART"; + "GRAB"; + "GRABREC"; + "CLOSURE"; + "CLOSUREREC"; + "CLOSURECOFIX"; + "OFFSETCLOSUREM2"; + "OFFSETCLOSURE0"; + "OFFSETCLOSURE2"; + "OFFSETCLOSURE"; + "PUSHOFFSETCLOSUREM2"; + "PUSHOFFSETCLOSURE0"; + "PUSHOFFSETCLOSURE2"; + "PUSHOFFSETCLOSURE"; + "GETGLOBAL"; + "PUSHGETGLOBAL"; + "MAKEBLOCK"; + "MAKEBLOCK1"; + "MAKEBLOCK2"; + "MAKEBLOCK3"; + "MAKEBLOCK4"; + "SWITCH"; + "PUSHFIELDS"; + "GETFIELD0"; + "GETFIELD1"; + "GETFIELD"; + "SETFIELD0"; + "SETFIELD1"; + "SETFIELD"; + "PROJ"; + "ENSURESTACKCAPACITY"; + "CONST0"; + "CONST1"; + "CONST2"; + "CONST3"; + "CONSTINT"; + "PUSHCONST0"; + "PUSHCONST1"; + "PUSHCONST2"; + "PUSHCONST3"; + "PUSHCONSTINT"; + "ACCUMULATE"; + "MAKESWITCHBLOCK"; + "MAKEACCU"; + "MAKEPROD"; + "BRANCH"; + "CHECKADDINT63"; + "ADDINT63"; + "CHECKADDCINT63"; + "CHECKADDCARRYCINT63"; + "CHECKSUBINT63"; + "SUBINT63"; + "CHECKSUBCINT63"; + "CHECKSUBCARRYCINT63"; + "CHECKMULINT63"; + "CHECKMULCINT63"; + "CHECKDIVINT63"; + "CHECKMODINT63"; + "CHECKDIVEUCLINT63"; + "CHECKDIV21INT63"; + "CHECKLXORINT63"; + "CHECKLORINT63"; + "CHECKLANDINT63"; + "CHECKLSLINT63"; + "CHECKLSRINT63"; + "CHECKADDMULDIVINT63"; + "CHECKLSLINT63CONST1"; + "CHECKLSRINT63CONST1"; + "CHECKEQINT63"; + "CHECKLTINT63"; + "LTINT63"; + "CHECKLEINT63"; + "LEINT63"; + "CHECKCOMPAREINT63"; + "CHECKHEAD0INT63"; + "CHECKTAIL0INT63"; + "ISINT"; + "AREINT2"; + "STOP" + |] + +let pp_c_comment fmt = + Format.fprintf fmt "/* %a */" + +let pp_ocaml_comment fmt = + Format.fprintf fmt "(* %a *)" + +let pp_header isOcaml fmt = + Format.fprintf fmt "%a" + (fun fmt -> + (if isOcaml then pp_ocaml_comment else pp_c_comment) fmt + Format.pp_print_string) + "DO NOT EDIT: automatically generated by kernel/genOpcodeFiles.ml" + +let pp_with_commas fmt k = + Array.iteri (fun n s -> + Format.fprintf fmt " %a%s@." + k s + (if n + 1 < Array.length opcodes + then "," else "") + ) opcodes + +let pp_coq_instruct_h fmt = + let line = Format.fprintf fmt "%s@." in + pp_header false fmt; + line "#pragma once"; + line "enum instructions {"; + pp_with_commas fmt Format.pp_print_string; + line "};" + +let pp_coq_jumptbl_h fmt = + pp_with_commas fmt (fun fmt -> Format.fprintf fmt "&&coq_lbl_%s") + +let pp_copcodes_ml fmt = + pp_header true fmt; + Array.iteri (fun n s -> + Format.fprintf fmt "let op%s = %d@.@." s n + ) opcodes + +let usage () = + Format.eprintf "usage: %s [enum|jump|copml]@." Sys.argv.(0); + exit 1 + +let main () = + match Sys.argv.(1) with + | "enum" -> pp_coq_instruct_h Format.std_formatter + | "jump" -> pp_coq_jumptbl_h Format.std_formatter + | "copml" -> pp_copcodes_ml Format.std_formatter + | _ -> usage () + | exception Invalid_argument _ -> usage () + +let () = main () diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index a5dafc5ab5..4e6e595331 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -122,73 +122,106 @@ let check_cumulativity univs variances env_ar params data = (************************** Type checking *******************************) (************************************************************************) -type univ_info = { ind_squashed : bool; +type univ_info = { ind_squashed : bool; ind_has_relevant_arg : bool; ind_min_univ : Universe.t option; (* Some for template *) ind_univ : Universe.t } -let check_univ_leq env u info = +let check_univ_leq ?(is_real_arg=false) env u info = let ind_univ = info.ind_univ in - if type_in_type env || (UGraph.check_leq (universes env) u ind_univ) + let info = if not info.ind_has_relevant_arg && is_real_arg && not (Univ.Universe.is_sprop u) + then {info with ind_has_relevant_arg=true} + else info + in + (* Inductive types provide explicit lifting from SProp to other universes, so allow SProp <= any. *) + if type_in_type env || Univ.Universe.is_sprop u || UGraph.check_leq (universes env) u ind_univ then { info with ind_min_univ = Option.map (Universe.sup u) info.ind_min_univ } else if is_impredicative_univ env ind_univ then if Option.is_empty info.ind_min_univ then { info with ind_squashed = true } else raise (InductiveError BadUnivs) else raise (InductiveError BadUnivs) -let check_indices_matter env_params info indices = - let check_index d (info,env) = +let check_context_univs ~ctor env info ctx = + let check_one d (info,env) = let info = match d with | LocalAssum (_,t) -> (* could be retyping if it becomes available in the kernel *) let tj = Typeops.infer_type env t in - check_univ_leq env (Sorts.univ_of_sort tj.utj_type) info + check_univ_leq ~is_real_arg:ctor env (Sorts.univ_of_sort tj.utj_type) info | LocalDef _ -> info in info, push_rel d env in + fst (Context.Rel.fold_outside ~init:(info,env) check_one ctx) + +let check_indices_matter env_params info indices = if not (indices_matter env_params) then info - else fst (Context.Rel.fold_outside ~init:(info,env_params) check_index indices) + else check_context_univs ~ctor:false env_params info indices (* env_ar contains the inductives before the current ones in the block, and no parameters *) let check_arity env_params env_ar ind = let {utj_val=arity;utj_type=_} = Typeops.infer_type env_params ind.mind_entry_arity in let indices, ind_sort = Reduction.dest_arity env_params arity in let ind_min_univ = if ind.mind_entry_template then Some Universe.type0m else None in - let univ_info = {ind_squashed=false;ind_min_univ;ind_univ=Sorts.univ_of_sort ind_sort} in + let univ_info = { + ind_squashed=false; + ind_has_relevant_arg=false; + ind_min_univ; + ind_univ=Sorts.univ_of_sort ind_sort; + } + in let univ_info = check_indices_matter env_params univ_info indices in (* We do not need to generate the universe of the arity with params; if later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) let arity = it_mkProd_or_LetIn arity (Environ.rel_context env_params) in - push_rel (LocalAssum (Name ind.mind_entry_typename, arity)) env_ar, + let x = Context.make_annot (Name ind.mind_entry_typename) (Sorts.relevance_of_sort ind_sort) in + push_rel (LocalAssum (x, arity)) env_ar, (arity, indices, univ_info) -let check_constructor_univs env_ar_par univ_info (args,_) = +let check_constructor_univs env_ar_par info (args,_) = (* We ignore the output, positivity will check that it's the expected inductive type *) - (* NB: very similar to check_indices_matter but that will change with SProp *) - fst (Context.Rel.fold_outside ~init:(univ_info,env_ar_par) (fun d (univ_info,env) -> - let univ_info = match d with - | LocalDef _ -> univ_info - | LocalAssum (_,t) -> - (* could be retyping if it becomes available in the kernel *) - let tj = Typeops.infer_type env t in - check_univ_leq env (Sorts.univ_of_sort tj.utj_type) univ_info - in - univ_info, push_rel d env) - args) - -let check_constructors env_ar_par params lc (arity,indices,univ_info) = + check_context_univs ~ctor:true env_ar_par info args + +let check_constructors env_ar_par isrecord params lc (arity,indices,univ_info) = let lc = Array.map_of_list (fun c -> (Typeops.infer_type env_ar_par c).utj_val) lc in let splayed_lc = Array.map (Reduction.dest_prod_assum env_ar_par) lc in - let univ_info = if Array.length lc <= 1 then univ_info - else check_univ_leq env_ar_par Univ.Universe.type0 univ_info + let univ_info = match Array.length lc with + (* Empty type: all OK *) + | 0 -> univ_info + + (* SProp primitive records are OK, if we squash and become fakerecord also OK *) + | 1 when isrecord -> univ_info + + (* Unit and identity types must squash if SProp *) + | 1 -> check_univ_leq env_ar_par Univ.Universe.type0m univ_info + + (* More than 1 constructor: must squash if Prop/SProp *) + | _ -> check_univ_leq env_ar_par Univ.Universe.type0 univ_info in let univ_info = Array.fold_left (check_constructor_univs env_ar_par) univ_info splayed_lc in (* generalize the constructors over the parameters *) let lc = Array.map (fun c -> Term.it_mkProd_or_LetIn c params) lc in (arity, lc), (indices, splayed_lc), univ_info +let check_record data = + List.for_all (fun (_,(_,splayed_lc),info) -> + (* records must have all projections definable -> equivalent to not being squashed *) + not info.ind_squashed + (* relevant records must have at least 1 relevant argument *) + && (Univ.Universe.is_sprop info.ind_univ + || info.ind_has_relevant_arg) + && (match splayed_lc with + (* records must have 1 constructor with at least 1 argument, and no anonymous fields *) + | [|ctx,_|] -> + let module D = Context.Rel.Declaration in + List.exists D.is_local_assum ctx && + List.for_all (fun d -> not (D.is_local_assum d) + || not (Name.is_anonymous (D.get_name d))) + ctx + | _ -> false)) + data + (* Allowed eliminations *) (* Previous comment: *) @@ -199,16 +232,18 @@ let check_constructors env_ar_par params lc (arity,indices,univ_info) = (* - all_sorts in case of small, unitary Prop (not smashed) *) (* - logical_sorts in case of large, unitary Prop (smashed) *) -let all_sorts = [InProp;InSet;InType] -let small_sorts = [InProp;InSet] -let logical_sorts = [InProp] +let all_sorts = [InSProp;InProp;InSet;InType] +let small_sorts = [InSProp;InProp;InSet] +let logical_sorts = [InSProp;InProp] +let sprop_sorts = [InSProp] -let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_} = +let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_;ind_has_relevant_arg=_} = if not ind_squashed then all_sorts else match Sorts.family (Sorts.sort_of_univ ind_univ) with | InType -> assert false | InSet -> small_sorts | InProp -> logical_sorts + | InSProp -> sprop_sorts (* Returns the list [x_1, ..., x_n] of levels contributing to template polymorphism. The elements x_k is None if the k-th parameter (starting @@ -268,18 +303,38 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = in (* Params *) - let env_params = Typeops.check_context env_univs mie.mind_entry_params in - let params = Environ.rel_context env_params in + let env_params, params = Typeops.check_context env_univs mie.mind_entry_params in (* Arities *) let env_ar, data = List.fold_left_map (check_arity env_params) env_univs mie.mind_entry_inds in let env_ar_par = push_rel_context params env_ar in (* Constructors *) - let data = List.map2 (fun ind data -> check_constructors env_ar_par params ind.mind_entry_lc data) + let isrecord = match mie.mind_entry_record with + | Some (Some _) -> true + | Some None | None -> false + in + let data = List.map2 (fun ind data -> + check_constructors env_ar_par isrecord params ind.mind_entry_lc data) mie.mind_entry_inds data in + let record = mie.mind_entry_record in + let data, record = match record with + | None | Some None -> data, record + | Some (Some _) -> + if check_record data then + data, record + else + (* if someone tried to declare a record as SProp but it can't + be primitive we must squash. *) + let data = List.map (fun (a,b,univs) -> + a,b,check_univ_leq env_ar_par Univ.Universe.type0m univs) + data + in + data, Some None + in + let () = match mie.mind_entry_variance with | None -> () | Some variances -> @@ -298,4 +353,4 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = Environ.push_rel_context ctx env in - env_ar_par, univs, mie.mind_entry_variance, params, Array.of_list data + env_ar_par, univs, mie.mind_entry_variance, record, params, Array.of_list data diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index 2598548f3f..ad51af66a2 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -17,6 +17,7 @@ open Declarations - environment with inductives + parameters in rel context - abstracted universes - checked variance info + - record entry (checked to be OK) - parameters - for each inductive, (arity * constructors) (with params) @@ -26,6 +27,7 @@ open Declarations val typecheck_inductive : env -> mutual_inductive_entry -> env * universes * Univ.Variance.t array option + * Names.Id.t array option option * Constr.rel_context * ((inductive_arity * Constr.types array) * (Constr.rel_context * (Constr.rel_context * Constr.types) array) * diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 8f06e1e4b8..009eb3da38 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -173,7 +173,9 @@ let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lrecparams) = let specif = (lookup_mind_specif env mi, u) in let ty = type_of_inductive env specif in let env' = - let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lrecparams) in + let r = (snd (fst specif)).mind_relevance in + let anon = Context.make_annot Anonymous r in + let decl = LocalAssum (anon, hnf_prod_applist env ty lrecparams) in push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: @@ -186,8 +188,8 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = if Int.equal n 0 then (ienv,c) else let c' = whd_all env c in match kind c' with - Prod(na,a,b) -> - let ienv' = ienv_push_var ienv (na,a,mk_norec) in + Prod(na,a,b) -> + let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b | _ -> assert false @@ -215,7 +217,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = let x,largs = decompose_app (whd_all env c) in match kind x with - | Prod (na,b,d) -> + | Prod (na,b,d) -> let () = assert (List.is_empty largs) in (** If one of the inductives of the mutually inductive block occurs in the left-hand side of a product, then @@ -406,8 +408,6 @@ let used_section_variables env inds = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) let rel_list n m = Array.to_list (rel_vect n m) -exception UndefinableExpansion - (** From a rel context describing the constructor arguments, build an expansion function. The term built is expecting to be substituted first by @@ -416,7 +416,9 @@ let compute_projections (kn, i as ind) mib = let pkt = mib.mind_packets.(i) in let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in - let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in + let (ctx, cty) = pkt.mind_nf_lc.(0) in + let cty = it_mkProd_or_LetIn cty ctx in + let rctx, _ = decompose_prod_assum (substl subst cty) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in (** We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not @@ -431,7 +433,7 @@ let compute_projections (kn, i as ind) mib = mkRel 1 :: List.map (lift 1) subst in subst in - let projections decl (i, j, labs, pbs, letsubst) = + let projections decl (i, j, labs, rs, pbs, letsubst) = match decl with | LocalDef (_na,c,_t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] @@ -443,10 +445,11 @@ let compute_projections (kn, i as ind) mib = (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) let letsubst = c2 :: letsubst in - (i, j+1, labs, pbs, letsubst) + (i, j+1, labs, rs, pbs, letsubst) | LocalAssum (na,t) -> - match na with + match na.Context.binder_name with | Name id -> + let r = na.Context.binder_relevance in let lab = Label.of_id id in let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:i lab in (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] @@ -458,14 +461,15 @@ let compute_projections (kn, i as ind) mib = (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] to [params, x:I |- t(proj1 x,..,projj x)] *) let fterm = mkProj (Projection.make kn false, mkRel 1) in - (i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst) - | Anonymous -> raise UndefinableExpansion + (i + 1, j + 1, lab :: labs, r :: rs, projty :: pbs, fterm :: letsubst) + | Anonymous -> assert false (* checked by indTyping *) in - let (_, _, labs, pbs, _letsubst) = - List.fold_right projections ctx (0, 1, [], [], paramsletsubst) + let (_, _, labs, rs, pbs, _letsubst) = + List.fold_right projections ctx (0, 1, [], [], [], paramsletsubst) in - Array.of_list (List.rev labs), - Array.of_list (List.rev pbs) + Array.of_list (List.rev labs), + Array.of_list (List.rev rs), + Array.of_list (List.rev pbs) let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in @@ -475,13 +479,17 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite (* Check one inductive *) let build_one_packet (id,cnames) ((arity,lc),(indices,splayed_lc),kelim) recarg = (* Type of constructors in normal form *) - let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b (d@paramsctxt)) splayed_lc in + let nf_lc = Array.map (fun (d, b) -> (d@paramsctxt, b)) splayed_lc in let consnrealdecls = Array.map (fun (d,_) -> Context.Rel.length d) splayed_lc in let consnrealargs = Array.map (fun (d,_) -> Context.Rel.nhyps d) - splayed_lc in + splayed_lc in + let mind_relevance = match arity with + | RegularArity { mind_sort;_ } -> Sorts.relevance_of_sort mind_sort + | TemplateArity _ -> Sorts.Relevant + in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in let transf num = @@ -508,8 +516,9 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite mind_consnrealargs = consnrealargs; mind_user_lc = lc; mind_nf_lc = nf_lc; - mind_recargs = recarg; - mind_nb_constant = !nconst; + mind_recargs = recarg; + mind_relevance; + mind_nb_constant = !nconst; mind_nb_args = !nblock; mind_reloc_tbl = rtbl; } in @@ -532,24 +541,12 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite in let record_info = match isrecord with | Some (Some rid) -> - let is_record pkt = - if Array.length pkt.mind_consnames != 1 then - user_err ~hdr:"build_inductive" - Pp.(str "Primitive records must have exactly one constructor.") - else if pkt.mind_consnrealargs.(0) = 0 then - user_err ~hdr:"build_inductive" - Pp.(str "Primitive records must have at least one constructor argument.") - else List.exists (Sorts.family_equal Sorts.InType) pkt.mind_kelim - in (** The elimination criterion ensures that all projections can be defined. *) - if Array.for_all is_record packets then - let map i id = - let labs, projs = compute_projections (kn, i) mib in - (id, labs, projs) - in - try PrimRecord (Array.mapi map rid) - with UndefinableExpansion -> FakeRecord - else FakeRecord + let map i id = + let labs, rs, projs = compute_projections (kn, i) mib in + (id, labs, rs, projs) + in + PrimRecord (Array.mapi map rid) | Some None -> FakeRecord | None -> NotRecord in @@ -560,7 +557,7 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar_par, univs, variance, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in + let (env_ar_par, univs, variance, record, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in (* Then check positivity conditions *) let chkpos = (Environ.typing_flags env).check_guarded in let names = Array.map_of_list (fun entry -> entry.mind_entry_typename, entry.mind_entry_consnames) @@ -572,5 +569,5 @@ let check_inductive env kn mie = in (* Build the inductive packets *) build_inductive env names mie.mind_entry_private univs variance - paramsctxt kn mie.mind_entry_record mie.mind_entry_finite + paramsctxt kn record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 848ae65c51..7452038ba5 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -188,13 +188,17 @@ let instantiate_universes env ctx ar argsorts = (* Non singleton type not containing types are interpretable in Set *) else if is_type0_univ level then Sorts.set (* This is a Type with constraints *) - else Sorts.Type level + else Sorts.sort_of_univ level in (ctx, ty) (* Type of an inductive type *) -let type_of_inductive_gen ?(polyprop=true) env ((_mib,mip),u) paramtyps = +let relevance_of_inductive env ind = + let _, mip = lookup_mind_specif env ind in + mip.mind_relevance + +let type_of_inductive_gen ?(polyprop=true) env ((_,mip),u) paramtyps = match mip.mind_arity with | RegularArity a -> subst_instance_constr u a.mind_user_arity | TemplateArity ar -> @@ -226,7 +230,10 @@ let type_of_inductive_knowing_parameters env ?(polyprop=true) mip args = (* The max of an array of universes *) let cumulate_constructor_univ u = let open Sorts in function - | Prop -> u + | SProp | Prop -> + (* SProp is non cumulative but allowed in constructors of any + inductive (except non-sprop primitive records) *) + u | Set -> Universe.sup Universe.type0 u | Type u' -> Universe.sup u u' @@ -251,7 +258,11 @@ let constrained_type_of_constructor (_cstr,u as cstru) (mib,_mip as ind) = let arities_of_specif (kn,u) (mib,mip) = let specif = mip.mind_nf_lc in - Array.map (constructor_instantiate kn u mib) specif + let map (ctx, c) = + let cty = Term.it_mkProd_or_LetIn c ctx in + constructor_instantiate kn u mib cty + in + Array.map map specif let arities_of_constructors ind specif = arities_of_specif (fst (fst ind), snd ind) specif @@ -294,16 +305,12 @@ let build_dependent_inductive ind (_,mip) params = @ Context.Rel.to_extended_list mkRel 0 realargs) (* This exception is local *) -exception LocalArity of (Sorts.family * Sorts.family * arity_error) option +exception LocalArity of (Sorts.family list * Sorts.family * Sorts.family * arity_error) option let check_allowed_sort ksort specif = - let open Sorts in - let eq_ksort s = match ksort, s with - | InProp, InProp | InSet, InSet | InType, InType -> true - | _ -> false in - if not (CList.exists eq_ksort (elim_sorts specif)) then + if not (CList.exists (Sorts.family_equal ksort) (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in - raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) + raise (LocalArity (Some(elim_sorts specif, ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity ind specif params in @@ -317,7 +324,7 @@ let is_correct_arity env c pj ind specif params = srec (push_rel (LocalAssum (na1,a1)) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) - let env' = push_rel (LocalAssum (na1,a1)) env in + let env' = push_rel (LocalAssum (na1,a1)) env in let ksort = match kind (whd_all env' a2) with | Sort s -> Sorts.family s | _ -> raise (LocalArity None) in @@ -333,7 +340,7 @@ let is_correct_arity env c pj ind specif params = in try srec env pj.uj_type (List.rev arsign) with LocalArity kinds -> - error_elim_arity env ind (elim_sorts specif) c pj kinds + error_elim_arity env ind c pj kinds (************************************************************************) @@ -342,7 +349,8 @@ let is_correct_arity env c pj ind specif params = (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) let build_branches_type (ind,u) (_,mip as specif) params p = - let build_one_branch i cty = + let build_one_branch i (ctx, c) = + let cty = Term.it_mkProd_or_LetIn c ctx in let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (cstrsign,ccl) = Term.decompose_prod_assum typi in let nargs = Context.Rel.length cstrsign in @@ -375,13 +383,14 @@ let type_case_branches env (pind,largs) pj c = (************************************************************************) (* Checking the case annotation is relevant *) -let check_case_info env (indsp,u) ci = +let check_case_info env (indsp,u) r ci = let (mib,mip as spec) = lookup_mind_specif env indsp in if not (eq_ind indsp ci.ci_ind) || not (Int.equal mib.mind_nparams ci.ci_npar) || not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) || not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) || + not (ci.ci_relevance == r) || is_primitive_record spec then raise (TypeError(env,WrongCaseInfo((indsp,u),ci))) @@ -570,7 +579,9 @@ let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = - let decl = LocalAssum (Anonymous, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in + let r = specif.mind_relevance in + let anon = Context.make_annot Anonymous r in + let decl = LocalAssum (anon, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in @@ -591,12 +602,14 @@ let rec ienv_decompose_prod (env,_ as ienv) n c = let dummy_univ = Level.(make (UGlobal.make (DirPath.make [Id.of_string "implicit"]) 0)) let dummy_implicit_sort = mkType (Universe.make dummy_univ) let lambda_implicit_lift n a = - let lambda_implicit a = mkLambda (Anonymous, dummy_implicit_sort, a) in + let anon = Context.make_annot Anonymous Sorts.Relevant in + let lambda_implicit a = mkLambda (anon, dummy_implicit_sort, a) in iterate lambda_implicit n (lift n a) (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) let abstract_mind_lc ntyps npars lc = + let lc = Array.map (fun (ctx, c) -> Term.it_mkProd_or_LetIn c ctx) lc in if Int.equal npars 0 then lc else @@ -1016,7 +1029,7 @@ let check_one_fix renv recpos trees def = check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body else match kind body with - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b @@ -1049,7 +1062,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = match kind (whd_all env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then - let env' = push_rel (LocalAssum (x,a)) env in + let env' = push_rel (LocalAssum (x,a)) env in if Int.equal n (k + 1) then (* get the inductive type of the fixpoint *) let (mind, _) = @@ -1062,8 +1075,19 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = (mind, (env', b)) else check_occur env' (n+1) b else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call.") - | _ -> raise_err env i NotEnoughAbstractionInFixBody in - check_occur fixenv 1 def in + | _ -> raise_err env i NotEnoughAbstractionInFixBody + in + let ((ind, _), _) as res = check_occur fixenv 1 def in + let _, ind = lookup_mind_specif env ind in + (* recursive sprop means non record with projections -> squashed *) + if Sorts.Irrelevant == ind.mind_relevance + then + begin + if names.(i).Context.binder_relevance == Sorts.Relevant + then raise_err env i FixpointOnIrrelevantInductive + end; + res + in (* Do it on every fixpoint *) let rv = Array.map2_i find_ind nvect bodies in (Array.map fst rv, Array.map snd rv) @@ -1106,7 +1130,7 @@ let rec codomain_is_coind env c = let b = whd_all env c in match kind b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (LocalAssum (x,a)) env) b + codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> (try find_coinductive env b with Not_found -> @@ -1144,7 +1168,7 @@ let check_one_cofix env nbfix def deftype = | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> let () = assert (List.is_empty args) in if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 3c1464c6c9..997a620742 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -45,6 +45,8 @@ val constrained_type_of_inductive : env -> mind_specif puniverses -> types const val constrained_type_of_inductive_knowing_parameters : env -> mind_specif puniverses -> types Lazy.t array -> types constrained +val relevance_of_inductive : env -> inductive -> Sorts.relevance + val type_of_inductive : env -> mind_specif puniverses -> types val type_of_inductive_knowing_parameters : @@ -93,7 +95,7 @@ val inductive_sort_family : one_inductive_body -> Sorts.family (** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) -val check_case_info : env -> pinductive -> case_info -> unit +val check_case_info : env -> pinductive -> Sorts.relevance -> case_info -> unit (** {6 Guard conditions for fix and cofix-points. } *) @@ -139,4 +141,4 @@ val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec val lambda_implicit_lift : int -> constr -> constr -val abstract_mind_lc : int -> Int.t -> constr array -> constr array +val abstract_mind_lc : int -> Int.t -> (rel_context * constr) array -> constr array diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 5108744bde..59c1d5890f 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -26,6 +26,7 @@ Conv_oracle Environ Primred CClosure +Retypeops Reduction Clambda Nativelambda diff --git a/kernel/make-opcodes b/kernel/make-opcodes deleted file mode 100644 index e1371b3d0c..0000000000 --- a/kernel/make-opcodes +++ /dev/null @@ -1,3 +0,0 @@ -$1=="enum" {n=0; next; } - {printf("(* THIS FILE IS GENERATED. DON'T EDIT. *)\n\n"); - for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}} diff --git a/kernel/make_opcodes.sh b/kernel/make_opcodes.sh deleted file mode 100755 index bb8aba2f07..0000000000 --- a/kernel/make_opcodes.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -script_dir="$(dirname "$0")" -tr -d "\r" < "${1}" | sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' | awk -f "$script_dir"/make-opcodes > "${2}" diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index cd675653cb..9397772415 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -339,9 +339,6 @@ let subst_retro_action subst action = | Register_type(prim,c) -> let c' = subst_constant subst c in if c == c' then action else Register_type(prim, c') - | Register_inline(c) -> - let c' = subst_constant subst c in - if c == c' then action else Register_inline(c') (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 421d932d9a..2de5faa6df 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -80,6 +80,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in + assert (j.uj_val == c); (* relevances should already be correct here *) let typ = cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in @@ -101,6 +102,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in + assert (j.uj_val == c); (* relevances should already be correct here *) let typ = cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index df60899b95..2dab14e732 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -11,6 +11,7 @@ open CErrors open Names open Constr +open Context open Declarations open Util open Nativevalues @@ -763,7 +764,7 @@ let empty_env univ () = } let push_rel env id = - let local = fresh_lname id in + let local = fresh_lname id.binder_name in local, { env with env_rel = MLlocal local :: env.env_rel; env_bound = env.env_bound + 1 @@ -772,7 +773,7 @@ let push_rel env id = let push_rels env ids = let lnames, env_rel = Array.fold_left (fun (names,env_rel) id -> - let local = fresh_lname id in + let local = fresh_lname id.binder_name in (local::names, MLlocal local::env_rel)) ([],env.env_rel) ids in Array.of_list (List.rev lnames), { env with env_rel = env_rel; @@ -1945,7 +1946,7 @@ let compile_mind mb mind stack = let tbl = ob.mind_reloc_tbl in (* Building info *) let ci = { ci_ind = ind; ci_npar = nparams; - ci_cstr_nargs = [|0|]; + ci_cstr_nargs = [|0|]; ci_relevance = ob.mind_relevance; ci_cstr_ndecls = [||] (*FIXME*); ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in let asw = { asw_ind = ind; asw_prefix = ""; asw_ci = ci; @@ -1968,7 +1969,7 @@ let compile_mind mb mind stack = let projs = match mb.mind_record with | NotRecord | FakeRecord -> [] | PrimRecord info -> - let _, _, pbs = info.(i) in + let _, _, _, pbs = info.(i) in Array.fold_left_i add_proj [] pbs in projs @ constructors @ gtype :: accu :: stack diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 0869f94042..ec3a7b893d 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -26,9 +26,9 @@ type lambda = | Lmeta of metavariable * lambda (* type *) | Levar of Evar.t * lambda array (* arguments *) | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Lrec of Name.t * lambda - | Llet of Name.t * lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Lrec of Name.t Context.binder_annot * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of prefix * pconstant | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) @@ -51,9 +51,9 @@ type lambda = | Llazy | Lforce -and lam_branches = (constructor * Name.t array * lambda) array +and lam_branches = (constructor * Name.t Context.binder_annot array * lambda) array -and fix_decl = Name.t array * lambda array * lambda array +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array type evars = { evars_val : existential -> constr option; @@ -362,7 +362,8 @@ let prim env kn p args = Lprim(prefix, kn, p, args) let expand_prim env kn op arity = - let ids = Array.make arity Anonymous in + (* primitives are always Relevant *) + let ids = Array.make arity Context.anonR in let args = make_args arity 1 in Llam(ids, prim env kn op args) @@ -395,7 +396,7 @@ module Cache = let get_construct_info cache env c : constructor_info = try ConstrTable.find cache c - with Not_found -> + with Not_found -> let ((mind,j), i) = c in let oib = lookup_mind mind env in let oip = oib.mind_packets.(j) in @@ -518,8 +519,10 @@ let rec lambda_of_constr cache env sigma c = else match b with | Llam(ids, body) when Int.equal (Array.length ids) arity -> (cn, ids, body) - | _ -> - let ids = Array.make arity Anonymous in + | _ -> + (** TODO relevance *) + let anon = Context.make_annot Anonymous Sorts.Relevant in + let ids = Array.make arity anon in let args = make_args arity 1 in let ll = lam_lift arity b in (cn, ids, mkLapp ll args) in diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index eb06522a33..b0de257a27 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -21,9 +21,9 @@ type lambda = | Lmeta of metavariable * lambda (* type *) | Levar of Evar.t * lambda array (* arguments *) | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Lrec of Name.t * lambda - | Llet of Name.t * lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Lrec of Name.t Context.binder_annot * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of prefix * pconstant | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) @@ -45,9 +45,9 @@ type lambda = | Llazy | Lforce -and lam_branches = (constructor * Name.t array * lambda) array +and lam_branches = (constructor * Name.t Context.binder_annot array * lambda) array -and fix_decl = Name.t array * lambda array * lambda array +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array type evars = { evars_val : existential -> constr option; @@ -55,8 +55,8 @@ type evars = val empty_evars : evars -val decompose_Llam : lambda -> Name.t array * lambda -val decompose_Llam_Llet : lambda -> (Name.t * lambda option) array * lambda +val decompose_Llam : lambda -> Name.t Context.binder_annot array * lambda +val decompose_Llam_Llet : lambda -> (Name.t Context.binder_annot * lambda option) array * lambda val is_lazy : constr -> bool val mk_lazy : lambda -> lambda diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index a6b48cd7e3..3eb51ffc59 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -117,11 +117,11 @@ let mk_ind_accu ind u = let mk_sort_accu s u = let open Sorts in match s with - | Prop | Set -> mk_accu (Asort s) + | SProp | Prop | Set -> mk_accu (Asort s) | Type s -> let u = Univ.Instance.of_array u in - let s = Univ.subst_instance_universe u s in - mk_accu (Asort (Type s)) + let s = Sorts.sort_of_univ (Univ.subst_instance_universe u s) in + mk_accu (Asort s) let mk_var_accu id = mk_accu (Avar id) diff --git a/kernel/primred.ml b/kernel/primred.ml index d95d7de7aa..d6d0a6143a 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -44,10 +44,6 @@ let add_retroknowledge env action = { retro with retro_cmp = Some r } in set_retroknowledge env retro - | Register_inline(c) -> - let (cb,r) = lookup_constant_key c env in - let cb = {cb with Declarations.const_inline_code = true} in - add_constant_key c cb !(fst r) env let get_int_type env = match env.retroknowledge.retro_int63 with diff --git a/kernel/reduction.ml b/kernel/reduction.ml index b583d33e29..2f11f3dd6b 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -193,8 +193,6 @@ type 'a extended_conversion_function = 'a -> 'a -> unit exception NotConvertible -exception NotConvertibleVect of int - (* Convertibility of sorts *) @@ -293,12 +291,6 @@ let conv_table_key infos k1 k2 cuniv = exception IrregularPatternShape -let rec skip_pattern n c = - if Int.equal n 0 then c - else match kind c with - | Lambda (_, _, c) -> skip_pattern (pred n) c - | _ -> raise IrregularPatternShape - let unfold_ref_with_args infos tab fl v = match unfold_reference infos tab fl with | Def def -> Some (def, v) @@ -310,6 +302,7 @@ let unfold_ref_with_args infos tab fl v = type conv_tab = { cnv_inf : clos_infos; + relevances : Sorts.relevance list; lft_tab : clos_tab; rgt_tab : clos_tab; } @@ -319,9 +312,23 @@ type conv_tab = { (** The same heap separation invariant must hold for the fconstr arguments passed to each respective side of the conversion function below. *) +let push_relevance infos r = + { infos with relevances = r.Context.binder_relevance :: infos.relevances } + +let rec skip_pattern infos n c1 c2 = + if Int.equal n 0 then infos, c1, c2 + else match kind c1, kind c2 with + | Lambda (x, _, c1), Lambda (_, _, c2) -> skip_pattern (push_relevance infos x) (pred n) c1 c2 + | _ -> raise IrregularPatternShape + +let is_irrelevant infos lft c = + let env = info_env infos.cnv_inf in + try Retypeops.relevance_of_fterm env infos.relevances lft c == Sorts.Irrelevant with _ -> false + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = - eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv + try eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv + with NotConvertible when is_irrelevant infos lft1 term1 && is_irrelevant infos lft2 term2 -> cuniv (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = @@ -399,14 +406,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = match unfold_projection infos.cnv_inf p2 with | Some s2 -> eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv - | None -> + | None -> if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) - && compare_stack_shape v1 v2 then + && compare_stack_shape v1 v2 then let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 u1 - else (* Two projections in WHNF: unfold *) + else (* Two projections in WHNF: unfold *) raise NotConvertible) | (FProj (p1,c1), t2) -> @@ -446,22 +453,22 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* Inconsistency: we tolerate that v1, v2 contain shift and update but we throw them away *) if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); - let (_,ty1,bd1) = destFLambda mk_clos hd1 in + anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); + let (x1,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in - ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv + ccnv CONV l2r (push_relevance infos x1) (el_lift el1) (el_lift el2) bd1 bd2 cuniv - | (FProd (_, c1, c2, e), FProd (_, c'1, c'2, e')) -> + | (FProd (x1, c1, c2, e), FProd (_, c'1, c'2, e')) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); (* Luo's system *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) (mk_clos (subs_lift e) c2) (mk_clos (subs_lift e') c'2) cuniv + ccnv cv_pb l2r (push_relevance infos x1) (el_lift el1) (el_lift el2) (mk_clos (subs_lift e) c2) (mk_clos (subs_lift e') c'2) cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> @@ -470,19 +477,21 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | _ -> anomaly (Pp.str "conversion was given unreduced term (FLambda).") in - let (_,_ty1,bd1) = destFLambda mk_clos hd1 in + let (x1,_ty1,bd1) = destFLambda mk_clos hd1 in + let infos = push_relevance infos x1 in eqappr CONV l2r infos - (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv + (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv | (_, FLambda _) -> let () = match v2 with | [] -> () | _ -> anomaly (Pp.str "conversion was given unreduced term (FLambda).") in - let (_,_ty2,bd2) = destFLambda mk_clos hd2 in + let (x2,_ty2,bd2) = destFLambda mk_clos hd2 in + let infos = push_relevance infos x2 in eqappr CONV l2r infos - (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv - + (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv + (* only one constant, defined var or defined rel *) | (FFlex fl1, c2) -> begin match unfold_ref_with_args infos.cnv_inf infos.lft_tab fl1 v1 with @@ -568,8 +577,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) - | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> - if Int.equal i1 i2 && Array.equal Int.equal op1 op2 + | (FFix (((op1, i1),(na1,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> + if Int.equal i1 i2 && Array.equal Int.equal op1 op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in @@ -580,12 +589,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = + let infos = Array.fold_left push_relevance infos na1 in convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible - | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> + | (FCoFix ((op1,(na1,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> if Int.equal op1 op2 then let n = Array.length cl1 in @@ -597,8 +608,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = + let infos = Array.fold_left push_relevance infos na1 in convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible @@ -662,8 +675,8 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = (** Skip comparison of the pattern types. We know that the two terms are living in a common type, thus this check is useless. *) - let fold n c1 c2 cuniv = match skip_pattern n c1, skip_pattern n c2 with - | (c1, c2) -> + let fold n c1 c2 cuniv = match skip_pattern infos n c1 c2 with + | (infos, c1, c2) -> let lft1 = el_liftn n lft1 in let lft2 = el_liftn n lft2 in let e1 = subs_liftn n e1 in @@ -680,6 +693,7 @@ let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let infos = create_clos_infos ~evars reds env in let infos = { cnv_inf = infos; + relevances = List.map Context.Rel.Declaration.get_relevance (rel_context env); lft_tab = create_tab (); rgt_tab = create_tab (); } in @@ -701,7 +715,8 @@ let check_sort_cmp_universes env pb s0 s1 univs = | CONV -> check_eq univs u0 u1 in match (s0,s1) with - | Prop, Prop | Set, Set -> () + | SProp, SProp | Prop, Prop | Set, Set -> () + | SProp, _ | _, SProp -> raise NotConvertible | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible | Set, Prop -> raise NotConvertible | Set, Type u -> check_pb Univ.type0_univ u @@ -749,7 +764,8 @@ let infer_cmp_universes env pb s0 s1 univs = | CONV -> infer_eq univs u0 u1 in match (s0,s1) with - | Prop, Prop | Set, Set -> univs + | SProp, SProp | Prop, Prop | Set, Set -> univs + | SProp, _ | _, SProp -> raise NotConvertible | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs | Set, Prop -> raise NotConvertible | Set, Type u -> infer_pb Univ.type0_univ u @@ -894,7 +910,7 @@ let dest_prod env = let t = whd_all env c in match kind t with | Prod (n,a,c0) -> - let d = LocalAssum (n,a) in + let d = LocalAssum (n,a) in decrec (push_rel d env) (Context.Rel.add d m) c0 | _ -> m,t in diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 0408dbf057..7dcafb7d7b 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -27,7 +27,6 @@ val nf_betaiota : env -> constr -> constr s conversion functions *) exception NotConvertible -exception NotConvertibleVect of int type 'a kernel_conversion_function = env -> 'a -> 'a -> unit type 'a extended_conversion_function = diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 18fafdb6d3..e1c4cec5b5 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -38,4 +38,3 @@ let empty = { type action = | Register_ind of CPrimitives.prim_ind * inductive | Register_type of CPrimitives.prim_type * Constant.t - | Register_inline of Constant.t diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 1554fe88da..09e8140308 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -25,4 +25,3 @@ val empty : retroknowledge type action = | Register_ind of CPrimitives.prim_ind * inductive | Register_type of CPrimitives.prim_type * Constant.t - | Register_inline of Constant.t diff --git a/kernel/retypeops.ml b/kernel/retypeops.ml new file mode 100644 index 0000000000..204dec3eda --- /dev/null +++ b/kernel/retypeops.ml @@ -0,0 +1,116 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Constr +open Declarations +open Environ +open Context + +module RelDecl = Context.Rel.Declaration + +let relevance_of_rel env n = + let decl = lookup_rel n env in + RelDecl.get_relevance decl + +let relevance_of_var env x = + let decl = lookup_named x env in + Context.Named.Declaration.get_relevance decl + +let relevance_of_constant env c = + let decl = lookup_constant c env in + decl.const_relevance + +let relevance_of_constructor env ((mi,i),_) = + let decl = lookup_mind mi env in + let packet = decl.mind_packets.(i) in + packet.mind_relevance + +let relevance_of_projection env p = + let mind = Projection.mind p in + let mib = lookup_mind mind env in + Declareops.relevance_of_projection_repr mib (Projection.repr p) + +let rec relevance_of_rel_extra env extra n = + match extra with + | [] -> relevance_of_rel env n + | r :: _ when Int.equal n 1 -> r + | _ :: extra -> relevance_of_rel_extra env extra (n-1) + +let relevance_of_flex env extra lft = function + | ConstKey (c,_) -> relevance_of_constant env c + | VarKey x -> relevance_of_var env x + | RelKey p -> relevance_of_rel_extra env extra (Esubst.reloc_rel p lft) + +let rec relevance_of_fterm env extra lft f = + let open CClosure in + match CClosure.relevance_of f with + | KnownR -> Sorts.Relevant + | KnownI -> Sorts.Irrelevant + | Unknown -> + let r = match fterm_of f with + | FRel n -> relevance_of_rel_extra env extra (Esubst.reloc_rel n lft) + | FAtom c -> relevance_of_term_extra env extra lft (Esubst.subs_id 0) c + | FFlex key -> relevance_of_flex env extra lft key + | FInt _ -> Sorts.Relevant + | FInd _ | FProd _ -> Sorts.Relevant (* types are always relevant *) + | FConstruct (c,_) -> relevance_of_constructor env c + | FApp (f, _) -> relevance_of_fterm env extra lft f + | FProj (p, _) -> relevance_of_projection env p + | FFix (((_,i),(lna,_,_)), _) -> (lna.(i)).binder_relevance + | FCoFix ((i,(lna,_,_)), _) -> (lna.(i)).binder_relevance + | FCaseT (ci, _, _, _, _) -> ci.ci_relevance + | FLambda (len, tys, bdy, e) -> + let extra = List.rev_append (List.map (fun (x,_) -> binder_relevance x) tys) extra in + let lft = Esubst.el_liftn len lft in + relevance_of_term_extra env extra lft e bdy + | FLetIn (x, _, _, bdy, e) -> + relevance_of_term_extra env (x.binder_relevance :: extra) + (Esubst.el_lift lft) (Esubst.subs_lift e) bdy + | FLIFT (k, f) -> relevance_of_fterm env extra (Esubst.el_shft k lft) f + | FCLOS (c, e) -> relevance_of_term_extra env extra lft e c + + | FEvar (_, _) -> Sorts.Relevant (* let's assume evars are relevant for now *) + | FLOCKED -> assert false + in + CClosure.set_relevance r f; + r + +and relevance_of_term_extra env extra lft subs c = + match kind c with + | Rel n -> + (match Esubst.expand_rel n subs with + | Inl (k, f) -> relevance_of_fterm env extra (Esubst.el_liftn k lft) f + | Inr (n, _) -> relevance_of_rel_extra env extra (Esubst.reloc_rel n lft)) + | Var x -> relevance_of_var env x + | Sort _ | Ind _ | Prod _ -> Sorts.Relevant (* types are always relevant *) + | Cast (c, _, _) -> relevance_of_term_extra env extra lft subs c + | Lambda ({binder_relevance=r;_}, _, bdy) -> + relevance_of_term_extra env (r::extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy + | LetIn ({binder_relevance=r;_}, _, _, bdy) -> + relevance_of_term_extra env (r::extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy + | App (c, _) -> relevance_of_term_extra env extra lft subs c + | Const (c,_) -> relevance_of_constant env c + | Construct (c,_) -> relevance_of_constructor env c + | Case (ci, _, _, _) -> ci.ci_relevance + | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance + | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance + | Proj (p, _) -> relevance_of_projection env p + | Int _ -> Sorts.Relevant + + | Meta _ | Evar _ -> Sorts.Relevant (* let's assume metas and evars are relevant for now *) + +let relevance_of_fterm env extra lft c = + if Environ.sprop_allowed env then relevance_of_fterm env extra lft c + else Sorts.Relevant + +let relevance_of_term env c = + if Environ.sprop_allowed env + then relevance_of_term_extra env [] Esubst.el_id (Esubst.subs_id 0) c + else Sorts.Relevant diff --git a/kernel/retypeops.mli b/kernel/retypeops.mli new file mode 100644 index 0000000000..f30c541c3f --- /dev/null +++ b/kernel/retypeops.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** We can take advantage of non-cumulativity of SProp to avoid fully + retyping terms when we just want to know if they inhabit some + proof-irrelevant type. *) + +val relevance_of_term : Environ.env -> Constr.constr -> Sorts.relevance + +val relevance_of_fterm : Environ.env -> Sorts.relevance list -> + Esubst.lift -> CClosure.fconstr -> + Sorts.relevance + + +(** Helpers *) +open Names +val relevance_of_rel_extra : Environ.env -> Sorts.relevance list -> int -> Sorts.relevance +val relevance_of_var : Environ.env -> Id.t -> Sorts.relevance +val relevance_of_constant : Environ.env -> Constant.t -> Sorts.relevance +val relevance_of_constructor : Environ.env -> constructor -> Sorts.relevance +val relevance_of_projection : Environ.env -> Projection.t -> Sorts.relevance diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index dc15d9d25e..edb1d0a02e 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -211,6 +211,10 @@ 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 the current (initial) one *) let check_engagement env expected_impredicative_set = @@ -437,14 +441,16 @@ let safe_push_named d env = let push_named_def (id,de) senv = - let c, typ = Term_typing.translate_local_def senv.env id de in - let env'' = safe_push_named (LocalDef (id, c, typ)) senv.env in + let c, r, typ = Term_typing.translate_local_def senv.env id de in + let x = Context.make_annot id r in + let env'' = safe_push_named (LocalDef (x, c, typ)) senv.env in { senv with env = env'' } let push_named_assum ((id,t,poly),ctx) senv = let senv' = push_context_set poly ctx senv in - let t = Term_typing.translate_local_assum senv'.env t in - let env'' = safe_push_named (LocalAssum (id,t)) senv'.env in + let t, r = Term_typing.translate_local_assum senv'.env t in + let x = Context.make_annot id r in + let env'' = safe_push_named (LocalAssum (x,t)) senv'.env in {senv' with env=env''} @@ -603,7 +609,7 @@ let inline_side_effects env body side_eff = if List.is_empty side_eff then (body, Univ.ContextSet.empty, sigs) else (** Second step: compute the lifts and substitutions to apply *) - let cname c = Name (Label.to_id (Constant.label c)) in + let cname c r = Context.make_annot (Name (Label.to_id (Constant.label c))) r in let fold (subst, var, ctx, args) (c, cb, b) = let (b, opaque) = match cb.const_body, b with | Def b, _ -> (Mod_subst.force_constr b, false) @@ -616,7 +622,7 @@ let inline_side_effects env body side_eff = let ty = cb.const_type in let subst = Cmap_env.add c (Inr var) subst in let ctx = Univ.ContextSet.union ctx univs in - (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) + (subst, var + 1, ctx, (cname c cb.const_relevance, b, ty, opaque) :: args) | Polymorphic _ -> (** Inline the term to emulate universe polymorphism *) let subst = Cmap_env.add c (Inl b) subst in @@ -1194,45 +1200,52 @@ let register_inline kn senv = let cb = {cb with const_inline_code = true} in let env = add_constant kn cb env in { senv with env} -let check_register_ind (mind,i) r env = - let mb = Environ.lookup_mind mind env in - let check_if b s = +let check_register_ind ind r env = + let (mb,ob as spec) = Inductive.lookup_mind_specif env ind in + let check_if b msg = if not b then - CErrors.user_err ~hdr:"check_register_ind" (Pp.str s) in - check_if (Int.equal (Array.length mb.mind_packets) 1) "A non mutual inductive is expected"; - let ob = mb.mind_packets.(i) in + CErrors.user_err ~hdr:"check_register_ind" msg in + check_if (Int.equal (Array.length mb.mind_packets) 1) Pp.(str "A non mutual inductive is expected"); + let is_monomorphic = function Monomorphic _ -> true | Polymorphic _ -> false in + check_if (is_monomorphic mb.mind_universes) Pp.(str "A universe monomorphic inductive type is expected"); + check_if (not @@ Inductive.is_private spec) Pp.(str "A non-private inductive type is expected"); + let check_nparams n = + check_if (Int.equal mb.mind_nparams n) Pp.(str "An inductive type with " ++ int n ++ str " parameters is expected") + in let check_nconstr n = check_if (Int.equal (Array.length ob.mind_consnames) n) - ("an inductive type with "^(string_of_int n)^" constructors is expected") + Pp.(str "an inductive type with " ++ int n ++ str " constructors is expected") in let check_name pos s = check_if (Id.equal ob.mind_consnames.(pos) (Id.of_string s)) - ("the "^(string_of_int (pos + 1))^ - "th constructor does not have the expected name: " ^ s) in + Pp.(str"the " ++ int (pos + 1) ++ str + "th constructor does not have the expected name: " ++ str s) in let check_type pos t = check_if (Constr.equal t ob.mind_user_lc.(pos)) - ("the "^(string_of_int (pos + 1))^ + Pp.(str"the " ++ int (pos + 1) ++ str "th constructor does not have the expected type") in let check_type_cte pos = check_type pos (Constr.mkRel 1) in match r with | CPrimitives.PIT_bool -> + check_nparams 0; check_nconstr 2; check_name 0 "true"; check_type_cte 0; check_name 1 "false"; check_type_cte 1 | CPrimitives.PIT_carry -> + check_nparams 1; check_nconstr 2; let test_type pos = let c = ob.mind_user_lc.(pos) in - let s = "the "^(string_of_int (pos + 1))^ - "th constructor does not have the expected type" in + let s = Pp.(str"the " ++ int (pos + 1) ++ str + "th constructor does not have the expected type") in check_if (Constr.isProd c) s; let (_,d,cd) = Constr.destProd c in check_if (Constr.is_Type d) s; check_if (Constr.equal - (mkProd (Anonymous,mkRel 1, mkApp (mkRel 3,[|mkRel 2|]))) + (mkProd (Context.anonR,mkRel 1, mkApp (mkRel 3,[|mkRel 2|]))) cd) s in check_name 0 "C0"; @@ -1240,11 +1253,11 @@ let check_register_ind (mind,i) r env = check_name 1 "C1"; test_type 1; | CPrimitives.PIT_pair -> + check_nparams 2; check_nconstr 1; check_name 0 "pair"; let c = ob.mind_user_lc.(0) in - let s = "the "^(string_of_int 1)^ - "th constructor does not have the expected type" in + let s = Pp.str "the constructor does not have the expected type" in begin match Term.decompose_prod c with | ([_,b;_,a;_,_B;_,_A], codom) -> check_if (is_Type _A) s; @@ -1255,6 +1268,7 @@ let check_register_ind (mind,i) r env = | _ -> check_if false s end | CPrimitives.PIT_cmp -> + check_nparams 0; check_nconstr 3; check_name 0 "Eq"; check_type_cte 0; diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 8539fdd504..46c97c1fb8 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -141,6 +141,8 @@ val set_typing_flags : Declarations.typing_flags -> safe_transformer0 val set_share_reduction : 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/sorts.ml b/kernel/sorts.ml index 566dce04c6..09c98ca1bc 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -10,13 +10,15 @@ open Univ -type family = InProp | InSet | InType +type family = InSProp | InProp | InSet | InType type t = + | SProp | Prop | Set | Type of Universe.t +let sprop = SProp let prop = Prop let set = Set let type1 = Type type1_univ @@ -25,15 +27,20 @@ let univ_of_sort = function | Type u -> u | Set -> Universe.type0 | Prop -> Universe.type0m + | SProp -> Universe.sprop let sort_of_univ u = - if is_type0m_univ u then prop + if Universe.is_sprop u then sprop + else if is_type0m_univ u then prop else if is_type0_univ u then set else Type u let compare s1 s2 = if s1 == s2 then 0 else match s1, s2 with + | SProp, SProp -> 0 + | SProp, _ -> -1 + | _, SProp -> 1 | Prop, Prop -> 0 | Prop, _ -> -1 | Set, Prop -> 1 @@ -44,34 +51,52 @@ let compare s1 s2 = let equal s1 s2 = Int.equal (compare s1 s2) 0 +let super = function + | SProp | Prop | Set -> Type (Universe.type1) + | Type u -> Type (Universe.super u) + +let is_sprop = function + | SProp -> true + | Prop | Set | Type _ -> false + let is_prop = function | Prop -> true - | Type u when Universe.equal Universe.type0m u -> true - | _ -> false + | SProp | Set | Type _ -> false let is_set = function | Set -> true - | Type u when Universe.equal Universe.type0 u -> true - | _ -> false + | SProp | Prop | Type _ -> false let is_small = function - | Prop | Set -> true - | Type u -> is_small_univ u + | SProp | Prop | Set -> true + | Type _ -> false let family = function + | SProp -> InSProp | Prop -> InProp | Set -> InSet - | Type u when is_type0m_univ u -> InProp - | Type u when is_type0_univ u -> InSet | Type _ -> InType +let family_compare a b = match a,b with + | InSProp, InSProp -> 0 + | InSProp, _ -> -1 + | _, InSProp -> 1 + | InProp, InProp -> 0 + | InProp, _ -> -1 + | _, InProp -> 1 + | InSet, InSet -> 0 + | InSet, _ -> -1 + | _, InSet -> 1 + | InType, InType -> 0 + let family_equal = (==) open Hashset.Combine let hash = function - | Prop -> combinesmall 1 0 - | Set -> combinesmall 1 1 + | SProp -> combinesmall 1 0 + | Prop -> combinesmall 1 1 + | Set -> combinesmall 1 2 | Type u -> let h = Univ.Universe.hash u in combinesmall 2 h @@ -103,12 +128,33 @@ module Hsorts = let hcons = Hashcons.simple_hcons Hsorts.generate Hsorts.hcons hcons_univ +(** On binders: is this variable proof relevant *) +type relevance = Relevant | Irrelevant + +let relevance_equal r1 r2 = match r1,r2 with + | Relevant, Relevant | Irrelevant, Irrelevant -> true + | (Relevant | Irrelevant), _ -> false + +let relevance_of_sort_family = function + | InSProp -> Irrelevant + | _ -> Relevant + +let relevance_hash = function + | Relevant -> 0 + | Irrelevant -> 1 + +let relevance_of_sort = function + | SProp -> Irrelevant + | _ -> Relevant + let debug_print = function - | Set -> Pp.(str "Set") + | SProp -> Pp.(str "SProp") | Prop -> Pp.(str "Prop") + | Set -> Pp.(str "Set") | Type u -> Pp.(str "Type(" ++ Univ.Universe.pr u ++ str ")") let pr_sort_family = function - | InSet -> Pp.(str "Set") + | InSProp -> Pp.(str "SProp") | InProp -> Pp.(str "Prop") + | InSet -> Pp.(str "Set") | InType -> Pp.(str "Type") diff --git a/kernel/sorts.mli b/kernel/sorts.mli index 6c5ce4df80..c49728b146 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -10,13 +10,15 @@ (** {6 The sorts of CCI. } *) -type family = InProp | InSet | InType +type family = InSProp | InProp | InSet | InType -type t = +type t = private + | SProp | Prop | Set | Type of Univ.Universe.t +val sprop : t val set : t val prop : t val type1 : t @@ -25,6 +27,7 @@ val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int +val is_sprop : t -> bool val is_set : t -> bool val is_prop : t -> bool val is_small : t -> bool @@ -32,6 +35,7 @@ val family : t -> family val hcons : t -> t +val family_compare : family -> family -> int val family_equal : family -> family -> bool module List : sig @@ -42,6 +46,18 @@ end val univ_of_sort : t -> Univ.Universe.t val sort_of_univ : Univ.Universe.t -> t +val super : t -> t + +(** On binders: is this variable proof relevant *) +type relevance = Relevant | Irrelevant + +val relevance_hash : relevance -> int + +val relevance_equal : relevance -> relevance -> bool + +val relevance_of_sort : t -> relevance +val relevance_of_sort_family : family -> relevance + val debug_print : t -> Pp.t val pr_sort_family : family -> Pp.t diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index dea72e8b59..1857ea3329 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -23,6 +23,7 @@ open Declareops open Reduction open Inductive open Modops +open Context open Mod_subst (*i*) @@ -190,8 +191,8 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 check (fun mib -> mib.mind_record <> NotRecord) (==) (fun x -> RecordFieldExpected x); if mib1.mind_record <> NotRecord then begin let rec names_prod_letin t = match kind t with - | Prod(n,_,t) -> n::(names_prod_letin t) - | LetIn(n,_,_,t) -> n::(names_prod_letin t) + | Prod(n,_,t) -> n.binder_name::(names_prod_letin t) + | LetIn(n,_,_,t) -> n.binder_name::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] in diff --git a/kernel/term.ml b/kernel/term.ml index 58b289eaa5..f09c45715f 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -14,13 +14,14 @@ open CErrors open Names open Vars open Constr +open Context (* Deprecated *) -type sorts_family = Sorts.family = InProp | InSet | InType +type sorts_family = Sorts.family = InSProp | InProp | InSet | InType [@@ocaml.deprecated "Alias for Sorts.family"] -type sorts = Sorts.t = - | Prop | Set +type sorts = Sorts.t = private + | SProp | Prop | Set | Type of Univ.Universe.t (** Type *) [@@ocaml.deprecated "Alias for Sorts.t"] @@ -32,9 +33,11 @@ type sorts = Sorts.t = (* Other term constructors *) (***************************) -let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c) -let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) -let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) +let name_annot = map_annot Name.mk_name + +let mkNamedProd id typ c = mkProd (name_annot id, typ, subst_var id.binder_name c) +let mkNamedLambda id typ c = mkLambda (name_annot id, typ, subst_var id.binder_name c) +let mkNamedLetIn id c1 t c2 = mkLetIn (name_annot id, c1, t, subst_var id.binder_name c2) (* Constructs either [(x:t)c] or [[x=b:t]c] *) let mkProd_or_LetIn decl c = @@ -60,10 +63,11 @@ let mkNamedProd_wo_LetIn decl c = let open Context.Named.Declaration in match decl with | LocalAssum (id,t) -> mkNamedProd id t c - | LocalDef (id,b,_t) -> subst1 b (subst_var id c) + | LocalDef (id,b,_) -> subst1 b (subst_var id.binder_name c) (* non-dependent product t1 -> t2 *) -let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) +let mkArrow t1 r t2 = mkProd (make_annot Anonymous r, t1, t2) +let mkArrowR t1 t2 = mkArrow t1 Sorts.Relevant t2 (* Constructs either [[x:t]c] or [[x=b:t]c] *) let mkLambda_or_LetIn decl c = @@ -366,8 +370,8 @@ let rec isArity c = type ('constr, 'types) kind_of_type = | SortType of Sorts.t | CastType of 'types * 'types - | ProdType of Name.t * 'types * 'types - | LetInType of Name.t * 'constr * 'types * 'types + | ProdType of Name.t Context.binder_annot * 'types * 'types + | LetInType of Name.t Context.binder_annot * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array let kind_of_type t = match kind t with diff --git a/kernel/term.mli b/kernel/term.mli index 181d714ed7..4265324693 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -17,12 +17,15 @@ open Constr [forall (_:t1), t2]. Beware [t_2] is NOT lifted. Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 1) (mkRel 2))] *) -val mkArrow : types -> types -> constr +val mkArrow : types -> Sorts.relevance -> types -> constr + +val mkArrowR : types -> types -> constr +(** For an always-relevant domain *) (** Named version of the functions from [Term]. *) -val mkNamedLambda : Id.t -> types -> constr -> constr -val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr -val mkNamedProd : Id.t -> types -> types -> types +val mkNamedLambda : Id.t Context.binder_annot -> types -> constr -> constr +val mkNamedLetIn : Id.t Context.binder_annot -> constr -> types -> constr -> constr +val mkNamedProd : Id.t Context.binder_annot -> types -> types -> types (** Constructs either [(x:t)c] or [[x=b:t]c] *) val mkProd_or_LetIn : Constr.rel_declaration -> types -> types @@ -45,24 +48,24 @@ val appvectc : constr -> constr array -> constr (** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) -val prodn : int -> (Name.t * constr) list -> constr -> constr +val prodn : int -> (Name.t Context.binder_annot * constr) list -> constr -> constr (** [compose_prod l b] @return [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [decompose_prod]. *) -val compose_prod : (Name.t * constr) list -> constr -> constr +val compose_prod : (Name.t Context.binder_annot * constr) list -> constr -> constr (** [lamn n l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) -val lamn : int -> (Name.t * constr) list -> constr -> constr +val lamn : int -> (Name.t Context.binder_annot * constr) list -> constr -> constr (** [compose_lam l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [it_destLam] *) -val compose_lam : (Name.t * constr) list -> constr -> constr +val compose_lam : (Name.t Context.binder_annot * constr) list -> constr -> constr (** [to_lambda n l] @return [fun (x_1:T_1)...(x_n:T_n) => T] @@ -107,22 +110,22 @@ val prod_applist_assum : int -> types -> constr list -> types (** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. *) -val decompose_prod : constr -> (Name.t*constr) list * constr +val decompose_prod : constr -> (Name.t Context.binder_annot * constr) list * constr (** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *) -val decompose_lam : constr -> (Name.t*constr) list * constr +val decompose_lam : constr -> (Name.t Context.binder_annot * constr) list * constr (** Given a positive integer n, decompose a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. Raise a user error if not enough products. *) -val decompose_prod_n : int -> constr -> (Name.t * constr) list * constr +val decompose_prod_n : int -> constr -> (Name.t Context.binder_annot * constr) list * constr (** Given a positive integer {% $ %}n{% $ %}, decompose a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}. Raise a user error if not enough lambdas. *) -val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr +val decompose_lam_n : int -> constr -> (Name.t Context.binder_annot * constr) list * constr (** Extract the premisses and the conclusion of a term of the form "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *) @@ -183,17 +186,17 @@ val isArity : types -> bool type ('constr, 'types) kind_of_type = | SortType of Sorts.t | CastType of 'types * 'types - | ProdType of Name.t * 'types * 'types - | LetInType of Name.t * 'constr * 'types * 'types + | ProdType of Name.t Context.binder_annot * 'types * 'types + | LetInType of Name.t Context.binder_annot * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array val kind_of_type : types -> (constr, types) kind_of_type (* Deprecated *) -type sorts_family = Sorts.family = InProp | InSet | InType +type sorts_family = Sorts.family = InSProp | InProp | InSet | InType [@@ocaml.deprecated "Alias for Sorts.family"] -type sorts = Sorts.t = - | Prop | Set +type sorts = Sorts.t = private + | SProp | Prop | Set | Type of Univ.Universe.t (** Type *) [@@ocaml.deprecated "Alias for Sorts.t"] diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 929f1c13a3..f773f800c6 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -21,7 +21,6 @@ open Constr open Declarations open Environ open Entries -open Typeops module NamedDecl = Context.Named.Declaration @@ -72,15 +71,16 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = | Monomorphic_entry uctx -> push_context_set ~strict:true uctx env | Polymorphic_entry (_, uctx) -> push_context ~strict:false uctx env in - let j = infer env t in + let j = Typeops.infer env t in let usubst, univs = Declareops.abstract_universes uctx in - let c = Typeops.assumption_of_judgment env j in - let t = Constr.hcons (Vars.subst_univs_level_constr usubst c) in + let r = Typeops.assumption_of_judgment env j in + let t = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in { Cooking.cook_body = Undef nl; cook_type = t; cook_universes = univs; cook_private_univs = None; + cook_relevance = r; cook_inline = false; cook_context = ctx; } @@ -93,12 +93,12 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let env = push_context_set ~strict:true uctxt env in let ty = match otyp with | Some typ -> - let tyj = infer_type env typ in - check_primitive_type env op_t tyj.utj_val; - Constr.hcons tyj.utj_val + let typ = Typeops.infer_type env typ in + Typeops.check_primitive_type env op_t typ.utj_val; + Constr.hcons typ.utj_val | None -> match op_t with - | CPrimitives.OT_op op -> type_of_prim env op + | CPrimitives.OT_op op -> Typeops.type_of_prim env op | CPrimitives.OT_type _ -> mkSet in let cd = @@ -110,7 +110,8 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = cook_universes = Monomorphic uctxt; cook_private_univs = None; cook_inline = false; - cook_context = None + cook_context = None; + cook_relevance = Sorts.Relevant; } (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, @@ -128,8 +129,8 @@ the polymorphic case const_entry_opaque = true; const_entry_universes = Monomorphic_entry univs; _ } as c) -> let env = push_context_set ~strict:true univs env in - let { const_entry_body = body; const_entry_feedback = feedback_id ; _ } = c in - let tyj = infer_type env typ in + let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in + let tyj = Typeops.infer_type env typ in let proofterm = Future.chain body (fun ((body,uctx),side_eff) -> (* don't redeclare universes which are declared for the type *) @@ -137,17 +138,17 @@ the polymorphic case let j, uctx = match trust with | Pure -> let env = push_context_set uctx env in - let j = infer env body in - let _ = judge_of_cast env j DEFAULTcast tyj in + let j = Typeops.infer env body in + let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in j, uctx | SideEffects handle -> let (body, uctx', valid_signatures) = handle env body side_eff in let uctx = Univ.ContextSet.union uctx uctx' in let env = push_context_set uctx env in let body,env,ectx = skip_trusted_seff valid_signatures body env in - let j = infer env body in + let j = Typeops.infer env body in let j = unzip ectx j in - let _ = judge_of_cast env j DEFAULTcast tyj in + let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in j, uctx in let c = Constr.hcons j.uj_val in @@ -156,9 +157,10 @@ the polymorphic case let def = OpaqueDef (Opaqueproof.create proofterm) in { Cooking.cook_body = def; - cook_type = typ; + cook_type = tyj.utj_val; cook_universes = Monomorphic univs; cook_private_univs = None; + cook_relevance = Sorts.relevance_of_sort tyj.utj_type; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; } @@ -194,14 +196,14 @@ the polymorphic case in env, sbst, Polymorphic auctx, local in - let j = infer env body in + let j = Typeops.infer env body in let typ = match typ with | None -> Vars.subst_univs_level_constr usubst j.uj_type | Some t -> - let tj = infer_type env t in - let _ = judge_of_cast env j DEFAULTcast tj in - Vars.subst_univs_level_constr usubst t + let tj = Typeops.infer_type env t in + let _ = Typeops.judge_of_cast env j DEFAULTcast tj in + Vars.subst_univs_level_constr usubst tj.utj_val in let def = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in let def = @@ -214,6 +216,7 @@ the polymorphic case cook_type = typ; cook_universes = univs; cook_private_univs = private_univs; + cook_relevance = Retypeops.relevance_of_term env j.uj_val; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; } @@ -309,6 +312,7 @@ let build_constant_declaration _kn env result = const_body_code = tps; const_universes = univs; const_private_poly_univs = result.cook_private_univs; + const_relevance = result.cook_relevance; const_inline_code = result.cook_inline; const_typing_flags = Environ.typing_flags env } @@ -319,9 +323,9 @@ let translate_constant mb env kn ce = (infer_declaration ~trust:mb env ce) let translate_local_assum env t = - let j = infer env t in + let j = Typeops.infer env t in let t = Typeops.assumption_of_judgment env j in - t + j.uj_val, t let translate_recipe ~hcons env kn r = build_constant_declaration kn env (Cooking.cook_constant ~hcons r) @@ -366,7 +370,7 @@ let translate_local_def env _id centry = p | Undef _ | Primitive _ -> assert false in - c, typ + c, decl.cook_relevance, typ (* Insertion of inductive types. *) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index faf434c142..d34c28138e 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -27,9 +27,9 @@ type _ trust = | SideEffects : 'a effect_handler -> 'a trust val translate_local_def : env -> Id.t -> section_def_entry -> - constr * types + constr * Sorts.relevance * types -val translate_local_assum : env -> types -> types +val translate_local_assum : env -> types -> types * Sorts.relevance val translate_constant : 'a trust -> env -> Constant.t -> 'a constant_entry -> diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 964d32c6b3..c45fe1cf00 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -33,6 +33,7 @@ type 'constr pguard_error = | RecCallInCasePred of 'constr | NotGuardedForm of 'constr | ReturnPredicateNotCoInductive of 'constr + | FixpointOnIrrelevantInductive type guard_error = constr pguard_error @@ -47,22 +48,25 @@ type ('constr, 'types) ptype_error = | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment | ReferenceVariables of Id.t * 'constr - | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment - * (Sorts.family * Sorts.family * arity_error) option + | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment + * (Sorts.family list * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int | IllFormedBranch of 'constr * pconstructor * 'constr * 'constr | Generalization of (Name.t * 'types) * ('constr, 'types) punsafe_judgment | ActualType of ('constr, 'types) punsafe_judgment * 'types + | IncorrectPrimitive of (CPrimitives.op_or_type,'types) punsafe_judgment * 'types | CantApplyBadType of (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array - | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array + | IllFormedRecBody of 'constr pguard_error * Name.t Context.binder_annot array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of - int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array + int * Name.t Context.binder_annot array * ('constr, 'types) punsafe_judgment array * 'types array | UnsatisfiedConstraints of Univ.Constraint.t | UndeclaredUniverse of Univ.Level.t + | DisallowedSProp + | BadRelevance type type_error = (constr, types) ptype_error @@ -101,8 +105,8 @@ let error_assumption env j = let error_reference_variables env id c = raise (TypeError (env, ReferenceVariables (id,c))) -let error_elim_arity env ind aritylst c pj okinds = - raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds))) +let error_elim_arity env ind c pj okinds = + raise (TypeError (env, ElimArity (ind,c,pj,okinds))) let error_case_not_inductive env j = raise (TypeError (env, CaseNotInductive j)) @@ -120,6 +124,9 @@ let error_generalization env nvar c = let error_actual_type env j expty = raise (TypeError (env, ActualType (j,expty))) +let error_incorrect_primitive env p t = + raise (TypeError (env, IncorrectPrimitive (p, t))) + let error_cant_apply_not_functional env rator randl = raise (TypeError (env, CantApplyNonFunctional (rator,randl))) @@ -145,6 +152,12 @@ let error_unsatisfied_constraints env c = let error_undeclared_universe env l = raise (TypeError (env, UndeclaredUniverse l)) +let error_disallowed_sprop env = + raise (TypeError (env, DisallowedSProp)) + +let error_bad_relevance env = + raise (TypeError (env, BadRelevance)) + let map_pguard_error f = function | NotEnoughAbstractionInFixBody -> NotEnoughAbstractionInFixBody | RecursionNotOnInductiveType c -> RecursionNotOnInductiveType (f c) @@ -161,6 +174,7 @@ let map_pguard_error f = function | RecCallInCasePred c -> RecCallInCasePred (f c) | NotGuardedForm c -> NotGuardedForm (f c) | ReturnPredicateNotCoInductive c -> ReturnPredicateNotCoInductive (f c) +| FixpointOnIrrelevantInductive -> FixpointOnIrrelevantInductive let map_ptype_error f = function | UnboundRel n -> UnboundRel n @@ -168,13 +182,14 @@ let map_ptype_error f = function | NotAType j -> NotAType (on_judgment f j) | BadAssumption j -> BadAssumption (on_judgment f j) | ReferenceVariables (id, c) -> ReferenceVariables (id, f c) -| ElimArity (pi, dl, c, j, ar) -> ElimArity (pi, dl, f c, on_judgment f j, ar) +| ElimArity (pi, c, j, ar) -> ElimArity (pi, f c, on_judgment f j, ar) | CaseNotInductive j -> CaseNotInductive (on_judgment f j) | WrongCaseInfo (pi, ci) -> WrongCaseInfo (pi, ci) | NumberBranches (j, n) -> NumberBranches (on_judgment f j, n) | IllFormedBranch (c, pc, t1, t2) -> IllFormedBranch (f c, pc, f t1, f t2) | Generalization ((na, t), j) -> Generalization ((na, f t), on_judgment f j) | ActualType (j, t) -> ActualType (on_judgment f j, f t) +| IncorrectPrimitive (p, t) -> IncorrectPrimitive ({p with uj_type=f p.uj_type}, f t) | CantApplyBadType ((n, c1, c2), j, vj) -> CantApplyBadType ((n, f c1, f c2), on_judgment f j, Array.map (on_judgment f) vj) | CantApplyNonFunctional (j, jv) -> CantApplyNonFunctional (on_judgment f j, Array.map (on_judgment f) jv) @@ -184,3 +199,5 @@ let map_ptype_error f = function IllTypedRecBody (n, na, Array.map (on_judgment f) jv, Array.map f t) | UnsatisfiedConstraints g -> UnsatisfiedConstraints g | UndeclaredUniverse l -> UndeclaredUniverse l +| DisallowedSProp -> DisallowedSProp +| BadRelevance -> BadRelevance diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 4b832930e1..88165a4f07 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -34,6 +34,7 @@ type 'constr pguard_error = | RecCallInCasePred of 'constr | NotGuardedForm of 'constr | ReturnPredicateNotCoInductive of 'constr + | FixpointOnIrrelevantInductive type guard_error = constr pguard_error @@ -48,22 +49,25 @@ type ('constr, 'types) ptype_error = | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment | ReferenceVariables of Id.t * 'constr - | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment - * (Sorts.family * Sorts.family * arity_error) option + | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment + * (Sorts.family list * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int | IllFormedBranch of 'constr * pconstructor * 'constr * 'constr | Generalization of (Name.t * 'types) * ('constr, 'types) punsafe_judgment | ActualType of ('constr, 'types) punsafe_judgment * 'types + | IncorrectPrimitive of (CPrimitives.op_or_type,'types) punsafe_judgment * 'types | CantApplyBadType of (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array - | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array + | IllFormedRecBody of 'constr pguard_error * Name.t Context.binder_annot array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of - int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array + int * Name.t Context.binder_annot array * ('constr, 'types) punsafe_judgment array * 'types array | UnsatisfiedConstraints of Univ.Constraint.t | UndeclaredUniverse of Univ.Level.t + | DisallowedSProp + | BadRelevance type type_error = (constr, types) ptype_error @@ -99,8 +103,8 @@ val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> Id.t -> constr -> 'a val error_elim_arity : - env -> pinductive -> Sorts.family list -> constr -> unsafe_judgment -> - (Sorts.family * Sorts.family * arity_error) option -> 'a + env -> pinductive -> constr -> unsafe_judgment -> + (Sorts.family list * Sorts.family * Sorts.family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a @@ -112,6 +116,8 @@ val error_generalization : env -> Name.t * types -> unsafe_judgment -> 'a val error_actual_type : env -> unsafe_judgment -> types -> 'a +val error_incorrect_primitive : env -> (CPrimitives.op_or_type,types) punsafe_judgment -> types -> 'a + val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a @@ -120,10 +126,10 @@ val error_cant_apply_bad_type : unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : - env -> guard_error -> Name.t array -> int -> env -> unsafe_judgment array -> 'a + env -> guard_error -> Name.t Context.binder_annot array -> int -> env -> unsafe_judgment array -> 'a val error_ill_typed_rec_body : - env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a + env -> int -> Name.t Context.binder_annot array -> unsafe_judgment array -> types array -> 'a val error_elim_explain : Sorts.family -> Sorts.family -> arity_error @@ -131,5 +137,9 @@ val error_unsatisfied_constraints : env -> Univ.Constraint.t -> 'a val error_undeclared_universe : env -> Univ.Level.t -> 'a +val error_disallowed_sprop : env -> 'a + +val error_bad_relevance : env -> 'a + val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 7eb8e803b3..12ffbf4357 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -12,8 +12,10 @@ open CErrors open Util open Names open Univ +open Sorts open Term open Constr +open Context open Vars open Declarations open Environ @@ -24,6 +26,8 @@ open Type_errors module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration +exception NotConvertibleVect of int + let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y let conv_leq_vecti env v1 v2 = @@ -47,11 +51,32 @@ let check_type env c t = (* This should be a type intended to be assumed. The error message is not as useful as for [type_judgment]. *) -let check_assumption env t ty = - try let _ = check_type env t ty in t +let infer_assumption env t ty = + try + let s = check_type env t ty in + (match s with Sorts.SProp -> Irrelevant | _ -> Relevant) with TypeError _ -> error_assumption env (make_judge t ty) +let warn_bad_relevance_name = "bad-relevance" +let warn_bad_relevance = + CWarnings.create ~name:warn_bad_relevance_name ~category:"debug" ~default:CWarnings.Disabled + Pp.(function + | None -> str "Bad relevance in case annotation." + | Some x -> str "Bad relevance for binder " ++ Name.print x.binder_name ++ str ".") + +let warn_bad_relevance_ci ?loc () = warn_bad_relevance ?loc None +let warn_bad_relevance ?loc x = warn_bad_relevance ?loc (Some x) + +let check_assumption env x t ty = + let r = x.binder_relevance in + let r' = infer_assumption env t ty in + let x = if Sorts.relevance_equal r r' + then x + else (warn_bad_relevance x; {x with binder_relevance = r'}) + in + x + (************************************************) (* Incremental typing rules: builds a typing judgment given the *) (* judgments for the subterms. *) @@ -69,7 +94,7 @@ let type_of_type u = mkType uu let type_of_sort = function - | Prop | Set -> type1 + | SProp | Prop | Set -> type1 | Type u -> type_of_type u (*s Type of a de Bruijn index. *) @@ -220,7 +245,7 @@ let type_of_prim env t = in let rec nary_int63_op arity ty = if Int.equal arity 0 then ty - else Constr.mkProd(Name (Id.of_string "x"), int_ty, nary_int63_op (arity-1) ty) + else Constr.mkProd(Context.nameR (Id.of_string "x"), int_ty, nary_int63_op (arity-1) ty) in let return_ty = let open CPrimitives in @@ -252,6 +277,11 @@ let type_of_prim env t = in nary_int63_op (CPrimitives.arity t) return_ty +let type_of_prim_or_type env = let open CPrimitives in + function + | OT_type t -> type_of_prim_type env t + | OT_op op -> type_of_prim env op + let judge_of_int env i = make_judge (Constr.mkInt i) (type_of_int env) @@ -259,6 +289,7 @@ let judge_of_int env i = let sort_of_product env domsort rangsort = match (domsort, rangsort) with + | (_, SProp) | (SProp, _) -> rangsort (* Product rule (s,Prop,Prop) *) | (_, Prop) -> rangsort (* Product rule (Prop/Set,Set,Set) *) @@ -270,13 +301,13 @@ let sort_of_product env domsort rangsort = rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - Type (Universe.sup Universe.type0 u1) + Sorts.sort_of_univ (Universe.sup Universe.type0 u1) (* Product rule (Prop,Type_i,Type_i) *) - | (Set, Type u2) -> Type (Universe.sup Universe.type0 u2) + | (Set, Type u2) -> Sorts.sort_of_univ (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) - | (Type u1, Type u2) -> Type (Universe.sup u1 u2) + | (Type u1, Type u2) -> Sorts.sort_of_univ (Universe.sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule @@ -371,11 +402,17 @@ let type_of_case env ci p pt c ct _lf lft = let (pind, _ as indspec) = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in - let () = check_case_info env pind ci in + let _, sp = try dest_arity env pt + with NotArity -> error_elim_arity env pind c (make_judge p pt) None in + let rp = Sorts.relevance_of_sort sp in + let ci = if ci.ci_relevance == rp then ci + else (warn_bad_relevance_ci (); {ci with ci_relevance=rp}) + in + let () = check_case_info env pind rp ci in let (bty,rslty) = type_case_branches env indspec (make_judge p pt) c in let () = check_branch_types env pind c ct lft bty in - rslty + ci, rslty let type_of_projection env p c ct = let pty = lookup_projection p env in @@ -450,6 +487,13 @@ let constr_of_global_in_context env r = (************************************************************************) (************************************************************************) +let check_binder_annot s x = + let r = x.binder_relevance in + let r' = Sorts.relevance_of_sort s in + if r' == r + then x + else (warn_bad_relevance x; {x with binder_relevance = r'}) + (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, Ind et Constructsi un jour cela devient des constructions @@ -458,88 +502,110 @@ let rec execute env cstr = let open Context.Rel.Declaration in match kind cstr with (* Atomic terms *) - | Sort s -> type_of_sort s + | Sort s -> + (match s with + | SProp -> if not (Environ.sprop_allowed env) then error_disallowed_sprop env + | _ -> ()); + cstr, type_of_sort s | Rel n -> - type_of_relative env n + cstr, type_of_relative env n | Var id -> - type_of_variable env id + cstr, type_of_variable env id | Const c -> - type_of_constant env c + cstr, type_of_constant env c | Proj (p, c) -> - let ct = execute env c in - type_of_projection env p c ct + let c', ct = execute env c in + let cstr = if c == c' then cstr else mkProj (p,c') in + cstr, type_of_projection env p c' ct (* Lambda calculus operators *) | App (f,args) -> - let argst = execute_array env args in - let ft = + let args', argst = execute_array env args in + let f', ft = match kind f with | Ind ind when Environ.template_polymorphic_pind ind env -> let args = Array.map (fun t -> lazy t) argst in - type_of_inductive_knowing_parameters env ind args + f, type_of_inductive_knowing_parameters env ind args | _ -> (* No template polymorphism *) execute env f in - - type_of_apply env f ft args argst + let cstr = if f == f' && args == args' then cstr else mkApp (f',args') in + cstr, type_of_apply env f' ft args' argst | Lambda (name,c1,c2) -> - let _ = execute_is_type env c1 in - let env1 = push_rel (LocalAssum (name,c1)) env in - let c2t = execute env1 c2 in - type_of_abstraction env name c1 c2t + let c1', s = execute_is_type env c1 in + let name' = check_binder_annot s name in + let env1 = push_rel (LocalAssum (name',c1')) env in + let c2', c2t = execute env1 c2 in + let cstr = if name == name' && c1 == c1' && c2 == c2' then cstr else mkLambda(name',c1',c2') in + cstr, type_of_abstraction env name' c1 c2t | Prod (name,c1,c2) -> - let vars = execute_is_type env c1 in - let env1 = push_rel (LocalAssum (name,c1)) env in - let vars' = execute_is_type env1 c2 in - type_of_product env name vars vars' + let c1', vars = execute_is_type env c1 in + let name' = check_binder_annot vars name in + let env1 = push_rel (LocalAssum (name',c1')) env in + let c2', vars' = execute_is_type env1 c2 in + let cstr = if name == name' && c1 == c1' && c2 == c2' then cstr else mkProd(name',c1',c2') in + cstr, type_of_product env name' vars vars' | LetIn (name,c1,c2,c3) -> - let c1t = execute env c1 in - let _c2s = execute_is_type env c2 in - let () = check_cast env c1 c1t DEFAULTcast c2 in - let env1 = push_rel (LocalDef (name,c1,c2)) env in - let c3t = execute env1 c3 in - subst1 c1 c3t + let c1', c1t = execute env c1 in + let c2', c2s = execute_is_type env c2 in + let name' = check_binder_annot c2s name in + let () = check_cast env c1' c1t DEFAULTcast c2' in + let env1 = push_rel (LocalDef (name',c1',c2')) env in + let c3', c3t = execute env1 c3 in + let cstr = if name == name' && c1 == c1' && c2 == c2' && c3 == c3' then cstr + else mkLetIn(name',c1',c2',c3') + in + cstr, subst1 c1 c3t | Cast (c,k,t) -> - let ct = execute env c in - let _ts = (check_type env t (execute env t)) in - let () = check_cast env c ct k t in - t + let c', ct = execute env c in + let t', _ts = execute_is_type env t in + let () = check_cast env c' ct k t' in + let cstr = if c == c' && t == t' then cstr else mkCast(c',k,t') in + cstr, t' (* Inductive types *) | Ind ind -> - type_of_inductive env ind + cstr, type_of_inductive env ind | Construct c -> - type_of_constructor env c + cstr, type_of_constructor env c | Case (ci,p,c,lf) -> - let ct = execute env c in - let pt = execute env p in - let lft = execute_array env lf in - type_of_case env ci p pt c ct lf lft - - | Fix ((_vn,i as vni),recdef) -> + let c', ct = execute env c in + let p', pt = execute env p in + let lf', lft = execute_array env lf in + let ci', t = type_of_case env ci p' pt c' ct lf' lft in + let cstr = if ci == ci' && c == c' && p == p' && lf == lf' then cstr + else mkCase(ci',p',c',lf') + in + cstr, t + + | Fix ((_vn,i as vni),recdef as fix) -> let (fix_ty,recdef') = execute_recdef env recdef i in - let fix = (vni,recdef') in - check_fix env fix; fix_ty + let cstr, fix = if recdef == recdef' then cstr, fix else + let fix = (vni,recdef') in mkFix fix, fix + in + check_fix env fix; cstr, fix_ty - | CoFix (i,recdef) -> + | CoFix (i,recdef as cofix) -> let (fix_ty,recdef') = execute_recdef env recdef i in - let cofix = (i,recdef') in - check_cofix env cofix; fix_ty + let cstr, cofix = if recdef == recdef' then cstr, cofix else + let cofix = (i,recdef') in mkCoFix cofix, cofix + in + check_cofix env cofix; cstr, fix_ty (* Primitive types *) - | Int _ -> type_of_int env - + | Int _ -> cstr, type_of_int env + (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly (Pp.str "the kernel does not support metavariables.") @@ -548,18 +614,22 @@ let rec execute env cstr = anomaly (Pp.str "the kernel does not support existential variables.") and execute_is_type env constr = - let t = execute env constr in - check_type env constr t - -and execute_recdef env (names,lar,vdef) i = - let lart = execute_array env lar in - let lara = Array.map2 (check_assumption env) lar lart in - let env1 = push_rec_types (names,lara,vdef) env in - let vdeft = execute_array env1 vdef in - let () = check_fixpoint env1 names lara vdef vdeft in - (lara.(i),(names,lara,vdef)) - -and execute_array env = Array.map (execute env) + let c, t = execute env constr in + c, check_type env constr t + +and execute_recdef env (names,lar,vdef as recdef) i = + let lar', lart = execute_array env lar in + let names' = Array.Smart.map_i (fun i na -> check_assumption env na lar'.(i) lart.(i)) names in + let env1 = push_rec_types (names',lar',vdef) env in (* vdef is ignored *) + let vdef', vdeft = execute_array env1 vdef in + let () = check_fixpoint env1 names' lar' vdef' vdeft in + let recdef = if names == names' && lar == lar' && vdef == vdef' then recdef else (names',lar',vdef') in + (lar'.(i),recdef) + +and execute_array env cs = + let tys = Array.make (Array.length cs) mkProp in + let cs = Array.Smart.map_i (fun i c -> let c, ty = execute env c in tys.(i) <- ty; c) cs in + cs, tys (* Derived functions *) @@ -571,8 +641,8 @@ let check_wellformed_universes env c = let infer env constr = let () = check_wellformed_universes env constr in - let t = execute env constr in - make_judge constr t + let constr, t = execute env constr in + make_judge constr t let infer = if Flags.profile then @@ -581,7 +651,7 @@ let infer = else (fun b c -> infer b c) let assumption_of_judgment env {uj_val=c; uj_type=t} = - check_assumption env c t + infer_assumption env c t let type_judgment env {uj_val=c; uj_type=t} = let s = check_type env c t in @@ -589,30 +659,27 @@ let type_judgment env {uj_val=c; uj_type=t} = let infer_type env constr = let () = check_wellformed_universes env constr in - let t = execute env constr in + let constr, t = execute env constr in let s = check_type env constr t in {utj_val = constr; utj_type = s} -let infer_v env cv = - let () = Array.iter (check_wellformed_universes env) cv in - let jv = execute_array env cv in - make_judgev cv jv - (* Typing of several terms. *) let check_context env rels = let open Context.Rel.Declaration in - Context.Rel.fold_outside (fun d env -> + Context.Rel.fold_outside (fun d (env,rels) -> match d with - | LocalAssum (_,ty) -> - let _ = infer_type env ty in - push_rel d env - | LocalDef (_,bd,ty) -> + | LocalAssum (x,ty) -> + let jty = infer_type env ty in + let x = check_binder_annot jty.utj_type x in + push_rel d env, LocalAssum (x,jty.utj_val) :: rels + | LocalDef (x,bd,ty) -> let j1 = infer env bd in - let _ = infer_type env ty in + let jty = infer_type env ty in conv_leq false env j1.uj_type ty; - push_rel d env) - rels ~init:env + let x = check_binder_annot jty.utj_type x in + push_rel d env, LocalDef (x,j1.uj_val,jty.utj_val) :: rels) + rels ~init:(env,[]) let judge_of_prop = make_judge mkProp type1 let judge_of_set = make_judge mkSet type1 @@ -634,17 +701,17 @@ let judge_of_apply env funj argjv = let args, argtys = dest_judgev argjv in make_judge (mkApp (funj.uj_val, args)) (type_of_apply env funj.uj_val funj.uj_type args argtys) -let judge_of_abstraction env x varj bodyj = - make_judge (mkLambda (x, varj.utj_val, bodyj.uj_val)) - (type_of_abstraction env x varj.utj_val bodyj.uj_type) +(* let judge_of_abstraction env x varj bodyj = *) +(* make_judge (mkLambda (x, varj.utj_val, bodyj.uj_val)) *) +(* (type_of_abstraction env x varj.utj_val bodyj.uj_type) *) -let judge_of_product env x varj outj = - make_judge (mkProd (x, varj.utj_val, outj.utj_val)) - (mkSort (sort_of_product env varj.utj_type outj.utj_type)) +(* let judge_of_product env x varj outj = *) +(* make_judge (mkProd (x, varj.utj_val, outj.utj_val)) *) +(* (mkSort (sort_of_product env varj.utj_type outj.utj_type)) *) -let judge_of_letin _env name defj typj j = - make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val)) - (subst1 defj.uj_val j.uj_type) +(* let judge_of_letin env name defj typj j = *) +(* make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val)) *) +(* (subst1 defj.uj_val j.uj_type) *) let judge_of_cast env cj k tj = let () = check_cast env cj.uj_val cj.uj_type k tj.utj_val in @@ -659,22 +726,12 @@ let judge_of_constructor env cu = let judge_of_case env ci pj cj lfj = let lf, lft = dest_judgev lfj in - make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) - (type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft) + let ci, t = type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft in + make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) t (* Building type of primitive operators and type *) -open CPrimitives - let check_primitive_type env op_t t = - match op_t with - | OT_type PT_int63 -> - (try - default_conv ~l2r:false CUMUL env mkSet t - with NotConvertible -> - CErrors.user_err Pp.(str"Was expecting the sort of this primitive type to be Set")) - | OT_op p -> - (try - default_conv ~l2r:false CUMUL env (type_of_prim env p) t - with NotConvertible -> - CErrors.user_err Pp.(str"Not the expected type for this primitive")) + let inft = type_of_prim_or_type env op_t in + try default_conv ~l2r:false CUMUL env inft t + with NotConvertible -> error_incorrect_primitive env (make_judge op_t inft) t diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 52c261c5e8..cc1885f42d 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -16,27 +16,29 @@ open Environ (** {6 Typing functions (not yet tagged as safe) } They return unsafe judgments that are "in context" of a set of - (local) universe variables (the ones that appear in the term) - and associated constraints. In case of polymorphic definitions, - these variables and constraints will be generalized. - *) + (local) universe variables (the ones that appear in the term) and + associated constraints. In case of polymorphic definitions, these + variables and constraints will be generalized. + When typechecking a term it may be updated to fix relevance marks. + Do not discard the result. *) val infer : env -> constr -> unsafe_judgment -val infer_v : env -> constr array -> unsafe_judgment array val infer_type : env -> types -> unsafe_type_judgment val check_context : - env -> Constr.rel_context -> env + env -> Constr.rel_context -> env * Constr.rel_context (** {6 Basic operations of the typing machine. } *) (** If [j] is the judgement {% $ %}c:t{% $ %}, then [assumption_of_judgement env j] returns the type {% $ %}c{% $ %}, checking that {% $ %}t{% $ %} is a sort. *) -val assumption_of_judgment : env -> unsafe_judgment -> types +val assumption_of_judgment : env -> unsafe_judgment -> Sorts.relevance val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment +val check_binder_annot : Sorts.t -> Name.t Context.binder_annot -> Name.t Context.binder_annot + (** {6 Type of sorts. } *) val type1 : types val type_of_sort : Sorts.t -> types @@ -65,21 +67,21 @@ val judge_of_apply : -> unsafe_judgment (** {6 Type of an abstraction. } *) -val judge_of_abstraction : - env -> Name.t -> unsafe_type_judgment -> unsafe_judgment - -> unsafe_judgment +(* val judge_of_abstraction : *) +(* env -> Name.t -> unsafe_type_judgment -> unsafe_judgment *) +(* -> unsafe_judgment *) (** {6 Type of a product. } *) val sort_of_product : env -> Sorts.t -> Sorts.t -> Sorts.t -val type_of_product : env -> Name.t -> Sorts.t -> Sorts.t -> types -val judge_of_product : - env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment - -> unsafe_judgment +val type_of_product : env -> Name.t Context.binder_annot -> Sorts.t -> Sorts.t -> types +(* val judge_of_product : *) +(* env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment *) +(* -> unsafe_judgment *) (** s Type of a let in. *) -val judge_of_letin : - env -> Name.t -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment - -> unsafe_judgment +(* val judge_of_letin : *) +(* env -> Name.t -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment *) +(* -> unsafe_judgment *) (** {6 Type of a cast. } *) val judge_of_cast : @@ -128,3 +130,6 @@ val judge_of_int : env -> Uint63.t -> unsafe_judgment val type_of_prim_type : env -> CPrimitives.prim_type -> types val type_of_prim : env -> CPrimitives.t -> types + +val warn_bad_relevance_name : string +(** Allow the checker to make this warning into an error. *) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 8187dea41b..0d5b55ca1b 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -29,15 +29,22 @@ module G = AcyclicGraph.Make(struct code (eg add_universe with a constraint vs G.add with no constraint) *) -type t = G.t -type 'a check_function = 'a G.check_function +type t = { graph: G.t; sprop_cumulative : bool } +type 'a check_function = t -> 'a -> 'a -> bool + +let g_map f g = + let g' = f g.graph in + if g.graph == g' then g + else {g with graph=g'} + +let make_sprop_cumulative g = {g with sprop_cumulative=true} let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with - | 0 -> G.check_leq g u v - | 1 -> G.check_lt g u v - | x when x < 0 -> G.check_leq g u v + | 0 -> G.check_leq g.graph u v + | 1 -> G.check_lt g.graph u v + | x when x < 0 -> G.check_leq g.graph u v | _ -> false let exists_bigger g ul l = @@ -48,24 +55,28 @@ let real_check_leq g u v = Universe.for_all (fun ul -> exists_bigger g ul v) u let check_leq g u v = - Universe.equal u v || - is_type0m_univ u || - real_check_leq g u v + Universe.equal u v || (g.sprop_cumulative && Universe.is_sprop u) || + (not (Universe.is_sprop u) && not (Universe.is_sprop v) && + (is_type0m_univ u || + real_check_leq g u v)) let check_eq g u v = Universe.equal u v || - (real_check_leq g u v && real_check_leq g v u) + (not (Universe.is_sprop u || Universe.is_sprop v) && + (real_check_leq g u v && real_check_leq g v u)) -let check_eq_level = G.check_eq +let check_eq_level g u v = + u == v || + (not (Level.is_sprop u || Level.is_sprop v) && G.check_eq g.graph u v) -let empty_universes = G.empty +let empty_universes = {graph=G.empty; sprop_cumulative=false} let initial_universes = let big_rank = 1000000 in let g = G.empty in let g = G.add ~rank:big_rank Level.prop g in let g = G.add ~rank:big_rank Level.set g in - G.enforce_lt Level.prop Level.set g + {graph=G.enforce_lt Level.prop Level.set g; sprop_cumulative=false} let enforce_constraint (u,d,v) g = match d with @@ -73,6 +84,13 @@ let enforce_constraint (u,d,v) g = | Lt -> G.enforce_lt u v g | Eq -> G.enforce_eq u v g +let enforce_constraint (u,d,v as cst) g = + match Level.is_sprop u, d, Level.is_sprop v with + | false, _, false -> g_map (enforce_constraint cst) g + | true, (Eq|Le), true -> g + | true, Le, false when g.sprop_cumulative -> g + | _ -> raise (UniverseInconsistency (d,Universe.make u, Universe.make v, None)) + let merge_constraints csts g = Constraint.fold enforce_constraint csts g let check_constraint g (u,d,v) = @@ -81,6 +99,13 @@ let check_constraint g (u,d,v) = | Lt -> G.check_lt g u v | Eq -> G.check_eq g u v +let check_constraint g (u,d,v as cst) = + match Level.is_sprop u, d, Level.is_sprop v with + | false, _, false -> check_constraint g.graph cst + | true, (Eq|Le), true -> true + | true, Le, false -> g.sprop_cumulative + | _ -> false + let check_constraints csts g = Constraint.for_all (check_constraint g) csts let leq_expr (u,m) (v,n) = @@ -125,17 +150,17 @@ let enforce_leq_alg u v g = exception AlreadyDeclared = G.AlreadyDeclared let add_universe u strict g = - let g = G.add u g in + let graph = G.add u g.graph in let d = if strict then Lt else Le in - enforce_constraint (Level.set,d,u) g + enforce_constraint (Level.set,d,u) {g with graph} -let add_universe_unconstrained u g = G.add u g +let add_universe_unconstrained u g = {g with graph=G.add u g.graph} exception UndeclaredLevel = G.Undeclared -let check_declared_universes = G.check_declared +let check_declared_universes g l = G.check_declared g.graph (LSet.remove Level.sprop l) -let constraints_of_universes = G.constraints_of -let constraints_for = G.constraints_for +let constraints_of_universes g = G.constraints_of g.graph +let constraints_for ~kept g = G.constraints_for ~kept:(LSet.remove Level.sprop kept) g.graph (** Subtyping of polymorphic contexts *) @@ -160,18 +185,20 @@ let check_eq_instances g t1 t2 = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) -let domain = G.domain -let choose = G.choose +let domain g = LSet.add Level.sprop (G.domain g.graph) +let choose p g u = if Level.is_sprop u + then if p u then Some u else None + else G.choose p g.graph u -let dump_universes = G.dump +let dump_universes f g = G.dump f g.graph -let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g +let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g.graph -let pr_universes = G.pr +let pr_universes prl g = G.pr prl g.graph let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] let make_dummy i = Level.(make (UGlobal.make dummy_mp i)) -let sort_universes g = G.sort make_dummy [Level.prop;Level.set] g +let sort_universes g = g_map (G.sort make_dummy [Level.prop;Level.set]) g (** Profiling *) diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index e1a5d50425..17d6c6e6d3 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -13,6 +13,9 @@ 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. *) + type 'a check_function = t -> 'a -> 'a -> bool val check_leq : Universe.t check_function diff --git a/kernel/univ.ml b/kernel/univ.ml index 09bf695915..8263c68bf5 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -53,6 +53,7 @@ struct end type t = + | SProp | Prop | Set | Level of UGlobal.t @@ -63,6 +64,7 @@ struct let equal x y = x == y || match x, y with + | SProp, SProp -> true | Prop, Prop -> true | Set, Set -> true | Level l, Level l' -> UGlobal.equal l l' @@ -71,6 +73,9 @@ struct let compare u v = match u, v with + | SProp, SProp -> 0 + | SProp, _ -> -1 + | _, SProp -> 1 | Prop,Prop -> 0 | Prop, _ -> -1 | _, Prop -> 1 @@ -88,6 +93,7 @@ struct let hequal x y = x == y || match x, y with + | SProp, SProp -> true | Prop, Prop -> true | Set, Set -> true | Level (n,d), Level (n',d') -> @@ -96,6 +102,7 @@ struct | _ -> false let hcons = function + | SProp as x -> x | Prop as x -> x | Set as x -> x | Level (d,n) as x -> @@ -106,8 +113,9 @@ struct open Hashset.Combine let hash = function - | Prop -> combinesmall 1 0 - | Set -> combinesmall 1 1 + | SProp -> combinesmall 1 0 + | Prop -> combinesmall 1 1 + | Set -> combinesmall 1 2 | Var n -> combinesmall 2 n | Level (d, n) -> combinesmall 3 (combine n (Names.DirPath.hash d)) @@ -118,6 +126,7 @@ module Level = struct module UGlobal = RawLevel.UGlobal type raw_level = RawLevel.t = + | SProp | Prop | Set | Level of UGlobal.t @@ -155,11 +164,13 @@ module Level = struct let set = make Set let prop = make Prop + let sprop = make SProp let is_small x = match data x with | Level _ -> false | Var _ -> false + | SProp -> true | Prop -> true | Set -> true @@ -173,12 +184,18 @@ module Level = struct | Set -> true | _ -> false + let is_sprop x = + match data x with + | SProp -> true + | _ -> false + let compare u v = if u == v then 0 else RawLevel.compare (data u) (data v) let to_string x = match data x with + | SProp -> "SProp" | Prop -> "Prop" | Set -> "Set" | Level (d,n) -> Names.DirPath.to_string d^"."^string_of_int n @@ -188,6 +205,7 @@ module Level = struct let apart u v = match data u, data v with + | SProp, _ | _, SProp | Prop, Set | Set, Prop -> true | _ -> false @@ -308,6 +326,7 @@ struct if Int.equal n n' then Level.compare x x' else n - n' + let sprop = hcons (Level.sprop, 0) let prop = hcons (Level.prop, 0) let set = hcons (Level.set, 0) let type1 = hcons (Level.set, 1) @@ -326,16 +345,16 @@ struct let cmp = Level.compare u v in if Int.equal cmp 0 then n <= n' else if n <= n' then - (Level.is_prop u && Level.is_small v) + (Level.is_prop u && not (Level.is_sprop v)) else false let successor (u,n) = - if Level.is_prop u then type1 + if Level.is_small u then type1 else (u, n + 1) let addn k (u,n as x) = if k = 0 then x - else if Level.is_prop u then + else if Level.is_small u then (Level.set,n+k) else (u,n+k) @@ -353,13 +372,16 @@ struct left expression is "smaller" than the right one in both cases. *) let super (u,n) (v,n') = let cmp = Level.compare u v in - if Int.equal cmp 0 then SuperSame (n < n') + if Int.equal cmp 0 then SuperSame (n < n') else let open RawLevel in match Level.data u, n, Level.data v, n' with - | Prop, _, Prop, _ -> SuperSame (n < n') - | Prop, 0, _, _ -> SuperSame true - | _, _, Prop, 0 -> SuperSame false + | SProp, _, SProp, _ | Prop, _, Prop, _ -> SuperSame (n < n') + | SProp, 0, Prop, 0 -> SuperSame true + | Prop, 0, SProp, 0 -> SuperSame false + | (SProp | Prop), 0, _, _ -> SuperSame true + | _, _, (SProp | Prop), 0 -> SuperSame false + | _, _, _, _ -> SuperDiff cmp let to_string (v, n) = @@ -445,6 +467,8 @@ struct | [l] -> Expr.is_small l | _ -> false + let sprop = tip Expr.sprop + (* The lower predicative level of the hierarchy that contains (impredicative) Prop and singleton inductive types *) let type0m = tip Expr.prop @@ -454,8 +478,9 @@ struct (* When typing [Prop] and [Set], there is no constraint on the level, hence the definition of [type1_univ], the type of [Prop] *) - let type1 = tip (Expr.successor Expr.set) + let type1 = tip Expr.type1 + let is_sprop x = equal sprop x let is_type0m x = equal type0m x let is_type0 x = equal type0 x @@ -656,7 +681,7 @@ let enforce_eq u v c = let constraint_add_leq v u c = (* We just discard trivial constraints like u<=u *) if Expr.equal v u then c - else + else match v, u with | (x,n), (y,m) -> let j = m - n in @@ -679,7 +704,12 @@ let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - List.fold_left (fun c v -> (List.fold_left (fun c u -> constraint_add_leq u v c) c u)) c v + match is_sprop u, is_sprop v with + | true, true -> c + | true, false | false, true -> + raise (UniverseInconsistency (Le, u, v, None)) + | false, false -> + List.fold_left (fun c v -> (List.fold_left (fun c u -> constraint_add_leq u v c) c u)) c v let enforce_leq u v c = if check_univ_leq u v then c @@ -845,7 +875,7 @@ struct else Array.append x y let of_array a = - assert(Array.for_all (fun x -> not (Level.is_prop x)) a); + assert(Array.for_all (fun x -> not (Level.is_prop x || Level.is_sprop x)) a); a let to_array a = a diff --git a/kernel/univ.mli b/kernel/univ.mli index 1fbebee350..5543c35741 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -30,11 +30,13 @@ sig val set : t val prop : t + val sprop : t (** The set and prop universe levels. *) val is_small : t -> bool (** Is the universe set or prop? *) + val is_sprop : t -> bool val is_prop : t -> bool val is_set : t -> bool (** Is it specifically Prop or Set *) @@ -119,6 +121,8 @@ sig val sup : t -> t -> t (** The l.u.b. of 2 universes *) + val sprop : t + val type0m : t (** image of Prop in the universes hierarchy *) @@ -128,6 +132,10 @@ sig val type1 : t (** the universe of the type of Prop/Set *) + val is_sprop : t -> bool + val is_type0m : t -> bool + val is_type0 : t -> bool + val exists : (Level.t * int -> bool) -> t -> bool val for_all : (Level.t * int -> bool) -> t -> bool diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 9a3eadf747..777a207013 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Sorts open Univ open Constr @@ -138,6 +137,7 @@ let hash_annot_switch asw = let pp_sort s = let open Sorts in match s with + | SProp -> Pp.str "SProp" | Prop -> Pp.str "Prop" | Set -> Pp.str "Set" | Type u -> Pp.(str "Type@{" ++ Univ.pr_uni u ++ str "}") @@ -335,10 +335,10 @@ let rec whd_accu a stk = let args = Array.init (nargs args) (arg args) in let s = Obj.obj (Obj.field at 0) in begin match s with - | Type u -> + | Sorts.Type u -> let inst = Instance.of_array (Array.map uni_lvl_val args) in let u = Univ.subst_instance_universe inst u in - Vatom_stk (Asort (Type u), []) + Vatom_stk (Asort (Sorts.sort_of_univ u), []) | _ -> assert false end | _ -> assert false diff --git a/kernel/write_uint63.ml b/kernel/write_uint63.ml index 0fcaf4f10a..beb59ce205 100644 --- a/kernel/write_uint63.ml +++ b/kernel/write_uint63.ml @@ -1,10 +1,18 @@ -(** Equivalent of rm -f *) +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(** Equivalent of rm -f *) let safe_remove f = try Unix.chmod f 0o644; Sys.remove f with _ -> () (** * Generate an implementation of 63-bit arithmetic *) - let ml_file_copy input output = safe_remove output; let i = open_in input in diff --git a/lib/flags.ml b/lib/flags.ml index 1195b8caf1..6718e7a954 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -43,8 +43,6 @@ let with_options ol f x = let record_aux_file = ref false -let test_mode = ref false - let async_proofs_worker_id = ref "master" let async_proofs_is_worker () = !async_proofs_worker_id <> "master" diff --git a/lib/flags.mli b/lib/flags.mli index 2b4446a1db..bf8846417b 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -35,10 +35,6 @@ be eventually removed by cleanups such as PR#1103 *) val record_aux_file : bool ref -(* Flag set when the test-suite is called. Its only effect to display - verbose information for `Fail` *) -val test_mode : bool ref - (** Async-related flags *) val async_proofs_worker_id : string ref val async_proofs_is_worker : unit -> bool diff --git a/lib/future.ml b/lib/future.ml index b372bedc5d..6e7c6fd9e3 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -33,7 +33,7 @@ let _ = CErrors.register_handler (function | _ -> raise CErrors.Unhandled) type fix_exn = Exninfo.iexn -> Exninfo.iexn -let id x = prerr_endline "Future: no fix_exn.\nYou have probably created a Future.computation from a value without passing the ~fix_exn argument. You probably want to chain with an already existing future instead."; x +let id x = x module UUID = struct type t = int diff --git a/library/global.ml b/library/global.ml index cf996ce644..d9f8a6ffa3 100644 --- a/library/global.ml +++ b/library/global.ml @@ -90,6 +90,9 @@ let set_engagement c = globalize0 (Safe_typing.set_engagement c) let set_indices_matter b = globalize0 (Safe_typing.set_indices_matter b) let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c) let typing_flags () = Environ.typing_flags (env ()) +let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative +let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) +let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) let add_constant ~in_section id d = globalize (Safe_typing.add_constant ~in_section (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) diff --git a/library/global.mli b/library/global.mli index 4e2ad92717..ca88d2dafd 100644 --- a/library/global.mli +++ b/library/global.mli @@ -32,6 +32,9 @@ val set_engagement : Declarations.engagement -> unit val set_indices_matter : bool -> unit val set_typing_flags : Declarations.typing_flags -> unit val typing_flags : unit -> Declarations.typing_flags +val make_sprop_cumulative : unit -> unit +val set_allow_sprop : bool -> unit +val sprop_allowed : unit -> bool (** Variables, Local definitions, constants, inductive types *) @@ -134,7 +137,7 @@ val constr_of_global_in_context : Environ.env -> val type_of_global_in_context : Environ.env -> GlobRef.t -> Constr.types * Univ.AUContext.t - [@@ocaml.deprecated "alias of [Typeops.type_of_global]"] + [@@ocaml.deprecated "alias of [Typeops.type_of_global_in_context]"] (** Returns the universe context of the global reference (whatever its polymorphic status is). *) val universes_of_global : GlobRef.t -> Univ.AUContext.t diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index b3ae24e941..6f73a3e4ed 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -31,7 +31,7 @@ let ldots_var = Id.of_string ".." let constr_kw = [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; "end"; "as"; "let"; "if"; "then"; "else"; "return"; - "Prop"; "Set"; "Type"; ".("; "_"; ".."; + "SProp"; "Prop"; "Set"; "Type"; ".("; "_"; ".."; "`{"; "`("; "{|"; "|}" ] let _ = List.iter CLexer.add_keyword constr_kw @@ -153,6 +153,7 @@ GRAMMAR EXTEND Gram sort: [ [ "Set" -> { GSet } | "Prop" -> { GProp } + | "SProp" -> { GSProp } | "Type" -> { GType [] } | "Type"; "@{"; u = universe; "}" -> { GType u } ] ] @@ -160,6 +161,7 @@ GRAMMAR EXTEND Gram sort_family: [ [ "Set" -> { Sorts.InSet } | "Prop" -> { Sorts.InProp } + | "SProp" -> { Sorts.InSProp } | "Type" -> { Sorts.InType } ] ] ; @@ -323,6 +325,7 @@ GRAMMAR EXTEND Gram ; universe_level: [ [ "Set" -> { GSet } + (* no parsing SProp as a level *) | "Prop" -> { GProp } | "Type" -> { GType UUnknown } | "_" -> { GType UAnonymous } diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 575d964158..23cdae7883 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -17,6 +17,7 @@ open Pp open Names open Sorts open Constr +open Context open Vars open Goptions open Tacmach @@ -421,11 +422,11 @@ let new_representative typ = let _A_ = Name (Id.of_string "A") let _B_ = Name (Id.of_string "A") -let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) +let _body_ = mkProd(make_annot Anonymous Sorts.Relevant,mkRel 2,mkRel 2) let cc_product s1 s2 = - mkLambda(_A_,mkSort(s1), - mkLambda(_B_,mkSort(s2),_body_)) + mkLambda(make_annot _A_ Sorts.Relevant,mkSort(s1), + mkLambda(make_annot _B_ Sorts.Relevant,mkSort(s2),_body_)) let rec constr_of_term = function Symb s-> s @@ -452,11 +453,11 @@ let rec canonize_name sigma c = let canon_mind = MutInd.make1 (MutInd.canonical kn) in mkConstructU (((canon_mind,i),j),u) | Prod (na,t,ct) -> - mkProd (na,func t, func ct) + mkProd (na,func t, func ct) | Lambda (na,t,ct) -> - mkLambda (na, func t,func ct) + mkLambda (na, func t,func ct) | LetIn (na,b,t,ct) -> - mkLetIn (na, func b,func t,func ct) + mkLetIn (na, func b,func t,func ct) | App (ct,l) -> mkApp (func ct,Array.Smart.map func l) | Proj(p,c) -> @@ -806,7 +807,8 @@ let __eps__ = Id.of_string "_eps_" let new_state_var typ state = let ids = Environ.ids_of_named_context_val (Environ.named_context_val state.env) in let id = Namegen.next_ident_away __eps__ ids in - state.env<- EConstr.push_named (Context.Named.Declaration.LocalAssum (id,typ)) state.env; + let r = Sorts.Relevant in (* TODO relevance *) + state.env<- EConstr.push_named (Context.Named.Declaration.LocalAssum (make_annot id r,typ)) state.env; id let complete_one_class state i= @@ -814,9 +816,9 @@ let complete_one_class state i= Partial pac -> let rec app t typ n = if n<=0 then t else - let _,etyp,rest= destProd typ in + let _,etyp,rest= destProd typ in let id = new_state_var (EConstr.of_constr etyp) state in - app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in + app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in let _c = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in let _c = EConstr.Unsafe.to_constr _c in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 055d36747d..5778acce0a 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -15,6 +15,7 @@ open Names open Inductiveops open Declarations open Constr +open Context open EConstr open Vars open Tactics @@ -151,19 +152,19 @@ let patterns_of_constr env sigma nrels term= let rec quantified_atom_of_constr env sigma nrels term = match EConstr.kind sigma (whd_delta env sigma term) with - Prod (id,atom,ff) -> + Prod (id,atom,ff) -> if is_global sigma (Lazy.force _False) ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff + quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts let litteral_of_constr env sigma term= match EConstr.kind sigma (whd_delta env sigma term) with - | Prod (id,atom,ff) -> + | Prod (id,atom,ff) -> if is_global sigma (Lazy.force _False) ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) @@ -171,7 +172,7 @@ let litteral_of_constr env sigma term= else begin try - quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff + quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end @@ -233,7 +234,7 @@ let build_projection intype (cstr:pconstructor) special default gls= let sigma = project gls in let body=Equality.build_selector (pf_env gls) sigma ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in - sigma, mkLambda(Name id,intype,body) + sigma, mkLambda(make_annot (Name id) Sorts.Relevant,intype,body) (* generate an adhoc tactic following the proof tree *) @@ -318,7 +319,7 @@ let rec proof_tac p : unit Proofview.tactic = refresh_universes (type_of tx1) (fun typx -> refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> let id = Tacmach.New.pf_get_new_id (Id.of_string "f") gl in - let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in + let appx1 = mkLambda(make_annot (Name id) Sorts.Relevant,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = app_global_with_holes _f_equal [|typf;typfx;appx1;tf1;tf2|] 1 in let lemma2 = app_global_with_holes _f_equal [|typx;typfx;tf2;tx1;tx2|] 1 in let prf = @@ -377,7 +378,7 @@ let convert_to_goal_tac c t1 t2 p = let neweq= app_global _eq [|sort;tt1;tt2|] in let e = Tacmach.New.pf_get_new_id (Id.of_string "e") gl in let x = Tacmach.New.pf_get_new_id (Id.of_string "X") gl in - let identity=mkLambda (Name x,sort,mkRel 1) in + let identity=mkLambda (make_annot (Name x) Sorts.Relevant,sort,mkRel 1) in let endt = app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; endt refine_exact_check] diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index d06a241969..afdbfa1999 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -9,6 +9,7 @@ (************************************************************************) open Constr +open Context open Context.Named.Declaration let map_const_entry_body (f:constr->constr) (x:Safe_typing.private_constants Entries.const_entry_body) @@ -39,7 +40,7 @@ let start_deriving f suchthat lemma = TCons ( env , sigma , f_type , (fun sigma ef -> let f_type = EConstr.Unsafe.to_constr f_type in let ef = EConstr.Unsafe.to_constr ef in - let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in + let env' = Environ.push_named (LocalDef (annotR f, ef, f_type)) env in let sigma, suchthat = Constrintern.interp_type_evars ~program_mode:false env' sigma suchthat in TCons ( env' , sigma , suchthat , (fun sigma _ -> TNil sigma)))))) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index b59e3b608c..0fa9be21c9 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -150,7 +150,7 @@ let check_fix env sg cb i = | Undef _ | OpaqueDef _ | Primitive _ -> raise Impossible let prec_declaration_equal sg (na1, ca1, ta1) (na2, ca2, ta2) = - Array.equal Name.equal na1 na2 && + Array.equal (Context.eq_annot Name.equal) na1 na2 && Array.equal (EConstr.eq_constr sg) ca1 ca2 && Array.equal (EConstr.eq_constr sg) ta1 ta2 diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 204f889f90..c9cfd74362 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -13,6 +13,7 @@ open Util open Names open Term open Constr +open Context open Declarations open Declareops open Environ @@ -73,13 +74,18 @@ type flag = info * scheme (*s [flag_of_type] transforms a type [t] into a [flag]. Really important function. *) +let info_of_family = function + | InSProp | InProp -> Logic + | InSet | InType -> Info + +let info_of_sort s = info_of_family (Sorts.family s) + let rec flag_of_type env sg t : flag = let t = whd_all env sg t in match EConstr.kind sg t with | Prod (x,t,c) -> flag_of_type (EConstr.push_rel (LocalAssum (x,t)) env) sg c - | Sort s when Sorts.is_prop (EConstr.ESorts.kind sg s) -> (Logic,TypeScheme) - | Sort _ -> (Info,TypeScheme) - | _ -> if (sort_of env sg t) == InProp then (Logic,Default) else (Info,Default) + | Sort s -> (info_of_sort (EConstr.ESorts.kind sg s),TypeScheme) + | _ -> (info_of_family (sort_of env sg t),Default) (*s Two particular cases of [flag_of_type]. *) @@ -179,7 +185,7 @@ let rec type_sign_vl env sg c = | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) sg d in if not (is_info_scheme env sg t) then Kill Kprop::s, vl - else Keep::s, (make_typvar n vl) :: vl + else Keep::s, (make_typvar n.binder_name vl) :: vl | _ -> [],[] let rec nb_default_params env sg c = @@ -259,14 +265,14 @@ let rec extract_type env sg db j c args = (* We just accumulate the arguments. *) extract_type env sg db j d (Array.to_list args' @ args) | Lambda (_,_,d) -> - (match args with + (match args with | [] -> assert false (* A lambda cannot be a type. *) | a :: args -> extract_type env sg db j (EConstr.Vars.subst1 a d) args) | Prod (n,t,d) -> - assert (List.is_empty args); - let env' = push_rel_assum (n,t) env in + assert (List.is_empty args); + let env' = push_rel_assum (n,t) env in (match flag_of_type env sg t with - | (Info, Default) -> + | (Info, Default) -> (* Standard case: two [extract_type] ... *) let mld = extract_type env' sg (0::db) j d [] in (match expand env mld with @@ -291,7 +297,7 @@ let rec extract_type env sg db j c args = (match EConstr.lookup_rel n env with | LocalDef (_,t,_) -> extract_type env sg db j (EConstr.Vars.lift n t) args - | _ -> + | _ -> (* Asks [db] a translation for [n]. *) if n > List.length db then Tunknown else let n' = List.nth db (n-1) in @@ -492,8 +498,8 @@ and extract_really_ind env kn mib = (* Now we're sure it's a record. *) (* First, we find its field names. *) let rec names_prod t = match Constr.kind t with - | Prod(n,_,t) -> n::(names_prod t) - | LetIn(_,_,_,t) -> names_prod t + | Prod(n,_,t) -> n::(names_prod t) + | LetIn(_,_,_,t) -> names_prod t | Cast(t,_,_) -> names_prod t | _ -> [] in @@ -506,9 +512,9 @@ and extract_really_ind env kn mib = | [],[] -> [] | _::l, typ::typs when isTdummy (expand env typ) -> select_fields l typs - | Anonymous::l, typ::typs -> + | {binder_name=Anonymous}::l, typ::typs -> None :: (select_fields l typs) - | Name id::l, typ::typs -> + | {binder_name=Name id}::l, typ::typs -> let knp = Constant.make2 mp (Label.of_id id) in (* Is it safe to use [id] for projections [foo.id] ? *) if List.for_all ((==) Keep) (type2signature env typ) @@ -551,8 +557,8 @@ and extract_really_ind env kn mib = and extract_type_cons env sg db dbmap c i = match EConstr.kind sg (whd_all env sg c) with | Prod (n,t,d) -> - let env' = push_rel_assum (n,t) env in - let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in + let env' = push_rel_assum (n,t) env in + let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in let l = extract_type_cons env' sg db' dbmap d (i+1) in (extract_type env sg db 0 t []) :: l | _ -> [] @@ -615,17 +621,18 @@ let rec extract_term env sg mle mlt c args = | App (f,a) -> extract_term env sg mle mlt f (Array.to_list a @ args) | Lambda (n, t, d) -> - let id = id_of_name n in + let id = map_annot id_of_name n in + let idna = map_annot Name.mk_name id in (match args with | a :: l -> (* We make as many [LetIn] as possible. *) let l' = List.map (EConstr.Vars.lift 1) l in - let d' = EConstr.mkLetIn (Name id,a,t,applistc d l') in + let d' = EConstr.mkLetIn (idna,a,t,applistc d l') in extract_term env sg mle mlt d' [] - | [] -> - let env' = push_rel_assum (Name id, t) env in + | [] -> + let env' = push_rel_assum (idna, t) env in let id, a = - try check_default env sg t; Id id, new_meta() + try check_default env sg t; Id id.binder_name, new_meta() with NotDefault d -> Dummy, Tdummy d in let b = new_meta () in @@ -634,9 +641,9 @@ let rec extract_term env sg mle mlt c args = let d' = extract_term env' sg (Mlenv.push_type mle a) b d [] in put_magic_if magic (MLlam (id, d'))) | LetIn (n, c1, t1, c2) -> - let id = id_of_name n in - let env' = EConstr.push_rel (LocalDef (Name id, c1, t1)) env in - (* We directly push the args inside the [LetIn]. + let id = map_annot id_of_name n in + let env' = EConstr.push_rel (LocalDef (map_annot Name.mk_name id, c1, t1)) env in + (* We directly push the args inside the [LetIn]. TODO: the opt_let_app flag is supposed to prevent that *) let args' = List.map (EConstr.Vars.lift 1) args in (try @@ -649,7 +656,7 @@ let rec extract_term env sg mle mlt c args = then Mlenv.push_gen mle a else Mlenv.push_type mle a in - MLletin (Id id, c1', extract_term env' sg mle' mlt c2 args') + MLletin (Id id.binder_name, c1', extract_term env' sg mle' mlt c2 args') with NotDefault d -> let mle' = Mlenv.push_std_type mle (Tdummy d) in ast_pop (extract_term env' sg mle' mlt c2 args')) @@ -913,7 +920,7 @@ and extract_fix env sg mle i (fi,ti,ci as recd) mlt = metas.(i) <- mlt; let mle = Array.fold_left Mlenv.push_type mle metas in let ei = Array.map2 (extract_maybe_term env sg mle) metas ci in - MLfix (i, Array.map id_of_name fi, ei) + MLfix (i, Array.map (fun x -> id_of_name x.binder_name) fi, ei) (*S ML declarations. *) @@ -989,7 +996,7 @@ let extract_std_constant env sg kn body typ = (* The initial ML environment. *) let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in (* The lambdas names. *) - let ids = List.map (fun (n,_) -> Id (id_of_name n)) rels in + let ids = List.map (fun (n,_) -> Id (id_of_name n.binder_name)) rels in (* The according Coq environment. *) let env = push_rels_assum rels env in (* The real extraction: *) @@ -1044,7 +1051,9 @@ let fake_match_projection env p = let indu = mkIndU (ind,u) in let ctx, paramslet = let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((fst ind, mib.mind_ntypes - i - 1), u)) in - let rctx, _ = decompose_prod_assum (Vars.substl subst mip.mind_nf_lc.(0)) in + let (ctx, cty) = mip.mind_nf_lc.(0) in + let cty = Term.it_mkProd_or_LetIn cty ctx in + let rctx, _ = decompose_prod_assum (Vars.substl subst cty) in List.chop mip.mind_consnrealdecls.(0) rctx in let ci_pp_info = { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in @@ -1053,12 +1062,15 @@ let fake_match_projection env p = ci_npar = mib.mind_nparams; ci_cstr_ndecls = mip.mind_consnrealdecls; ci_cstr_nargs = mip.mind_consnrealargs; + ci_relevance = Declareops.relevance_of_projection_repr mib p; ci_pp_info; } in let x = match mib.mind_record with | NotRecord | FakeRecord -> assert false - | PrimRecord info -> Name (pi1 info.(snd ind)) + | PrimRecord info -> + let x, _, _, _ = info.(snd ind) in + make_annot (Name x) mip.mind_relevance in let indty = mkApp (indu, Context.Rel.to_extended_vect mkRel 0 paramslet) in let rec fold arg j subst = function @@ -1066,7 +1078,7 @@ let fake_match_projection env p = | LocalAssum (na,ty) :: rem -> let ty = Vars.substl subst (liftn 1 j ty) in if arg != proj_arg then - let lab = match na with Name id -> Label.of_id id | Anonymous -> assert false in + let lab = match na.binder_name with Name id -> Label.of_id id | Anonymous -> assert false in let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:arg lab in fold (arg+1) (j+1) (mkProj (Projection.make kn false, mkRel 1)::subst) rem else diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 2058837b8e..399a77c596 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -449,11 +449,11 @@ let argnames_of_global r = let typ, _ = Typeops.type_of_global_in_context env r in let rels,_ = decompose_prod (Reduction.whd_all env typ) in - List.rev_map fst rels + List.rev_map (fun x -> Context.binder_name (fst x)) rels let msg_of_implicit = function | Kimplicit (r,i) -> - let name = match List.nth (argnames_of_global r) (i-1) with + let name = match (List.nth (argnames_of_global r) (i-1)) with | Anonymous -> "" | Name id -> "(" ^ Id.to_string id ^ ") " in diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index a60a966cec..56b3dc97cf 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -13,7 +13,6 @@ open Names open Constr open EConstr open Vars -open Termops open Util open Declarations open Globnames @@ -100,9 +99,8 @@ let kind_of_formula env sigma term = else let has_realargs=(n>0) in let is_trivial= - let is_constant c = - Int.equal (nb_prod sigma (EConstr.of_constr c)) mib.mind_nparams in - Array.exists is_constant mip.mind_nf_lc in + let is_constant n = Int.equal n 0 in + Array.exists is_constant mip.mind_consnrealargs in if Inductiveops.mis_is_recursive (ind,mib,mip) || (has_realargs && not is_trivial) then diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 286021d68e..1c9ab2e3bd 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -107,7 +107,7 @@ let mk_open_instance env evmap id idc m t = (* since we know we will get a product, reduction is not too expensive *) let (nam,_,_)=destProd evmap (whd_all env evmap typ) in - match nam with + match nam.Context.binder_name with Name id -> id | Anonymous -> dummy_bvid in let revt=substl (List.init m (fun i->mkRel (m-i))) t in @@ -115,7 +115,7 @@ let mk_open_instance env evmap id idc m t = if Int.equal n 0 then evmap, decls else let nid=(fresh_id_in_env avoid var_id env) in let (evmap, (c, _)) = Evarutil.new_type_evar env evmap Evd.univ_flexible in - let decl = LocalAssum (Name nid, c) in + let decl = LocalAssum (Context.make_annot (Name nid) Sorts.Relevant, c) in aux (n-1) (Id.Set.add nid avoid) (EConstr.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m Id.Set.empty env evmap [] in (evmap, decls, revt) diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 832a98b7f8..7f06ab6777 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -163,9 +163,9 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq = let ll_arrow_tac a b c backtrack id continue seq= let open EConstr in let open Vars in - let cc=mkProd(Anonymous,a,(lift 1 b)) in - let d idc = mkLambda (Anonymous,b, - mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in + let cc=mkProd(Context.make_annot Anonymous Sorts.Relevant,a,(lift 1 b)) in + let d idc = mkLambda (Context.make_annot Anonymous Sorts.Relevant,b, + mkApp (idc, [|mkLambda (Context.make_annot Anonymous Sorts.Relevant,(lift 1 a),(mkRel 2))|])) in tclORELSE (tclTHENS (cut c) [tclTHENLIST diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index d63fe9d799..0c958ddee3 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -65,13 +65,13 @@ let unif evd t1 t2= bind i t else raise (UFAIL(nt1,nt2)) | Cast(_,_,_),_->Queue.add (strip_outer_cast evd nt1,nt2) bige | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige - | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> + | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> Queue.add (pa,pb) bige; Queue.add (ca,cb) bige; let l=Array.length va in - if not (Int.equal l (Array.length vb)) then + if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else for i=0 to l-1 do diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 8da30bd9c9..34283c49c3 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -2,6 +2,7 @@ open Printer open CErrors open Util open Constr +open Context open EConstr open Vars open Namegen @@ -238,7 +239,9 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = raise NoChange; end in - let eq_constr c1 c2 = Option.has_some (Evarconv.conv env sigma c1 c2) in + let eq_constr c1 c2 = + try ignore(Evarconv.unify_delay env sigma c1 c2); true + with Evarconv.UnableToUnify _ -> false in if not (noccurn sigma 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp sigma t) then nochange "not an equality"; @@ -300,7 +303,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = in let old_context_length = List.length context + 1 in let witness_fun = - mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t, + 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 @@ -310,7 +313,8 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = 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_name decl, witness, RelDecl.get_type decl, witness_fun)) + (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) ) @@ -426,7 +430,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = else if isProd sigma type_of_hyp then begin - let (x,t_x,t') = destProd sigma type_of_hyp in + 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 @@ -539,7 +543,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (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' + scan_type (LocalAssum (x,t_x) :: context) t' end end else @@ -608,7 +612,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = anomaly (Pp.str "cannot compute new term value.") in let fun_body = - mkLambda(Anonymous, + mkLambda(make_annot Anonymous Sorts.Relevant, pf_unsafe_type_of g' term, Termops.replace_term (project g') term (mkRel 1) dyn_infos.info ) @@ -734,7 +738,7 @@ let build_proof g in build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda(n,t,b) -> + | Lambda(n,t,b) -> begin match EConstr.kind sigma (pf_concl g) with | Prod _ -> @@ -1147,7 +1151,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam 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)) -> + | Fix((idxs,i),(names,typess,bodies)) -> let bodies_with_all_params = Array.map (fun body -> @@ -1162,7 +1166,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (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)); + name = Nameops.Name.get_id (fresh_id names.(i).binder_name); types = types; offset = fix_offset; nb_realargs = @@ -1193,9 +1197,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam applist(body,List.rev_map var_of_decl full_params)) in match EConstr.kind (project g) body_with_full_params with - | Fix((_,num),(_,_,bs)) -> + | Fix((_,num),(_,_,bs)) -> Reductionops.nf_betaiota (pf_env g) (project g) - ( + ( (applist (substl (List.rev @@ -1512,7 +1516,7 @@ let is_valid_hypothesis sigma predicates_name = 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' + | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' | _ -> false in is_valid_hypothesis @@ -1563,7 +1567,7 @@ let prove_principle_for_gen in let rec_arg_id = match List.rev post_rec_arg with - | (LocalAssum (Name id,_) | LocalDef (Name id,_,_)) :: _ -> id + | (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)); *) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index ca09cad1f3..1217ba0eba 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -14,6 +14,7 @@ open Term open Sorts open Util open Constr +open Context open Vars open Namegen open Names @@ -72,7 +73,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = then List.tl args else args in - Context.Named.Declaration.LocalAssum (Nameops.Name.get_id (Context.Rel.Declaration.get_name decl), + Context.Named.Declaration.LocalAssum (map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl), Term.compose_prod real_args (mkSort new_sort)) in let new_predicates = @@ -137,14 +138,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Rel n -> begin try match Environ.lookup_rel n env with - | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved + | 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 + | 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 @@ -164,8 +165,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = 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 + | 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 *) @@ -181,14 +182,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x : Name.t = get_name (Termops.ids_of_context env) x in - let new_env = Environ.push_rel (LocalAssum (x,t)) env 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), + bind_fun(new_x,new_t,new_b), list_union_eq Constr.equal binders_to_remove_from_t @@ -210,14 +211,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = 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 : Name.t = get_name (Termops.ids_of_context env) x in - let new_env = Environ.push_rel (LocalDef (x,v,t)) env 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), + 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) @@ -250,8 +251,11 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in it_mkProd_or_LetIn (it_mkProd_or_LetIn - pre_res (List.map (function Context.Named.Declaration.LocalAssum (id,b) -> LocalAssum (Name (Hashtbl.find tbl id), b) - | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b)) + 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) @@ -264,7 +268,7 @@ let change_property_sort evd toSort princ princName = let princ_info = compute_elim_sig evd princ in let change_sort_in_predicate decl = LocalAssum - (get_name decl, + (get_annot decl, let args,ty = decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in let s = destSort ty in Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); @@ -414,7 +418,7 @@ let get_funs_constant mp = | Fix((_,(na,_,_))) -> Array.mapi (fun i na -> - match na with + match na.binder_name with | Name id -> let const = Constant.make2 mp (Label.of_id id) in const,i @@ -451,7 +455,8 @@ let get_funs_constant mp = let first_params = List.hd l_params in List.iter (fun params -> - if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && Constr.equal c1 c2) first_params params) + if not (List.equal (fun (n1, c1) (n2, c2) -> + eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) then user_err Pp.(str "Not a mutal recursive block") ) l_params @@ -461,7 +466,7 @@ 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) + | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) | _ -> if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec @@ -469,9 +474,9 @@ let get_funs_constant mp = in let first_infos = extract_info true (List.hd l_bodies) in 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 Name.equal na1 na2 && - Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 + let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = + Array.equal Int.equal ia1 ia2 && Array.equal (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 user_err Pp.(str "Not a mutal recursive block") diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index ba0a3bbb5c..8611dcaf83 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -2,6 +2,7 @@ open Printer open Pp open Names open Constr +open Context open Vars open Glob_term open Glob_ops @@ -343,12 +344,13 @@ 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 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 (id,typ)) env + EConstr.push_named (NamedDecl.LocalAssum (na,typ)) env | Some value -> - EConstr.push_named (NamedDecl.LocalDef (id, value, typ)) env) + EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env) let add_pat_variables pat typ env : Environ.env = @@ -356,7 +358,7 @@ let add_pat_variables pat typ env : 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 (na,typ)) env + | 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) @@ -375,16 +377,18 @@ let add_pat_variables pat typ env : Environ.env = let open Context.Rel.Declaration in let sigma, _ = Pfedit.get_current_context () in match decl with - | LocalAssum (Anonymous,_) | LocalDef (Anonymous,_,_) -> assert false - | LocalAssum (Name id, t) -> + | 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 (id,new_t)) env,mkVar id::ctxt) - | LocalDef (Name id, v, t) -> + (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 () ++ @@ -394,7 +398,7 @@ let add_pat_variables pat typ env : Environ.env = str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt) + (Environ.push_named (LocalDef (na,new_v,new_t)) env,mkVar id::ctxt) ) (Environ.rel_context new_env) ~init:(env,[]) @@ -626,11 +630,12 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let v_res = build_entry_lc env funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_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 (id,v_as_constr,v_type)) env - in + | 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 funnames avoid b in combine_results (combine_letin n) v_res b_res | GCases(_,_,el,brl) -> @@ -939,9 +944,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = 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 new_env = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + 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 @@ -974,9 +980,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = 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 new_env = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + 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 @@ -1057,8 +1064,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in let new_env = let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in - EConstr.push_rel (LocalAssum (n,t')) env - 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 @@ -1095,8 +1103,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = 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 new_env = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + 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 @@ -1111,8 +1120,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> 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 new_env = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + 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 @@ -1132,8 +1142,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let t',ctx = Pretyping.understand env (Evd.from_env env) t in match n with | Name id -> - let new_env = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + 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 @@ -1158,7 +1169,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let type_t' = Typing.unsafe_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 (n,t',type_t')) env 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 @@ -1182,8 +1193,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = depth t in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let new_env = EConstr.push_rel (LocalAssum (na,t')) env in - let new_b,id_to_exclude = + 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) @@ -1320,7 +1332,7 @@ let do_build_inductive 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 (id,t)) + Environ.push_named (LocalAssum (make_annot id Sorts.Relevant,t)) env ) funnames @@ -1364,7 +1376,8 @@ let do_build_inductive 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 - Environ.push_named (LocalAssum (rel_name,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 = diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 42dc66dcf4..b69ca7080c 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -3,6 +3,7 @@ open Sorts open Util open Names open Constr +open Context open EConstr open Pp open Indfun_common @@ -49,7 +50,8 @@ let functional_induction with_clean c princl pat = user_err (str "Cannot find induction information on "++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in - match Tacticals.elimination_sort_of_goal g with + match Tacticals.elimination_sort_of_goal g with + | InSProp -> finfo.sprop_lemma | InProp -> finfo.prop_lemma | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma @@ -169,7 +171,8 @@ let build_newrecursive let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd bl in let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in let open Context.Named.Declaration in - (EConstr.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) + let r = Sorts.Relevant in (* TODO relevance *) + (EConstr.push_named (LocalAssum (make_annot recname r,arity)) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) @@ -621,8 +624,8 @@ let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in - let constr_expr_typel = + let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in + let constr_expr_typel = with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index cba3cc3d42..88546e9ae8 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -199,6 +199,7 @@ type function_info = 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 *) } @@ -249,6 +250,7 @@ let subst_Function (subst,finfos) = 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 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 && @@ -256,7 +258,8 @@ let subst_Function (subst,finfos) = completeness_lemma' == finfos.completeness_lemma && rect_lemma' == finfos.rect_lemma && rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma + prop_lemma' == finfos.prop_lemma && + sprop_lemma' == finfos.sprop_lemma then finfos else { function_constant = function_constant'; @@ -267,6 +270,7 @@ let subst_Function (subst,finfos) = rect_lemma = rect_lemma' ; rec_lemma = rec_lemma'; prop_lemma = prop_lemma'; + sprop_lemma = sprop_lemma'; is_general = finfos.is_general } @@ -333,6 +337,7 @@ let add_Function is_general f = and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect") and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec") 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 | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") @@ -345,6 +350,7 @@ let add_Function is_general f = rect_lemma = rect_lemma; rec_lemma = rec_lemma; prop_lemma = prop_lemma; + sprop_lemma = sprop_lemma; graph_ind = graph_ind; is_general = is_general diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 1e0b95df34..4ec3131518 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -70,6 +70,7 @@ type function_info = rect_lemma : Constant.t option; rec_lemma : Constant.t option; prop_lemma : Constant.t option; + sprop_lemma : Constant.t option; is_general : bool; } @@ -109,9 +110,9 @@ val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_referenc val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> - (Names.Name.t * EConstr.t) list * EConstr.t -val compose_lam : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t -val compose_prod : (Names.Name.t * EConstr.t) list -> EConstr.t -> 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 diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 95e2e9f6e5..37dbfec4c9 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -15,6 +15,7 @@ open Util open Names open Term open Constr +open Context open EConstr open Vars open Pp @@ -142,12 +143,13 @@ let generate_type evd g_to_f f graph i = \[\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 (Name res_id, lift 1 res_type) :: LocalDef (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt + LocalAssum (make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: + LocalDef (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 (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else LocalAssum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + then LocalAssum (make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph + else LocalAssum (make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph (* @@ -270,10 +272,10 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i let type_of_hid = pf_unsafe_type_of g (mkVar hid) in let sigma = project g in match EConstr.kind sigma type_of_hid with - | Prod(_,_,t') -> + | Prod(_,_,t') -> begin match EConstr.kind sigma t' with - | Prod(_,t'',t''') -> + | Prod(_,t'',t''') -> begin match EConstr.kind sigma t'',EConstr.kind sigma t''' with | App(eq,args), App(graph',_) @@ -358,17 +360,16 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i (* end of branche proof *) let lemmas = Array.map - (fun ((_,(ctxt,concl))) -> - match ctxt with - | [] | [_] | [_;_] -> 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_name decl, RelDecl.get_type decl) :: ctxt) - in - res - ) - lemmas_types_infos + (fun ((_,(ctxt,concl))) -> + match ctxt with + | [] | [_] | [_;_] -> 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 @@ -429,7 +430,7 @@ let generalize_dependent_of x hyp g = let open Context.Named.Declaration in tclMAP (function - | LocalAssum (id,t) when not (Id.equal id hyp) && + | LocalAssum ({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 [mkVar id])) (thin [id]) | _ -> tclIDTAC ) @@ -456,7 +457,7 @@ 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') -> + | Prod(_,t,t') -> begin match EConstr.kind sigma t with | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 8746c37309..988cae8fbf 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -12,6 +12,7 @@ module CVars = Vars open Constr +open Context open EConstr open Vars open Namegen @@ -182,7 +183,7 @@ let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = ) in let context = List.map - (fun (x, c) -> LocalAssum (Name x, c)) (List.combine rev_x_id_l (List.rev al)) + (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 = @@ -388,9 +389,9 @@ let add_vars sigma 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 ids = List.fold_left (fun acc (na,_) -> let pre_id = - match na with + match na.binder_name with | Name x -> x | Anonymous -> ano_id in @@ -433,10 +434,10 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = 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) -> + | LetIn(na,b,t,e) -> begin let new_continuation_tac = - jinfo.letiN (na,b,t,e) expr_info 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 @@ -450,7 +451,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = with e when CErrors.noncritical e -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end - | Lambda(n,t,b) -> + | Lambda(n,t,b) -> begin try check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; @@ -853,8 +854,8 @@ let rec prove_le g = EConstr.is_global sigma (le ()) c | _ -> false in - let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) - 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) @@ -877,10 +878,10 @@ let rec make_rewrite_list expr_info max = function let sigma = project g in let t_eq = compute_renamed_type g (mkVar 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,Nameops.Name.get_id def_na + 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 @@ -903,10 +904,10 @@ let make_rewrite expr_info l hp max = let sigma = project g in let t_eq = compute_renamed_type g (mkVar 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,Nameops.Name.get_id def_na + 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 (str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences @@ -1054,20 +1055,19 @@ let compute_terminate_type nb_args func = 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 ((Name def_id) , lift 4 a_arrow_b, equality)) 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 - (Name - p_id, + (make_annot (Name p_id) Sorts.Relevant, delayed_force nat, - (mkProd (Name k_id, delayed_force nat, - mkArrow cond result))))|])in + (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, + mkArrow cond Sorts.Relevant result))))|])in let value = mkApp(constr_of_global (Util.delayed_force coq_sig_ref), [|b; - (mkLambda (Name v_id, b, nb_iter))|]) in + (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in compose_prod rev_args value @@ -1165,15 +1165,15 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let func_body = EConstr.of_constr func_body in let (f_name, _, body1) = destLambda sigma func_body in let f_id = - match f_name with + 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 with + (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 @@ -1270,12 +1270,12 @@ let is_rec_res id = let clear_goals sigma = let rec clear_goal t = match EConstr.kind sigma t with - | Prod(Name id as na,t',b) -> + | 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') + else mkProd(na,t',b') | _ -> EConstr.map sigma clear_goal t in List.map clear_goal @@ -1519,7 +1519,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let env = Global.env() in let evd = Evd.from_env env in let evd, function_type = interp_type_evars ~program_mode:false env evd type_of_f in - let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env 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 = Evd.minimize_universes evd in @@ -1537,7 +1538,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num (* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) match Constr.kind eq' with | App(e,[|_;_;eq_fix|]) -> - mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars 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 diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index b0277e9cc2..050fdcb608 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -11,6 +11,7 @@ open Util open Names open Constr +open Context open CErrors open Evar_refiner open Tacmach @@ -62,7 +63,7 @@ let instantiate_tac n c ido = evar_list sigma (EConstr.of_constr (NamedDecl.get_type decl)) | InHypValueOnly -> (match decl with - | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body) + | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body) | _ -> user_err Pp.(str "Not a defined hypothesis.")) in if List.length evl < n then user_err Pp.(str "Not enough uninstantiated existential variables."); @@ -108,5 +109,6 @@ let hget_evar n = if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); let ev = List.nth evl (n-1) in let ev_type = EConstr.existential_type sigma ev in - Tactics.change_concl (mkLetIn (Name.Anonymous,mkEvar ev,ev_type,concl)) + let r = Retyping.relevance_of_type (Proofview.Goal.env gl) sigma ev_type in + Tactics.change_concl (mkLetIn (make_annot Name.Anonymous r,mkEvar ev,ev_type,concl)) end diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index ffd8b71e5d..0428f08138 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -12,6 +12,7 @@ open Pp open Constr +open Context open Genarg open Stdarg open Tacarg @@ -674,7 +675,7 @@ let hResolve id c occ t = let sigma = Evd.merge_universe_context sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (change_concl (mkLetIn (Name.Anonymous,t_constr,t_constr_type,concl))) + (change_concl (mkLetIn (make_annot Name.Anonymous Sorts.Relevant,t_constr,t_constr_type,concl))) end let hResolve_auto id c t = diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 9ecc36bdf3..3f2fabeeee 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -99,8 +99,19 @@ TACTIC EXTEND is_ground | [ "is_ground" constr(ty) ] -> { is_ground ty } END +{ +let deprecated_autoapply_using = + CWarnings.create + ~name:"autoapply-using" ~category:"deprecated" + (fun () -> Pp.str "The syntax [autoapply ... using] is deprecated. Use [autoapply ... with] instead.") +} + TACTIC EXTEND autoapply -| [ "autoapply" constr(c) "using" preident(i) ] -> { autoapply c i } +| [ "autoapply" constr(c) "using" preident(i) ] -> { + deprecated_autoapply_using (); + autoapply c i + } +| [ "autoapply" constr(c) "with" preident(i) ] -> { autoapply c i } END { diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 5e3f4df192..e188971f00 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -1158,7 +1158,7 @@ let pr_goal_selector ~toplevel s = if n=0 then (List.rev acc, EConstr.of_constr ty) else match Constr.kind ty with | Constr.Prod(na,a,b) -> - strip_ty (([CAst.make na],EConstr.of_constr a)::acc) (n-1) b + strip_ty (([CAst.make na.Context.binder_name],EConstr.of_constr a)::acc) (n-1) b | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in strip_ty [] n ty diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 2d833a2cde..b1d5c0252f 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -15,6 +15,7 @@ open Names open Nameops open Namegen open Constr +open Context open EConstr open Vars open Reduction @@ -220,23 +221,23 @@ end) = struct let rec aux env evars ty l = let t = Reductionops.whd_all env (goalevars evars) ty in match EConstr.kind (goalevars evars) t, l with - | Prod (na, ty, b), obj :: cstrs -> + | Prod (na, ty, b), obj :: cstrs -> let b = Reductionops.nf_betaiota env (goalevars evars) b in - if noccurn (goalevars evars) 1 b (* non-dependent product *) then + if noccurn (goalevars evars) 1 b (* non-dependent product *) then let ty = Reductionops.nf_betaiota env (goalevars evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in let evars, relty = mk_relty evars env ty obj in let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in - evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs + evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else let (evars, b, arg, cstrs) = - aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs + aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs in let ty = Reductionops.nf_betaiota env (goalevars evars) ty in - let pred = mkLambda (na, ty, b) in - let liftarg = mkLambda (na, ty, arg) in - let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in - if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs + let pred = mkLambda (na, ty, b) in + let liftarg = mkLambda (na, ty, arg) in + let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in + if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs else user_err Pp.(str "build_signature: no constraint can apply on a dependent argument") | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products.") | _, [] -> @@ -253,7 +254,7 @@ end) = struct let unfold_impl sigma t = match EConstr.kind sigma t with | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (Anonymous, a, lift 1 b) + mkProd (make_annot Anonymous Sorts.Relevant, a, lift 1 b) | _ -> assert false let unfold_all sigma t = @@ -279,7 +280,7 @@ end) = struct (app_poly env evd arrow [| a; b |]), unfold_impl (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) else if bp then (* Dummy forall *) - (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall + (app_poly env evd coq_all [| a; mkLambda (make_annot Anonymous Sorts.Relevant, a, lift 1 b) |]), unfold_forall else (* None in Prop, use arrow *) (app_poly env evd arrow [| a; b |]), unfold_impl @@ -308,7 +309,8 @@ end) = struct app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] else app_poly env evd forall_relation - [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] + [| t; mkLambda (make_annot n Sorts.Relevant, t, car); + mkLambda (make_annot n Sorts.Relevant, t, rel) |] let lift_cstr env evars (args : constr list) c ty cstr = let start evars env car = @@ -323,15 +325,15 @@ end) = struct else let sigma = goalevars evars in match EConstr.kind sigma (Reductionops.whd_all env sigma prod) with - | Prod (na, ty, b) -> + | Prod (na, ty, b) -> if noccurn sigma 1 b then let b' = lift (-1) b in let evars, rb = aux evars env b' (pred n) in app_poly env evars pointwise_relation [| ty; b'; rb |] else - let evars, rb = aux evars (push_rel (LocalAssum (na, ty)) env) b (pred n) in + let evars, rb = aux evars (push_rel (LocalAssum (na, ty)) env) b (pred n) in app_poly env evars forall_relation - [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] | _ -> raise Not_found in let rec find env c ty = function @@ -449,7 +451,7 @@ let evd_convertible env evd x y = unsolvable constraints remain, so we check that this unification does not introduce any new problem. *) let _, pbs = Evd.extract_all_conv_pbs evd in - let evd' = Evarconv.the_conv_x env x y evd in + let evd' = Evarconv.unify_delay env evd x y in let _, pbs' = Evd.extract_all_conv_pbs evd' in if evd' == evd || problem_inclusion pbs' pbs then Some evd' else None @@ -481,8 +483,9 @@ let rec decompose_app_rel env evd t = | App (f, [|arg|]) -> let (f', argl, argr) = decompose_app_rel env evd arg in let ty = Typing.unsafe_type_of env evd argl in - let f'' = mkLambda (Name default_dependent_ident, ty, - mkLambda (Name (Id.of_string "y"), lift 1 ty, + let r = Retyping.relevance_of_type env evd ty in + let f'' = mkLambda (make_annot (Name default_dependent_ident) r, ty, + mkLambda (make_annot (Name (Id.of_string "y")) r, lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) in (f'', argl, argr) | App (f, args) -> @@ -522,7 +525,7 @@ let decompose_applied_relation env sigma (c,l) = | Some c -> c | None -> let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with | Some c -> c | None -> user_err Pp.(str "Cannot find an homogeneous relation to rewrite.") @@ -803,7 +806,7 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation in EConstr.push_named - (LocalDef (Id.of_string "do_subrelation", + (LocalDef (make_annot (Id.of_string "do_subrelation") Sorts.Relevant, snd (app_poly_sort b env evars dosub [||]), snd (app_poly_nocheck env evars appsub [||]))) env @@ -906,7 +909,7 @@ let make_leibniz_proof env c ty r = let prf = e_app_poly env evars coq_f_equal [| r.rew_car; ty; - mkLambda (Anonymous, r.rew_car, c); + mkLambda (make_annot Anonymous Sorts.Relevant, r.rew_car, c); r.rew_from; r.rew_to; prf |] in RewPrf (rel, prf) | RewCast k -> r.rew_prf @@ -1103,7 +1106,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = (* else *) | Prod (n, dom, codom) -> - let lam = mkLambda (n, dom, codom) in + let lam = mkLambda (n, dom, codom) in let (evars', app), unfold = if eq_constr (fst evars) ty mkProp then (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all @@ -1149,9 +1152,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = (* | _ -> b') *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env) n in + let n' = map_annot (Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env)) n in let open Context.Rel.Declaration in - let env' = EConstr.push_rel (LocalAssum (n', t)) env in + let env' = EConstr.push_rel (LocalAssum (n', t)) env in let bty = Retyping.get_type_of env' (goalevars evars) b in let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in let state, b' = s.strategy { state ; env = env' ; unfresh ; @@ -1166,15 +1169,15 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let point = if prop then PropGlobal.pointwise_or_dep_relation else TypeGlobal.pointwise_or_dep_relation in - let evars, rel = point env r.rew_evars n' t r.rew_car rel in - let prf = mkLambda (n', t, prf) in + let evars, rel = point env r.rew_evars n'.binder_name t r.rew_car rel in + let prf = mkLambda (n', t, prf) in { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } | x -> r in Success { r with - rew_car = mkProd (n, t, r.rew_car); - rew_from = mkLambda(n, t, r.rew_from); - rew_to = mkLambda (n, t, r.rew_to) } + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) } | Fail | Identity -> b' in state, res @@ -1516,7 +1519,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul | Some (t, ty) -> let t = Reductionops.nf_evar evars' t in let ty = Reductionops.nf_evar evars' ty in - mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) + mkApp (mkLambda (make_annot (Name (Id.of_string "lemma")) Sorts.Relevant, ty, p), [| t |]) in let proof = match is_hyp with | None -> term @@ -1542,7 +1545,8 @@ let assert_replacing id newt tac = let after, before = List.split_when (NamedDecl.get_id %> Id.equal id) ctx in let nc = match before with | [] -> assert false - | d :: rem -> insert_dependent env sigma (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem + | d :: rem -> insert_dependent env sigma + (LocalAssum (make_annot (NamedDecl.get_id d) Sorts.Relevant, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Refine.refine ~typecheck:true begin fun sigma -> @@ -1586,7 +1590,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (LocalAssum (id, newt)) <*> + convert_hyp_no_check (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> @@ -1905,7 +1909,7 @@ let build_morphism_signature env sigma m = let cstrs = let rec aux t = match EConstr.kind sigma t with - | Prod (na, a, b) -> + | Prod (na, a, b) -> None :: aux b | _ -> [] in aux t diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 026c00b849..fcab98c7e8 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -199,7 +199,8 @@ let id_of_name = function basename | Sort s -> begin - match ESorts.kind sigma s with + match ESorts.kind sigma s with + | Sorts.SProp -> Label.to_id (Label.make "SProp") | Sorts.Prop -> Label.to_id (Label.make "Prop") | Sorts.Set -> Label.to_id (Label.make "Set") | Sorts.Type _ -> Label.to_id (Label.make "Type") diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index a1e21aab04..543d4de0fe 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -557,7 +557,7 @@ let rec intern_atomic lf ist x = | _ -> false in let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in TacChange (None, diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 30f716d764..eac84f0543 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1766,7 +1766,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | _ -> false in let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in let c_interp patvars env sigma = diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index 54924f1644..2b5e496168 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -12,6 +12,7 @@ (lazy)match and (lazy)match goal. *) open Names +open Context open Tacexpr open Context.Named.Declaration @@ -299,8 +300,8 @@ module PatternMatching (E:StaticEnvironment) = struct | LocalDef (id,body,hyp) -> pattern_match_term false bodypat body () <*> pattern_match_term true typepat hyp () <*> - put_terms (id_map_try_add_name hypname (EConstr.mkVar id) empty_term_subst) <*> - return id + put_terms (id_map_try_add_name hypname (EConstr.mkVar id.binder_name) empty_term_subst) <*> + return id.binder_name | LocalAssum (id,hyp) -> fail (** [hyp_match pat hyps] dispatches to diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 19256e054d..4c65445b89 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -142,7 +142,7 @@ let flatten_contravariant_conj _ ist = ~onlybinary:flags.binary_mode typ with | Some (_,args) -> - let newtyp = List.fold_right mkArrow args c in + let newtyp = List.fold_right (fun a b -> mkArrow a Sorts.Relevant b) args c in let intros = tclMAP (fun _ -> intro) args in let by = tclTHENLIST [intros; apply hyp; split; assumption] in tclTHENLIST [assert_ ~by newtyp; clear (destVar sigma hyp)] @@ -173,7 +173,7 @@ let flatten_contravariant_disj _ ist = typ with | Some (_,args) -> let map i arg = - let typ = mkArrow arg c in + let typ = mkArrow arg Sorts.Relevant c in let ci = Tactics.constructor_tac false None (succ i) Tactypes.NoBindings in let by = tclTHENLIST [intro; apply hyp; ci; assumption] in assert_ ~by typ diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 7adae148bd..ac34faa7da 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -23,6 +23,7 @@ open Names open Goptions open Mutils open Constr +open Context open Tactypes (** @@ -1243,7 +1244,7 @@ let dump_rexpr = lazy let prodn n env b = let rec prodrec = function | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, EConstr.mkProd (v,t,b)) + | (n, ((v,t)::l), b) -> prodrec (n-1, l, EConstr.mkProd (make_annot v Sorts.Relevant,t,b)) | _ -> assert false in prodrec (n,env,b) @@ -1293,8 +1294,8 @@ let make_goal_of_formula sigma dexpr form = | FF -> Lazy.force coq_False | C(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) | D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) - | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) - | N(x) -> EConstr.mkArrow (xdump pi xi x) (Lazy.force coq_False) + | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y) + | N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) | A(x,_,_) -> dump_cstr xi x | X(t) -> let idx = Env.get_rank props sigma t in EConstr.mkRel (pi+idx) in @@ -1327,7 +1328,7 @@ let make_goal_of_formula sigma dexpr form = | (e::l) -> let (name,expr,typ) = e in xset (EConstr.mkNamedLetIn - (Names.Id.of_string name) + (make_annot (Names.Id.of_string name) Sorts.Relevant) expr typ acc) l in xset concl l @@ -1614,7 +1615,7 @@ let abstract_formula hyps f = | I(f1,hyp,f2) -> (match xabs f1 , hyp, xabs f2 with | X a1 , Some _ , af2 -> af2 - | X a1 , None , X a2 -> X (EConstr.mkArrow a1 a2) + | X a1 , None , X a2 -> X (EConstr.mkArrow a1 Sorts.Relevant a2) | af1 , _ , af2 -> I(af1,hyp,af2) ) | FF -> FF diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index b91feb3984..d1776b8ca4 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -20,3 +20,9 @@ val sos_Q : unit Proofview.tactic -> unit Proofview.tactic val sos_R : unit Proofview.tactic -> unit Proofview.tactic val lra_Q : unit Proofview.tactic -> unit Proofview.tactic val lra_R : unit Proofview.tactic -> unit Proofview.tactic + + +(** {5 Use Micromega independently from tactics. } *) + +(** [dump_proof_term] generates the Coq representation of a Micromega proof witness *) +val dump_proof_term : Micromega.zArithProof -> EConstr.t diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index dff25b3a42..4802608fda 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -19,6 +19,7 @@ open CErrors open Util open Names open Constr +open Context open Nameops open EConstr open Tacticals.New @@ -431,8 +432,8 @@ let destructurate_prop sigma t = | Ind (isp,_), args -> Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) | Var id,[] -> Kvar id - | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) - | Prod (Name _,_,_),[] -> CErrors.user_err Pp.(str "Omega: Not a quantifier-free goal") + | Prod ({binder_name=Anonymous},typ,body), [] -> Kimp(typ,body) + | Prod ({binder_name=Name _},_,_),[] -> CErrors.user_err Pp.(str "Omega: Not a quantifier-free goal") | _ -> Kufo let nf = Tacred.simpl @@ -499,13 +500,13 @@ let context sigma operation path (t : constr) = | (p, Fix ((_,n as ln),(tys,lna,v))) -> let l = Array.length v in let v' = Array.copy v in - v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) + v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) | ((P_TYPE :: p), Prod (n,t,c)) -> - (mkProd (n,loop i p t,c)) + (mkProd (n,loop i p t,c)) | ((P_TYPE :: p), Lambda (n,t,c)) -> - (mkLambda (n,loop i p t,c)) + (mkLambda (n,loop i p t,c)) | ((P_TYPE :: p), LetIn (n,b,t,c)) -> - (mkLetIn (n,b,loop i p t,c)) + (mkLetIn (n,b,loop i p t,c)) | (p, _) -> failwith ("abstract_path " ^ string_of_int(List.length p)) in @@ -528,7 +529,7 @@ let occurrence sigma path (t : constr) = let abstract_path sigma typ path t = let term_occur = ref (mkRel 0) in let abstract = context sigma (fun i t -> term_occur:= t; mkRel i) path t in - mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur + mkLambda (make_annot (Name (Id.of_string "x")) Sorts.Relevant, typ, abstract), !term_occur let focused_simpl path = let open Tacmach.New in @@ -604,10 +605,10 @@ let clever_rewrite_base_poly typ p result theorem = let t = applist (mkLambda - (Name (Id.of_string "P"), - mkArrow typ mkProp, + (make_annot (Name (Id.of_string "P")) Sorts.Relevant, + mkArrow typ Sorts.Relevant mkProp, mkLambda - (Name (Id.of_string "H"), + (make_annot (Name (Id.of_string "H")) Sorts.Relevant, applist (mkRel 1,[result]), mkApp (Lazy.force coq_eq_ind_r, [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), @@ -1264,7 +1265,7 @@ let replay_history tactic_normalisation = mkApp (Lazy.force coq_ex, [| Lazy.force coq_Z; mkLambda - (Name vid, + (make_annot (Name vid) Sorts.Relevant, Lazy.force coq_Z, mk_eq (mkRel 1) eq1) |]) in @@ -1725,11 +1726,11 @@ let destructure_hyps = try match destructurate_type env sigma typ with | Kapp(Nat,_) | Kapp(Z,_) -> - let hid = fresh_id Id.Set.empty (add_suffix i "_eqn") gl in - let hty = mk_gen_eq typ (mkVar i) body in + let hid = fresh_id Id.Set.empty (add_suffix i.binder_name "_eqn") gl in + let hty = mk_gen_eq typ (mkVar i.binder_name) body in tclTHEN (assert_by (Name hid) hty reflexivity) - (loop (LocalAssum (hid, hty) :: lit)) + (loop (LocalAssum (make_annot hid Sorts.Relevant, hty) :: lit)) | _ -> loop lit with e when catchable_exception e -> loop lit end @@ -1742,18 +1743,20 @@ let destructure_hyps = | Kapp(Or,[t1;t2]) -> (tclTHENS (elim_id i) - [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit))); - onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ]) + [ onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t1)::lit))); + onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit))) + loop (LocalAssum (make_annot i1 Sorts.Relevant,t1) :: + LocalAssum (make_annot i2 Sorts.Relevant,t2) :: lit))) | Kapp(Iff,[t1;t2]) -> tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,mkArrow t2 t1) :: lit))) + loop (LocalAssum (make_annot i1 Sorts.Relevant,mkArrow t1 Sorts.Relevant t2) :: + LocalAssum (make_annot i2 Sorts.Relevant,mkArrow t2 Sorts.Relevant t1) :: lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) @@ -1764,7 +1767,7 @@ let destructure_hyps = (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_or (mk_not t1) t2) :: lit)))) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) t2) :: lit)))) ] else loop lit @@ -1775,7 +1778,7 @@ let destructure_hyps = (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_and (mk_not t1) (mk_not t2)) :: lit)))) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(And,[t1;t2]) -> let d1 = decidability t1 in @@ -1784,7 +1787,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_and, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_or (mk_not t1) (mk_not t2)) :: lit)))) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(Iff,[t1;t2]) -> let d1 = decidability t1 in @@ -1794,7 +1797,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_iff, [| t1; t2; d1; d2; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i, mk_or (mk_and t1 (mk_not t2)) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_and t1 (mk_not t2)) (mk_and (mk_not t1) t2)) :: lit)))) ] | Kimp(t1,t2) -> @@ -1806,14 +1809,14 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_imp, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_and t1 (mk_not t2)) :: lit)))) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and t1 (mk_not t2)) :: lit)))) ] | Kapp(Not,[t]) -> let d = decidability t in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); - (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit)))) + (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t) :: lit)))) ] | Kapp(op,[t1;t2]) -> (try diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 751f0d8334..c2dec264ad 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -294,10 +294,10 @@ Qed. End Store. -Arguments PNone [A]. +Arguments PNone {A}. Arguments PSome [A] _. -Arguments Tempty [A]. +Arguments Tempty {A}. Arguments Branch0 [A] _ _. Arguments Branch1 [A] _ _ _. @@ -311,7 +311,7 @@ Arguments mkStore [A] index contents. Arguments index [A] s. Arguments contents [A] s. -Arguments empty [A]. +Arguments empty {A}. Arguments get [A] i S. Arguments push [A] a S. @@ -319,7 +319,7 @@ Arguments get_empty [A] i. Arguments get_push_Full [A] i a S _. Arguments Full [A] _. -Arguments F_empty [A]. +Arguments F_empty {A}. Arguments F_push [A] a S _. Arguments In [A] x S F. diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index a6b6c57ff9..89528fe357 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -16,6 +16,7 @@ open CErrors open Util open Term open Constr +open Context open Proof_search open Context.Named.Declaration @@ -127,7 +128,7 @@ let rec make_hyps env sigma atom_env lenv = function | LocalAssum (id,typ)::rest -> let hrec= make_hyps env sigma atom_env (typ::lenv) rest in - if List.exists (fun c -> Termops.local_occur_var Evd.empty (* FIXME *) id c) lenv || + if List.exists (fun c -> Termops.local_occur_var Evd.empty (* FIXME *) id.binder_name c) lenv || (Retyping.get_sort_family_of env sigma typ != InProp) then hrec @@ -291,7 +292,7 @@ let rtauto_tac = build_form formula; build_proof [] 0 prf|]) in let term= - applistc main (List.rev_map (fun (id,_) -> mkVar id) hyps) in + applistc main (List.rev_map (fun (id,_) -> mkVar id.binder_name) hyps) in let build_end_time=System.get_time () in let () = if !verbose then begin diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index 49b5ee5ac7..3de0ba44df 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -23,6 +23,6 @@ val make_hyps -> atom_env -> EConstr.types list -> EConstr.named_context - -> (Names.Id.t * Proof_search.form) list + -> (Names.Id.t Context.binder_annot * Proof_search.form) list val rtauto_tac : unit Proofview.tactic diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index dba72337b2..f5d13053b1 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -1789,5 +1789,5 @@ End Field. End Complete. -Arguments FEO [C]. -Arguments FEI [C]. +Arguments FEO {C}. +Arguments FEI {C}. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 9ef24144d2..12f716c496 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -1507,5 +1507,5 @@ Qed. End MakeRingPol. -Arguments PEO [C]. -Arguments PEI [C]. +Arguments PEO {C}. +Arguments PEI {C}. diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index ed4ff2aa66..d6b7371647 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -813,21 +813,21 @@ Proof. by case b1; case b2; constructor; auto. Qed. End ReflectConnectives. -Arguments idP [b1]. -Arguments idPn [b1]. -Arguments negP [b1]. -Arguments negPn [b1]. -Arguments negPf [b1]. -Arguments andP [b1 b2]. -Arguments and3P [b1 b2 b3]. -Arguments and4P [b1 b2 b3 b4]. -Arguments and5P [b1 b2 b3 b4 b5]. -Arguments orP [b1 b2]. -Arguments or3P [b1 b2 b3]. -Arguments or4P [b1 b2 b3 b4]. -Arguments nandP [b1 b2]. -Arguments norP [b1 b2]. -Arguments implyP [b1 b2]. +Arguments idP {b1}. +Arguments idPn {b1}. +Arguments negP {b1}. +Arguments negPn {b1}. +Arguments negPf {b1}. +Arguments andP {b1 b2}. +Arguments and3P {b1 b2 b3}. +Arguments and4P {b1 b2 b3 b4}. +Arguments and5P {b1 b2 b3 b4 b5}. +Arguments orP {b1 b2}. +Arguments or3P {b1 b2 b3}. +Arguments or4P {b1 b2 b3 b4}. +Arguments nandP {b1 b2}. +Arguments norP {b1 b2}. +Arguments implyP {b1 b2}. Prenex Implicits idP idPn negP negPn negPf. Prenex Implicits andP and3P and4P and5P orP or3P or4P nandP norP implyP. @@ -953,7 +953,7 @@ Proof. by case: a; case: b. Qed. Lemma addbP a b : reflect (~~ a = b) (a (+) b). Proof. by case: a; case: b; constructor. Qed. -Arguments addbP [a b]. +Arguments addbP {a b}. (** Resolution tactic for blindly weeding out common terms from boolean @@ -1158,8 +1158,8 @@ Definition clone_pred U := End Predicates. -Arguments pred0 [T]. -Arguments predT [T]. +Arguments pred0 {T}. +Arguments predT {T}. Prenex Implicits pred0 predT predI predU predC predD preim relU. Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) @@ -1357,7 +1357,7 @@ Variant qualifier (q : nat) T := Qualifier of predPredType T. Coercion has_quality n T (q : qualifier n T) : pred_class := fun x => let: Qualifier _ p := q in p x. -Arguments has_quality n [T]. +Arguments has_quality n {T}. Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 0961edb6cb..58daa7a7d4 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -15,6 +15,7 @@ open Names open Evd open Term open Constr +open Context open Termops open Printer open Locusops @@ -429,15 +430,16 @@ let convert_concl t = Tactics.convert_concl t DEFAULTcast let rename_hd_prod orig_name_ref gl = match EConstr.kind (project gl) (pf_concl gl) with - | Prod(_,src,tgt) -> - Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkProd (!orig_name_ref,src,tgt))) gl + | Prod(x,src,tgt) -> + let x = {x with binder_name = !orig_name_ref} in + Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkProd (x,src,tgt))) gl | _ -> CErrors.anomaly (str "gentac creates no product") (* Reduction that preserves the Prod/Let spine of the "in" tactical. *) let inc_safe n = if n = 0 then n else n + 1 let rec safe_depth s c = match EConstr.kind s c with -| LetIn (Name x, _, _, c') when is_discharged_id x -> safe_depth s c' + 1 +| LetIn ({binder_name=Name x}, _, _, c') when is_discharged_id x -> safe_depth s c' + 1 | LetIn (_, _, _, c') | Prod (_, _, c') -> inc_safe (safe_depth s c') | _ -> 0 @@ -529,7 +531,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = let concl = EConstr.Unsafe.to_constr evi.evar_concl in let dc = EConstr.Unsafe.to_named_context (CList.firstn n (evar_filtered_context evi)) in let abs_dc c = function - | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) + | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t x.binder_relevance c) | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma t in @@ -552,7 +554,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = | _ -> Constr.map_with_binders ((+) 1) get i c in let rec loop c i = function | (_, (n, t)) :: evl -> - loop (mkLambda (mk_evar_name n, get (i - 1) t, c)) (i - 1) evl + loop (mkLambda (make_annot (mk_evar_name n) Sorts.Relevant, get (i - 1) t, c)) (i - 1) evl | [] -> c in List.length evlist, EConstr.of_constr (loop (get 1 c0) 1 evlist), List.map fst evlist, ucst @@ -590,7 +592,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let concl = EConstr.Unsafe.to_constr evi.evar_concl in let dc = EConstr.Unsafe.to_named_context (CList.firstn n (evar_filtered_context evi)) in let abs_dc c = function - | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) + | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t x.binder_relevance c) | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma0 (nf_evar sigma t) in @@ -646,7 +648,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = | (_, (n, t, _)) :: evl -> let t = get evlist (i - 1) t in let n = Name (Id.of_string (ssr_anon_hyp ^ string_of_int n)) in - loopP evlist (mkProd (n, t, c)) (i - 1) evl + loopP evlist (mkProd (make_annot n Sorts.Relevant, t, c)) (i - 1) evl | [] -> c in let rec loop c i = function | (_, (n, t, _)) :: evl -> @@ -658,7 +660,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) (List.rev t_evplist) in let c = if extra_args = [] then c else app extra_args 1 c in - loop (mkLambda (mk_evar_name n, t, c)) (i - 1) evl + loop (mkLambda (make_annot (mk_evar_name n) Sorts.Relevant, t, c)) (i - 1) evl | [] -> c in let res = loop (get evlist 1 c0) 1 evlist in pp(lazy(str"res= " ++ pr_constr res)); @@ -679,6 +681,9 @@ let pf_type_id gl t = Id.of_string (Namegen.hdchar (pf_env gl) (project gl) t) let pfe_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty +let pfe_type_relevance_of gl t = + let gl, ty = pfe_type_of gl t in + gl, ty, pf_apply Retyping.relevance_of_term gl t let pf_type_of gl t = let sigma, ty = pf_type_of gl (EConstr.of_constr t) in re_sig (sig_it gl) sigma, EConstr.Unsafe.to_constr ty @@ -710,13 +715,13 @@ let pf_abs_cterm gl n c0 = | _ -> [], strip i c in let rec strip_evars i c = match Constr.kind c with | Lambda (x, t1, c1) when i < n -> - let na = nb_evar_deps x in + let na = nb_evar_deps x.binder_name in let dl, t2 = strip_ndeps (i + na) i t1 in let na' = List.length dl in eva.(i) <- Array.of_list (na - na' :: dl); let x' = if na' = 0 then Name (pf_type_id gl (EConstr.of_constr t2)) else mk_evar_name na' in - mkLambda (x', t2, strip_evars (i + 1) c1) + mkLambda ({x with binder_name=x'}, t2, strip_evars (i + 1) c1) (* if noccurn 1 c2 then lift (-1) c2 else mkLambda (Name (pf_type_id gl t2), t2, c2) *) | _ -> strip i c in @@ -739,9 +744,9 @@ let rec constr_name sigma c = match EConstr.kind sigma c with | _ -> Anonymous let pf_mkprod gl c ?(name=constr_name (project gl) c) cl = - let gl, t = pfe_type_of gl c in - if name <> Anonymous || EConstr.Vars.noccurn (project gl) 1 cl then gl, EConstr.mkProd (name, t, cl) else - gl, EConstr.mkProd (Name (pf_type_id gl t), t, cl) + let gl, t, r = pfe_type_relevance_of gl c in + if name <> Anonymous || EConstr.Vars.noccurn (project gl) 1 cl then gl, EConstr.mkProd (make_annot name r, t, cl) else + gl, EConstr.mkProd (make_annot (Name (pf_type_id gl t)) r, t, cl) let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (Termops.subst_term (project gl) c cl) @@ -783,13 +788,17 @@ let mkRefl t c gl = let discharge_hyp (id', (id, mode)) gl = let cl' = Vars.subst_var id (pf_concl gl) in - match pf_get_hyp gl id, mode with - | NamedDecl.LocalAssum (_, t), _ | NamedDecl.LocalDef (_, _, t), "(" -> - Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true (EConstr.of_constr (mkProd (Name id', t, cl'))) + let decl = pf_get_hyp gl id in + match decl, mode with + | NamedDecl.LocalAssum _, _ | NamedDecl.LocalDef _, "(" -> + let id' = {(NamedDecl.get_annot decl) with binder_name = Name id'} in + Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true + (EConstr.of_constr (mkProd (id', NamedDecl.get_type decl, cl'))) [EConstr.of_constr (mkVar id)]) gl | NamedDecl.LocalDef (_, v, t), _ -> + let id' = {(NamedDecl.get_annot decl) with binder_name = Name id'} in Proofview.V82.of_tactic - (convert_concl (EConstr.of_constr (mkLetIn (Name id', v, t, cl')))) gl + (convert_concl (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl (* wildcard names *) let clear_wilds wilds gl = @@ -983,7 +992,7 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = let rec loop sigma bo args = function (* saturate with metas *) | 0 -> EConstr.mkApp (t, Array.of_list (List.rev args)), re_sig si sigma | n -> match EConstr.kind sigma bo with - | Lambda (_, ty, bo) -> + | Lambda (_, ty, bo) -> if not (EConstr.Vars.closed0 sigma ty) then raise dependent_apply_error; let m = Evarutil.new_meta () in @@ -1019,7 +1028,7 @@ let () = CLexer.set_keyword_state frozen_lexer ;; let rec fst_prod red tac = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in match EConstr.kind (Proofview.Goal.sigma gl) concl with - | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id + | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id.binder_name | _ -> if red then Tacticals.New.tclZEROMSG (str"No product even after head-reduction.") else Tacticals.New.tclTHEN Tactics.hnf_in_concl (fst_prod true tac) end @@ -1122,14 +1131,14 @@ let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = errorstrm (str "@ can be used with variables only") else match Tacmach.pf_get_hyp gl (EConstr.destVar sigma c) with | NamedDecl.LocalAssum _ -> errorstrm (str "@ can be used with let-ins only") - | NamedDecl.LocalDef (name, b, ty) -> true, pat, EConstr.mkLetIn (Name name,b,ty,cl),c,clr,ucst,gl + | NamedDecl.LocalDef (name, b, ty) -> true, pat, EConstr.mkLetIn (map_annot Name.mk_name name,b,ty,cl),c,clr,ucst,gl else let gl, ccl = pf_mkprod gl c cl in false, pat, ccl, c, clr,ucst,gl else if to_ind && occ = None then let nv, p, _, ucst' = pf_abs_evars gl (fst pat, c) in let ucst = UState.union ucst ucst' in if nv = 0 then anomaly "occur_existential but no evars" else - let gl, pty = pfe_type_of gl p in - false, pat, EConstr.mkProd (constr_name (project gl) c, pty, Tacmach.pf_concl gl), p, clr,ucst,gl + let gl, pty, rp = pfe_type_relevance_of gl p in + false, pat, EConstr.mkProd (make_annot (constr_name (project gl) c) rp, pty, Tacmach.pf_concl gl), p, clr,ucst,gl else CErrors.user_err ?loc:(loc_of_cpattern t) (str "generalized term didn't match") let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true x xs) @@ -1235,7 +1244,10 @@ let abs_wgen keep_let f gen (gl,args,c) = (EConstr.Vars.subst_var x c) | _, Some ((x, _), None) -> let x = hoi_id x in - gl, EConstr.mkVar x :: args, EConstr.mkProd (Name (f x),Tacmach.pf_get_hyp_typ gl x, EConstr.Vars.subst_var x c) + let hyp = Tacmach.pf_get_hyp gl x in + let x' = make_annot (Name (f x)) (NamedDecl.get_relevance hyp) in + let prod = EConstr.mkProd (x', NamedDecl.get_type hyp, EConstr.Vars.subst_var x c) in + gl, EConstr.mkVar x :: args, prod | _, Some ((x, "@"), Some p) -> let x = hoi_id x in let cp = interp_cpattern gl p None in @@ -1246,8 +1258,8 @@ let abs_wgen keep_let f gen (gl,args,c) = let t = EConstr.of_constr t in evar_closed t p; let ut = red_product_skip_id env sigma t in - let gl, ty = pfe_type_of gl t in - pf_merge_uc ucst gl, args, EConstr.mkLetIn(Name (f x), ut, ty, c) + let gl, ty, r = pfe_type_relevance_of gl t in + pf_merge_uc ucst gl, args, EConstr.mkLetIn(make_annot (Name (f x)) r, ut, ty, c) | _, Some ((x, _), Some p) -> let x = hoi_id x in let cp = interp_cpattern gl p None in @@ -1257,8 +1269,8 @@ let abs_wgen keep_let f gen (gl,args,c) = let c = EConstr.of_constr c in let t = EConstr.of_constr t in evar_closed t p; - let gl, ty = pfe_type_of gl t in - pf_merge_uc ucst gl, t :: args, EConstr.mkProd(Name (f x), ty, c) + let gl, ty, r = pfe_type_relevance_of gl t in + pf_merge_uc ucst gl, t :: args, EConstr.mkProd(make_annot (Name (f x)) r, ty, c) | _ -> gl, args, c let clr_of_wgen gen clrs = match gen with @@ -1321,8 +1333,8 @@ let unsafe_intro env decl b = end let set_decl_id id = let open Context in function - | Rel.Declaration.LocalAssum(name,ty) -> Named.Declaration.LocalAssum(id,ty) - | Rel.Declaration.LocalDef(name,ty,t) -> Named.Declaration.LocalDef(id,ty,t) + | Rel.Declaration.LocalAssum(name,ty) -> Named.Declaration.LocalAssum({name with binder_name=id},ty) + | Rel.Declaration.LocalDef(name,ty,t) -> Named.Declaration.LocalDef({name with binder_name=id},ty,t) let rec decompose_assum env sigma orig_goal = let open Context in @@ -1400,8 +1412,8 @@ let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> let concl = Goal.concl gl in let sigma = Goal.sigma gl in match EConstr.kind sigma concl with - | Prod(_,src,tgt) -> - convert_concl_no_check EConstr.(mkProd (name,src,tgt)) + | Prod(x,src,tgt) -> + convert_concl_no_check EConstr.(mkProd ({x with binder_name = name},src,tgt)) | _ -> CErrors.anomaly (Pp.str "rename_hd_prod: no head product") end @@ -1429,11 +1441,12 @@ let tacMKPROD c ?name cl = tacCONSTR_NAME ?name c >>= fun name -> Goal.enter_one ~__LOC__ begin fun g -> let sigma, env = Goal.sigma g, Goal.env g in + let r = Retyping.relevance_of_term env sigma c in if name <> Names.Name.Anonymous || EConstr.Vars.noccurn sigma 1 cl - then tclUNIT (EConstr.mkProd (name, t, cl)) + then tclUNIT (EConstr.mkProd (make_annot name r, t, cl)) else let name = Names.Id.of_string (Namegen.hdchar env sigma t) in - tclUNIT (EConstr.mkProd (Names.Name.Name name, t, cl)) + tclUNIT (EConstr.mkProd (make_annot (Name.Name name) r, t, cl)) end let tacINTERP_CPATTERN cp = diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index e642b5e788..9662daa7c7 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -155,7 +155,7 @@ val pf_e_type_of : val splay_open_constr : Goal.goal Evd.sigma -> evar_map * EConstr.t -> - (Names.Name.t * EConstr.t) list * EConstr.t + (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t val isAppInd : Environ.env -> Evd.evar_map -> EConstr.types -> bool val mk_term : ssrtermkind -> constr_expr -> ssrterm @@ -205,6 +205,9 @@ val pf_type_of : val pfe_type_of : Goal.goal Evd.sigma -> EConstr.t -> Goal.goal Evd.sigma * EConstr.types +val pfe_type_relevance_of : + Goal.goal Evd.sigma -> + EConstr.t -> Goal.goal Evd.sigma * EConstr.types * Sorts.relevance val pf_abs_prod : Name.t -> Goal.goal Evd.sigma -> diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index a0b1d784f1..82a88678f0 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -15,6 +15,7 @@ open Names open Printer open Term open Constr +open Context open Termops open Tactypes open Tacmach @@ -209,7 +210,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let mind,indb = Inductive.lookup_mind_specif env (kn,i) in let tys = indb.Declarations.mind_nf_lc in let renamed_tys = - Array.mapi (fun j t -> + Array.mapi (fun j (ctx, cty) -> + let t = Term.it_mkProd_or_LetIn cty ctx in ppdebug(lazy Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); let t = Arguments_renaming.rename_type t (GlobRef.ConstructRef((kn,i),j+1)) in @@ -363,14 +365,14 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let gl, eq = get_eq_type gl in let gen_eq_tac, gl = let refl = EConstr.mkApp (eq, [|t; c; c|]) in - let new_concl = EConstr.mkArrow refl (EConstr.Vars.lift 1 (pf_concl orig_gl)) in + let new_concl = EConstr.mkArrow refl Sorts.Relevant (EConstr.Vars.lift 1 (pf_concl orig_gl)) in let new_concl = fire_subst gl new_concl in let erefl, gl = mkRefl t c gl in let erefl = fire_subst gl erefl in apply_type new_concl [erefl], gl in let rel = k + if c_is_head_p then 1 else 0 in let src, gl = mkProt EConstr.mkProp EConstr.(mkApp (eq,[|t; c; mkRel rel|])) gl in - let concl = EConstr.mkArrow src (EConstr.Vars.lift 1 concl) in + let concl = EConstr.mkArrow src Sorts.Relevant (EConstr.Vars.lift 1 concl) in let clr = if deps <> [] then clr else [] in concl, gen_eq_tac, clr, gl | _ -> concl, Tacticals.tclIDTAC, clr, gl in @@ -445,7 +447,7 @@ let injecteq_id = mk_internal_id "injection equation" let revtoptac n0 gl = let n = pf_nb_prod gl - n0 in let dc, cl = EConstr.decompose_prod_n_assum (project gl) n (pf_concl gl) in - let dc' = dc @ [Context.Rel.Declaration.LocalAssum(Name rev_id, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in + let dc' = dc @ [Context.Rel.Declaration.LocalAssum(make_annot (Name rev_id) Sorts.Relevant, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in Refiner.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) gl @@ -485,7 +487,7 @@ let perform_injection c gl = CErrors.user_err (Pp.str "can't decompose a quantified equality") else let cl = pf_concl gl in let n = List.length dc in let c_eq = mkEtaApp c n 2 in - let cl1 = EConstr.mkLambda EConstr.(Anonymous, mkArrow eqt cl, mkApp (mkRel 1, [|c_eq|])) in + let cl1 = EConstr.mkLambda EConstr.(make_annot Anonymous Sorts.Relevant, mkArrow eqt Sorts.Relevant cl, mkApp (mkRel 1, [|c_eq|])) in let id = injecteq_id in let id_with_ebind = (EConstr.mkVar id, NoBindings) in let injtac = Tacticals.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 64e023c68a..18461c0533 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -15,6 +15,7 @@ open Util open Names open Term open Constr +open Context open Vars open Locus open Printer @@ -136,7 +137,7 @@ let newssrcongrtac arg ist gl = (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) ty) ist) (fun () -> let lhs, gl' = mk_evar gl EConstr.mkProp in let rhs, gl' = mk_evar gl' EConstr.mkProp in - let arrow = EConstr.mkArrow lhs (EConstr.Vars.lift 1 rhs) in + let arrow = EConstr.mkArrow lhs Sorts.Relevant (EConstr.Vars.lift 1 rhs) in tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) (fun lr -> tclTHEN (Proofview.V82.of_tactic (Tactics.apply (ssr_congr lr))) (congrtac (arg, mkRType) ist)) (fun _ _ -> errorstrm Pp.(str"Conclusion is not an equality nor an arrow"))) @@ -335,7 +336,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let (sigma, ev) = Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in (sigma, ev) in - let pred = EConstr.mkNamedLambda pattern_id rdx_ty pred in + let pred = EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdx_ty pred in let elim, gl = let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in let sort = elimination_sort_of_goal gl in @@ -362,7 +363,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let names = let rec aux t = function 0 -> [] | n -> let t = Reductionops.whd_all env sigma t in match EConstr.kind_of_type sigma t with - | ProdType (name, _, t) -> name :: aux t (n-1) + | ProdType (name, _, t) -> name.binder_name :: aux t (n-1) | _ -> assert false in aux hd_ty (Array.length args) in hd_ty, Util.List.map_filter (fun (t, name) -> let evs = Evar.Set.elements (Evarutil.undefined_evars_of_term sigma t) in @@ -403,7 +404,7 @@ let rwcltac cl rdx dir sr gl = let new_rdx = if dir = L2R then a.(2) else a.(1) in pirrel_rewrite cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl | _ -> - let cl' = EConstr.mkApp (EConstr.mkNamedLambda pattern_id rdxt cl, [|rdx|]) in + let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl, [|rdx|]) in let sigma, _ = Typing.type_of env sigma cl' in let gl = pf_merge_uc_of sigma gl in Proofview.V82.of_tactic (convert_concl cl'), rewritetac dir r', gl @@ -413,8 +414,8 @@ let rwcltac cl rdx dir sr gl = try EConstr.destCast (project gl) r2 with _ -> errorstrm Pp.(str "no cast from " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd sr)) ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in - let cl' = EConstr.mkNamedProd rule_id (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in - let cl'' = EConstr.mkNamedProd pattern_id rdxt cl' in + let cl' = EConstr.mkNamedProd (make_annot rule_id Sorts.Relevant) (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in + let cl'' = EConstr.mkNamedProd (make_annot pattern_id Sorts.Relevant) rdxt cl' in let itacs = [introid pattern_id; introid rule_id] in let cltac = Proofview.V82.of_tactic (Tactics.clear [pattern_id; rule_id]) in let rwtacs = [rewritetac dir (EConstr.mkVar rule_id); cltac] in @@ -426,7 +427,9 @@ let rwcltac cl rdx dir sr gl = if occur_existential (project gl) (Tacmach.pf_concl gl) then errorstrm Pp.(str "Rewriting impacts evars") else errorstrm Pp.(str "Dependent type error in rewrite of " - ++ pr_constr_env (pf_env gl) (project gl) (Term.mkNamedLambda pattern_id (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl))) + ++ pr_constr_env (pf_env gl) (project gl) + (Term.mkNamedLambda (make_annot pattern_id Sorts.Relevant) + (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl))) in tclTHEN cvtac' rwtac gl diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 8c1363020a..9ea35b8694 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -13,6 +13,7 @@ open Pp open Names open Constr +open Context open Tacmach open Ssrmatching_plugin.Ssrmatching @@ -54,7 +55,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = let c, (gl, cty) = match EConstr.kind sigma c with | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) | _ -> c, pfe_type_of gl c in - let cl' = EConstr.mkLetIn (Name id, c, cty, cl) in + let cl' = EConstr.mkLetIn (make_annot (Name id) Sorts.Relevant, c, cty, cl) in Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl open Util @@ -162,7 +163,7 @@ let havetac ist let assert_is_conv gl = try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ - pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) concl)) in + pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) Sorts.Relevant concl)) in gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c | FwdHave, false, false -> let skols = List.flatten (List.map (function @@ -190,10 +191,10 @@ let havetac ist Proofview.V82.of_tactic (unfold [abstract; abstract_key]) gl)) | _,true,true -> let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in - gl, EConstr.mkArrow ty concl, hint, itac, clr + gl, EConstr.mkArrow ty Sorts.Relevant concl, hint, itac, clr | _,false,true -> let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in - gl, EConstr.mkArrow ty concl, hint, id, itac_c + gl, EConstr.mkArrow ty Sorts.Relevant concl, hint, id, itac_c | _, false, false -> let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in gl, cty, Tacticals.tclTHEN (binderstac n) hint, id, Tacticals.tclTHEN itac_c simpltac @@ -233,7 +234,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let gens = List.filter (function _, Some _ -> true | _ -> false) gens in let concl = pf_concl gl in let c = EConstr.mkProp in - let c = if cut_implies_goal then EConstr.mkArrow c concl else c in + let c = if cut_implies_goal then EConstr.mkArrow c Sorts.Relevant concl else c in let gl, args, c = List.fold_right mkabs gens (gl,[],c) in let env, _ = List.fold_left (fun (env, c) _ -> @@ -245,10 +246,10 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let fake_gl = {Evd.it = k; Evd.sigma = sigma} in let _, ct, _, uc = pf_interp_ty ist fake_gl ct in let rec var2rel c g s = match EConstr.kind sigma c, g with - | Prod(Anonymous,_,c), [] -> EConstr.mkProd(Anonymous, EConstr.Vars.subst_vars s ct, c) + | Prod({binder_name=Anonymous} as x,_,c), [] -> EConstr.mkProd(x, EConstr.Vars.subst_vars s ct, c) | Sort _, [] -> EConstr.Vars.subst_vars s ct - | LetIn(Name id as n,b,ty,c), _::g -> EConstr.mkLetIn (n,b,ty,var2rel c g (id::s)) - | Prod(Name id as n,ty,c), _::g -> EConstr.mkProd (n,ty,var2rel c g (id::s)) + | LetIn({binder_name=Name id} as n,b,ty,c), _::g -> EConstr.mkLetIn (n,b,ty,var2rel c g (id::s)) + | Prod({binder_name=Name id} as n,ty,c), _::g -> EConstr.mkProd (n,ty,var2rel c g (id::s)) | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_econstr_env env sigma c) in let c = var2rel c gens [] in let rec pired c = function diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index a8dfd69240..e9fe1f3e48 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -13,6 +13,7 @@ open Ssrmatching_plugin open Util open Names open Constr +open Context open Proofview open Proofview.Notations @@ -393,12 +394,12 @@ let tcltclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let sigma, m = Evarutil.new_evar env sigma abstract_ty in sigma, (m, abstract_ty) in let sigma, kont = - let rd = Context.Rel.Declaration.LocalAssum (Name id, abstract_ty) in + let rd = Context.Rel.Declaration.LocalAssum (make_annot (Name id) Sorts.Relevant, abstract_ty) in let sigma, ev = Evarutil.new_evar (EConstr.push_rel rd env) sigma concl in sigma, ev in let term = - EConstr.(mkApp (mkLambda(Name id,abstract_ty,kont),[|abstract_proof|])) in + EConstr.(mkApp (mkLambda(make_annot (Name id) Sorts.Relevant,abstract_ty,kont),[|abstract_proof|])) in let sigma, _ = Typing.type_of env sigma term in sigma, term end in @@ -608,7 +609,7 @@ let with_defective maintac deps clr = Goal.enter begin fun g -> let sigma, concl = Goal.(sigma g, concl g) in let top_id = match EConstr.kind_of_type sigma concl with - | Term.ProdType (Name id, _, _) + | Term.ProdType ({binder_name=Name id}, _, _) when Ssrcommon.is_discharged_id id -> id | _ -> Ssrcommon.top_id in let top_gen = Ssrequality.mkclr clr, Ssrmatching.cpattern_of_id top_id in @@ -683,7 +684,7 @@ let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = let name = Ssrcommon.mk_anon_id "K" (Tacmach.New.pf_ids_of_hyps g) in let new_concl = - mkProd (Name name, case_ty, mkArrow refl (Vars.lift 2 concl)) in + mkProd (make_annot (Name name) Sorts.Relevant, case_ty, mkArrow refl Sorts.Relevant (Vars.lift 2 concl)) in let erefl, sigma = mkCoqRefl case_ty case env sigma in Proofview.Unsafe.tclEVARS sigma <*> Tactics.apply_type ~typecheck:true new_concl [case;erefl] @@ -707,7 +708,7 @@ let mkEq dir cl c t n env sigma = eqargs.(Ssrequality.dir_org dir) <- mkRel n; let eq, sigma = mkCoqEq env sigma in let refl, sigma = mkCoqRefl t c env sigma in - mkArrow (mkApp (eq, eqargs)) (Vars.lift 1 cl), refl, sigma + mkArrow (mkApp (eq, eqargs)) Sorts.Relevant (Vars.lift 1 cl), refl, sigma (** in [tac/v: last gens..] the first (last to be run) generalization is "special" in that is it also the main argument of [tac] and is eventually @@ -743,7 +744,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin Ssrcommon.errorstrm Pp.(str "@ can be used with let-ins only") | Context.Named.Declaration.LocalDef (name, b, ty) -> Unsafe.tclEVARS sigma <*> - tclUNIT (true, EConstr.mkLetIn (Name name,b,ty,cl), c, clr) + tclUNIT (true, EConstr.mkLetIn (map_annot Name.mk_name name,b,ty,cl), c, clr) else Unsafe.tclEVARS sigma <*> Ssrcommon.tacMKPROD c cl >>= fun ccl -> @@ -757,7 +758,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin Unsafe.tclEVARS sigma <*> Ssrcommon.tacTYPEOF p >>= fun pty -> (* TODO: check bug: cl0 no lift? *) - let ccl = EConstr.mkProd (Ssrcommon.constr_name sigma c, pty, cl0) in + let ccl = EConstr.mkProd (make_annot (Ssrcommon.constr_name sigma c) Sorts.Relevant, pty, cl0) in tclUNIT (false, ccl, p, clr) else Ssrcommon.errorstrm Pp.(str "generalized term didn't match") diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index f12f9fac0f..bbe7bde78b 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -12,6 +12,7 @@ open Names open Constr +open Context open Termops open Tacmach @@ -102,10 +103,10 @@ let endclausestac id_map clseq gl_id cl0 gl = forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in let rec unmark c = match EConstr.kind (project gl) c with | Var id when hidden_clseq clseq && id = gl_id -> cl0 - | Prod (Name id, t, c') when List.mem_assoc id id_map -> - EConstr.mkProd (Name (orig_id id), unmark t, unmark c') - | LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> - EConstr.mkLetIn (Name (orig_id id), unmark v, unmark t, unmark c') + | Prod ({binder_name=Name id} as na, t, c') when List.mem_assoc id id_map -> + EConstr.mkProd ({na with binder_name=Name (orig_id id)}, unmark t, unmark c') + | LetIn ({binder_name=Name id} as na, v, t, c') when List.mem_assoc id id_map -> + EConstr.mkLetIn ({na with binder_name=Name (orig_id id)}, unmark v, unmark t, unmark c') | _ -> EConstr.map (project gl) unmark c in let utac hyp = Proofview.V82.of_tactic diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index d083d34b52..2e1554d496 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -152,7 +152,7 @@ let declare_one_prenex_implicit locality f = with _ -> errorstrm (pr_qualid f ++ str " is not declared") in let rec loop = function | a :: args' when Impargs.is_status_implicit a -> - (ExplByName (Impargs.name_of_implicit a), (true, true, true)) :: loop args' + Impargs.MaximallyImplicit :: loop args' | args' when List.exists Impargs.is_status_implicit args' -> errorstrm (str "Expected prenex implicits for " ++ pr_qualid f) | _ -> [] in @@ -165,7 +165,7 @@ let declare_one_prenex_implicit locality f = | [] -> errorstrm (str "Expected some implicits for " ++ pr_qualid f) | impls -> - Impargs.declare_manual_implicits locality fref ~enriching:false [impls] + Impargs.set_implicits locality fref [impls] } diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 2794696017..537fd7d7b4 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -10,6 +10,7 @@ open Util open Names +open Context open Ltac_plugin @@ -95,7 +96,7 @@ let vsBOOTSTRAP = Goal.enter_one ~__LOC__ begin fun gl -> let concl = Goal.concl gl in let id = (* We keep the orig name for checks in "in" tcl *) match EConstr.kind_of_type (Goal.sigma gl) concl with - | Term.ProdType(Name.Name id, _, _) + | Term.ProdType({binder_name=Name.Name id}, _, _) when Ssrcommon.is_discharged_id id -> id | _ -> mk_anon_id "view_subject" (Tacmach.New.pf_ids_of_hyps gl) in let view = EConstr.mkVar id in diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 552a4048b1..b83a6a34cb 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -16,6 +16,7 @@ open Pp open Genarg open Stdarg open Term +open Context module CoqConstr = Constr open CoqConstr open Vars @@ -213,7 +214,7 @@ let unif_EQ_args env sigma pa a = loop 0 let unif_HO env ise p c = - try Evarconv.the_conv_x env p c ise + try Evarconv.unify_delay env ise p c with Evarconv.UnableToUnify(ise, err) -> raise Pretype_errors.(PretypeError(env,ise,CannotUnify(p,c,Some err))) @@ -383,7 +384,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = | Context.Named.Declaration.LocalDef (x, b, t) -> d, mkNamedLetIn x (put b) (put t) c | Context.Named.Declaration.LocalAssum (x, t) -> - mkVar x :: d, mkNamedProd x (put t) c in + mkVar x.binder_name :: d, mkNamedProd x (put t) c in let a, t = Context.Named.fold_inside abs_dc ~init:([], (put @@ EConstr.Unsafe.to_constr evi.evar_concl)) @@ -548,7 +549,7 @@ let match_upats_FO upats env sigma0 ise orig_c = if skip || not (closed0 c') then () else try let _ = match u.up_k with | KpatFlex -> - let kludge v = mkLambda (Anonymous, mkProp, v) in + let kludge v = mkLambda (make_annot Anonymous Sorts.Relevant, mkProp, v) in unif_FO env ise (kludge u.up_FO) (kludge c') | KpatLet -> let kludge vla = @@ -1286,7 +1287,7 @@ let ssrpatterntac _ist arg gl = let t = EConstr.of_constr t in let concl_x = EConstr.of_constr concl_x in let gl, tty = pf_type_of gl t in - let concl = EConstr.mkLetIn (Name (Id.of_string "selected"), t, tty, concl_x) in + let concl = EConstr.mkLetIn (make_annot (Name (Id.of_string "selected")) Sorts.Relevant, t, tty, concl_x) in Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 08df9a2460..3b3de33d8e 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -13,6 +13,7 @@ open Names open Globnames open Term open Constr +open Context open Environ open Util open Libobject @@ -72,7 +73,7 @@ let arguments_names r = GlobRef.Map.find r !name_table let rename_type ty ref = let name_override old_name override = match override with - | Name _ as x -> x + | Name _ as x -> {old_name with binder_name=x} | Anonymous -> old_name in let rec rename_type_aux c = function | [] -> c diff --git a/pretyping/cases.ml b/pretyping/cases.ml index ed7c3d6770..e22368d5e5 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -16,6 +16,7 @@ open Util open Names open Nameops open Constr +open Context open Termops open Environ open EConstr @@ -321,9 +322,9 @@ let inh_coerce_to_ind env sigma0 loc ty tyi = constructor and renounce if not able to give more information *) (* devrait être indifférent d'exiger leq ou pas puisque pour un inductif cela doit être égal *) - match cumul env sigma expected_typ ty with - | Some sigma -> sigma - | None -> sigma0 + match Evarconv.unify_leq_delay env sigma expected_typ ty with + | sigma -> sigma + | exception Evarconv.UnableToUnify _ -> sigma0 let binding_vars_of_inductive sigma = function | NotInd _ -> [] @@ -426,16 +427,16 @@ let adjust_tomatch_to_pattern ~program_mode sigma pb ((current,typ),deps,dep) = let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in (match find_row_ind tm1 with | None -> sigma, (current, tmtyp) - | Some (_,(ind,_)) -> + | Some (loc,(ind,_)) -> let sigma, indt = inductive_template !!(pb.env) sigma None ind in let sigma, current = if List.is_empty deps && isEvar sigma typ then (* Don't insert coercions if dependent; only solve evars *) - match cumul !!(pb.env) sigma indt typ with - | None -> sigma, current - | Some sigma -> sigma, current + match Evarconv.unify_leq_delay !!(pb.env) sigma indt typ with + | exception Evarconv.UnableToUnify _ -> sigma, current + | sigma -> sigma, current else - let sigma, j = Coercion.inh_conv_coerce_to ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in + let sigma, j = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in sigma, j.uj_val in sigma, (current, try_find_ind !!(pb.env) sigma indt names)) @@ -472,7 +473,8 @@ let push_current_pattern ~program_mode sigma (cur,ty) eqn = let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in match eqn.patterns with | pat::pats -> - let _,rhs_env = push_rel ~hypnaming sigma (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in + let r = Sorts.Relevant in (* TODO relevance *) + let _,rhs_env = push_rel ~hypnaming sigma (LocalDef (make_annot (alias_of_pat pat) r,cur,ty)) eqn.rhs.rhs_env in { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } @@ -762,7 +764,10 @@ let get_names avoid env sigma sign eqns = (fun (l,avoid) d na -> let na = merge_name - (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env sigma t na) avoid)) + (fun decl -> + let na = get_name decl in + let t = get_type decl in + Name (next_name_away (named_hd env sigma t na) avoid)) d na in (na::l,Id.Set.add (Name.get_id na) avoid)) @@ -782,10 +787,10 @@ let recover_and_adjust_alias_names (_,avoid) names sign = let rec aux = function | [],[] -> [] - | x::names, LocalAssum (_,t)::sign -> - (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign) + | x::names, LocalAssum (x',t)::sign -> + (x, LocalAssum ({x' with binder_name=alias_of_pat x},t)) :: aux (names,sign) | names, (LocalDef (na,_,_) as decl)::sign -> - (DAst.make @@ PatVar na, decl) :: aux (names,sign) + (DAst.make @@ PatVar na.binder_name, decl) :: aux (names,sign) | _ -> assert false in List.split (aux (names,sign)) @@ -1247,7 +1252,7 @@ let rec generalize_problem names sigma pb = function let pb',deps = generalize_problem names sigma pb l in let d = map_constr (lift i) (lookup_rel i !!(pb.env)) in begin match d with - | LocalDef (Anonymous,_,_) -> pb', deps + | LocalDef ({binder_name=Anonymous},_,_) -> pb', deps | _ -> (* for better rendering *) let d = RelDecl.map_type (fun c -> whd_betaiota sigma c) d in @@ -1436,16 +1441,15 @@ let compile ~program_mode sigma pb = brvals pb.tomatch pb.pred deps cstrs in let brvals = Array.map (fun (sign,body) -> it_mkLambda_or_LetIn body sign) brvals in - let (pred,typ) = + let (pred,typ) = find_predicate pb.caseloc pb.env sigma - pred current indt (names,dep) tomatch in - let ci = make_case_info !!(pb.env) (fst mind) pb.casestyle in + pred current indt (names,dep) tomatch + in + let rci = Typing.check_allowed_sort !!(pb.env) sigma mind current pred in + let ci = make_case_info !!(pb.env) (fst mind) rci pb.casestyle in let pred = nf_betaiota !!(pb.env) sigma pred in - let case = - make_case_or_project !!(pb.env) sigma indf ci pred current brvals - in + let case = make_case_or_project !!(pb.env) sigma indf ci pred current brvals in let sigma, _ = Typing.type_of !!(pb.env) sigma pred in - Typing.check_allowed_sort !!(pb.env) sigma mind current pred; sigma, { uj_val = applist (case, inst); uj_type = prod_applist sigma typ inst } @@ -1460,7 +1464,7 @@ let compile ~program_mode sigma pb = let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let pb = { pb with - env = snd (push_rel ~hypnaming sigma (LocalDef (na,current,ty)) env); + env = snd (push_rel ~hypnaming sigma (LocalDef (annotR na,current,ty)) env); tomatch = tomatch; pred = lift_predicate 1 pred tomatch; history = pop_history pb.history; @@ -1511,7 +1515,8 @@ let compile ~program_mode sigma pb = and compile_alias initial sigma pb (na,orig,(expanded,expanded_typ)) rest = let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let f c t = - let alias = LocalDef (na,c,t) in + let r = Retyping.relevance_of_type !!(pb.env) sigma t in + let alias = LocalDef (make_annot na r,c,t) in let pb = { pb with env = snd (push_rel ~hypnaming sigma alias pb.env); @@ -1524,7 +1529,7 @@ let compile ~program_mode sigma pb = if isRel sigma c || isVar sigma c || count_occurrences sigma (mkRel 1) j.uj_val <= 1 then subst1 c j.uj_val else - mkLetIn (na,c,t,j.uj_val); + mkLetIn (make_annot na r,c,t,j.uj_val); uj_type = subst1 c j.uj_type } in (* spiwack: when an alias appears on a deep branch, its non-expanded form is automatically a variable of the same name. We avoid @@ -1707,9 +1712,11 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context !!env) in let sigma, ev' = Evarutil.new_evar ~src ~typeclass_candidate:false !!env sigma ty in - begin match solve_simple_eqn (evar_conv_x TransparentState.full) !!env sigma (None,ev,substl inst ev') with - | Success evd -> evdref := evd - | UnifFailure _ -> assert false + begin + let flags = (default_flags_of TransparentState.full) in + match solve_simple_eqn evar_unify flags !!env sigma (None,ev,substl inst ev') with + | Success evd -> evdref := evd + | UnifFailure _ -> assert false end; ev' | _ -> @@ -1765,9 +1772,9 @@ let build_tycon ?loc env tycon_env s subst tycon extenv sigma t = let sigma, t = abstract_tycon ?loc tycon_env sigma subst tycon extenv t in let sigma, tt = Typing.type_of !!extenv sigma t in (sigma, t, tt) in - match cumul !!env sigma tt (mkSort s) with - | None -> anomaly (Pp.str "Build_tycon: should be a type."); - | Some sigma -> + match unify_leq_delay !!env sigma tt (mkSort s) with + | exception Evarconv.UnableToUnify _ -> anomaly (Pp.str "Build_tycon: should be a type."); + | sigma -> sigma, { uj_val = t; uj_type = tt } (* For a multiple pattern-matching problem Xi on t1..tn with return @@ -1810,7 +1817,7 @@ let build_inversion_problem ~program_mode loc env sigma tms t = List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in - let d = LocalAssum (alias_of_pat pat,typ) in + let d = LocalAssum (annotR (alias_of_pat pat),typ) in let patl,acc_sign,acc = aux (n+1) (snd (push_rel ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma d env)) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in let avoid0 = GlobEnv.vars_of_env env in @@ -1911,9 +1918,11 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = match tm with | NotInd (bo,typ) -> (match t with - | None -> let sign = match bo with - | None -> [LocalAssum (na, lift n typ)] - | Some b -> [LocalDef (na, lift n b, lift n typ)] in sign + | None -> + let r = Sorts.Relevant in (* TODO relevance *) + let sign = match bo with + | None -> [LocalAssum (make_annot na r, lift n typ)] + | Some b -> [LocalDef (make_annot na r, lift n b, lift n typ)] in sign | Some {CAst.loc} -> user_err ?loc (str"Unexpected type annotation for a term of non inductive type.")) @@ -1921,7 +1930,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let indf' = if dolift then lift_inductive_family n indf else indf in let ((ind,u),_) = dest_ind_family indf' in let nrealargs_ctxt = inductive_nrealdecls_env env0 ind in - let arsign = fst (get_arity env0 indf') in + let arsign, inds = get_arity env0 indf' in let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in let realnal = match t with @@ -1933,8 +1942,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = List.rev realnal | None -> List.make nrealargs_ctxt Anonymous in + let r = Sorts.relevance_of_sort_family inds in let t = EConstr.of_constr (build_dependent_inductive env0 indf') in - LocalAssum (na, t) :: List.map2 RelDecl.set_name realnal arsign in + LocalAssum (make_annot na r, t) :: List.map2 RelDecl.set_name realnal arsign in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> @@ -1945,7 +1955,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let inh_conv_coerce_to_tycon ?loc ~program_mode env sigma j tycon = match tycon with - | Some p -> Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma j p + | Some p -> Coercion.inh_conv_coerce_to ?loc ~program_mode true env sigma + ~flags:(default_flags_of TransparentState.full) j p | None -> sigma, j (* We put the tycon inside the arity signature, possibly discovering dependencies. *) @@ -2140,9 +2151,10 @@ let constr_of_pat env sigma arsign pat avoid = | Anonymous -> let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, Id.Set.add id avoid - in - (sigma, (DAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, - (List.map (fun x -> mkRel 1) realargs), 1, avoid) + in + let r = Sorts.Relevant in (* TODO relevance *) + (sigma, (DAst.make ?loc @@ PatVar name), [LocalAssum (make_annot name r, ty)] @ realargs, mkRel 1, ty, + (List.map (fun x -> mkRel 1) realargs), 1, avoid) | PatCstr (((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in let IndType (indf, _) = @@ -2181,23 +2193,26 @@ let constr_of_pat env sigma arsign pat avoid = match alias with Anonymous -> sigma, pat', sign, app, apptype, realargs, n, avoid - | Name id -> - let sign = LocalAssum (alias, lift m ty) :: sign in - let avoid = Id.Set.add id avoid in + | Name id -> + let _, inds = get_arity env indf in + let r = Sorts.relevance_of_sort_family inds in + let sign = LocalAssum (make_annot alias r, lift m ty) :: sign in + let avoid = Id.Set.add id avoid in let sigma, sign, i, avoid = try let env = EConstr.push_rel_context sign env in - let sigma = the_conv_x_leq (EConstr.push_rel_context sign env) - (lift (succ m) ty) (lift 1 apptype) sigma in + let sigma = unify_leq_delay (EConstr.push_rel_context sign env) sigma + (lift (succ m) ty) (lift 1 apptype) in let sigma, eq_t = mk_eq sigma (lift (succ m) ty) (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) in - let neq = eq_id avoid id in - sigma, LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid - with Reduction.NotConvertible -> sigma, sign, 1, avoid + let neq = eq_id avoid id in + (* if we ever allow using a SProp-typed coq_eq_ind this relevance will be wrong *) + sigma, LocalDef (nameR neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid + with Evarconv.UnableToUnify _ -> sigma, sign, 1, avoid in - (* Mark the equality as a hole *) + (* Mark the equality as a hole *) sigma, pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in let sigma, pat', sign, patc, patty, args, z, avoid = typ env sigma (RelDecl.get_type (List.hd arsign), List.tl arsign) pat avoid in @@ -2219,18 +2234,18 @@ match EConstr.kind sigma t with let rels_of_patsign sigma = List.map (fun decl -> match decl with - | LocalDef (na,t',t) when is_topvar sigma t' -> LocalAssum (na,t) + | LocalDef (na,t',t) when is_topvar sigma t' -> LocalAssum (na,t) | _ -> decl) let vars_of_ctx sigma ctx = let _, y = List.fold_right (fun decl (prev, vars) -> match decl with - | LocalDef (na,t',t) when is_topvar sigma t' -> + | LocalDef (na,t',t) when is_topvar sigma t' -> prev, (DAst.make @@ GApp ( (DAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), - [hole na; DAst.make @@ GVar prev])) :: vars + [hole na.binder_name; DAst.make @@ GVar prev])) :: vars | _ -> match RelDecl.get_name decl with Anonymous -> invalid_arg "vars_of_ctx" @@ -2340,12 +2355,13 @@ let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = let args = List.rev args in substl args (liftn signlen (succ nargs) arity) in - let rhs_rels', tycon = + let r = Sorts.Relevant in (* TODO relevance *) + let rhs_rels', tycon = let neqs_rels, arity = match ineqs with | None -> [], arity | Some ineqs -> - [LocalAssum (Anonymous, ineqs)], lift 1 arity + [LocalAssum (make_annot Anonymous r, ineqs)], lift 1 arity in let eqs_rels, arity = decompose_prod_n_assum sigma neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity @@ -2356,7 +2372,7 @@ let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let sigma, _btype = Typing.type_of !!env sigma bbody in let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in - let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in + let branch_decl = LocalDef (make_annot (Name branch_name) r, lift !i bbody, lift !i btype) in let branch = let bref = DAst.make @@ GVar branch_name in match vars_of_ctx sigma rhs_rels with @@ -2404,9 +2420,10 @@ let abstract_tomatch env sigma tomatchs tycon = | _ -> let tycon = Option.map (fun t -> subst_term sigma (lift 1 c) (lift 1 t)) tycon in - let name = next_ident_away (Id.of_string "filtered_var") names in + let name = next_ident_away (Id.of_string "filtered_var") names in + let r = Sorts.Relevant in (* TODO relevance *) (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, - LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, + LocalDef (make_annot (Name name) r, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, Id.Set.add name names, tycon) ([], [], Id.Set.empty, tycon) tomatchs in List.rev prev, ctx, tycon @@ -2468,8 +2485,8 @@ let build_dependent_signature env sigma avoid tomatchs arsign = make_prime avoid name in (sigma, env, succ nargeqs, - (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs, - refl_arg :: refl_args, + (LocalAssum (make_annot (Name (eq_id avoid previd)) Sorts.Relevant, eq)) :: argeqs, + refl_arg :: refl_args, pred slift, RelDecl.set_name (Name id) decl :: argsign')) (sigma, env, neqs, [], [], slift, []) args argsign @@ -2483,8 +2500,8 @@ let build_dependent_signature env sigma avoid tomatchs arsign = in let sigma, refl_eq = mk_JMeq_refl sigma ty tm in let previd, id = make_prime avoid appn in - (sigma, (LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, - succ nargeqs, + (sigma, (LocalAssum (make_annot (Name (eq_id avoid previd)) Sorts.Relevant, eq) :: argeqs) :: eqs, + succ nargeqs, refl_eq :: refl_args, pred slift, ((RelDecl.set_name (Name id) app_decl :: argsign') :: arsigns)) @@ -2500,8 +2517,9 @@ let build_dependent_signature env sigma avoid tomatchs arsign = (mkRel slift) (lift nar tm) in let sigma, refl = mk_eq_refl sigma tomatch_ty tm in + let na = make_annot (Name (eq_id avoid previd)) Sorts.Relevant in (sigma, - [LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, + [LocalAssum (na, eq)] :: eqs, succ neqs, refl :: refl_args, pred slift, (arsign' :: []) :: arsigns)) (sigma, [], 0, [], nar, []) tomatchs arsign @@ -2577,11 +2595,12 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) - let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) - | NotInd (Some b, t) -> LocalDef (na,b,t) - | IsInd (typ,_,_) -> LocalAssum (na,typ) in + (* TODO relevance *) + let out_tmt na = function NotInd (None,t) -> LocalAssum (make_annot na Sorts.Relevant,t) + | NotInd (Some b, t) -> LocalDef (make_annot na Sorts.Relevant,b,t) + | IsInd (typ,_,_) -> LocalAssum (make_annot na Sorts.Relevant,typ) in let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in - + let typs = List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in @@ -2651,10 +2670,11 @@ let compile_cases ?loc ~program_mode style (typing_fun, sigma) tycon env (predop (* names of aliases will be recovered from patterns (hence Anonymous *) (* here) *) + (* TODO relevance *) let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) | NotInd (Some b,t) -> LocalDef (na,b,t) | IsInd (typ,_,_) -> LocalAssum (na,typ) in - let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in + let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt (make_annot na Sorts.Relevant) tmt)) nal tomatchs in let typs = List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index e27fc536eb..c9f18d89be 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -48,7 +48,7 @@ type cbv_value = | VAL of int * constr | STACK of int * cbv_value * cbv_stack | CBN of constr * cbv_value subs - | LAM of int * (Name.t * constr) list * constr * cbv_value subs + | LAM of int * (Name.t Context.binder_annot * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor Univ.puniverses * cbv_value array @@ -281,11 +281,11 @@ and reify_value = function (* reduction under binders *) apply_env env @@ List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) b ctxt - | FIXP ((lij,(names,lty,bds)),env,args) -> - let fix = mkFix (lij, (names, lty, bds)) in + | FIXP ((lij,fix),env,args) -> + let fix = mkFix (lij, fix) in mkApp (apply_env env fix, Array.map reify_value args) - | COFIXP ((j,(names,lty,bds)),env,args) -> - let cofix = mkCoFix (j, (names,lty,bds)) in + | COFIXP ((j,cofix),env,args) -> + let cofix = mkCoFix (j, cofix) in mkApp (apply_env env cofix, Array.map reify_value args) | CONSTR (c,args) -> mkApp(mkConstructU c, Array.map reify_value args) @@ -550,7 +550,7 @@ and cbv_norm_value info = function (* reduction under binders *) | FIXP ((lij,(names,lty,bds)),env,args) -> mkApp (mkFix (lij, - (names, + (names, Array.map (cbv_norm_term info env) lty, Array.map (cbv_norm_term info (subs_liftn (Array.length lty) env)) bds)), @@ -558,7 +558,7 @@ and cbv_norm_value info = function (* reduction under binders *) | COFIXP ((j,(names,lty,bds)),env,args) -> mkApp (mkCoFix (j, - (names,Array.map (cbv_norm_term info env) lty, + (names,Array.map (cbv_norm_term info env) lty, Array.map (cbv_norm_term info (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 0a1e771921..d6c2ad146e 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -32,7 +32,7 @@ type cbv_value = | VAL of int * constr | STACK of int * cbv_value * cbv_stack | CBN of constr * cbv_value subs - | LAM of int * (Name.t * constr) list * constr * cbv_value subs + | LAM of int * (Name.t Context.binder_annot * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor Univ.puniverses * cbv_value array diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 306a76e35e..54a1aa9aa0 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -179,7 +179,7 @@ let find_class_type sigma t = | Proj (p, c) when not (Projection.unfolded p) -> CL_PROJ (Projection.repr p), EInstance.empty, (c :: args) | Ind (ind_sp,u) -> CL_IND ind_sp, u, args - | Prod (_,_,_) -> CL_FUN, EInstance.empty, [] + | Prod _ -> CL_FUN, EInstance.empty, [] | Sort _ -> CL_SORT, EInstance.empty, [] | _ -> raise Not_found diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 2329b87acc..82411ba2ef 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -21,6 +21,7 @@ open Util open Names open Term open Constr +open Context open Environ open EConstr open Vars @@ -64,9 +65,9 @@ let apply_coercion_args env sigma check isproj argl funj = | Prod (_,c1,c2) -> let sigma = if check then - begin match cumul env sigma (Retyping.get_type_of env sigma h) c1 with - | None -> raise NoCoercion - | Some sigma -> sigma + begin match Evarconv.unify_leq_delay env sigma (Retyping.get_type_of env sigma h) c1 with + | exception Evarconv.UnableToUnify _ -> raise NoCoercion + | sigma -> sigma end else sigma in @@ -157,7 +158,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let rec coerce_unify env x y = let x = hnf env !evdref x and y = hnf env !evdref y in try - evdref := the_conv_x_leq env x y !evdref; + evdref := Evarconv.unify_leq_delay env !evdref x y; None with UnableToUnify _ -> coerce' env x y and coerce' env x y : (EConstr.constr -> EConstr.constr) option = @@ -172,26 +173,26 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let rec aux tele typ typ' i co = if i < len then let hdx = l.(i) and hdy = l'.(i) in - try evdref := the_conv_x_leq env hdx hdy !evdref; + try evdref := unify_leq_delay env !evdref hdx hdy; let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in - aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co + aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co with UnableToUnify _ -> - let (n, eqT), restT = dest_prod typ in + let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in let () = - try evdref := the_conv_x_leq env eqT eqT' !evdref - with UnableToUnify _ -> raise NoSubtacCoercion - in + try evdref := unify_leq_delay env !evdref eqT eqT' + with UnableToUnify _ -> raise NoSubtacCoercion + in (* Disallow equalities on arities *) if Reductionops.is_arity env !evdref eqT then raise NoSubtacCoercion; let restargs = lift_args 1 (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) in let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in - let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in + let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in - let evar = make_existential ?loc n env evdref eq in + let evar = make_existential ?loc n.binder_name env evdref eq in let eq_app x = papp evdref coq_eq_rect [| eqT; hdx; pred; x; hdy; evar|] in @@ -216,9 +217,12 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> let name' = - Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.vars_of_env env)) - in - let env' = push_rel (LocalAssum (name', a')) env in + {name' with + binder_name = + Name (Namegen.next_ident_away + Namegen.default_dependent_ident (Termops.vars_of_env env))} + in + let env' = push_rel (LocalAssum (name', a')) env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) let coec1 = app_opt env' evdref c1 (mkRel 1) in @@ -230,7 +234,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) | _, _ -> Some (fun f -> - mkLambda (name', a', + mkLambda (name', a', app_opt env' evdref c2 (mkApp (lift 1 f, [| coec1 |]))))) @@ -253,11 +257,11 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let c1 = coerce_unify env a a' in let remove_head a c = match EConstr.kind !evdref c with - | Lambda (n, t, t') -> c, t' + | Lambda (n, t, t') -> c, t' | Evar (k, args) -> let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in evdref := evs; - let (n, dom, rng) = destLambda !evdref t in + let (n, dom, rng) = destLambda !evdref t in if isEvar !evdref dom then let (domk, args) = destEvar !evdref dom in evdref := define domk a !evdref; @@ -265,8 +269,12 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) t, rng | _ -> raise NoSubtacCoercion in - let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in - let env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in + let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in + let ra = Retyping.relevance_of_type env !evdref a in + let env' = push_rel + (LocalAssum (make_annot (Name Namegen.default_dependent_ident) ra, a)) + env + in let c2 = coerce_unify env' b b' in match c1, c2 with | None, None -> None @@ -396,9 +404,9 @@ let apply_coercion env sigma p hj typ_cl = let inh_app_fun_core ~program_mode env evd j = let t = whd_all env evd j.uj_type in match EConstr.kind evd t with - | Prod (_,_,_) -> (evd,j) + | Prod _ -> (evd,j) | Evar ev -> - let (evd',t) = Evardefine.define_evar_as_product evd ev in + let (evd',t) = Evardefine.define_evar_as_product env evd ev in (evd',{ uj_val = j.uj_val; uj_type = t }) | _ -> try let t,p = @@ -466,7 +474,7 @@ let inh_coerce_to_prod ?loc ~program_mode env evd t = !evdref, typ' else (evd, t) -let inh_coerce_to_fail env evd rigidonly v t c1 = +let inh_coerce_to_fail flags env evd rigidonly v t c1 = if rigidonly && not (Heads.is_rigid env (EConstr.Unsafe.to_constr c1) && Heads.is_rigid env (EConstr.Unsafe.to_constr t)) then raise NoCoercion @@ -483,13 +491,16 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = | None -> evd, None, t with Not_found -> raise NoCoercion in - try (the_conv_x_leq env t' c1 evd, v') + try (unify_leq_delay ~flags env evd t' c1, v') with UnableToUnify _ -> raise NoCoercion -let rec inh_conv_coerce_to_fail ?loc env evd rigidonly v t c1 = - try (the_conv_x_leq env t c1 evd, v) +let default_flags_of env = + default_flags_of TransparentState.full + +let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigidonly v t c1 = + try (unify_leq_delay ~flags env evd t c1, v) with UnableToUnify (best_failed_evd,e) -> - try inh_coerce_to_fail env evd rigidonly v t c1 + try inh_coerce_to_fail flags env evd rigidonly v t c1 with NoCoercion -> match EConstr.kind evd (whd_all env evd t), @@ -502,11 +513,11 @@ let rec inh_conv_coerce_to_fail ?loc env evd rigidonly v t c1 = (* has type forall (x:u1), u2 (with v' recursively obtained) *) (* Note: we retype the term because template polymorphism may have *) (* weakened its type *) - let name = match name with + let name = map_annot (function | Anonymous -> Name Namegen.default_dependent_ident - | _ -> name in + | na -> na) name in let open Context.Rel.Declaration in - let env1 = push_rel (LocalAssum (name,u1)) env in + let env1 = push_rel (LocalAssum (name,u1)) env in let (evd', v1) = inh_conv_coerce_to_fail ?loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in @@ -516,14 +527,14 @@ let rec inh_conv_coerce_to_fail ?loc env evd rigidonly v t c1 = | None -> subst_term evd' v1 t2 | Some v2 -> Retyping.get_type_of env1 evd' v2 in let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in - (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') + (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) -let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly env evd cj t = +let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env evd cj t = let (evd', val') = try - inh_conv_coerce_to_fail ?loc env evd rigidonly (Some cj.uj_val) cj.uj_type t + inh_conv_coerce_to_fail ?loc env evd ~flags rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> try if program_mode then @@ -545,15 +556,14 @@ let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly env evd cj t let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) -let inh_conv_coerce_to ?loc ~program_mode resolve_tc = - inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc false - -let inh_conv_coerce_rigid_to ?loc ~program_mode resolve_tc = - inh_conv_coerce_to_gen ~program_mode resolve_tc ?loc true +let inh_conv_coerce_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) = + inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc false flags env evd +let inh_conv_coerce_rigid_to ?loc ~program_mode resolve_tc env evd ?(flags=default_flags_of env) = + inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc true flags env evd -let inh_conv_coerces_to ?loc env evd t t' = +let inh_conv_coerces_to ?loc env evd ?(flags=default_flags_of env) t t' = try - fst (inh_conv_coerce_to_fail ?loc env evd true None t t') + fst (inh_conv_coerce_to_fail ?loc env evd ~flags true None t t') with NoCoercion -> evd (* Maybe not enough information to unify *) diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index a941391125..43d4059785 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -45,17 +45,21 @@ val inh_coerce_to_prod : ?loc:Loc.t -> program_mode:bool -> a way [t] and [j.uj_type] are convertible; it fails if no coercion is applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) + val inh_conv_coerce_to : ?loc:Loc.t -> program_mode:bool -> bool -> - env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment + env -> evar_map -> ?flags:Evarconv.unify_flags -> + unsafe_judgment -> types -> evar_map * unsafe_judgment val inh_conv_coerce_rigid_to : ?loc:Loc.t -> program_mode:bool ->bool -> - env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment + env -> evar_map -> ?flags:Evarconv.unify_flags -> + unsafe_judgment -> types -> evar_map * unsafe_judgment (** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] is coercible to an object of type [t'] adding evar constraints if needed; it fails if no coercion exists *) val inh_conv_coerces_to : ?loc:Loc.t -> - env -> evar_map -> types -> types -> evar_map + env -> evar_map -> ?flags:Evarconv.unify_flags -> + types -> types -> evar_map (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 94257fedd7..bc083ed9d9 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -14,6 +14,7 @@ open CErrors open Util open Names open Constr +open Context open Globnames open Termops open Term @@ -70,7 +71,7 @@ let constrain sigma n (ids, m) ((names,seen as names_seen), terms as subst) = (names_seen, Id.Map.add n (ids, m) terms) let add_binders na1 na2 binding_vars ((names,seen), terms as subst) = - match na1, na2 with + match na1, na2.binder_name with | Name id1, Name id2 when Id.Set.mem id1 binding_vars -> if Id.Map.mem id1 names then let () = Glob_ops.warn_variable_collision id1 in @@ -94,7 +95,7 @@ let rec build_lambda sigma vars ctx m = match vars with let (na, t, suf) = match suf with | [] -> assert false | (_, id, t) :: suf -> - (Name id, t, suf) + (map_annot Name.mk_name id, t, suf) in (* Check that the abstraction is legal by generating a transitive closure of its dependencies. *) @@ -178,11 +179,12 @@ let make_renaming ids = function | _ -> dummy_constr let push_binder na1 na2 t ctx = - let id2 = match na2 with - | Name id2 -> id2 - | Anonymous -> - let avoid = Id.Set.of_list (List.map pi2 ctx) in - Namegen.next_ident_away Namegen.default_non_dependent_ident avoid in + let id2 = map_annot (function + | Name id2 -> id2 + | Anonymous -> + let avoid = Id.Set.of_list (List.map (fun (_,id,_) -> id.binder_name) ctx) in + Namegen.next_ident_away Namegen.default_non_dependent_ident avoid) na2 + in (na1, id2, t) :: ctx (* This is an optimization of the main pattern-matching which shares @@ -341,19 +343,19 @@ let matches_core env sigma allow_bound_rels sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,Some t1,d1), LetIn(na2,c2,t2,d2) -> - sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env (sorec ctx env subst c1 c2) t1 t2)) d1 d2 | PLetIn (na1,c1,None,d1), LetIn(na2,c2,t2,d2) -> - sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 99cd89cc2a..ac7c3d30d5 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -13,6 +13,7 @@ open CErrors open Util open Names open Constr +open Context open Term open EConstr open Vars @@ -40,9 +41,12 @@ let print_evar_arguments = ref false let add_name na b t (nenv, env) = let open Context.Rel.Declaration in + (* Is this just a dummy? Be careful, printing doesn't always give us + a correct env. *) + let r = Sorts.Relevant in add_name na nenv, push_rel (match b with - | None -> LocalAssum (na,t) - | Some b -> LocalDef (na,b,t) + | None -> LocalAssum (make_annot na r,t) + | Some b -> LocalDef (make_annot na r,b,t) ) env @@ -202,11 +206,11 @@ let computable sigma p k = let lookup_name_as_displayed env sigma t s = let rec lookup avoid n c = match EConstr.kind sigma c with | Prod (name,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal avoid name c' with + (match compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | LetIn (name,_,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal avoid name c' with + (match compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid n c @@ -216,7 +220,7 @@ let lookup_name_as_displayed env sigma t s = let lookup_index_as_renamed env sigma t n = let rec lookup n d c = match EConstr.kind sigma c with | Prod (name,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name c' with + (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -226,7 +230,7 @@ let lookup_index_as_renamed env sigma t n = else lookup (n-1) (d+1) c') | LetIn (name,_,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name c' with + (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with | (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -342,9 +346,9 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c = | b::tags -> let na,c,f,body,t = match EConstr.kind sigma (strip_outer_cast sigma c), b with - | Lambda (na,t,c),false -> na,c,compute_displayed_let_name_in,None,Some t - | LetIn (na,b,t,c),true -> - na,c,compute_displayed_name_in,Some b,Some t + | Lambda (na,t,c),false -> na.binder_name,c,compute_displayed_let_name_in,None,Some t + | LetIn (na,b,t,c),true -> + na.binder_name,c,compute_displayed_name_in,Some b,Some t | _, false -> Name default_dependent_ident,(applist (lift 1 c, [mkRel 1])), compute_displayed_name_in,None,None @@ -490,19 +494,16 @@ let rec share_names detype n l avoid env sigma c t = match EConstr.kind sigma c, EConstr.kind sigma t with (* factorize even when not necessary to have better presentation *) | Lambda (na,t,c), Prod (na',t',c') -> - let na = match (na,na') with - Name _, _ -> na - | _, Name _ -> na' - | _ -> na in + let na = Nameops.Name.pick_annot na na' in let t' = detype avoid env sigma t in - let id = next_name_away na avoid in + let id = next_name_away na.binder_name avoid in let avoid = Id.Set.add id avoid and env = add_name (Name id) None t env in share_names detype (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' (* May occur for fix built interactively *) | LetIn (na,b,t',c), _ when n > 0 -> let t'' = detype avoid env sigma t' in let b' = detype avoid env sigma b in - let id = next_name_away na avoid in + let id = next_name_away na.binder_name avoid in let avoid = Id.Set. add id avoid and env = add_name (Name id) (Some b) t' env in share_names detype n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t) (* Only if built with the f/n notation or w/o let-expansion in types *) @@ -511,7 +512,7 @@ let rec share_names detype n l avoid env sigma c t = (* If it is an open proof: we cheat and eta-expand *) | _, Prod (na',t',c') when n > 0 -> let t'' = detype avoid env sigma t' in - let id = next_name_away na' avoid in + let id = next_name_away na'.binder_name avoid in let avoid = Id.Set.add id avoid and env = add_name (Name id) None t' env in let appc = mkApp (lift 1 c,[|mkRel 1|]) in share_names detype (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' @@ -549,7 +550,7 @@ let detype_fix detype avoid env sigma (vn,_ as nvn) (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> - let id = next_name_away na avoid in + let id = next_name_away na.binder_name avoid in (Id.Set.add id avoid, add_name (Name id) None ty env, id::l)) (avoid, env, []) names tys in let n = Array.length tys in @@ -565,7 +566,7 @@ let detype_cofix detype avoid env sigma n (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> - let id = next_name_away na avoid in + let id = next_name_away na.binder_name avoid in (Id.Set.add id avoid, add_name (Name id) None ty env, id::l)) (avoid, env, []) names tys in let ntys = Array.length tys in @@ -597,6 +598,7 @@ let detype_universe sigma u = Univ.Universe.map fn u let detype_sort sigma = function + | SProp -> GSProp | Prop -> GProp | Set -> GSet | Type u -> @@ -702,9 +704,9 @@ and detype_r d flags avoid env sigma t = match decl with | LocalDef _ -> true | LocalAssum (id,_) -> - try let n = List.index Name.equal (Name id) (fst env) in + try let n = List.index Name.equal (Name id.binder_name) (fst env) in isRelN sigma n c - with Not_found -> isVarId sigma id c + with Not_found -> isVarId sigma id.binder_name c in let id,l = try @@ -765,11 +767,11 @@ and detype_eqn d (lax,isgoal as flags) avoid env sigma constr construct_nargs br [DAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], detype d flags avoid env sigma b) | Lambda (x,t,b), false::l -> - let pat,new_avoid,new_env,new_ids = make_pat x avoid env b None t ids in + let pat,new_avoid,new_env,new_ids = make_pat x.binder_name avoid env b None t ids in buildrec new_ids (pat::patlist) new_avoid new_env l b | LetIn (x,b,t,b'), true::l -> - let pat,new_avoid,new_env,new_ids = make_pat x avoid env b' (Some b) t ids in + let pat,new_avoid,new_env,new_ids = make_pat x.binder_name avoid env b' (Some b) t ids in buildrec new_ids (pat::patlist) new_avoid new_env l b' | Cast (c,_,_), l -> (* Oui, il y a parfois des cast *) @@ -791,7 +793,7 @@ and detype_eqn d (lax,isgoal as flags) avoid env sigma constr construct_nargs br in buildrec Id.Set.empty [] avoid env construct_nargs branch -and detype_binder d (lax,isgoal as flags) bk avoid env sigma na body ty c = +and detype_binder d (lax,isgoal as flags) bk avoid env sigma {binder_name=na} body ty c = let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (fst env,c) in let na',avoid' = match bk with | BLetIn -> compute_displayed_let_name_in sigma flag avoid na c @@ -827,7 +829,7 @@ let detype_rel_context d ?(lax=false) where avoid env sigma sign = (RenamingElsewhereFor (fst env,c)) avoid na c in let b = match decl with | LocalAssum _ -> None - | LocalDef (_,b,_) -> Some b + | LocalDef (_,b,_) -> Some b in let b' = Option.map (detype d (lax,false) avoid env sigma) b in let t' = detype d (lax,false) avoid env sigma t in @@ -864,7 +866,7 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = (* spiwack: I'm not sure it is the right thing to do, but I'm computing the detyping environment like [Printer.pr_constr_under_binders_env] does. *) - let assums = List.map (fun id -> LocalAssum (Name id,(* dummy *) mkProp)) b in + let assums = List.map (fun id -> LocalAssum (make_annot (Name id) Sorts.Relevant,(* dummy *) mkProp)) b in let env = push_rel_context assums env in DAst.get (detype Now ?lax isgoal avoid env sigma c) (* if [id] is bound to a [closed_glob_constr]. *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index bb163ddaee..28a97bb91a 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -15,6 +15,7 @@ open Constr open Termops open Environ open EConstr +open Context open Vars open Reduction open Reductionops @@ -24,14 +25,28 @@ open Evardefine open Evarsolve open Evd open Pretype_errors -open Context.Named.Declaration module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -type unify_fun = TransparentState.t -> +type unify_flags = Evarsolve.unify_flags + +type unify_fun = unify_flags -> env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> Evarsolve.unification_result +let default_transparent_state env = TransparentState.full +(* Conv_oracle.get_transp_state (Environ.oracle env) *) + +let default_flags_of ?(subterm_ts=TransparentState.empty) ts = + { modulo_betaiota = true; + open_ts = ts; closed_ts = ts; subterm_ts; + frozen_evars = Evar.Set.empty; with_cs = true; + allow_K_at_toplevel = true } + +let default_flags env = + let ts = default_transparent_state env in + default_flags_of ts + let debug_unification = ref (false) let () = Goptions.(declare_bool_option { optdepr = false; @@ -42,6 +57,16 @@ let () = Goptions.(declare_bool_option { optwrite = (fun a -> debug_unification:=a); }) +let debug_ho_unification = ref (false) +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = + "Print higher-order unification debug information"; + optkey = ["Debug";"HO";"Unification"]; + optread = (fun () -> !debug_ho_unification); + optwrite = (fun a -> debug_ho_unification:=a); +}) + (*******************************************) (* Functions to deal with impossible cases *) (*******************************************) @@ -54,8 +79,8 @@ let impossible_default_case env = let coq_unit_judge = let open Environ in let make_judge c t = make_judge (EConstr.of_constr c) (EConstr.of_constr t) in - let na1 = Name (Id.of_string "A") in - let na2 = Name (Id.of_string "H") in + let na1 = make_annot (Name (Id.of_string "A")) Sorts.Relevant in + let na2 = make_annot (Name (Id.of_string "H")) Sorts.Relevant in fun env -> match impossible_default_case env with | Some (id, type_of_id, ctx) -> @@ -63,7 +88,7 @@ let coq_unit_judge = | None -> (* In case the constants id/ID are not defined *) Environ.make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) - (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), + (mkProd (na1,mkProp,mkArrow (mkRel 1) Sorts.Relevant (mkRel 2))), Univ.ContextSet.empty let unfold_projection env evd ts p c = @@ -101,42 +126,106 @@ type flex_kind_of_term = | MaybeFlexible of EConstr.t (* reducible but not necessarily reduced *) | Flexible of EConstr.existential -let flex_kind_of_term ts env evd c sk = +let is_frozen flags (evk, _) = Evar.Set.mem evk flags.frozen_evars + +let flex_kind_of_term flags env evd c sk = match EConstr.kind evd c with | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> - Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env evd c) - | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible c - | Evar ev -> Flexible ev + Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term flags.open_ts env evd c) + | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> + if flags.modulo_betaiota then MaybeFlexible c + else Rigid + | Evar ev -> + if is_frozen flags ev then Rigid + else Flexible ev | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ | Int _ -> Rigid | Meta _ -> Rigid | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) | Cast _ | App _ | Case _ -> assert false -let apprec_nohdbeta ts env evd c = +let apprec_nohdbeta flags env evd c = let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in - if Stack.not_purely_applicative sk + if flags.modulo_betaiota && Stack.not_purely_applicative sk then Stack.zip evd (fst (whd_betaiota_deltazeta_for_iota_state - ts env evd Cst_stack.empty appr)) + flags.open_ts env evd Cst_stack.empty appr)) else c let position_problem l2r = function | CONV -> None | CUMUL -> Some l2r -let occur_rigidly (evk,_ as ev) evd t = +(* [occur_rigidly ev evd t] tests if the evar ev occurs in a rigid + context in t. Precondition: t has a rigid head and is not reducible. + + That function is an under approximation of occur-check, it can return + false even if the occur-check would succeed on the normal form. This + means we might postpone unsolvable constraints which will ultimately + result in an occur-check after reductions. If it returns true, we + know that the occur-check would also return true on the normal form. + + [t] is assumed to have a rigid head, which can + appear under a elimination context (e.g. application, match or projection). + + In the inner recursive function, the result indicates if the term is + rigid (irreducible), normal (succession of constructors) or + potentially reducible. For applications, this means than an + occurrence of the evar in arguments should be looked at to find an + occur-check if the head is rigid or normal. For inductive + eliminations, only an occurrence in a rigid context of the + discriminee counts as a rigid occurrence overall, not a normal + occurrence which might disappear after reduction. *) + +type result = Rigid of bool | Normal of bool | Reducible + +let rigid_normal_occ = function Rigid b -> b | Normal b -> b | _ -> false + +let occur_rigidly flags env evd (evk,_) t = let rec aux t = match EConstr.kind evd t with - | App (f, c) -> if aux f then Array.exists aux c else false - | Construct _ | Ind _ | Sort _ | Meta _ | Fix _ | CoFix _ | Int _ -> true - | Proj (p, c) -> not (aux c) - | Evar (evk',_) -> if Evar.equal evk evk' then raise Occur else false + | App (f, c) -> + (match aux f with + | Rigid b -> Rigid (b || Array.exists (fun x -> rigid_normal_occ (aux x)) c) + | Normal b -> Normal (b || Array.exists (fun x -> rigid_normal_occ (aux x)) c) + | Reducible -> Reducible) + | Construct _ -> Normal false + | Ind _ | Sort _ -> Rigid false + | Proj (p, c) -> + let cst = Projection.constant p in + let rigid = not (TransparentState.is_transparent_constant flags.open_ts cst) in + if rigid then aux c + else (* if the evar appears rigidly in c then this elimination + cannot reduce and we have a rigid occurrence, otherwise + we don't know. *) + (match aux c with + | Rigid _ as res -> res + | Normal b -> Reducible + | Reducible -> Reducible) + | Evar (evk',l as ev) -> + if Evar.equal evk evk' then Rigid true + else if is_frozen flags ev then + Rigid (Array.exists (fun x -> rigid_normal_occ (aux x)) l) + else Reducible | Cast (p, _, _) -> aux p - | Lambda _ | LetIn _ -> false - | Const _ -> false - | Prod (_, b, t) -> ignore(aux b || aux t); true - | Rel _ | Var _ -> false - | Case (_,_,c,_) -> if eq_constr evd (mkEvar ev) c then raise Occur else false - in try ignore(aux t); false with Occur -> true + | Lambda (na, t, b) -> aux b + | LetIn (na, _, _, b) -> aux b + | Const (c,_) -> + if TransparentState.is_transparent_constant flags.open_ts c then Reducible + else Rigid false + | Prod (_, b, t) -> + let b' = aux b and t' = aux t in + if rigid_normal_occ b' || rigid_normal_occ t' then Rigid true + else Reducible + | Rel _ | Var _ -> Reducible + | Case (_,_,c,_) -> + (match aux c with + | Rigid b -> Rigid b + | _ -> Reducible) + | Meta _ | Fix _ | CoFix _ | Int _ -> Reducible + in + match aux t with + | Rigid b -> b + | Normal b -> b + | Reducible -> false (* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose the problem (t1 stack1) = (t2 stack2) into a problem @@ -163,8 +252,8 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let canon_s,sk2_effective = try match EConstr.kind sigma t2 with - Prod (_,a,b) -> (* assert (l2=[]); *) - let _, a, b = destProd sigma t2 in + Prod (_,a,b) -> (* assert (l2=[]); *) + let _, a, b = destProd sigma t2 in if noccurn sigma 1 b then lookup_canonical_conversion (proji, Prod_cs), (Stack.append_app [|a;pop b|] Stack.empty) @@ -365,7 +454,21 @@ let compare_cumulative_instances evd variances u u' = Success evd | Inr p -> UnifFailure (evd, UnifUnivInconsistency p) -let rec evar_conv_x ts env evd pbty term1 term2 = +let conv_fun f flags on_types = + let typefn env evd pbty term1 term2 = + let flags = { (default_flags env) with + with_cs = flags.with_cs; + frozen_evars = flags.frozen_evars } + in f flags env evd pbty term1 term2 + in + let termfn env evd pbty term1 term2 = + f flags env evd pbty term1 term2 + in + match on_types with + | TypeUnification -> typefn + | TermUnification -> termfn + +let rec evar_conv_x flags env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in let term2 = whd_head_evar evd term2 in (* Maybe convertible but since reducing can erase evars which [evar_apprec] @@ -374,7 +477,7 @@ let rec evar_conv_x ts env evd pbty term1 term2 = let ground_test = if is_ground_term evd term1 && is_ground_term evd term2 then ( let e = - match infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts) env evd term1 term2 with + match infer_conv ~catch_incon:false ~pb:pbty ~ts:flags.closed_ts env evd term1 term2 with | Some evd -> Success evd | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)) | exception Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) @@ -389,30 +492,30 @@ let rec evar_conv_x ts env evd pbty term1 term2 = | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) - let term1 = apprec_nohdbeta (fst ts) env evd term1 in - let term2 = apprec_nohdbeta (fst ts) env evd term2 in + let term1 = apprec_nohdbeta flags env evd term1 in + let term2 = apprec_nohdbeta flags env evd term2 in let default () = - evar_eqappr_x ts env evd pbty + evar_eqappr_x flags env evd pbty (whd_nored_state evd (term1,Stack.empty), Cst_stack.empty) (whd_nored_state evd (term2,Stack.empty), Cst_stack.empty) in begin match EConstr.kind evd term1, EConstr.kind evd term2 with - | Evar ev, _ when Evd.is_undefined evd (fst ev) -> - (match solve_simple_eqn (evar_conv_x ts) env evd - (position_problem true pbty,ev, term2) with + | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> + (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd + (position_problem true pbty,ev,term2) with | UnifFailure (_,OccurCheck _) -> (* Eta-expansion might apply *) default () | x -> x) - | _, Evar ev when Evd.is_undefined evd (fst ev) -> - (match solve_simple_eqn (evar_conv_x ts) env evd - (position_problem false pbty,ev, term1) with + | _, Evar ev when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> + (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd + (position_problem false pbty,ev,term1) with | UnifFailure (_, OccurCheck _) -> (* Eta-expansion might apply *) default () | x -> x) | _ -> default () end -and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty +and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) = let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) @@ -423,18 +526,18 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Some l1' -> (* Miller-Pfenning's patterns unification *) let t2 = tM in let t2 = solve_pattern_eqn env evd l1' t2 in - solve_simple_eqn (evar_conv_x ts) env evd + solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem on_left pbty,ev,t2) in let consume_stack on_left (termF,skF) (termO,skO) evd = let switch f a b = if on_left then f a b else f b a in let not_only_app = Stack.not_purely_applicative skO in - match switch (ise_stack2 not_only_app env evd (evar_conv_x ts)) skF skO with + match switch (ise_stack2 not_only_app env evd (evar_conv_x flags)) skF skO with |Some (l,r), Success i' when on_left && (not_only_app || List.is_empty l) -> - switch (evar_conv_x ts env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) + switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) |Some (r,l), Success i' when not on_left && (not_only_app || List.is_empty l) -> - switch (evar_conv_x ts env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) - |None, Success i' -> switch (evar_conv_x ts env i' pbty) termF termO + switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) + |None, Success i' -> switch (evar_conv_x flags env i' pbty) termF termO |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (evd,NotSameArgSize) in let eta env evd onleft sk term sk' term' = @@ -443,12 +546,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let c = nf_evar evd c1 in let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state - (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in + flags.open_ts env' evd Cst_stack.empty (c'1, Stack.empty) in let out2 = whd_nored_state evd (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in - if onleft then evar_eqappr_x ts env' evd CONV out1 out2 - else evar_eqappr_x ts env' evd CONV out2 out1 + if onleft then evar_eqappr_x flags env' evd CONV out1 out2 + else evar_eqappr_x flags env' evd CONV out2 out1 in let rigids env evd sk term sk' term' = let check_strict evd u u' = @@ -504,12 +607,16 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_and evd [(fun i -> try compare_heads i with Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk sk')] + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk sk')] in - let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = + let consume on_left (_, skF as apprF) (_,skM as apprM) i = + if not (Stack.is_empty skF && Stack.is_empty skM) then + consume_stack on_left apprF apprM i + else quick_fail i + in + let miller on_left ev (termF,skF as apprF) (termM, skM as apprM) i = let switch f a b = if on_left then f a b else f b a in let not_only_app = Stack.not_purely_applicative skM in - let f1 i = match Stack.list_of_app_stack skF with | None -> quick_fail evd | Some lF -> @@ -518,17 +625,17 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun () -> if not_only_app then (* Postpone the use of an heuristic *) switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) (Stack.zip evd apprF) tM else quick_fail i) - ev lF tM i - and consume (termF,skF as apprF) (termM,skM as apprM) i = - if not (Stack.is_empty skF && Stack.is_empty skM) then - consume_stack on_left apprF apprM i - else quick_fail i - and delta i = - switch (evar_eqappr_x ts env i pbty) (apprF,cstsF) - (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i cstsM (vM,skM)) + ev lF tM i + in + let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = + let switch f a b = if on_left then f a b else f b a in + let delta i = + switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i cstsM (vM,skM)) in - let default i = ise_try i [f1; consume apprF apprM; delta] + let default i = ise_try i [miller on_left ev apprF apprM; + consume on_left apprF apprM; + delta] in match EConstr.kind evd termM with | Proj (p, c) when not (Stack.is_empty skF) -> @@ -543,13 +650,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty try let termM' = Retyping.expand_projection env evd p c [] in let apprM', cstsM' = - whd_betaiota_deltazeta_for_iota_state - (fst ts) env evd cstsM (termM',skM) + whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd cstsM (termM',skM) in let delta' i = - switch (evar_eqappr_x ts env i pbty) (apprF,cstsF) (apprM',cstsM') + switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) (apprM',cstsM') in - fun i -> ise_try i [f1; consume apprF apprM'; delta'] + fun i -> ise_try i [miller on_left ev apprF apprM'; + consume on_left apprF apprM'; delta'] with Retyping.RetypeError _ -> (* Happens thanks to w_unify building ill-typed terms *) default @@ -563,7 +670,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty match EConstr.kind evd termR with | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR -> eta env evd false skR termR skF termF - | Construct u -> eta_constructor ts env evd skR u skF termF + | Construct u -> eta_constructor flags env evd skR u skF termF | _ -> UnifFailure (evd,NotSameHead) in match Stack.list_of_app_stack skF with @@ -571,12 +678,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_try evd [consume_stack on_left apprF apprR; eta] | Some lF -> let tR = Stack.zip evd apprR in - miller_pfenning on_left - (fun () -> - ise_try evd - [eta;(* Postpone the use of an heuristic *) - (fun i -> - if not (occur_rigidly ev i tR) then + miller_pfenning on_left + (fun () -> + ise_try evd + [eta;(* Postpone the use of an heuristic *) + (fun i -> + if not (occur_rigidly flags env i ev tR) then let i,tF = if isRel i tR || isVar i tR then (* Optimization so as to generate candidates *) @@ -585,95 +692,111 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else i,Stack.zip evd apprF in switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) - tF tR - else + tF tR + else UnifFailure (evd,OccurCheck (fst ev,tR)))]) - ev lF tR evd + ev lF tR evd + in + let first_order env i t1 t2 sk1 sk2 = + (* Try first-order unification *) + match ise_stack2 false env i (evar_conv_x flags) sk1 sk2 with + | None, Success i' -> + (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) + (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) + let ev1' = whd_evar i' t1 in + if isEvar i' ev1' then + solve_simple_eqn (conv_fun evar_conv_x) flags env i' + (position_problem true pbty,destEvar i' ev1',term2) + else + evar_eqappr_x flags env evd pbty + ((ev1', sk1), csts1) ((term2, sk2), csts2) + | Some (r,[]), Success i' -> + (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) + (* we now unify r[?ev1] and ?ev2 *) + let ev2' = whd_evar i' t2 in + if isEvar i' ev2' then + solve_simple_eqn (conv_fun evar_conv_x) flags env i' + (position_problem false pbty,destEvar i' ev2',Stack.zip i' (term1,r)) + else + evar_eqappr_x flags env evd pbty + ((ev2', sk1), csts1) ((term2, sk2), csts2) + | Some ([],r), Success i' -> + (* Symmetrically *) + (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) + (* we now unify ?ev1 and r[?ev2] *) + let ev1' = whd_evar i' t1 in + if isEvar i' ev1' then + solve_simple_eqn (conv_fun evar_conv_x) flags env i' + (position_problem true pbty,destEvar i' ev1',Stack.zip i' (term2,r)) + else evar_eqappr_x flags env evd pbty + ((ev1', sk1), csts1) ((term2, sk2), csts2) + | None, (UnifFailure _ as x) -> + (* sk1 and sk2 have no common outer part *) + if Stack.not_purely_applicative sk2 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid true (destEvar evd t1) appr1 appr2 + else + if Stack.not_purely_applicative sk1 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid false (destEvar evd t2) appr2 appr1 + else + (* We could instead try Miller unification, then + postpone to see if other equations help, as in: + [Check fun a b : unit => (eqᵣefl : _ a = _ a b)] *) + x + | Some _, Success _ -> + (* sk1 and sk2 have a common outer part *) + if Stack.not_purely_applicative sk2 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid true (destEvar evd t1) appr1 appr2 + else + if Stack.not_purely_applicative sk1 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid false (destEvar evd t2) appr2 appr1 + else + (* We could instead try Miller unification, then + postpone to see if other equations help, as in: + [Check fun a b c : unit => (eqᵣefl : _ a b = _ c a b)] *) + UnifFailure (i,NotSameArgSize) + | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.") in let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then let open Pp in Feedback.msg_notice (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in - match (flex_kind_of_term (fst ts) env evd term1 sk1, - flex_kind_of_term (fst ts) env evd term2 sk2) with - | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) -> + match (flex_kind_of_term flags env evd term1 sk1, + flex_kind_of_term flags env evd term2 sk2) with + | Flexible (sp1,al1), Flexible (sp2,al2) -> (* sk1[?ev1] =? sk2[?ev2] *) - let f1 i = - (* Try first-order unification *) - match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with - | None, Success i' -> - (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) - (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) - let ev1' = whd_evar i' (mkEvar ev1) in - if isEvar i' ev1' then - solve_simple_eqn (evar_conv_x ts) env i' - (position_problem true pbty,destEvar i' ev1', term2) - else - evar_eqappr_x ts env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) - | Some (r,[]), Success i' -> - (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) - (* we now unify r[?ev1] and ?ev2 *) - let ev2' = whd_evar i' (mkEvar ev2) in - if isEvar i' ev2' then - solve_simple_eqn (evar_conv_x ts) env i' - (position_problem false pbty,destEvar i' ev2',Stack.zip evd (term1,r)) - else - evar_eqappr_x ts env evd pbty - ((ev2', sk1), csts1) ((term2, sk2), csts2) - | Some ([],r), Success i' -> - (* Symmetrically *) - (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) - (* we now unify ?ev1 and r[?ev2] *) - let ev1' = whd_evar i' (mkEvar ev1) in - if isEvar i' ev1' then - solve_simple_eqn (evar_conv_x ts) env i' - (position_problem true pbty,destEvar i' ev1',Stack.zip evd (term2,r)) - else evar_eqappr_x ts env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) - | None, (UnifFailure _ as x) -> - (* sk1 and sk2 have no common outer part *) - if Stack.not_purely_applicative sk2 then - (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) - flex_rigid true ev1 appr1 appr2 - else - if Stack.not_purely_applicative sk1 then - (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) - flex_rigid false ev2 appr2 appr1 - else - (* We could instead try Miller unification, then - postpone to see if other equations help, as in: - [Check fun a b : unit => (eqᵣefl : _ a = _ a b)] *) - x - | Some _, Success _ -> - (* sk1 and sk2 have a common outer part *) - if Stack.not_purely_applicative sk2 then - (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) - flex_rigid true ev1 appr1 appr2 - else - if Stack.not_purely_applicative sk1 then - (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) - flex_rigid false ev2 appr2 appr1 - else - (* We could instead try Miller unification, then - postpone to see if other equations help, as in: - [Check fun a b c : unit => (eqᵣefl : _ a b = _ c a b)] *) - UnifFailure (i,NotSameArgSize) - | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.") - + let f1 i = first_order env i term1 term2 sk1 sk2 and f2 i = if Evar.equal sp1 sp2 then - match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with + match ise_stack2 false env i (evar_conv_x flags) sk1 sk2 with |None, Success i' -> - Success (solve_refl (fun env i pbty a1 a2 -> - is_success (evar_conv_x ts env i pbty a1 a2)) + Success (solve_refl (fun flags p env i pbty a1 a2 -> + let flags = + match p with + | TypeUnification -> default_flags env + | TermUnification -> flags + in + is_success (evar_conv_x flags env i pbty a1 a2)) flags env i' (position_problem true pbty) sp1 al1 al2) |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (i,NotSameArgSize) else UnifFailure (i,NotSameHead) - in - ise_try evd [f1; f2] + and f3 i = miller true (sp1,al1) appr1 appr2 i + and f4 i = miller false (sp2,al2) appr2 appr1 i + and f5 i = + (* We ensure failure of consuming the stacks does not + propagate an error about unification of the stacks while + the heads themselves cannot be unified, so we return + NotSameHead. *) + match consume true appr1 appr2 i with + | Success _ as x -> x + | UnifFailure _ -> quick_fail i + in + ise_try evd [f1; f2; f3; f4; f5] | Flexible ev1, MaybeFlexible v2 -> flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 @@ -687,31 +810,31 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let f1 i = (* FO *) ise_and i [(fun i -> ise_try i - [(fun i -> evar_conv_x ts env i CUMUL t1 t2); - (fun i -> evar_conv_x ts env i CUMUL t2 t1)]); - (fun i -> evar_conv_x ts env i CONV b1 b2); + [(fun i -> evar_conv_x flags env i CUMUL t1 t2); + (fun i -> evar_conv_x flags env i CUMUL t2 t1)]); + (fun i -> evar_conv_x flags env i CONV b1 b2); (fun i -> let b = nf_evar i b1 in let t = nf_evar i t1 in - let na = Nameops.Name.pick na1 na2 in - evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] - and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2) - in evar_eqappr_x ts env i pbty out1 out2 + let na = Nameops.Name.pick_annot na1 na2 in + evar_conv_x flags (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] + and f2 i = + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] | Proj (p, c), Proj (p', c') when Projection.repr_equal p p' -> let f1 i = ise_and i - [(fun i -> evar_conv_x ts env i CONV c c'); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + [(fun i -> evar_conv_x flags env i CONV c c'); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2) - in evar_eqappr_x ts env i pbty out1 out2 + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] @@ -723,7 +846,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in (match res with | Some (f1,args1) -> - evar_eqappr_x ts env evd pbty ((f1,Stack.append_app args1 sk1),csts1) + evar_eqappr_x flags env evd pbty ((f1,Stack.append_app args1 sk1),csts1) (appr2,csts2) | None -> UnifFailure (evd,NotSameHead)) @@ -734,7 +857,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in (match res with | Some (f2,args2) -> - evar_eqappr_x ts env evd pbty (appr1,csts1) ((f2,Stack.append_app args2 sk2),csts2) + evar_eqappr_x flags env evd pbty (appr1,csts1) ((f2,Stack.append_app args2 sk2),csts2) | None -> UnifFailure (evd,NotSameHead)) | _, _ -> @@ -751,13 +874,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty try Success (Evd.add_universe_constraints i univs) with UniversesDiffer -> UnifFailure (i,NotSameHead) | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] | None -> UnifFailure (i,NotSameHead) and f2 i = (try - if not (snd ts) then raise Not_found - else conv_record ts env i + if not flags.with_cs then raise Not_found + else conv_record flags env i (try check_conv_record env i appr1 appr2 with Not_found -> check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) @@ -775,7 +898,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed (fst (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i Cst_stack.empty (subst1 b c, args))) + flags.open_ts env i Cst_stack.empty (subst1 b c, args))) | Fix _ -> true (* Partially applied fix can be the result of a whd call *) | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args | Case _ | App _| Cast _ -> assert false in @@ -783,20 +906,20 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed (fst (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i Cst_stack.empty (v2, applicative_stack))) in + flags.open_ts env i Cst_stack.empty (v2, applicative_stack))) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in if (EConstr.isLambda i term1 || rhs_is_already_stuck) && (not (Stack.not_purely_applicative sk1)) then - evar_eqappr_x ~rhs_is_already_stuck ts env i pbty + evar_eqappr_x ~rhs_is_already_stuck flags env i pbty (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) + flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) (appr2,csts2) else - evar_eqappr_x ts env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty (appr1,csts1) (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f1; f2; f3] end @@ -804,13 +927,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Rigid, Rigid when EConstr.isLambda evd term1 && EConstr.isLambda evd term2 -> let (na1,c1,c'1) = EConstr.destLambda evd term1 in let (na2,c2,c'2) = EConstr.destLambda evd term2 in - assert app_empty; ise_and evd - [(fun i -> evar_conv_x ts env i CONV c1 c2); + [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in - let na = Nameops.Name.pick na1 na2 in - evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)] + let na = Nameops.Name.pick_annot na1 na2 in + evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2); + (* When in modulo_betaiota = false case, lambda's are not reduced *) + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 @@ -818,13 +942,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | MaybeFlexible v1, Rigid -> let f3 i = (try - if not (snd ts) then raise Not_found - else conv_record ts env i (check_conv_record env i appr1 appr2) + if not flags.with_cs then raise Not_found + else conv_record flags env i (check_conv_record env i appr1 appr2) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x ts env i pbty + evar_eqappr_x flags env i pbty (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) + flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) (appr2,csts2) in ise_try evd [f3; f4] @@ -832,13 +956,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Rigid, MaybeFlexible v2 -> let f3 i = (try - if not (snd ts) then raise Not_found - else conv_record ts env i (check_conv_record env i appr2 appr1) + if not flags.with_cs then raise Not_found + else conv_record flags env i (check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x ts env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty (appr1,csts1) (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f3; f4] @@ -865,22 +989,22 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty UnifFailure (evd,UnifUnivInconsistency p) | e when CErrors.noncritical e -> UnifFailure (evd,NotSameHead)) - | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> + | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> ise_and evd - [(fun i -> evar_conv_x ts env i CONV c1 c2); + [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in - let na = Nameops.Name.pick n1 n2 in - evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] + let na = Nameops.Name.pick_annot n1 n2 in + evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> if Int.equal x1 x2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 + exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 else UnifFailure (evd,NotSameHead) | Var var1, Var var2 -> if Id.equal var1 var2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 + exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 else UnifFailure (evd,NotSameHead) | Const _, Const _ @@ -889,49 +1013,59 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Int _, Int _ -> rigids env evd sk1 term1 sk2 term2 + | Evar (sp1,al1), Evar (sp2,al2) -> (* Frozen evars *) + if Evar.equal sp1 sp2 then + match ise_stack2 false env evd (evar_conv_x flags) sk1 sk2 with + |None, Success i' -> + ise_array2 i' (fun i' -> evar_conv_x flags env i' CONV) al1 al2 + |_, (UnifFailure _ as x) -> x + |Some _, _ -> UnifFailure (evd,NotSameArgSize) + else UnifFailure (evd,NotSameHead) + | Construct u, _ -> - eta_constructor ts env evd sk1 u sk2 term2 + eta_constructor flags env evd sk1 u sk2 term2 | _, Construct u -> - eta_constructor ts env evd sk2 u sk1 term1 + eta_constructor flags env evd sk2 u sk1 term1 - | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) + | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then ise_and evd [ - (fun i -> ise_array2 i (fun i' -> evar_conv_x ts env i' CONV) tys1 tys2); - (fun i -> ise_array2 i (fun i' -> evar_conv_x ts (push_rec_types recdef1 env) i' CONV) bds1 bds2); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + (fun i -> ise_array2 i (fun i' -> evar_conv_x flags env i' CONV) tys1 tys2); + (fun i -> ise_array2 i (fun i' -> evar_conv_x flags (push_rec_types recdef1 env) i' CONV) bds1 bds2); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] else UnifFailure (evd, NotSameHead) - | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> + | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> if Int.equal i1 i2 then ise_and evd [(fun i -> ise_array2 i - (fun i -> evar_conv_x ts env i CONV) tys1 tys2); + (fun i -> evar_conv_x flags env i CONV) tys1 tys2); (fun i -> ise_array2 i - (fun i -> evar_conv_x ts (push_rec_types recdef1 env) i CONV) + (fun i -> evar_conv_x flags (push_rec_types recdef1 env) i CONV) bds1 bds2); (fun i -> exact_ise_stack2 env i - (evar_conv_x ts) sk1 sk2)] + (evar_conv_x flags) sk1 sk2)] else UnifFailure (evd,NotSameHead) | (Meta _, _) | (_, Meta _) -> - begin match ise_stack2 true env evd (evar_conv_x ts) sk1 sk2 with + begin match ise_stack2 true env evd (evar_conv_x flags) sk1 sk2 with |_, (UnifFailure _ as x) -> x - |None, Success i' -> evar_conv_x ts env i' CONV term1 term2 - |Some (sk1',sk2'), Success i' -> evar_conv_x ts env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) + |None, Success i' -> evar_conv_x flags env i' CONV term1 term2 + |Some (sk1',sk2'), Success i' -> evar_conv_x flags env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) end - | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _), _ -> + | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Evar _ | Lambda _), _ -> UnifFailure (evd,NotSameHead) - - | (App _ | Cast _ | Case _ | Proj _), _ -> assert false - | (LetIn _| Evar _), _ -> assert false - | (Lambda _), _ -> assert false - + | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Evar _ | Lambda _) -> + UnifFailure (evd,NotSameHead) + | Case _, _ -> UnifFailure (evd,NotSameHead) + | Proj _, _ -> UnifFailure (evd,NotSameHead) + | (App _ | Cast _), _ -> assert false + | LetIn _, _ -> assert false end -and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = +and conv_record flags env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = (* Tries to unify the states (proji params1 c1 | sk1) = (proji params2 (c (?xs:bs)) | sk2) @@ -962,7 +1096,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) (fun (i,ks,m,test) b -> if match n with Some n -> Int.equal m n | None -> false then let ty = Retyping.get_type_of env i t2 in - let test i = evar_conv_x trs env i CUMUL ty (substl ks b) in + let test i = evar_conv_x flags env i CUMUL ty (substl ks b) in (i,t2::ks, m-1, test) else let dloc = Loc.tag Evar_kinds.InternalHole in @@ -974,20 +1108,20 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) ise_and evd' [(fun i -> exact_ise_stack2 env i - (fun env' i' cpb x1 x -> evar_conv_x trs env' i' cpb x1 (substl ks x)) + (fun env' i' cpb x1 x -> evar_conv_x flags env' i' cpb x1 (substl ks x)) params1 params); (fun i -> exact_ise_stack2 env i - (fun env' i' cpb u1 u -> evar_conv_x trs env' i' cpb u1 (substl ks u)) + (fun env' i' cpb u1 u -> evar_conv_x flags env' i' cpb u1 (substl ks u)) us2 us); - (fun i -> evar_conv_x trs env i CONV c1 app); - (fun i -> exact_ise_stack2 env i (evar_conv_x trs) sk1 sk2); + (fun i -> evar_conv_x flags env i CONV c1 app); + (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2); test; - (fun i -> evar_conv_x trs env i CONV h2 + (fun i -> evar_conv_x flags env i CONV h2 (fst (decompose_app_vect i (substl ks h))))] else UnifFailure(evd,(*dummy*)NotSameHead) -and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = +and eta_constructor flags env evd sk1 ((ind, i), u) sk2 term2 = let open Declarations in let mib = lookup_mind (fst ind) env in match get_projections env ind with @@ -999,15 +1133,17 @@ and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = let term = Stack.zip evd (term2,sk2) in List.map (fun p -> EConstr.mkProj (Projection.make p false, term)) (Array.to_list projs) in - exact_ise_stack2 env evd (evar_conv_x (fst ts, false)) l1' + exact_ise_stack2 env evd (evar_conv_x { flags with with_cs = false}) l1' (Stack.append_app_list l2' Stack.empty) - with + with | Invalid_argument _ -> (* Stack.tail: partially applied constructor *) UnifFailure(evd,NotSameHead)) | _ -> UnifFailure (evd,NotSameHead) -let evar_conv_x ts = evar_conv_x (ts, true) +let evar_conv_x flags = evar_conv_x flags + +let evar_unify = conv_fun evar_conv_x (* Profiling *) let evar_conv_x = @@ -1018,25 +1154,26 @@ let evar_conv_x = let evar_conv_hook_get, evar_conv_hook_set = Hook.make ~default:evar_conv_x () -let evar_conv_x ts = Hook.get evar_conv_hook_get ts +let evar_conv_x flags = Hook.get evar_conv_hook_get flags let set_evar_conv f = Hook.set evar_conv_hook_set f (* We assume here |l1| <= |l2| *) -let first_order_unification ts env evd (ev1,l1) (term2,l2) = +let first_order_unification flags env evd (ev1,l1) (term2,l2) = let (deb2,rest2) = Array.chop (Array.length l2-Array.length l1) l2 in ise_and evd (* First compare extra args for better failure message *) - [(fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) rest2 l1); + [(fun i -> ise_array2 i (fun i -> evar_conv_x flags env i CONV) rest2 l1); (fun i -> (* Then instantiate evar unless already done by unifying args *) let t2 = mkApp(term2,deb2) in if is_defined i (fst ev1) then - evar_conv_x ts env i CONV t2 (mkEvar ev1) + evar_conv_x flags env i CONV t2 (mkEvar ev1) else - solve_simple_eqn ~choose:true (evar_conv_x ts) env i (None,ev1,t2))] + solve_simple_eqn ~choose:true ~imitate_defs:false + evar_unify flags env i (None,ev1,t2))] let choose_less_dependent_instance evk evd term args = let evi = Evd.find_undefined evd evk in @@ -1046,30 +1183,57 @@ let choose_less_dependent_instance evk evd term args = | [] -> None | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd) -let apply_on_subterm env evdref f c t = +type occurrence_match_test = + env -> evar_map -> constr -> + env -> evar_map -> int -> constr -> constr -> bool * evar_map + +type occurrence_selection = + | AtOccurrences of Locus.occurrences + | Unspecified of Abstraction.abstraction + +type occurrences_selection = + occurrence_match_test * occurrence_selection list + +let default_occurrence_selection = Unspecified Abstraction.Imitate + +let default_occurrence_test ~frozen_evars ts _ origsigma _ env sigma _ c pat = + let flags = { (default_flags_of ~subterm_ts:ts ts) with frozen_evars } in + match evar_conv_x flags env sigma CONV c pat with + | Success sigma -> true, sigma + | UnifFailure _ -> false, sigma + +let default_occurrences_selection ?(frozen_evars=Evar.Set.empty) ts n = + (default_occurrence_test ~frozen_evars ts, + List.init n (fun _ -> default_occurrence_selection)) + +let apply_on_subterm env evd fixedref f test c t = + let test = test env evd c in + let prc env evd = Termops.Internal.print_constr_env env evd in + let evdref = ref evd in let rec applyrec (env,(k,c) as acc) t = - (* By using eq_constr, we make an approximation, for instance, we *) - (* could also be interested in finding a term u convertible to t *) - (* such that c occurs in u *) - let eq_constr c1 c2 = match EConstr.eq_constr_universes env !evdref c1 c2 with - | None -> false - | Some cstr -> - try ignore (Evd.add_universe_constraints !evdref cstr); true - with UniversesDiffer -> false - in - if eq_constr c t then f k - else + if Evar.Set.exists (fun fixed -> occur_evar !evdref fixed t) !fixedref then match EConstr.kind !evdref t with - | Evar (evk,args) -> - let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in - let g decl a = if is_local_assum decl then applyrec acc a else a in - mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args))) - | _ -> - map_constr_with_binders_left_to_right !evdref - (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) - applyrec acc t + | Evar (ev, args) when Evar.Set.mem ev !fixedref -> t + | _ -> map_constr_with_binders_left_to_right !evdref + (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) + applyrec acc t + else + (if !debug_ho_unification then + Feedback.msg_debug Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t); + let b, evd = + try test env !evdref k c t + with e when CErrors.noncritical e -> assert false in + if b then (if !debug_ho_unification then Feedback.msg_debug (Pp.str "succeeded"); + let evd', t' = f !evdref k t in + evdref := evd'; t') + else ( + if !debug_ho_unification then Feedback.msg_debug (Pp.str "failed"); + map_constr_with_binders_left_to_right !evdref + (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) + applyrec acc t)) in - applyrec (env,(0,c)) t + let t' = applyrec (env,(0,c)) t in + !evdref, t' let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the @@ -1114,117 +1278,284 @@ let set_solve_evars f = solve_evars := f * proposition from Dan Grayson] *) +let check_selected_occs env sigma c occ occs = + let notfound = + match occs with + | AtOccurrences occs -> + (match occs with + | Locus.AtLeastOneOccurrence -> occ == 1 + | Locus.AllOccurrences -> false + | Locus.AllOccurrencesBut l -> List.last l > occ + | Locus.OnlyOccurrences l -> List.last l > occ + | Locus.NoOccurrences -> false) + | Unspecified abstract -> false + in if notfound then + raise (PretypeError (env,sigma,NoOccurrenceFound (c,None))) + else () + exception TypingFailed of evar_map -let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = +let set_of_evctx l = + List.fold_left (fun s decl -> Id.Set.add (NamedDecl.get_id decl) s) Id.Set.empty l + +(** Weaken the existentials so that they can be typed in sign and raise + an error if the term otherwise mentions variables not bound in sign. *) +let thin_evars env sigma sign c = + let evdref = ref sigma in + let ctx = set_of_evctx sign in + let rec applyrec (env,acc) t = + match kind sigma t with + | Evar (ev, args) -> + let evi = Evd.find_undefined sigma ev in + let filter = Array.map (fun c -> Id.Set.subset (collect_vars sigma c) ctx) args in + let filter = Filter.make (Array.to_list filter) in + let candidates = Option.map (List.map EConstr.of_constr) (evar_candidates evi) in + let evd, ev = restrict_evar !evdref ev filter candidates in + evdref := evd; whd_evar !evdref t + | Var id -> + if not (Id.Set.mem id ctx) then raise (TypingFailed sigma) + else t + | _ -> + map_constr_with_binders_left_to_right !evdref + (fun d (env,acc) -> (push_rel d env, acc+1)) + applyrec (env,acc) t + in + let c' = applyrec (env,0) c in + (!evdref, c') + +let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = try let evi = Evd.find_undefined evd evk in + let evi = nf_evar_info evd evi in + let env_evar_unf = evar_env evi in let env_evar = evar_filtered_env evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - let instance = List.map mkVar (List.map NamedDecl.get_id ctxt) in - + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs); + Feedback.msg_debug Pp.(str"env evars: " ++ Termops.Internal.print_env env_evar)); + let args = Array.map (nf_evar evd) args in + let vars = List.map NamedDecl.get_id ctxt in + let argsubst = List.map2 (fun id c -> (id, c)) vars (Array.to_list args) in + let instance = List.map mkVar vars in + let rhs = nf_evar evd rhs in + if not (noccur_evar env_rhs evd evk rhs) then raise (TypingFailed evd); + (* Ensure that any progress made by Typing.e_solve_evars will not contradict + the solution we are trying to build here by adding the problem as a constraint. *) + let evd = Evarutil.add_unification_pb (CONV,env_rhs,mkEvar (evk,args),rhs) evd in + let prc env evd c = Termops.Internal.print_constr_env env evd c in let rec make_subst = function - | decl'::ctxt', c::l, occs::occsl when isVarId evd (NamedDecl.get_id decl') c -> + | decl'::ctxt', c::l, occs::occsl when isVarId evd (NamedDecl.get_id decl') c -> begin match occs with - | Some _ -> - user_err Pp.(str "Cannot force abstraction on identity instance.") - | None -> - make_subst (ctxt',l,occsl) + | AtOccurrences loc when not (Locusops.is_all_occurrences loc) -> + user_err Pp.(str "Cannot force abstraction on identity instance.") + | _ -> + make_subst (ctxt',l,occsl) end - | decl'::ctxt', c::l, occs::occsl -> - let id = NamedDecl.get_id decl' in + | decl'::ctxt', c::l, occs::occsl -> + let id = NamedDecl.get_annot decl' in let t = NamedDecl.get_type decl' in let evs = ref [] in - let ty = Retyping.get_type_of env_rhs evd c in - let filter' = filter_possible_projections evd c ty ctxt args in + let c = nf_evar evd c in + (* ty is in env_rhs now *) + let ty = replace_vars argsubst t in + let filter' = filter_possible_projections evd c (nf_evar evd ty) ctxt args in (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl) - | _, _, [] -> [] - | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list.") in - - let rec set_holes evdref rhs = function - | (id,_,c,cty,evsref,filter,occs)::subst -> - let set_var k = - match occs with - | Some Locus.AllOccurrences -> mkVar id - | Some _ -> user_err Pp.(str "Selection of specific occurrences not supported") - | None -> - let evty = set_holes evdref cty subst in - let instance = Filter.filter_list filter instance in - let evd = !evdref in - let (evd, ev) = new_evar_instance sign evd evty ~filter instance in - evdref := evd; - evsref := (fst (destEvar !evdref ev),evty)::!evsref; - ev in - set_holes evdref (apply_on_subterm env_rhs evdref set_var c rhs) subst - | [] -> rhs in + | _, _, [] -> [] + | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list.") + in + let fixed = ref Evar.Set.empty in + let rec set_holes env_rhs evd rhs = function + | (id,idty,c,cty,evsref,filter,occs)::subst -> + let c = nf_evar evd c in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"set holes for: " ++ + prc env_rhs evd (mkVar id.binder_name) ++ spc () ++ + prc env_rhs evd c ++ str" in " ++ + prc env_rhs evd rhs); + let occ = ref 1 in + let set_var evd k inst = + let oc = !occ in + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"Found one occurrence"); + Feedback.msg_debug Pp.(str"cty: " ++ prc env_rhs evd c)); + incr occ; + match occs with + | AtOccurrences occs -> + if Locusops.is_selected oc occs then evd, mkVar id.binder_name + else evd, inst + | Unspecified prefer_abstraction -> + let evd, evty = set_holes env_rhs evd cty subst in + let evty = nf_evar evd evty in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ + str" of type: " ++ prc env_evar evd evty ++ + str " for " ++ prc env_rhs evd c); + let instance = Filter.filter_list filter instance in + (* Allow any type lower than the variable's type as the + abstracted subterm might have a smaller type, which could be + crucial to make the surrounding context typecheck. *) + let evd, evty = + if isArity evd evty then + refresh_universes ~status:Evd.univ_flexible (Some true) + env_evar_unf evd evty + else evd, evty in + let (evd, ev) = new_evar_instance sign evd evty ~filter instance in + let evk = fst (destEvar evd ev) in + evsref := (evk,evty,inst,prefer_abstraction)::!evsref; + fixed := Evar.Set.add evk !fixed; + evd, ev + in + let evd, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracted: " ++ prc env_rhs evd rhs'); + let () = check_selected_occs env_rhs evd c !occ occs in + let env_rhs' = push_named (NamedDecl.LocalAssum (id,idty)) env_rhs in + set_holes env_rhs' evd rhs' subst + | [] -> evd, rhs in let subst = make_subst (ctxt,Array.to_list args,argoccs) in - let evd, rhs = - let evdref = ref evd in - let rhs = set_holes evdref rhs subst in - !evdref, rhs - in - + let evd, rhs' = set_holes env_rhs evd rhs subst in + let rhs' = nf_evar evd rhs' in + (* Thin evars making the term typable in env_evar *) + let evd, rhs' = thin_evars env_evar evd ctxt rhs' in (* We instantiate the evars of which the value is forced by typing *) - let evd,rhs = - try !solve_evars env_evar evd rhs + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"solve_evars on: " ++ prc env_evar evd rhs'); + Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + let evd,rhs' = + try !solve_evars env_evar evd rhs' with e when Pretype_errors.precatchable_exception e -> (* Could not revert all subterms *) raise (TypingFailed evd) in + let rhs' = nf_evar evd rhs' in + (* We instantiate the evars of which the value is forced by typing *) + if !debug_ho_unification then + (Feedback.msg_debug Pp.(str"after solve_evars: " ++ prc env_evar evd rhs'); + Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let rec abstract_free_holes evd = function - | (id,idty,c,_,evsref,_,_)::l -> - let rec force_instantiation evd = function - | (evk,evty)::evs -> - let evd = - if is_undefined evd evk then - (* We force abstraction over this unconstrained occurrence *) - (* and we use typing to propagate this instantiation *) - (* This is an arbitrary choice *) - let evd = Evd.define evk (mkVar id) evd in - match evar_conv_x ts env_evar evd CUMUL idty evty with - | UnifFailure _ -> user_err Pp.(str "Cannot find an instance") - | Success evd -> - match reconsider_unif_constraints (evar_conv_x ts) evd with - | UnifFailure _ -> user_err Pp.(str "Cannot find an instance") - | Success evd -> - evd - else - evd - in - force_instantiation evd evs - | [] -> - abstract_free_holes evd l - in - force_instantiation evd !evsref - | [] -> - let evd = - try Evarsolve.check_evar_instance evd evk rhs - (evar_conv_x TransparentState.full) - with IllTypedInstance _ -> raise (TypingFailed evd) - in - Evd.define evk rhs evd + | (id,idty,c,cty,evsref,_,_)::l -> + let id = id.binder_name in + let c = nf_evar evd c in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracting: " ++ + prc env_rhs evd (mkVar id) ++ spc () ++ + prc env_rhs evd c); + let rec force_instantiation evd = function + | (evk,evty,inst,abstract)::evs -> + let evk = Option.default evk (Evarutil.advance evd evk) in + let evd = + if is_undefined evd evk then + (* We try abstraction or concretisation for *) + (* this unconstrained occurrence *) + (* and we use typing to propagate this instantiation *) + (* We avoid making an arbitrary choice by leaving candidates *) + (* if both can work *) + let evi = Evd.find_undefined evd evk in + let vid = mkVar id in + let candidates = [inst; vid] in + try + let evd, ev = Evarutil.restrict_evar evd evk (Evd.evar_filter evi) (Some candidates) in + let evi = Evd.find evd ev in + (match evar_candidates evi with + | Some [t] -> + if not (noccur_evar env_rhs evd ev (EConstr.of_constr t)) then + raise (TypingFailed evd); + instantiate_evar evar_unify flags evd ev (EConstr.of_constr t) + | Some l when abstract = Abstraction.Abstract && + List.exists (fun c -> isVarId evd id (EConstr.of_constr c)) l -> + instantiate_evar evar_unify flags evd ev vid + | _ -> evd) + with e -> user_err (Pp.str "Cannot find an instance") + else + ((if !debug_ho_unification then + let evi = Evd.find evd evk in + let env = Evd.evar_env evi in + Feedback.msg_debug Pp.(str"evar is defined: " ++ + int (Evar.repr evk) ++ spc () ++ + prc env evd (match evar_body evi with Evar_defined c -> c + | Evar_empty -> assert false))); + evd) + in force_instantiation evd evs + | [] -> abstract_free_holes evd l + in force_instantiation evd !evsref + | [] -> + if Evd.is_defined evd evk then + (* Can happen due to dependencies: instantiating evars in the arguments of evk might + instantiate evk itself. *) + (if !debug_ho_unification then + begin + let evi = Evd.find evd evk in + let evenv = evar_env evi in + let body = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c in + Feedback.msg_debug Pp.(str"evar was defined already as: " ++ prc evenv evd body) + end; + evd) + else + try + let evi = Evd.find_undefined evd evk in + let evenv = evar_env evi in + let rhs' = nf_evar evd rhs' in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracted type before second solve_evars: " ++ + prc evenv evd rhs'); + (* solve_evars is not commuting with nf_evar, because restricting + an evar might provide a more specific type. *) + let evd, _ = !solve_evars evenv evd rhs' in + if !debug_ho_unification then + Feedback.msg_debug Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs')); + let flags = default_flags_of TransparentState.full in + Evarsolve.instantiate_evar evar_unify flags evd evk rhs' + with IllTypedInstance _ -> raise (TypingFailed evd) in - abstract_free_holes evd subst, true + let evd = abstract_free_holes evd subst in + evd, true with TypingFailed evd -> evd, false -let second_order_matching_with_args ts env evd pbty ev l t = -(* - let evd,ev = evar_absorb_arguments env evd ev l in - let argoccs = Array.map_to_list (fun _ -> None) (snd ev) in - let evd, b = second_order_matching ts env evd ev argoccs t in - if b then Success evd - else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) - if b then Success evd else - *) - let pb = (pbty,env,mkApp(mkEvar ev,l),t) in - UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) - -let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = - let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in - let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in +let default_evar_selection flags evd (ev,args) = + let evi = Evd.find_undefined evd ev in + let rec aux args abs = + match args, abs with + | _ :: args, a :: abs -> + let spec = + if not flags.allow_K_at_toplevel then + (* [evar_absorb_arguments] puts an Abstract flag for the + toplevel binders that were absorbed. *) + let occs = + if a == Abstraction.Abstract then Locus.AtLeastOneOccurrence + else Locus.AllOccurrences + in AtOccurrences occs + else Unspecified a + in spec :: aux args abs + | l, [] -> List.map (fun _ -> default_occurrence_selection) l + | [], _ :: _ -> assert false + in aux (Array.to_list args) evi.evar_abstract_arguments + +let second_order_matching_with_args flags env evd with_ho pbty ev l t = + if with_ho then + let evd,ev = evar_absorb_arguments env evd ev (Array.to_list l) in + let argoccs = default_evar_selection flags evd ev in + let test = default_occurrence_test ~frozen_evars:flags.frozen_evars flags.subterm_ts in + let evd, b = + try second_order_matching flags env evd ev (test,argoccs) t + with PretypeError (_, _, NoOccurrenceFound _) -> evd, false + in + if b then Success evd + else + UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) + else + let pb = (pbty,env,mkApp(mkEvar ev,l),t) in + UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) + +let is_beyond_capabilities = function + | CannotSolveConstraint (pb,ProblemBeyondCapabilities) -> true + | _ -> false + +let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = + let t1 = apprec_nohdbeta flags env evd (whd_head_evar evd t1) in + let t2 = apprec_nohdbeta flags env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in let () = if !debug_unification then @@ -1234,7 +1565,8 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = Termops.Internal.print_constr_env env evd t2 ++ cut ())) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in match EConstr.kind evd term1, EConstr.kind evd term2 with - | Evar (evk1,args1), (Rel _|Var _) when app_empty + | Evar (evk1,args1 as ev1), (Rel _|Var _) when app_empty + && not (is_frozen flags ev1) && List.for_all (fun a -> EConstr.eq_constr evd a term2 || isEvar evd a) (remove_instance_local_defs evd evk1 args1) -> (* The typical kind of constraint coming from pattern-matching return @@ -1244,8 +1576,9 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = | None -> let reason = ProblemBeyondCapabilities in UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) - | (Rel _|Var _), Evar (evk2,args2) when app_empty - && List.for_all (fun a -> EConstr.eq_constr evd a term1 || isEvar evd a) + | (Rel _|Var _), Evar (evk2,args2 as ev2) when app_empty + && not (is_frozen flags ev2) + && List.for_all (fun a -> EConstr.eq_constr evd a term1 || isEvar evd a) (remove_instance_local_defs evd evk2 args2) -> (* The typical kind of constraint coming from pattern-matching return type inference *) @@ -1255,36 +1588,44 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let reason = ProblemBeyondCapabilities in UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> - let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in - Success (solve_refl ~can_drop:true f env evd + let f flags ontype env evd pbty x y = + let reds = + match ontype with + | TypeUnification -> TransparentState.full + | TermUnification -> flags.open_ts + in is_fconv ~reds pbty env evd x y + in + Success (solve_refl ~can_drop:true f flags env evd (position_problem true pbty) evk1 args1 args2) | Evar ev1, Evar ev2 when app_empty -> + (* solve_evar_evar handles the cases ev1 and/or ev2 are frozen *) Success (solve_evar_evar ~force:true - (evar_define (evar_conv_x ts) ~choose:true) (evar_conv_x ts) env evd - (position_problem true pbty) ev1 ev2) - | Evar ev1,_ when Array.length l1 <= Array.length l2 -> + (evar_define evar_unify flags ~choose:true) + evar_unify flags env evd + (position_problem true pbty) ev1 ev2) + | Evar ev1,_ when not (is_frozen flags ev1) && Array.length l1 <= Array.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) (* and otherwise second-order matching *) ise_try evd - [(fun evd -> first_order_unification ts env evd (ev1,l1) appr2); + [(fun evd -> first_order_unification flags env evd (ev1,l1) appr2); (fun evd -> - second_order_matching_with_args ts env evd pbty ev1 l1 t2)] - | _,Evar ev2 when Array.length l2 <= Array.length l1 -> + second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2)] + | _,Evar ev2 when not (is_frozen flags ev2) && Array.length l2 <= Array.length l1 -> (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *) (* and otherwise second-order matching *) ise_try evd - [(fun evd -> first_order_unification ts env evd (ev2,l2) appr1); + [(fun evd -> first_order_unification flags env evd (ev2,l2) appr1); (fun evd -> - second_order_matching_with_args ts env evd pbty ev2 l2 t1)] - | Evar ev1,_ -> + second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1)] + | Evar ev1,_ when not (is_frozen flags ev1) -> (* Try second-order pattern-matching *) - second_order_matching_with_args ts env evd pbty ev1 l1 t2 - | _,Evar ev2 -> + second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2 + | _,Evar ev2 when not (is_frozen flags ev2) -> (* Try second-order pattern-matching *) - second_order_matching_with_args ts env evd pbty ev2 l2 t1 + second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1 | _ -> (* Some head evar have been instantiated, or unknown kind of problem *) - evar_conv_x ts env evd pbty t1 t2 + evar_conv_x flags env evd pbty t1 t2 let error_cannot_unify env evd pb ?reason t1 t2 = Pretype_errors.error_cannot_unify @@ -1313,7 +1654,7 @@ let max_undefined_with_candidates evd = with MaxUndefined ans -> Some ans -let rec solve_unconstrained_evars_with_candidates ts evd = +let rec solve_unconstrained_evars_with_candidates flags evd = (* max_undefined is supposed to return the most recent, hence possibly most dependent evar *) match max_undefined_with_candidates evd with @@ -1324,11 +1665,9 @@ let rec solve_unconstrained_evars_with_candidates ts evd = | a::l -> (* In case of variables, most recent ones come first *) try - let conv_algo = evar_conv_x ts in - let evd = check_evar_instance evd evk a conv_algo in - let evd = Evd.define evk a evd in - match reconsider_unif_constraints conv_algo evd with - | Success evd -> solve_unconstrained_evars_with_candidates ts evd + let evd = instantiate_evar evar_unify flags evd evk a in + match reconsider_unif_constraints evar_unify flags evd with + | Success evd -> solve_unconstrained_evars_with_candidates flags evd | UnifFailure _ -> aux l with | IllTypedInstance _ -> aux l @@ -1336,7 +1675,7 @@ let rec solve_unconstrained_evars_with_candidates ts evd = (* Expected invariant: most dependent solutions come first *) (* so as to favor progress when used with the refine tactics *) let evd = aux l in - solve_unconstrained_evars_with_candidates ts evd + solve_unconstrained_evars_with_candidates flags evd let solve_unconstrained_impossible_cases env evd = Evd.fold_undefined (fun evk ev_info evd' -> @@ -1345,35 +1684,40 @@ let solve_unconstrained_impossible_cases env evd = let j, ctx = coq_unit_judge env in let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in let ty = j_type j in - let conv_algo = evar_conv_x TransparentState.full in - let evd' = check_evar_instance evd' evk ty conv_algo in - Evd.define evk ty evd' + let flags = default_flags env in + instantiate_evar evar_unify flags evd' evk ty | _ -> evd') evd evd let solve_unif_constraints_with_heuristics env - ?(ts=Conv_oracle.get_transp_state (Environ.oracle env)) evd = - let evd = solve_unconstrained_evars_with_candidates ts evd in + ?(flags=default_flags env) ?(with_ho=false) evd = + let evd = solve_unconstrained_evars_with_candidates flags evd in let rec aux evd pbs progress stuck = match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> - (match apply_conversion_problem_heuristic ts env evd pbty t1 t2 with + (match apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 with | Success evd' -> - let (evd', rest) = extract_all_conv_pbs evd' in - begin match rest with + let evd' = solve_unconstrained_evars_with_candidates flags evd' in + let (evd', rest) = extract_all_conv_pbs evd' in + begin match rest with | [] -> aux evd' pbs true stuck - | _ -> (* Unification got actually stuck, postpone *) - aux evd pbs progress (pb :: stuck) + | l -> + (* Unification got actually stuck, postpone *) + let reason = CannotSolveConstraint (pb,ProblemBeyondCapabilities) in + aux evd pbs progress ((pb, reason):: stuck) end | UnifFailure (evd,reason) -> - error_cannot_unify env evd pb ~reason t1 t2) + if is_beyond_capabilities reason then + aux evd pbs progress ((pb,reason) :: stuck) + else aux evd [] false ((pb,reason) :: stuck)) | _ -> - if progress then aux evd stuck false [] + if progress then aux evd (List.map fst stuck) false [] else match stuck with | [] -> (* We're finished *) evd - | (pbty,env,t1,t2 as pb) :: _ -> - (* There remains stuck problems *) - error_cannot_unify env evd pb t1 t2 + | ((pbty,env,t1,t2 as pb), reason) :: _ -> + (* There remains stuck problems *) + Pretype_errors.error_cannot_unify ?loc:(loc_of_conv_pb evd pb) + env evd ~reason (t1, t2) in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in @@ -1384,16 +1728,49 @@ let solve_unif_constraints_with_heuristics env exception UnableToUnify of evar_map * unification_error -let default_transparent_state env = TransparentState.full -(* Conv_oracle.get_transp_state (Environ.oracle env) *) +let unify_delay ?flags env evd t1 t2 = + let flags = + match flags with + | None -> default_flags_of (default_transparent_state env) + | Some flags -> flags + in + match evar_conv_x flags env evd CONV t1 t2 with + | Success evd' -> evd' + | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) +let unify_leq_delay ?flags env evd t1 t2 = + let flags = + match flags with + | None -> default_flags_of (default_transparent_state env) + | Some flags -> flags + in + match evar_conv_x flags env evd CUMUL t1 t2 with + | Success evd' -> evd' + | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) + +let unify ?flags ?(with_ho=true) env evd cv_pb ty1 ty2 = + let flags = + match flags with + | None -> default_flags_of (default_transparent_state env) + | Some flags -> flags + in + let res = evar_conv_x flags env evd cv_pb ty1 ty2 in + match res with + | Success evd -> + solve_unif_constraints_with_heuristics ~flags ~with_ho env evd + | UnifFailure (evd, reason) -> + raise (PretypeError (env, evd, CannotUnify (ty1, ty2, Some reason))) + +(* deprecated *) let the_conv_x env ?(ts=default_transparent_state env) t1 t2 evd = - match evar_conv_x ts env evd CONV t1 t2 with + let flags = default_flags_of ts in + match evar_conv_x flags env evd CONV t1 t2 with | Success evd' -> evd' | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) let the_conv_x_leq env ?(ts=default_transparent_state env) t1 t2 evd = - match evar_conv_x ts env evd CUMUL t1 t2 with + let flags = default_flags_of ts in + match evar_conv_x flags env evd CUMUL t1 t2 with | Success evd' -> evd' | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) @@ -1402,7 +1779,9 @@ let make_opt = function | UnifFailure _ -> None let conv env ?(ts=default_transparent_state env) evd t1 t2 = - make_opt(evar_conv_x ts env evd CONV t1 t2) + let flags = default_flags_of ts in + make_opt(evar_conv_x flags env evd CONV t1 t2) let cumul env ?(ts=default_transparent_state env) evd t1 t2 = - make_opt(evar_conv_x ts env evd CUMUL t1 t2) + let flags = default_flags_of ts in + make_opt(evar_conv_x flags env evd CUMUL t1 t2) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 4585fac252..0fe47c2a48 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -16,28 +16,74 @@ open Locus (** {4 Unification for type inference. } *) +type unify_flags = Evarsolve.unify_flags + +(** The default subterm transparent state is no unfoldings *) +val default_flags_of : ?subterm_ts:TransparentState.t -> TransparentState.t -> unify_flags + +type unify_fun = unify_flags -> + env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result + +val conv_fun : unify_fun -> Evarsolve.unifier + exception UnableToUnify of evar_map * Pretype_errors.unification_error (** {6 Main unification algorithm for type inference. } *) -(** returns exception NotUnifiable with best known evar_map if not unifiable *) +(** There are two variants for unification: one that delays constraints outside its capabilities + ([unify_delay]) and another that tries to solve such remaining constraints using + heuristics ([unify]). *) + +(** Theses functions allow to pass arbitrary flags to the unifier and can delay constraints. + In case the flags are not specified, they default to + [default_flags_of TransparentState.full] currently. + + In case of success, the two terms are hence unifiable only if the remaining constraints + can be solved or [check_problems_are_solved] is true. + + @raises UnableToUnify in case the two terms do not unify *) + +val unify_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map +val unify_leq_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map + +(** returns exception UnableToUnify with best known evar_map if not unifiable *) val the_conv_x : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map +[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] val the_conv_x_leq : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map - +[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] (** The same function resolving evars by side-effect and catching the exception *) + val conv : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option +[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] val cumul : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option +[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] + +(** This function also calls [solve_unif_constraints_with_heuristics] to resolve any remaining + constraints. In case of success the two terms are unified without condition. + + The with_ho option tells if higher-order unification should be tried to resolve the + constraints. + + @raises a PretypeError if it cannot unify *) +val unify : ?flags:unify_flags -> ?with_ho:bool -> + env -> evar_map -> conv_pb -> constr -> constr -> evar_map (** {6 Unification heuristics. } *) (** Try heuristics to solve pending unification problems and to solve - evars with candidates *) + evars with candidates. + + The with_ho option tells if higher-order unification should be tried + to resolve the constraints. -val solve_unif_constraints_with_heuristics : env -> ?ts:TransparentState.t -> evar_map -> evar_map + @raises a PretypeError if it fails to resolve some problem *) -(** Check all pending unification problems are solved and raise an - error otherwise *) +val solve_unif_constraints_with_heuristics : + env -> ?flags:unify_flags -> ?with_ho:bool -> evar_map -> evar_map + +(** Check all pending unification problems are solved and raise a + PretypeError otherwise *) val check_problems_are_solved : env -> evar_map -> unit @@ -54,28 +100,55 @@ val check_conv_record : env -> evar_map -> (** Try to solve problems of the form ?x[args] = c by second-order matching, using typing to select occurrences *) -val second_order_matching : TransparentState.t -> env -> evar_map -> - EConstr.existential -> occurrences option list -> constr -> evar_map * bool +type occurrence_match_test = + env -> evar_map -> constr -> (* Used to precompute the local tests *) + env -> evar_map -> int -> constr -> constr -> bool * evar_map + +(** When given the choice of abstracting an occurrence or leaving it, + force abstration. *) + +type occurrence_selection = + | AtOccurrences of occurrences + | Unspecified of Abstraction.abstraction + +(** By default, unspecified, not preferring abstraction. + This provides the most general solutions. *) +val default_occurrence_selection : occurrence_selection + +type occurrences_selection = + occurrence_match_test * occurrence_selection list + +val default_occurrence_test : frozen_evars:Evar.Set.t -> TransparentState.t -> occurrence_match_test + +(** [default_occurrence_selection n] + Gives the default test and occurrences for [n] arguments *) +val default_occurrences_selection : ?frozen_evars:Evar.Set.t (* By default, none *) -> + TransparentState.t -> int -> occurrences_selection + +val second_order_matching : unify_flags -> env -> evar_map -> + EConstr.existential -> occurrences_selection -> constr -> evar_map * bool (** Declare function to enforce evars resolution by using typing constraints *) val set_solve_evars : (env -> evar_map -> constr -> evar_map * constr) -> unit -type unify_fun = TransparentState.t -> - env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result - (** Override default [evar_conv_x] algorithm. *) val set_evar_conv : unify_fun -> unit (** The default unification algorithm with evars and universes. *) val evar_conv_x : unify_fun +val evar_unify : Evarsolve.unifier + (**/**) (* For debugging *) -val evar_eqappr_x : ?rhs_is_already_stuck:bool -> TransparentState.t * bool -> +val evar_eqappr_x : ?rhs_is_already_stuck:bool -> unify_flags -> env -> evar_map -> conv_pb -> state * Cst_stack.t -> state * Cst_stack.t -> Evarsolve.unification_result + +val occur_rigidly : Evarsolve.unify_flags -> + 'a -> Evd.evar_map -> Evar.t * 'b -> EConstr.t -> bool (**/**) (** {6 Functions to deal with impossible cases } *) diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 571be7466c..a51cb22c20 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -13,6 +13,7 @@ open Util open Pp open Names open Constr +open Context open Termops open EConstr open Vars @@ -72,7 +73,7 @@ let idx = Namegen.default_dependent_ident (* Refining an evar to a product *) -let define_pure_evar_as_product evd evk = +let define_pure_evar_as_product env evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in @@ -84,11 +85,12 @@ let define_pure_evar_as_product evd evk = let evd1,(dom,u1) = new_type_evar evenv evd univ_flexible_alg ~src ~filter:(evar_filter evi) in + let rdom = Sorts.Relevant in (* TODO relevance *) let evd2,rng = - let newenv = push_named (LocalAssum (id, dom)) evenv in + let newenv = push_named (LocalAssum (make_annot id rdom, dom)) evenv in let src = subterm_source evk ~where:Codomain evksrc in let filter = Filter.extend 1 (evar_filter evi) in - if Sorts.is_prop (ESorts.kind evd1 s) then + if Environ.is_impredicative_sort env (ESorts.kind evd1 s) then (* Impredicative product, conclusion must fall in [Prop]. *) new_evar newenv evd1 concl ~src ~filter else @@ -97,17 +99,17 @@ let define_pure_evar_as_product evd evk = new_type_evar newenv evd1 status ~src ~filter in let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in - let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) (ESorts.kind evd1 s) in + let evd3 = Evd.set_leq_sort evenv evd3 (Sorts.sort_of_univ prods) (ESorts.kind evd1 s) in evd3, rng in - let prod = mkProd (Name id, dom, subst_var id rng) in + let prod = mkProd (make_annot (Name id) rdom, dom, subst_var id rng) in let evd3 = Evd.define evk prod evd2 in evd3,prod (* Refine an applied evar to a product and returns its instantiation *) -let define_evar_as_product evd (evk,args) = - let evd,prod = define_pure_evar_as_product evd evk in +let define_evar_as_product env evd (evk,args) = + let evd,prod = define_pure_evar_as_product env evd evk in (* 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 @@ -131,16 +133,19 @@ let define_pure_evar_as_lambda env evd evk = let typ = Reductionops.whd_all evenv evd (evar_concl evi) in let evd1,(na,dom,rng) = match EConstr.kind evd typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) - | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd evd typ + | Evar ev' -> let evd,typ = define_evar_as_product env evd ev' in evd,destProd evd typ | _ -> error_not_product env evd typ in let avoid = Environ.ids_of_named_context_val evi.evar_hyps in let id = - next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in + map_annot (fun na -> next_name_away_with_default_using_types "x" na avoid + (Reductionops.whd_evar evd dom)) na + in let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = subterm_source evk ~where:Body (evar_source evk evd1) in - let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in - let lam = mkLambda (Name id, dom, subst_var id body) in + let abstract_arguments = Abstraction.abstract_last evi.evar_abstract_arguments in + let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id.binder_name) rng) ~filter ~abstract_arguments in + let lam = mkLambda (map_annot Name.mk_name id, dom, subst_var id.binder_name body) in Evd.define evk lam evd2, lam let define_evar_as_lambda env evd (evk,args) = @@ -163,13 +168,12 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function (* Refining an evar to a sort *) let define_evar_as_sort env evd (ev,args) = - let evd, u = new_univ_variable univ_rigid evd in + let evd, s = new_sort_variable univ_rigid evd in let evi = Evd.find_undefined evd ev in - let s = Type u in let concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in let sort = destSort evd concl in let evd' = Evd.define ev (mkSort s) evd in - Evd.set_leq_sort env evd' (Type (Univ.super u)) (ESorts.kind evd' sort), s + Evd.set_leq_sort env evd' (Sorts.super s) (ESorts.kind evd' sort), s (* Propagation of constraints through application and abstraction: Given a type constraint on a functional term, returns the type @@ -180,21 +184,22 @@ let split_tycon ?loc env evd tycon = let rec real_split evd c = let t = Reductionops.whd_all env evd c in match EConstr.kind evd t with - | Prod (na,dom,rng) -> evd, (na, dom, rng) + | Prod (na,dom,rng) -> evd, (na, dom, rng) | Evar ev (* ev is undefined because of whd_all *) -> - let (evd',prod) = define_evar_as_product evd ev in - let (_,dom,rng) = destProd evd prod in - evd',(Anonymous, dom, rng) - | App (c,args) when isEvar evd c -> - let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in + let (evd',prod) = define_evar_as_product env evd ev in + let (na,dom,rng) = destProd evd prod in + let anon = {na with binder_name = Anonymous} in + evd',(anon, dom, rng) + | App (c,args) when isEvar evd c -> + let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in real_split evd' (mkApp (lam,args)) | _ -> error_not_product ?loc env evd c in match tycon with - | None -> evd,(Anonymous,None,None) + | None -> evd,(make_annot Anonymous Relevant,None,None) | Some c -> - let evd', (n, dom, rng) = real_split evd c in - evd', (n, mk_tycon dom, mk_tycon rng) + let evd', (n, dom, rng) = real_split evd c in + evd', (n, mk_tycon dom, mk_tycon rng) let valcon_of_tycon x = x let lift_tycon n = Option.map (lift n) diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index cd23f9c601..8ff113196b 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -33,12 +33,12 @@ val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> val split_tycon : ?loc:Loc.t -> env -> evar_map -> type_constraint -> - evar_map * (Name.t * type_constraint * type_constraint) + evar_map * (Name.t Context.binder_annot * type_constraint * type_constraint) val valcon_of_tycon : type_constraint -> val_constraint val lift_tycon : int -> type_constraint -> type_constraint -val define_evar_as_product : evar_map -> existential -> evar_map * types +val define_evar_as_product : env -> evar_map -> existential -> evar_map * types val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types val define_evar_as_sort : env -> evar_map -> existential -> evar_map * Sorts.t diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4c4a236620..a4a078bfa0 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -12,6 +12,7 @@ open Sorts open Util open CErrors open Names +open Context open Constr open Environ open Termops @@ -24,6 +25,49 @@ open Reductionops open Evarutil open Pretype_errors +type unify_flags = { + modulo_betaiota: bool; + open_ts : TransparentState.t; + closed_ts : TransparentState.t; + subterm_ts : TransparentState.t; + frozen_evars : Evar.Set.t; + allow_K_at_toplevel : bool; + with_cs : bool } + +type unification_kind = + | TypeUnification + | TermUnification + +(************************) +(* Unification results *) +(************************) + +type unification_result = + | Success of evar_map + | UnifFailure of evar_map * unification_error + +let is_success = function Success _ -> true | UnifFailure _ -> false + +let test_success unify flags b env evd c c' rhs = + is_success (unify flags b env evd c c' rhs) + +(** A unification function parameterized by: + - unification flags + - the kind of unification + - environment + - sigma + - conversion problem + - the two terms to unify. *) + +type unifier = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> unification_result + +(** A conversion function: parameterized by the kind of unification, + environment, sigma, conversion problem and the two terms to convert. + Conversion is not allowed to instantiate evars contrary to unification. *) +type conversion_check = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> bool + let normalize_evar evd ev = match EConstr.kind evd (mkEvar ev) with | Evar (evk,args) -> (evk,args) @@ -129,20 +173,6 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c = let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in refresh_universes (Some false) env sigma ty - - -(************************) -(* Unification results *) -(************************) - -type unification_result = - | Success of evar_map - | UnifFailure of evar_map * unification_error - -let is_success = function Success _ -> true | UnifFailure _ -> false - -let test_success conv_algo env evd c c' rhs = - is_success (conv_algo env evd c c' rhs) let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = match pbty with @@ -154,7 +184,7 @@ let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = exception IllTypedInstance of env * EConstr.types * EConstr.types -let recheck_applications conv_algo env evdref t = +let recheck_applications unify flags env evdref t = let rec aux env t = match EConstr.kind !evdref t with | App (f, args) -> @@ -164,9 +194,9 @@ let recheck_applications conv_algo env evdref t = let rec aux i ty = if i < Array.length argsty then match EConstr.kind !evdref (whd_all env !evdref ty) with - | Prod (na, dom, codom) -> - (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with - | Success evd -> evdref := evd; + | Prod (na, dom, codom) -> + (match unify flags TypeUnification env !evdref Reduction.CUMUL argsty.(i) dom with + | Success evd -> evdref := evd; aux (succ i) (subst1 args.(i) codom) | UnifFailure (evd, reason) -> Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) @@ -324,7 +354,7 @@ let compute_rel_aliases var_aliases rels sigma = (fun decl (n,aliases) -> (n-1, match decl with - | LocalDef (_,t,u) -> + | LocalDef (_,t,u) -> (match EConstr.kind sigma t with | Var id' -> let aliases_of_n = @@ -611,7 +641,7 @@ let make_projectable_subst aliases sigma evi args = List.fold_right_i (fun i decl (args,all,cstrs,revmap) -> match decl,args with - | LocalAssum (id,c), a::rest -> + | LocalAssum ({binder_name=id},c), a::rest -> let revmap = Id.Map.add id i revmap in let cstrs = let a',args = decompose_app_vect sigma a in @@ -622,7 +652,7 @@ let make_projectable_subst aliases sigma evi args = | _ -> cstrs in let all = Int.Map.add i [a,normalize_alias_opt sigma aliases a,id] all in (rest,all,cstrs,revmap) - | LocalDef (id,c,_), a::rest -> + | LocalDef ({binder_name=id},c,_), a::rest -> let revmap = Id.Map.add id i revmap in (match EConstr.kind sigma c with | Var id' -> @@ -698,7 +728,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in - let id = next_name_away na avoid in + let id = map_annot (fun na -> next_name_away na avoid) na in let evd,t_in_sign = let s = Retyping.get_sort_of env evd t_in_env in let evd,ty_t_in_sign = refresh_universes @@ -714,7 +744,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = (push_named_context_val d' sign, Filter.extend 1 filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), - push_rel d env,evd,Id.Set.add id avoid)) + 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) in @@ -734,6 +764,19 @@ let restrict_upon_filter evd evk p args = let len = Array.length args in Filter.restrict_upon oldfullfilter len (fun i -> p (Array.unsafe_get args i)) +let check_evar_instance unify flags evd evk1 body = + let evi = Evd.find evd evk1 in + let evenv = evar_env evi in + (* FIXME: The body might be ill-typed when this is called from w_merge *) + (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) + let ty = + try Retyping.get_type_of ~lax:true evenv evd body + with Retyping.RetypeError _ -> user_err (Pp.(str "Ill-typed evar instance")) + in + match unify flags TypeUnification evenv evd Reduction.CUMUL ty evi.evar_concl with + | Success evd -> evd + | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) + (***************) (* Unification *) @@ -869,12 +912,13 @@ let rec find_solution_type evarenv = function * pass [define] to [do_projection_effects] as a parameter. *) -let rec do_projection_effects define_fun env ty evd = function +let rec do_projection_effects unify flags define_fun env ty evd = function | ProjectVar -> evd | ProjectEvar ((evk,argsv),evi,id,p) -> - let evd = Evd.define evk (mkVar id) evd in + let evd = check_evar_instance unify flags evd evk (mkVar id) in + let evd = Evd.define evk (EConstr.mkVar id) evd in (* TODO: simplify constraints involving evk *) - let evd = do_projection_effects define_fun env ty evd p in + let evd = do_projection_effects unify flags define_fun env ty evd p in let ty = whd_all env evd (Lazy.force ty) in if not (isSort evd ty) then (* Don't try to instantiate if a sort because if evar_concl is an @@ -1110,9 +1154,9 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = * Note: argument f is the function used to instantiate evars. *) -let filter_compatible_candidates conv_algo env evd evi args rhs c = +let filter_compatible_candidates unify flags env evd evi args rhs c = let c' = instantiate_evar_array evi c args in - match conv_algo env evd Reduction.CONV rhs c' with + match unify flags TermUnification env evd Reduction.CONV rhs c' with | Success evd -> Some (c,evd) | UnifFailure _ -> None @@ -1122,7 +1166,7 @@ let filter_compatible_candidates conv_algo env evd evi args rhs c = exception DoesNotPreserveCandidateRestriction -let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = +let restrict_candidates unify flags env evd filter1 (evk1,argsv1) (evk2,argsv2) = let evi1 = Evd.find evd evk1 in let evi2 = Evd.find evd evk2 in match evi1.evar_candidates, evi2.evar_candidates with @@ -1133,7 +1177,7 @@ let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = let l1' = List.filter (fun c1 -> let c1' = instantiate_evar_array evi1 c1 argsv1 in let filter c2 = - let compatibility = filter_compatible_candidates conv_algo env evd evi2 argsv2 c1' c2 in + let compatibility = filter_compatible_candidates unify flags env evd evi2 argsv2 c1' c2 in match compatibility with | None -> false | Some _ -> true @@ -1200,14 +1244,14 @@ exception EvarSolvedOnTheFly of evar_map * EConstr.constr (* Try to project evk1[argsv1] on evk2[argsv2], if [ev1] is a pattern on the common domain of definition *) -let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = +let project_evar_on_evar force unify flags env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *) let fvs2 = free_vars_and_rels_up_alias_expansion env evd aliases (mkEvar ev2) in let filter1 = restrict_upon_filter evd evk1 (has_constrainable_free_vars env evd aliases force k2 evk2 fvs2) argsv1 in let candidates1 = - try restrict_candidates g env evd filter1 ev1 ev2 + try restrict_candidates unify flags env evd filter1 ev1 ev2 with DoesNotPreserveCandidateRestriction -> let evd,ev1' = do_restrict_hyps evd ev1 filter1 NoUpdate in raise (CannotProject (evd,ev1')) in @@ -1225,35 +1269,22 @@ let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (e else raise (CannotProject (evd,ev1')) -let check_evar_instance evd evk1 body conv_algo = - let evi = Evd.find evd evk1 in - let evenv = evar_env evi in - (* FIXME: The body might be ill-typed when this is called from w_merge *) - (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) - let ty = - try Retyping.get_type_of ~lax:true evenv evd body - with Retyping.RetypeError _ -> user_err Pp.(str "Ill-typed evar instance") - in - match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with - | Success evd -> evd - | UnifFailure _ -> raise (IllTypedInstance (evenv,ty, evi.evar_concl)) - let update_evar_info ev1 ev2 evd = (* We update the source of obligation evars during evar-evar unifications. *) let loc, evs1 = evar_source ev1 evd in let evi = Evd.find evd ev2 in Evd.add evd ev2 {evi with evar_source = loc, evs1} -let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) = +let solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 (evk2,_ as ev2) = try - let evd,body = project_evar_on_evar force g env evd aliases 0 pbty ev1 ev2 in + let evd,body = project_evar_on_evar force unify flags env evd aliases 0 pbty ev1 ev2 in let evd' = Evd.define_with_evar evk2 body evd in let evd' = if is_obligation_evar evd evk2 then update_evar_info evk2 (fst (destEvar evd' body)) evd' else evd' in - check_evar_instance evd' evk2 body g + check_evar_instance unify flags evd' evk2 body with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1264,22 +1295,33 @@ let preferred_orientation evd evk1 evk2 = else if is_obligation_evar evd evk2 then false else true -let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = +let solve_evar_evar_aux force f unify flags env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = let aliases = make_alias_map env evd in + let frozen_ev1 = Evar.Set.mem evk1 flags.frozen_evars in + let frozen_ev2 = Evar.Set.mem evk2 flags.frozen_evars in if preferred_orientation evd evk1 evk2 then - try solve_evar_evar_l2r force f g env evd aliases (opp_problem pbty) ev2 ev1 + try if not frozen_ev1 then + solve_evar_evar_l2r force f unify flags env evd aliases (opp_problem pbty) ev2 ev1 + else raise (CannotProject (evd,ev2)) with CannotProject (evd,ev2) -> - try solve_evar_evar_l2r force f g env evd aliases pbty ev1 ev2 - with CannotProject (evd,ev1) -> - add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd + try if not frozen_ev2 then + solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 ev2 + else raise (CannotProject (evd,ev1)) + with CannotProject (evd,ev1) -> + add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd else - try solve_evar_evar_l2r force f g env evd aliases pbty ev1 ev2 + try if not frozen_ev2 then + solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 ev2 + else raise (CannotProject (evd,ev1)) with CannotProject (evd,ev1) -> - try solve_evar_evar_l2r force f g env evd aliases (opp_problem pbty) ev2 ev1 + try if not frozen_ev1 then + solve_evar_evar_l2r force f unify flags env evd aliases (opp_problem pbty) ev2 ev1 + else raise (CannotProject (evd,ev2)) with CannotProject (evd,ev2) -> - add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd + add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd -let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = +(** Precondition: evk1 is not frozen *) +let solve_evar_evar ?(force=false) f unify flags env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = let pbty = if force then None else pbty in let evi = Evd.find evd evk1 in let downcast evk t evd = downcast evk t evd in @@ -1314,25 +1356,19 @@ let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,ar downcast evk2 t2 (downcast evk1 t1 evd) with Reduction.NotArity -> evd in - solve_evar_evar_aux force f g env evd pbty ev1 ev2 - -type conv_fun = - env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> unification_result - -type conv_fun_bool = - env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> bool + solve_evar_evar_aux force f unify flags env evd pbty ev1 ev2 (* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint * definitions. We try to unify the ti with the ui pairwise. The pairs * that don't unify are discarded (i.e. ?e is redefined so that it does not * depend on these args). *) -let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 = +let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = let evdref = ref evd in let eq_constr c1 c2 = match EConstr.eq_constr_universes env !evdref c1 c2 with | None -> false | Some cstr -> - try ignore (Evd.add_universe_constraints !evdref cstr); true + try evdref := Evd.add_universe_constraints !evdref cstr; true with UniversesDiffer -> false in if Array.equal eq_constr argsv1 argsv2 then !evdref else @@ -1340,19 +1376,26 @@ let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 = let args = Array.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in let untypedfilter = restrict_upon_filter evd evk - (fun (a1,a2) -> conv_algo env evd Reduction.CONV a1 a2) args in + (fun (a1,a2) -> unify flags TermUnification env evd Reduction.CONV a1 a2) args in let candidates = filter_candidates evd evk untypedfilter NoUpdate in let filter = closure_of_filter evd evk untypedfilter in - let evd,ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in - if Evar.equal (fst ev1) evk && can_drop then (* No refinement *) evd else + let evd',ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in + let frozen = Evar.Set.mem evk flags.frozen_evars in + if Evar.equal (fst ev1) evk && (frozen || can_drop) then + (* No refinement needed *) evd' + else (* either progress, or not allowed to drop, e.g. to preserve possibly *) (* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *) (* if e can depend on x until ?y is not resolved, or, conversely, we *) (* don't know if ?y has to be unified with ?y, until e is resolved *) - let argsv2 = restrict_instance evd evk filter argsv2 in - let ev2 = (fst ev1,argsv2) in - (* Leave a unification problem *) - add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd + if frozen then + (* We cannot prune a frozen evar *) + add_conv_oriented_pb (pbty,env,mkEvar (evk, argsv1),mkEvar (evk,argsv2)) evd + else + let argsv2 = restrict_instance evd' evk filter argsv2 in + let ev2 = (fst ev1,argsv2) in + (* Leave a unification problem *) + add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd' (* If the evar can be instantiated by a finite set of candidates known in advance, we check which of them apply *) @@ -1360,14 +1403,14 @@ let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 = exception NoCandidates exception IncompatibleCandidates -let solve_candidates conv_algo env evd (evk,argsv) rhs = +let solve_candidates unify flags env evd (evk,argsv) rhs = let evi = Evd.find evd evk in match evi.evar_candidates with | None -> raise NoCandidates | Some l -> let l' = List.map_filter - (fun c -> filter_compatible_candidates conv_algo env evd evi argsv rhs c) l in + (fun c -> filter_compatible_candidates unify flags env evd evi argsv rhs c) l in match l' with | [] -> raise IncompatibleCandidates | [c,evd] -> @@ -1375,7 +1418,7 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then let evd' = Evd.define evk c evd in - check_evar_instance evd' evk c conv_algo + check_evar_instance unify flags evd' evk c else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in @@ -1399,6 +1442,13 @@ let occur_evar_upto_types sigma n c = in try occur_rec c; false with Occur -> true +let instantiate_evar unify flags evd evk body = + (* Check instance freezing the evar to be defined, as + checking could involve the same evar definition problem again otherwise *) + let flags = { flags with frozen_evars = Evar.Set.add evk flags.frozen_evars } in + let evd' = check_evar_instance unify flags evd evk body in + Evd.define evk body evd' + (* We try to instantiate the evar assuming the body won't depend * on arguments that are not Rels or Vars, or appearing several times * (i.e. we tackle a generalization of Miller-Pfenning patterns unification) @@ -1428,7 +1478,8 @@ exception NotEnoughInformationEvarEvar of EConstr.constr exception OccurCheckIn of evar_map * EConstr.constr exception MetaOccurInBodyInternal -let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = +let rec invert_definition unify flags choose imitate_defs + env evd pbty (evk,argsv as ev) rhs = let aliases = make_alias_map env evd in let evdref = ref evd in let progress = ref false in @@ -1447,7 +1498,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = if choose then (mkVar id, p) else raise (NotUniqueInType sols) in let ty = lazy (Retyping.get_type_of env !evdref (of_alias t)) in - let evd = do_projection_effects (evar_define conv_algo ~choose) env ty !evdref p in + let evd = do_projection_effects unify flags (evar_define unify flags ~choose) env ty !evdref p in evdref := evd; c with @@ -1460,7 +1511,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let ty = find_solution_type (evar_filtered_env evi) sols in let ty' = instantiate_evar_array evi ty argsv in let (evd,evar,(evk',argsv' as ev')) = - materialize_evar (evar_define conv_algo ~choose) env !evdref 0 ev ty' in + materialize_evar (evar_define unify flags ~choose) env !evdref 0 ev ty' in let ts = expansions_of_var evd aliases t in let test c = isEvar evd c || List.exists (is_alias evd c) ts in let filter = restrict_upon_filter evd evk test argsv' in @@ -1484,13 +1535,15 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | LocalAssum _ -> project_variable (RelAlias (i-k)) | LocalDef (_,b,_) -> try project_variable (RelAlias (i-k)) - with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i (EConstr.of_constr b))) + with NotInvertibleUsingOurAlgorithm _ when imitate_defs -> + imitate envk (lift i (EConstr.of_constr b))) | Var id -> (match Environ.lookup_named id env' with | LocalAssum _ -> project_variable (VarAlias id) | LocalDef (_,b,_) -> try project_variable (VarAlias id) - with NotInvertibleUsingOurAlgorithm _ -> imitate envk (EConstr.of_constr b)) + with NotInvertibleUsingOurAlgorithm _ when imitate_defs -> + imitate envk (EConstr.of_constr b)) | LetIn (na,b,u,c) -> imitate envk (subst1 b c) | Evar (evk',args' as ev') -> @@ -1499,7 +1552,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let aliases = lift_aliases k aliases in (try let ev = (evk,Array.map (lift k) argsv) in - let evd,body = project_evar_on_evar false conv_algo env' !evdref aliases k None ev' ev in + let evd,body = project_evar_on_evar false unify flags env' !evdref aliases k None ev' ev in evdref := evd; body with @@ -1510,15 +1563,15 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* Make the virtual left evar real *) let ty = get_type_of env' evd t in let (evd,evar'',ev'') = - materialize_evar (evar_define conv_algo ~choose) env' evd k ev ty in + materialize_evar (evar_define unify flags ~choose) env' evd k ev ty in (* materialize_evar may instantiate ev' by another evar; adjust it *) let (evk',args' as ev') = normalize_evar evd ev' in let evd = (* Try to project (a restriction of) the left evar ... *) try - let evd,body = project_evar_on_evar false conv_algo env' evd aliases 0 None ev'' ev' in + let evd,body = project_evar_on_evar false unify flags env' evd aliases 0 None ev'' ev' in let evd = Evd.define evk' body evd in - check_evar_instance evd evk' body conv_algo + check_evar_instance unify flags evd evk' body with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) | CannotProject (evd,ev'') -> @@ -1555,7 +1608,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | [x] -> x | _ -> let (evd,evar'',ev'') = - materialize_evar (evar_define conv_algo ~choose) env' !evdref k ev ty in + materialize_evar (evar_define unify flags ~choose) env' !evdref k ev ty in evdref := restrict_evar evd (fst ev'') None (UpdateWith candidates); evar'') | None -> @@ -1585,7 +1638,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = else let t' = imitate (env,0) rhs in if !progress then - (recheck_applications conv_algo (evar_env evi) evdref t'; t') + (recheck_applications unify flags (evar_env evi) evdref t'; t') else t' in (!evdref,body) @@ -1594,46 +1647,30 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = * [define] tries to find an instance lhs such that * "lhs [hyps:=args]" unifies to rhs. The term "lhs" must be closed in * context "hyps" and not referring to itself. + * ev is assumed not to be frozen. *) -and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = +and evar_define unify flags ?(choose=false) ?(imitate_defs=true) env evd pbty (evk,argsv as ev) rhs = match EConstr.kind evd rhs with | Evar (evk2,argsv2 as ev2) -> if Evar.equal evk evk2 then solve_refl ~can_drop:choose - (test_success conv_algo) env evd pbty evk argsv argsv2 + (test_success unify) flags env evd pbty evk argsv argsv2 else solve_evar_evar ~force:choose - (evar_define conv_algo) conv_algo env evd pbty ev ev2 + (evar_define unify flags) unify flags env evd pbty ev ev2 | _ -> - try solve_candidates conv_algo env evd ev rhs + try solve_candidates unify flags env evd ev rhs with NoCandidates -> try - let (evd',body) = invert_definition conv_algo choose env evd pbty ev rhs in + let (evd',body) = invert_definition unify flags choose imitate_defs env evd pbty ev rhs in if occur_meta evd' body then raise MetaOccurInBodyInternal; (* invert_definition may have instantiate some evars of rhs with evk *) (* so we recheck acyclicity *) if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) let evd', body = refresh_universes pbty env evd' body in -(* Cannot strictly type instantiations since the unification algorithm - * does not unify applications from left to right. - * e.g problem f x == g y yields x==y and f==g (in that order) - * Another problem is that type variables are evars of type Type - let _ = - try - let env = evar_filtered_env evi in - let ty = evi.evar_concl in - Typing.check env evd' body ty - with e -> - msg_info - (str "Ill-typed evar instantiation: " ++ fnl() ++ - pr_evar_map evd' ++ fnl() ++ - str "----> " ++ int ev ++ str " := " ++ - print_constr body); - raise e in*) - let evd' = check_evar_instance evd' evk body conv_algo in - Evd.define evk body evd' + instantiate_evar unify flags evd' evk body with | NotEnoughInformationToProgress sols -> postpone_non_unique_projection env evd pbty ev sols rhs @@ -1648,8 +1685,8 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = let c = whd_all env evd rhs in match EConstr.kind evd c with | Evar (evk',argsv2) when Evar.equal evk evk' -> - solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma c c') - env evd pbty evk argsv argsv2 + solve_refl (fun flags _b env sigma pb c c' -> is_fconv pb env sigma c c') flags + env evd pbty evk argsv argsv2 | _ -> raise (OccurCheckIn (evd,rhs)) @@ -1683,13 +1720,13 @@ let status_changed evd lev (pbty,_,t1,t2) = (try Evar.Set.mem (head_evar evd t1) lev with NoHeadEvar -> false) || (try Evar.Set.mem (head_evar evd t2) lev with NoHeadEvar -> false) -let reconsider_unif_constraints conv_algo evd = +let reconsider_unif_constraints unify flags evd = let (evd,pbs) = extract_changed_conv_pbs evd (status_changed evd) in List.fold_left (fun p (pbty,env,t1,t2 as x) -> match p with | Success evd -> - (match conv_algo env evd pbty t1 t2 with + (match unify flags TermUnification env evd pbty t1 t2 with | Success _ as x -> x | UnifFailure (i,e) -> UnifFailure (i,CannotSolveConstraint (x,e))) | UnifFailure _ as x -> x) @@ -1702,11 +1739,12 @@ let reconsider_unif_constraints conv_algo evd = * if the problem couldn't be solved. *) (* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *) -let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = +let solve_simple_eqn unify flags ?(choose=false) ?(imitate_defs=true) + env evd (pbty,(evk1,args1 as ev1),t2) = try let t2 = whd_betaiota evd t2 in (* includes whd_evar *) - let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in - reconsider_unif_constraints conv_algo evd + let evd = evar_define unify flags ~choose ~imitate_defs env evd pbty ev1 t2 in + reconsider_unif_constraints unify flags evd with | NotInvertibleUsingOurAlgorithm t -> UnifFailure (evd,NotClean (ev1,env,t)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 4665ed29a2..ebf8230bbd 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -16,6 +16,25 @@ type alias val of_alias : alias -> EConstr.t +type unify_flags = { + modulo_betaiota : bool; + (* Enable beta-iota reductions during unification *) + open_ts : TransparentState.t; + (* Enable delta reduction according to open_ts for open terms *) + closed_ts : TransparentState.t; + (* Enable delta reduction according to closed_ts for closed terms (when calling conversion) *) + subterm_ts : TransparentState.t; + (* Enable delta reduction according to subterm_ts for selection of subterms during higher-order + unifications. *) + frozen_evars : Evar.Set.t; + (* Frozen evars are treated like rigid variables during unification: they can not be instantiated. *) + allow_K_at_toplevel : bool; + (* During higher-order unifications, allow to produce K-redexes: i.e. to produce + an abstraction for an unused argument *) + with_cs : bool + (* Enable canonical structure resolution during unification *) +} + type unification_result = | Success of evar_map | UnifFailure of evar_map * Pretype_errors.unification_error @@ -26,19 +45,49 @@ val is_success : unification_result -> bool their representative that is most ancient in the context *) val expand_vars_in_term : env -> evar_map -> constr -> constr +(** One might want to use different conversion strategies for types and terms: + e.g. preventing delta reductions when doing term unifications but allowing + arbitrary delta conversion when checking the types of evar instances. *) + +type unification_kind = + | TypeUnification + | TermUnification + +(** A unification function parameterized by: + - unification flags + - the kind of unification + - environment + - sigma + - conversion problem + - the two terms to unify. *) +type unifier = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> unification_result + +(** A conversion function: parameterized by the kind of unification, + environment, sigma, conversion problem and the two terms to convert. + Conversion is not allowed to instantiate evars contrary to unification. *) +type conversion_check = unify_flags -> unification_kind -> + env -> evar_map -> conv_pb -> constr -> constr -> bool + +(** [instantiate_evar unify flags env sigma ev c] defines the evar [ev] with [c], + checking that the type of [c] is unifiable with [ev]'s declared type first. + + Preconditions: + - [ev] does not occur in [c]. + - [c] does not contain any Meta(_) + *) + +val instantiate_evar : unifier -> unify_flags -> evar_map -> + Evar.t -> constr -> evar_map + (** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]), possibly solving related unification problems, possibly leaving open some problems that cannot be solved in a unique way (except if choose is true); fails if the instance is not valid for the given [ev] *) -type conv_fun = - env -> evar_map -> conv_pb -> constr -> constr -> unification_result - -type conv_fun_bool = - env -> evar_map -> conv_pb -> constr -> constr -> bool +val evar_define : unifier -> unify_flags -> ?choose:bool -> ?imitate_defs:bool -> + env -> evar_map -> bool option -> existential -> constr -> evar_map -val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> - bool option -> existential -> constr -> evar_map val refresh_universes : ?status:Evd.rigid -> @@ -49,18 +98,18 @@ val refresh_universes : bool option (* direction: true for levels lower than the existing levels *) -> env -> evar_map -> types -> evar_map * types -val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map -> +val solve_refl : ?can_drop:bool -> conversion_check -> unify_flags -> env -> evar_map -> bool option -> Evar.t -> constr array -> constr array -> evar_map val solve_evar_evar : ?force:bool -> (env -> evar_map -> bool option -> existential -> constr -> evar_map) -> - conv_fun -> + unifier -> unify_flags -> env -> evar_map -> bool option -> existential -> existential -> evar_map -val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> +val solve_simple_eqn : unifier -> unify_flags -> ?choose:bool -> ?imitate_defs:bool -> env -> evar_map -> bool option * existential * constr -> unification_result -val reconsider_unif_constraints : conv_fun -> evar_map -> unification_result +val reconsider_unif_constraints : unifier -> unify_flags -> evar_map -> unification_result val is_unification_pattern_evar : env -> evar_map -> existential -> constr list -> constr -> alias list option @@ -75,8 +124,8 @@ val noccur_evar : env -> evar_map -> Evar.t -> constr -> bool exception IllTypedInstance of env * types * types (* May raise IllTypedInstance if types are not convertible *) -val check_evar_instance : - evar_map -> Evar.t -> constr -> conv_fun -> evar_map +val check_evar_instance : unifier -> unify_flags -> + evar_map -> Evar.t -> constr -> evar_map val remove_instance_local_defs : evar_map -> Evar.t -> 'a array -> 'a list diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index b16087031b..7019cdf046 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -70,7 +70,7 @@ let map_named_declaration_with_hyploc f hyploc acc decl = in match decl,hyploc with | LocalAssum (id,_), InHypValueOnly -> - error_occurrences_error (IncorrectInValueOccurrence id) + error_occurrences_error (IncorrectInValueOccurrence id.Context.binder_name) | LocalAssum (id,typ), _ -> let acc,typ = f acc typ in acc, LocalAssum (id,typ) | LocalDef (id,body,typ), InHypTypeOnly -> @@ -125,7 +125,7 @@ let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = end; add_subst t subst; incr pos; (* Check nested matching subterms *) - if occs != Locus.AllOccurrences && occs != Locus.NoOccurrences then + if not (Locusops.is_all_occurrences occs) && occs != Locus.NoOccurrences then begin nested := true; ignore (subst_below k t); nested := false end; (* Do the effective substitution *) Vars.lift k (bywhat ())) diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index d6b204561e..cd82b1993b 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -92,7 +92,7 @@ let push_rec_types ~hypnaming sigma (lna,typarray) env = let open Context.Rel.Declaration in let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in let env,ctx = Array.fold_left_map (fun e assum -> let (d,e) = push_rel sigma assum e ~hypnaming in (e,d)) env ctxt in - Array.map get_name ctx, env + Array.map get_annot ctx, env let new_evar env sigma ?src ?naming typ = let open Context.Named.Declaration in diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 63f72e60bd..65ae495135 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -50,7 +50,7 @@ val vars_of_env : t -> Id.Set.t val push_rel : hypnaming:naming_mode -> evar_map -> rel_declaration -> t -> rel_declaration * t val push_rel_context : hypnaming:naming_mode -> ?force_names:bool -> evar_map -> rel_context -> t -> rel_context * t -val push_rec_types : hypnaming:naming_mode -> evar_map -> Name.t array * constr array -> t -> Name.t array * t +val push_rec_types : hypnaming:naming_mode -> evar_map -> Name.t Context.binder_annot array * constr array -> t -> Name.t Context.binder_annot array * t (** Declare an evar using renaming information *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 68626597fc..affed5389f 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -514,12 +514,11 @@ let rec cases_pattern_of_glob_constr na c = ) c open Declarations -open Term open Context (* Keep only patterns which are not bound to a local definitions *) -let drop_local_defs typi args = - let (decls,_) = decompose_prod_assum typi in +let drop_local_defs params decls args = + let decls = List.skipn (Rel.length params) (List.rev decls) in let rec aux decls args = match decls, args with | [], [] -> [] @@ -531,7 +530,7 @@ let drop_local_defs typi args = end | Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args | _ -> assert false in - aux (List.rev decls) args + aux decls args let add_patterns_for_params_remove_local_defs (ind,j) l = let (mib,mip) = Global.lookup_inductive ind in @@ -540,9 +539,8 @@ let add_patterns_for_params_remove_local_defs (ind,j) l = if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then (* Optimisation *) l else - let typi = mip.mind_nf_lc.(j-1) in - let (_,typi) = decompose_prod_n_assum (Rel.length mib.mind_params_ctxt) typi in - drop_local_defs typi l in + let (ctx, _) = mip.mind_nf_lc.(j - 1) in + drop_local_defs mib.mind_params_ctxt ctx l in Util.List.addn nparams (DAst.make @@ PatVar Anonymous) l let add_alias ?loc na c = diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index 8670c1d964..c57cf88cc6 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -24,6 +24,7 @@ type existential_name = Id.t (** Sorts *) type 'a glob_sort_gen = + | GSProp (** representation of [SProp] literal *) | GProp (** representation of [Prop] literal *) | GSet (** representation of [Set] literal *) | GType of 'a (** representation of [Type] literal *) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index bd321d5886..4f940fa16a 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -21,6 +21,7 @@ open Globnames open Nameops open Term open Constr +open Context open Vars open Namegen open Declarations @@ -43,8 +44,8 @@ exception RecursionSchemeError of env * recursion_scheme_error let named_hd env t na = named_hd env (Evd.from_env env) (EConstr.of_constr t) na let name_assumption env = function -| LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) -| LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) +| LocalAssum (na,t) -> LocalAssum (map_annot (named_hd env t) na, t) +| LocalDef (na,c,t) -> LocalDef (map_annot (named_hd env c) na, c, t) let mkLambda_or_LetIn_name env d b = mkLambda_or_LetIn (name_assumption env d) b let mkProd_or_LetIn_name env d b = mkProd_or_LetIn (name_assumption env d) b @@ -54,7 +55,7 @@ let it_mkProd_or_LetIn_name env b l = List.fold_left (fun c d -> mkProd_or_LetIn let it_mkLambda_or_LetIn_name env b l = List.fold_left (fun c d -> mkLambda_or_LetIn_name env d c) b l let make_prod_dep dep env = if dep then mkProd_name env else mkProd -let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c) +let mkLambda_string s r t c = mkLambda (make_annot (Name (Id.of_string s)) r, t, c) (*******************************************) @@ -79,6 +80,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let indf = make_ind_family(pind, Context.Rel.to_extended_list mkRel 0 lnamespar) in let constrs = get_constructors env indf in let projs = get_projections env ind in + let relevance = Sorts.relevance_of_sort_family kind in let () = if Option.is_empty projs then check_privacy_block mib in let () = @@ -98,11 +100,13 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let nbprod = k+1 in let indf' = lift_inductive_family nbprod indf in - let arsign,_ = get_arity env indf' in + let arsign,sort = get_arity env indf' in + let r = Sorts.relevance_of_sort_family sort in let depind = build_dependent_inductive env indf' in - let deparsign = LocalAssum (Anonymous,depind)::arsign in + let deparsign = LocalAssum (make_annot Anonymous r,depind)::arsign in - let ci = make_case_info env (fst pind) RegularStyle in + let rci = relevance in + let ci = make_case_info env (fst pind) rci RegularStyle in let pbody = appvect (mkRel (ndepar + nbprod), @@ -111,7 +115,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let p = it_mkLambda_or_LetIn_name env' ((if dep then mkLambda_name env' else mkLambda) - (Anonymous,depind,pbody)) + (make_annot Anonymous r,depind,pbody)) arsign in let obj = @@ -132,16 +136,16 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = else let cs = lift_constructor (k+1) constrs.(k) in let t = build_branch_type env sigma dep (mkRel (k+1)) cs in - mkLambda_string "f" t - (add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1)) + mkLambda_string "f" relevance t + (add_branch (push_rel (LocalAssum (make_annot Anonymous relevance, t)) env) (k+1)) in let (sigma, s) = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg sigma kind in let typP = make_arity env' sigma dep indf s in let typP = EConstr.Unsafe.to_constr typP in let c = it_mkLambda_or_LetIn_name env - (mkLambda_string "P" typP - (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar + (mkLambda_string "P" Sorts.Relevant typP + (add_branch (push_rel (LocalAssum (make_annot Anonymous Sorts.Relevant,typP)) env') 0)) lnamespar in (sigma, c) @@ -171,12 +175,12 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let p' = EConstr.Unsafe.to_constr p' in let largs = List.map EConstr.Unsafe.to_constr largs in match kind p' with - | Prod (n,t,c) -> - let d = LocalAssum (n,t) in - make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) - | LetIn (n,b,t,c) when List.is_empty largs -> - let d = LocalDef (n,b,t) in - mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) + | Prod (n,t,c) -> + let d = LocalAssum (n,t) in + make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) + | LetIn (n,b,t,c) when List.is_empty largs -> + let d = LocalDef (n,b,t) in + mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) | Ind (_,_) -> let realargs = List.skipn nparams largs in let base = applist (lift i pk,realargs) in @@ -208,23 +212,24 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = (match optionpos with | None -> make_prod env - (n,t, - process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest + (n,t, + process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest (nhyps-1) (i::li)) | Some(dep',p) -> let nP = lift (i+1+decP) p in let env' = push_rel (LocalAssum (n,t)) env in - let t_0 = process_pos env' dep' nP (lift 1 t) in + let t_0 = process_pos env' dep' nP (lift 1 t) in + let r_0 = Retyping.relevance_of_type env' sigma (EConstr.of_constr t_0) in make_prod_dep (dep || dep') env (n,t, - mkArrow t_0 + mkArrow t_0 r_0 (process_constr - (push_rel (LocalAssum (Anonymous,t_0)) env') + (push_rel (LocalAssum (make_annot Anonymous n.binder_relevance,t_0)) env') (i+2) (lift 1 c_0) rest (nhyps-1) (i::li)))) | LetIn (n,b,t,c_0) -> - mkLetIn (n,b,t, + mkLetIn (n,b,t, process_constr - (push_rel (LocalDef (n,b,t)) env) + (push_rel (LocalDef (n,b,t)) env) (i+1) c_0 recargs (nhyps-1) li) | _ -> assert false else @@ -250,12 +255,12 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let p' = EConstr.Unsafe.to_constr p' in let largs = List.map EConstr.Unsafe.to_constr largs in match kind p' with - | Prod (n,t,c) -> - let d = LocalAssum (n,t) in - mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) - | LetIn (n,b,t,c) when List.is_empty largs -> - let d = LocalDef (n,b,t) in - mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) + | Prod (n,t,c) -> + let d = LocalAssum (n,t) in + mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) + | LetIn (n,b,t,c) when List.is_empty largs -> + let d = LocalDef (n,b,t) in + mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) | Ind _ -> let realargs = List.skipn nparrec largs and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect mkRel 0 hyps) in @@ -280,7 +285,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = (match optionpos with | None -> mkLambda_name env - (n,t,process_constr (push_rel d env) (i+1) + (n,t,process_constr (push_rel d env) (i+1) (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1)]))))) (cprest,rest)) | Some(_,f_0) -> @@ -288,12 +293,12 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let env' = push_rel d env in let arg = process_pos env' nF (lift 1 t) in mkLambda_name env - (n,t,process_constr env' (i+1) + (n,t,process_constr env' (i+1) (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg]))))) (cprest,rest))) | (LocalDef (n,c,t) as d)::cprest, rest -> mkLetIn - (n,c,t, + (n,c,t, process_constr (push_rel d env) (i+1) (lift 1 f) (cprest,rest)) | [],[] -> f @@ -329,25 +334,26 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = let recargpar = recargparn [] (nparams-nparrec) in let make_one_rec p = let makefix nbconstruct = - let rec mrec i ln ltyp ldef = function - | ((indi,u),mibi,mipi,dep,_)::rest -> - let tyi = snd indi in - let nctyi = - Array.length mipi.mind_consnames in (* nb constructeurs du type*) + let rec mrec i ln lrelevance ltyp ldef = function + | ((indi,u),mibi,mipi,dep,target_sort)::rest -> + let tyi = snd indi in + let nctyi = + Array.length mipi.mind_consnames in (* nb constructeurs du type*) - (* arity in the context of the fixpoint, i.e. + (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) - let args = Context.Rel.to_extended_list mkRel (nrec+nbconstruct) lnamesparrec in - let indf = make_ind_family((indi,u),args) in + let args = Context.Rel.to_extended_list mkRel (nrec+nbconstruct) lnamesparrec in + let indf = make_ind_family((indi,u),args) in - let arsign,_ = get_arity env indf in - let depind = build_dependent_inductive env indf in - let deparsign = LocalAssum (Anonymous,depind)::arsign in + let arsign,s = get_arity env indf in + let r = Sorts.relevance_of_sort_family s in + let depind = build_dependent_inductive env indf in + let deparsign = LocalAssum (make_annot Anonymous r,depind)::arsign in - let nonrecpar = Context.Rel.length lnonparrec in - let larsign = Context.Rel.length deparsign in - let ndepar = larsign - nonrecpar in - let dect = larsign+nrec+nbconstruct in + let nonrecpar = Context.Rel.length lnonparrec in + let larsign = Context.Rel.length deparsign in + let ndepar = larsign - nonrecpar in + let dect = larsign+nrec+nbconstruct in (* constructors in context of the Cases expr, i.e. P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) @@ -375,9 +381,10 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = (* Predicate in the context of the case *) - let depind' = build_dependent_inductive env indf' in - let arsign',_ = get_arity env indf' in - let deparsign' = LocalAssum (Anonymous,depind')::arsign' in + let depind' = build_dependent_inductive env indf' in + let arsign',s = get_arity env indf' in + let r = Sorts.relevance_of_sort_family s in + let deparsign' = LocalAssum (make_annot Anonymous r,depind')::arsign' in let pargs = let nrpar = Context.Rel.to_extended_list mkRel (2*ndepar) lnonparrec @@ -388,13 +395,15 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = in (* body of i-th component of the mutual fixpoint *) + let target_relevance = Sorts.relevance_of_sort_family target_sort in let deftyi = - let ci = make_case_info env indi RegularStyle in + let rci = target_relevance in + let ci = make_case_info env indi rci RegularStyle in let concl = applist (mkRel (dect+j+ndepar),pargs) in let pred = it_mkLambda_or_LetIn_name env ((if dep then mkLambda_name env else mkLambda) - (Anonymous,depind',concl)) + (make_annot Anonymous r,depind',concl)) arsign' in let obj = @@ -416,20 +425,21 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = in it_mkProd_or_LetIn_name env concl deparsign - in - mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (typtyi::ltyp) + in + mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (target_relevance::lrelevance) (typtyi::ltyp) (deftyi::ldef) rest | [] -> let fixn = Array.of_list (List.rev ln) in let fixtyi = Array.of_list (List.rev ltyp) in let fixdef = Array.of_list (List.rev ldef) in - let names = Array.make nrec (Name(Id.of_string "F")) in - mkFix ((fixn,p),(names,fixtyi,fixdef)) + let lrelevance = CArray.rev_of_list lrelevance in + let names = Array.map (fun r -> make_annot (Name(Id.of_string "F")) r) lrelevance in + mkFix ((fixn,p),(names,fixtyi,fixdef)) in - mrec 0 [] [] [] + mrec 0 [] [] [] [] in let rec make_branch env i = function - | ((indi,u),mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,sfam)::rest -> let tyi = snd indi in let nconstr = Array.length mipi.mind_consnames in let rec onerec env j = @@ -443,9 +453,10 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = let p_0 = type_rec_branch true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg - in - mkLambda_string "f" p_0 - (onerec (push_rel (LocalAssum (Anonymous,p_0)) env) (j+1)) + in + let r_0 = Sorts.relevance_of_sort_family sfam in + mkLambda_string "f" r_0 p_0 + (onerec (push_rel (LocalAssum (make_annot Anonymous r_0,p_0)) env) (j+1)) in onerec env 0 | [] -> makefix i listdepkind @@ -458,9 +469,9 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = evdref := sigma; res in let typP = make_arity env !evdref dep indf s in - let typP = EConstr.Unsafe.to_constr typP in - mkLambda_string "P" typP - (put_arity (push_rel (LocalAssum (Anonymous,typP)) env) (i+1) rest) + let typP = EConstr.Unsafe.to_constr typP in + mkLambda_string "P" Sorts.Relevant typP + (put_arity (push_rel (LocalAssum (anonR,typP)) env) (i+1) rest) | [] -> make_branch env 0 listdepkind in @@ -530,7 +541,7 @@ let weaken_sort_scheme env evd set sort npars term ty = mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) else let c',term' = drec (np-1) c in - mkProd (n, t, c'), mkLambda (n, t, term') + mkProd (n, t, c'), mkLambda (n, t, term') | LetIn (n,b,t,c) -> let c',term' = drec np c in mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type.") @@ -588,6 +599,7 @@ let build_induction_scheme env sigma pind dep kind = (*s Eliminations. *) let elimination_suffix = function + | InSProp -> "_sind" | InProp -> "_ind" | InSet -> "_rec" | InType -> "_rect" diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 4c02dc0f09..678aebfbe6 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -15,6 +15,7 @@ open Univ open Term open Constr open Vars +open Context open Termops open Declarations open Declareops @@ -60,6 +61,8 @@ let lift_inductive_family n = liftn_inductive_family n 1 let substnl_ind_family l n = map_ind_family (substnl l n) +let relevance_of_inductive_family env ((ind,_),_ : inductive_family) = + Inductive.relevance_of_inductive env ind type inductive_type = IndType of inductive_family * EConstr.constr list @@ -75,6 +78,9 @@ let lift_inductive_type n = liftn_inductive_type n 1 let substnl_ind_type l n = map_inductive_type (EConstr.Vars.substnl l n) +let relevance_of_inductive_type env (IndType (indf, _)) = + relevance_of_inductive_family env indf + let mkAppliedInd (IndType ((ind,params), realargs)) = let open EConstr in let ind = on_snd EInstance.make ind in @@ -101,7 +107,8 @@ let mis_nf_constructor_type ((ind,u),mib,mip) j = and nconstr = Array.length mip.mind_consnames in let make_Ik k = mkIndU (((fst ind),ntypes-k-1),u) in if j > nconstr then user_err Pp.(str "Not enough constructors in the type."); - substl (List.init ntypes make_Ik) (subst_instance_constr u specif.(j-1)) + let (ctx, cty) = specif.(j - 1) in + substl (List.init ntypes make_Ik) (subst_instance_constr u (Term.it_mkProd_or_LetIn cty ctx)) (* Number of constructors *) @@ -275,13 +282,12 @@ let has_dependent_elim mib = | NotRecord | FakeRecord -> true (* Annotation for cases *) -let make_case_info env ind style = +let make_case_info env ind r style = let (mib,mip) = Inductive.lookup_mind_specif env ind in let ind_tags = Context.Rel.to_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in let cstr_tags = - Array.map2 (fun c n -> - let d,_ = decompose_prod_assum c in + Array.map2 (fun (d, _) n -> Context.Rel.to_tags (List.firstn n d)) mip.mind_nf_lc mip.mind_consnrealdecls in let print_info = { ind_tags; cstr_tags; style } in @@ -289,6 +295,7 @@ let make_case_info env ind style = ci_npar = mib.mind_nparams; ci_cstr_ndecls = mip.mind_consnrealdecls; ci_cstr_nargs = mip.mind_consnrealargs; + ci_relevance = r; ci_pp_info = print_info } (*s Useful functions *) @@ -419,12 +426,14 @@ let build_dependent_inductive env ((ind, params) as indf) = (* builds the arity of an elimination predicate in sort [s] *) let make_arity_signature env sigma dep indf = - let (arsign,_) = get_arity env indf in + let (arsign,s) = get_arity env indf in + let r = Sorts.relevance_of_sort_family s in + let anon = make_annot Anonymous r in let arsign = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) arsign in if dep then (* We need names everywhere *) Namegen.name_context env sigma - ((LocalAssum (Anonymous,EConstr.of_constr (build_dependent_inductive env indf)))::arsign) + ((LocalAssum (anon,EConstr.of_constr (build_dependent_inductive env indf)))::arsign) (* Costly: would be better to name once for all at definition time *) else (* No need to enforce names *) @@ -457,12 +466,15 @@ let compute_projections env (kn, i as ind) = let x = match mib.mind_record with | NotRecord | FakeRecord -> anomaly Pp.(str "Trying to build primitive projections for a non-primitive record") - | PrimRecord info-> Name (pi1 (info.(i))) + | PrimRecord info -> + let id, _, _, _ = info.(i) in + make_annot (Name id) mib.mind_packets.(i).mind_relevance in let pkt = mib.mind_packets.(i) in let { mind_nparams = nparamargs; mind_params_ctxt = params } = mib in let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in - let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in + let ctx, cty = pkt.mind_nf_lc.(0) in + let rctx, _ = decompose_prod_assum (substl subst (Term.it_mkProd_or_LetIn cty ctx)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in (* We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not @@ -490,7 +502,7 @@ let compute_projections env (kn, i as ind) = let subst = c1 :: subst in (proj_arg, j+1, pbs, subst) | LocalAssum (na,t) -> - match na with + match na.binder_name with | Name id -> let lab = Label.of_id id in let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab in @@ -600,7 +612,7 @@ let is_predicate_explicitly_dep env sigma pred arsign = From Coq > 8.2, using or not the effective dependency of the predicate is parametrable! *) - begin match na with + begin match na.binder_name with | Anonymous -> false | Name _ -> true end @@ -622,9 +634,7 @@ let set_pattern_names env sigma ind brv = let (mib,mip) = Inductive.lookup_mind_specif env ind in let arities = Array.map - (fun c -> - Context.Rel.length ((prod_assum c)) - - mib.mind_nparams) + (fun (d, _) -> List.length d - mib.mind_nparams) mip.mind_nf_lc in Array.map2 (set_names env sigma) arities brv @@ -644,9 +654,10 @@ let type_case_branches_with_names env sigma indspec p c = (* Type of Case predicates *) let arity_of_case_predicate env (ind,params) dep k = - let arsign,_ = get_arity env (ind,params) in + let arsign,s = get_arity env (ind,params) in + let r = Sorts.relevance_of_sort_family s in let mind = build_dependent_inductive env (ind,params) in - let concl = if dep then mkArrow mind (mkSort k) else mkSort k in + let concl = if dep then mkArrow mind r (mkSort k) else mkSort k in Term.it_mkProd_or_LetIn concl arsign (***********************************************) @@ -721,7 +732,7 @@ let control_only_guard env sigma c = match kind c with | CoFix (_,(_,_,_) as cofix) -> Inductive.check_cofix e cofix - | Fix (_,(_,_,_) as fix) -> + | Fix fix -> Inductive.check_fix e fix | _ -> () in diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 5a4257e175..c74bbfe98b 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -38,6 +38,8 @@ val lift_inductive_family : int -> inductive_family -> inductive_family val substnl_ind_family : constr list -> int -> inductive_family -> inductive_family +val relevance_of_inductive_family : env -> inductive_family -> Sorts.relevance + (** An inductive type with its parameters and real arguments *) type inductive_type = IndType of inductive_family * EConstr.constr list val make_ind_type : inductive_family * EConstr.constr list -> inductive_type @@ -47,6 +49,8 @@ val liftn_inductive_type : int -> int -> inductive_type -> inductive_type val lift_inductive_type : int -> inductive_type -> inductive_type val substnl_ind_type : EConstr.constr list -> int -> inductive_type -> inductive_type +val relevance_of_inductive_type : env -> inductive_type -> Sorts.relevance + val mkAppliedInd : inductive_type -> EConstr.constr val mis_is_recursive_subset : int list -> wf_paths -> bool val mis_is_recursive : @@ -176,7 +180,7 @@ val type_case_branches_with_names : env -> evar_map -> pinductive * EConstr.constr list -> constr -> constr -> types array * types (** Annotation for cases *) -val make_case_info : env -> inductive -> case_style -> case_info +val make_case_info : env -> inductive -> Sorts.relevance -> case_style -> case_info (** Make a case or substitute projections if the inductive type is a record with primitive projections. diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml index bf8a38a353..fefc15dfb2 100644 --- a/pretyping/inferCumulativity.ml +++ b/pretyping/inferCumulativity.ml @@ -201,7 +201,7 @@ let infer_inductive env mie = Array.fold_left (fun variances u -> LMap.add u Variance.Irrelevant variances) LMap.empty uarray in - let env = Typeops.check_context env params in + let env, params = Typeops.check_context env params in let variances = List.fold_left (fun variances entry -> let variances = infer_arity_constructor true env variances entry.mind_entry_arity diff --git a/pretyping/locus.ml b/pretyping/locus.ml index 37dd120c1a..087a6b9174 100644 --- a/pretyping/locus.ml +++ b/pretyping/locus.ml @@ -20,6 +20,7 @@ type 'a or_var = type 'a occurrences_gen = | AllOccurrences + | AtLeastOneOccurrence | AllOccurrencesBut of 'a list (** non-empty *) | NoOccurrences | OnlyOccurrences of 'a list (** non-empty *) diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 6b6a3f8a9f..aaa4ce684d 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -19,15 +19,17 @@ let occurrences_map f = function | AllOccurrencesBut l -> let l' = f l in if l' = [] then AllOccurrences else AllOccurrencesBut l' - | (NoOccurrences|AllOccurrences) as o -> o + | (NoOccurrences|AllOccurrences|AtLeastOneOccurrence) as o -> o let convert_occs = function + | AtLeastOneOccurrence -> (false,[]) | AllOccurrences -> (false,[]) | AllOccurrencesBut l -> (false,l) | NoOccurrences -> (true,[]) | OnlyOccurrences l -> (true,l) let is_selected occ = function + | AtLeastOneOccurrence -> true | AllOccurrences -> true | AllOccurrencesBut l -> not (Int.List.mem occ l) | OnlyOccurrences l -> Int.List.mem occ l @@ -46,6 +48,11 @@ let is_nowhere = function | { onhyps=Some[]; concl_occs=NoOccurrences } -> true | _ -> false +let is_all_occurrences = function + | AtLeastOneOccurrence + | AllOccurrences -> true + | _ -> false + (** Clause conversion functions, parametrized by a hyp enumeration function *) (** From [clause] to [simple_clause] *) @@ -61,12 +68,12 @@ let simple_clause_of enum_hyps cl = List.map Option.make (enum_hyps ()) | Some l -> List.map (fun ((occs,id),w) -> - if occs <> AllOccurrences then error_occurrences (); + if not (is_all_occurrences occs) then error_occurrences (); if w = InHypValueOnly then error_body_selection (); Some id) l in if cl.concl_occs = NoOccurrences then hyps else - if cl.concl_occs <> AllOccurrences then error_occurrences () + if not (is_all_occurrences cl.concl_occs) then error_occurrences () else None :: hyps (** From [clause] to [concrete_clause] *) @@ -111,7 +118,7 @@ let clause_with_generic_occurrences cls = List.for_all (function ((AllOccurrences,_),_) -> true | _ -> false) hyps in let concl = match cls.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in hyps && concl @@ -122,6 +129,6 @@ let clause_with_generic_context_selection cls = List.for_all (function ((AllOccurrences,_),InHyp) -> true | _ -> false) hyps in let concl = match cls.concl_occs with - | AllOccurrences | NoOccurrences -> true + | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in hyps && concl diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli index a07c018c32..ac15fe1018 100644 --- a/pretyping/locusops.mli +++ b/pretyping/locusops.mli @@ -21,6 +21,8 @@ val convert_occs : occurrences -> bool * int list val is_selected : int -> occurrences -> bool +val is_all_occurrences : 'a occurrences_gen -> bool + (** Usual clauses *) val allHypsAndConcl : 'a clause_expr diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index b7090e69da..0b2d760ca8 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -10,6 +10,7 @@ open CErrors open Term open Constr +open Context open Vars open Environ open Reduction @@ -89,10 +90,12 @@ let invert_tag cst tag reloc_tbl = with Find_at j -> (j+1) let decompose_prod env t = - let (name,dom,codom as res) = destProd (whd_all env t) in - match name with - | Anonymous -> (Name (Id.of_string "x"),dom,codom) - | _ -> res + let (name,dom,codom) = destProd (whd_all env t) in + let name = map_annot (function + | Anonymous -> Name (Id.of_string "x") + | na -> na) name + in + (name,dom,codom) let app_type env c = let t = whd_all env c in @@ -107,7 +110,8 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib u typ params = +let type_constructor mind mib u (ctx, typ) params = + let typ = it_mkProd_or_LetIn typ ctx in let s = ind_subst mind mib u in let ctyp = substl s typ in let nparams = Array.length params in @@ -193,7 +197,7 @@ let rec nf_val env sigma v typ = | Vaccu accu -> nf_accu env sigma accu | Vfun f -> let lvl = nb_rel env in - let name,dom,codom = + let name,dom,codom = try decompose_prod env typ with DestKO -> CErrors.anomaly @@ -274,11 +278,13 @@ and nf_atom env sigma atom = | Asort s -> mkSort s | Avar id -> mkVar id | Aprod(n,dom,codom) -> - let dom = nf_type env sigma dom in - let vn = mk_rel_accu (nb_rel env) in - let env = push_rel (LocalAssum (n,dom)) env in - let codom = nf_type env sigma (codom vn) in - mkProd(n,dom,codom) + let dom, sdom = nf_type_sort env sigma dom in + let rdom = Sorts.relevance_of_sort sdom in + let n = make_annot n rdom in + let vn = mk_rel_accu (nb_rel env) in + let env = push_rel (LocalAssum (n,dom)) env in + let codom = nf_type env sigma (codom vn) in + mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv | Aproj (p, c) -> let c = nf_accu env sigma c in @@ -324,28 +330,34 @@ and nf_atom_type env sigma atom = let ci = ans.asw_ci in mkCase(ci, p, a, branchs), tcase | Afix(tt,ft,rp,s) -> - let tt = Array.map (fun t -> nf_type env sigma t) tt in - let name = Array.map (fun _ -> (Name (Id.of_string "Ffix"))) tt in + let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in + let tt = Array.map fst tt and rt = Array.map snd tt in + let name = Name (Id.of_string "Ffix") in + let names = Array.map (fun s -> make_annot name (Sorts.relevance_of_sort s)) rt in let lvl = nb_rel env in let nbfix = Array.length ft in let fargs = mk_rels_accu lvl (Array.length ft) in - (* Third argument of the tuple is ignored by push_rec_types *) - let env = push_rec_types (name,tt,[||]) env in + (* Body argument of the tuple is ignored by push_rec_types *) + let env = push_rec_types (names,tt,[||]) env in (* We lift here because the types of arguments (in tt) will be evaluated in an environment where the fixpoints have been pushed *) let norm_body i v = nf_val env sigma (napply v fargs) (lift nbfix tt.(i)) in let ft = Array.mapi norm_body ft in - mkFix((rp,s),(name,tt,ft)), tt.(s) + mkFix((rp,s),(names,tt,ft)), tt.(s) | Acofix(tt,ft,s,_) | Acofixe(tt,ft,s,_) -> - let tt = Array.map (nf_type env sigma) tt in - let name = Array.map (fun _ -> (Name (Id.of_string "Fcofix"))) tt in + let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in + let tt = Array.map fst tt and rt = Array.map snd tt in + let name = Name (Id.of_string "Fcofix") in let lvl = nb_rel env in + let names = Array.map (fun s -> make_annot name (Sorts.relevance_of_sort s)) rt in let fargs = mk_rels_accu lvl (Array.length ft) in - let env = push_rec_types (name,tt,[||]) env in + let env = push_rec_types (names,tt,[||]) env in let ft = Array.mapi (fun i v -> nf_val env sigma (napply v fargs) tt.(i)) ft in - mkCoFix(s,(name,tt,ft)), tt.(s) + mkCoFix(s,(names,tt,ft)), tt.(s) | Aprod(n,dom,codom) -> let dom,s1 = nf_type_sort env sigma dom in + let r1 = Sorts.relevance_of_sort s1 in + let n = make_annot n r1 in let vn = mk_rel_accu (nb_rel env) in let env = push_rel (LocalAssum (n,dom)) env in let codom,s2 = nf_type_sort env sigma (codom vn) in @@ -389,6 +401,8 @@ and nf_predicate env sigma ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in + let r = Inductive.relevance_of_inductive env (fst ind) in + let name = make_annot name r in let body = nf_type (push_rel (LocalAssum (name,dom)) env) sigma vb in mkLambda(name,dom,body) | _ -> nf_type env sigma v diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 6803ea7d9b..13034d078a 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -15,6 +15,7 @@ open Globnames open Nameops open Term open Constr +open Context open Glob_term open Pp open Mod_subst @@ -153,16 +154,20 @@ let pattern_of_constr env sigma t = | Rel n -> PRel n | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) | Var id -> PVar id + | Sort SProp -> PSort GSProp | Sort Prop -> PSort GProp | Sort Set -> PSort GSet | Sort (Type _) -> PSort (GType []) | Cast (c,_,_) -> pattern_of_constr env c - | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c,Some (pattern_of_constr env t), - pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b) - | Prod (na,c,b) -> PProd (na,pattern_of_constr env c, - pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) - | Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c, - pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) + | LetIn (na,c,t,b) -> PLetIn (na.binder_name, + pattern_of_constr env c,Some (pattern_of_constr env t), + pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b) + | Prod (na,c,b) -> PProd (na.binder_name, + pattern_of_constr env c, + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) + | Lambda (na,c,b) -> PLambda (na.binder_name, + pattern_of_constr env c, + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) | App (f,a) -> (match match kind f with @@ -206,12 +211,12 @@ let pattern_of_constr env sigma t = | Fix (lni,(lna,tl,bl)) -> let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in - PFix (lni,(lna,Array.map (pattern_of_constr env) tl, + PFix (lni,(Array.map binder_name lna,Array.map (pattern_of_constr env) tl, Array.map (pattern_of_constr env') bl)) | CoFix (ln,(lna,tl,bl)) -> let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in - PCoFix (ln,(lna,Array.map (pattern_of_constr env) tl, + PCoFix (ln,(Array.map binder_name lna,Array.map (pattern_of_constr env) tl, Array.map (pattern_of_constr env') bl)) | Int i -> PInt i in pattern_of_constr env t diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index dc6607557d..35a7036af4 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -60,6 +60,7 @@ type pretype_error = | CannotUnifyOccurrences of subterm_unification_error | UnsatisfiableConstraints of (Evar.t * Evar_kinds.t) option * Evar.Set.t option + | DisallowedSProp exception PretypeError of env * Evd.evar_map * pretype_error @@ -107,9 +108,9 @@ let error_ill_typed_rec_body ?loc env sigma i na jl tys = raise_type_error ?loc (env, sigma, IllTypedRecBody (i, na, jl, tys)) -let error_elim_arity ?loc env sigma pi s c j a = +let error_elim_arity ?loc env sigma pi c j a = raise_type_error ?loc - (env, sigma, ElimArity (pi, s, c, j, a)) + (env, sigma, ElimArity (pi, c, j, a)) let error_not_a_type ?loc env sigma j = raise_type_error ?loc (env, sigma, NotAType j) @@ -171,6 +172,9 @@ let error_var_not_found ?loc env sigma s = let error_evar_not_found ?loc env sigma id = raise_pretype_error ?loc (env, sigma, EvarNotFound id) +let error_disallowed_sprop env sigma = + raise (PretypeError (env, sigma, DisallowedSProp)) + (*s Typeclass errors *) let unsatisfiable_constraints env evd ev comp = diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index a0d459fe6b..a9e2b0ea8f 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -67,6 +67,7 @@ type pretype_error = | UnsatisfiableConstraints of (Evar.t * Evar_kinds.t) option * Evar.Set.t option (** unresolvable evar, connex component *) + | DisallowedSProp exception PretypeError of env * Evd.evar_map * pretype_error @@ -101,12 +102,12 @@ val error_number_branches : val error_ill_typed_rec_body : ?loc:Loc.t -> env -> Evd.evar_map -> - int -> Name.t array -> unsafe_judgment array -> types array -> 'b + int -> Name.t Context.binder_annot array -> unsafe_judgment array -> types array -> 'b val error_elim_arity : ?loc:Loc.t -> env -> Evd.evar_map -> - pinductive -> Sorts.family list -> constr -> - unsafe_judgment -> (Sorts.family * Sorts.family * arity_error) option -> 'b + pinductive -> constr -> + unsafe_judgment -> (Sorts.family list * Sorts.family * Sorts.family * arity_error) option -> 'b val error_not_a_type : ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b @@ -158,6 +159,8 @@ val error_var_not_found : ?loc:Loc.t -> env -> Evd.evar_map -> Id.t -> 'b val error_evar_not_found : ?loc:Loc.t -> env -> Evd.evar_map -> Id.t -> 'b +val error_disallowed_sprop : env -> Evd.evar_map -> 'a + (** {6 Typeclass errors } *) val unsatisfiable_constraints : env -> Evd.evar_map -> Evar.t option -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index a92b245b91..8e9a2e114b 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -29,7 +29,7 @@ open Util open Names open Evd open Constr -open Term +open Context open Termops open Environ open EConstr @@ -266,7 +266,7 @@ let apply_inference_hook hook env sigma frozen = match frozen with let apply_heuristics env sigma fail_evar = (* Resolve eagerly, potentially making wrong choices *) try solve_unif_constraints_with_heuristics - ~ts:(Typeclasses.classes_transparent_state ()) env sigma + ~flags:(default_flags_of (Typeclasses.classes_transparent_state ())) env sigma with e when CErrors.noncritical e -> let e = CErrors.push e in if fail_evar then iraise e else sigma @@ -399,11 +399,13 @@ let pretype_id pretype k0 loc env sigma id = (* Main pretyping function *) let interp_known_glob_level ?loc evd = function + | GSProp -> Univ.Level.sprop | GProp -> Univ.Level.prop | GSet -> Univ.Level.set | GType s -> interp_known_level_info ?loc evd s let interp_glob_level ?loc evd : glob_level -> _ = function + | GSProp -> evd, Univ.Level.sprop | GProp -> evd, Univ.Level.prop | GSet -> evd, Univ.Level.set | GType s -> interp_level_info ?loc evd s @@ -448,11 +450,12 @@ let pretype_ref ?loc sigma env ref us = let judge_of_Type ?loc evd s = let evd, s = interp_universe ?loc evd s in let judge = - { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } + { uj_val = mkType s; uj_type = mkType (Univ.super s) } in evd, judge let pretype_sort ?loc sigma = function + | GSProp -> sigma, judge_of_sprop | GProp -> sigma, judge_of_prop | GSet -> sigma, judge_of_set | GType s -> judge_of_Type ?loc sigma s @@ -473,8 +476,8 @@ let mark_obligation_evar sigma k evc = let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in - let pretype_type = pretype_type k0 resolve_tc in - let pretype = pretype k0 resolve_tc in + let pretype_type = pretype_type ~program_mode k0 resolve_tc in + let pretype = pretype ~program_mode k0 resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in match DAst.get t with @@ -483,7 +486,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon | GVar id -> - let sigma, t_id = pretype_id (fun e r t -> pretype ~program_mode tycon e r t) k0 loc env sigma id in + let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) k0 loc env sigma id in inh_conv_coerce_to_tycon ?loc env sigma t_id tycon | GEvar (id, inst) -> @@ -535,21 +538,23 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo let rec type_bl env sigma ctxt = function | [] -> sigma, ctxt | (na,bk,None,ty)::bl -> - let sigma, ty' = pretype_type ~program_mode empty_valcon env sigma ty in - let dcl = LocalAssum (na, ty'.utj_val) in + let sigma, ty' = pretype_type empty_valcon env sigma ty in + let rty' = Sorts.relevance_of_sort ty'.utj_type in + let dcl = LocalAssum (make_annot na rty', ty'.utj_val) in let dcl', env = push_rel ~hypnaming sigma dcl env in type_bl env sigma (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> - let sigma, ty' = pretype_type ~program_mode empty_valcon env sigma ty in - let sigma, bd' = pretype ~program_mode (mk_tycon ty'.utj_val) env sigma bd in - let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in + let sigma, ty' = pretype_type empty_valcon env sigma ty in + let rty' = Sorts.relevance_of_sort ty'.utj_type in + let sigma, bd' = pretype (mk_tycon ty'.utj_val) env sigma bd in + let dcl = LocalDef (make_annot na rty', bd'.uj_val, ty'.utj_val) in let dcl', env = push_rel ~hypnaming sigma dcl env in type_bl env sigma (Context.Rel.add dcl' ctxt) bl in let sigma, ctxtv = Array.fold_left_map (fun sigma -> type_bl env sigma Context.Rel.empty) sigma bl in let sigma, larj = Array.fold_left2_map (fun sigma e ar -> - pretype_type ~program_mode empty_valcon (snd (push_rel_context ~hypnaming sigma e env)) sigma ar) + pretype_type empty_valcon (snd (push_rel_context ~hypnaming sigma e env)) sigma ar) sigma ctxtv lar in let lara = Array.map (fun a -> a.utj_val) larj in let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in @@ -562,12 +567,16 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo | GFix (vn,i) -> i | GCoFix i -> i in - begin match conv !!env sigma ftys.(fixi) t with - | None -> sigma - | Some sigma -> sigma + begin match Evarconv.unify_delay !!env sigma ftys.(fixi) t with + | exception Evarconv.UnableToUnify _ -> sigma + | sigma -> sigma end | None -> sigma in + let names = Array.map2 (fun na t -> + make_annot na (Retyping.relevance_of_type !!(env) sigma t)) + names ftys + in (* Note: bodies are not used by push_rec_types, so [||] is safe *) let names,newenv = push_rec_types ~hypnaming sigma (names,ftys) env in let sigma, vdefj = @@ -579,7 +588,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo decompose_prod_n_assum sigma (Context.Rel.length ctxt) (lift nbfix ftys.(i)) in let ctxt,nenv = push_rel_context ~hypnaming sigma ctxt newenv in - let sigma, j = pretype ~program_mode (mk_tycon ty) nenv sigma def in + let sigma, j = pretype (mk_tycon ty) nenv sigma def in sigma, { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) sigma ctxtv vdef in @@ -602,10 +611,10 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) vn) in - let fixdecls = (names,ftys,fdefs) in + let fixdecls = (names,ftys,fdefs) in let indexes = esearch_guard ?loc !!env sigma possible_indexes fixdecls in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | GCoFix i -> + | GCoFix i -> let fixdecls = (names,ftys,fdefs) in let cofix = (i, fixdecls) in (try check_cofix !!env (i, nf_fix sigma fixdecls) @@ -622,7 +631,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo inh_conv_coerce_to_tycon ?loc env sigma j tycon | GApp (f,args) -> - let sigma, fj = pretype ~program_mode empty_tycon env sigma f in + let sigma, fj = pretype empty_tycon env sigma f in let floc = loc_of_glob_constr f in let length = List.length args in let candargs = @@ -665,24 +674,24 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo match EConstr.kind sigma resty with | Prod (na,c1,c2) -> let tycon = Some c1 in - let sigma, hj = pretype ~program_mode tycon env sigma c in + let sigma, hj = pretype tycon env sigma c in let sigma, candargs, ujval = match candargs with | [] -> sigma, [], j_val hj | arg :: args -> - begin match conv !!env sigma (j_val hj) arg with - | Some sigma -> - sigma, args, nf_evar sigma (j_val hj) - | None -> + begin match Evarconv.unify_delay !!env sigma (j_val hj) arg with + | exception Evarconv.UnableToUnify _ -> sigma, [], j_val hj + | sigma -> + sigma, args, nf_evar sigma (j_val hj) end in - let sigma, ujval = adjust_evar_source sigma na ujval in - let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in + let sigma, ujval = adjust_evar_source sigma na.binder_name ujval in + let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in let j = { uj_val = value; uj_type = typ } in apply_rec env sigma (n+1) j candargs rest | _ -> - let sigma, hj = pretype ~program_mode empty_tycon env sigma c in + let sigma, hj = pretype empty_tycon env sigma c in error_cant_apply_not_functional ?loc:(Loc.merge_opt floc argloc) !!env sigma resj [|hj|] in @@ -712,26 +721,28 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo in let sigma, (name',dom,rng) = split_tycon ?loc !!env sigma tycon' in let dom_valcon = valcon_of_tycon dom in - let sigma, j = pretype_type ~program_mode dom_valcon env sigma c1 in + let sigma, j = pretype_type dom_valcon env sigma c1 in + let name = {binder_name=name; binder_relevance=Sorts.relevance_of_sort j.utj_type} in let var = LocalAssum (name, j.utj_val) in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let var',env' = push_rel ~hypnaming sigma var env in - let sigma, j' = pretype ~program_mode rng env' sigma c2 in + let sigma, j' = pretype rng env' sigma c2 in let name = get_name var' in - let resj = judge_of_abstraction !!env (orelse_name name name') j j' in + let resj = judge_of_abstraction !!env (orelse_name name name'.binder_name) j j' in inh_conv_coerce_to_tycon ?loc env sigma resj tycon | GProd(name,bk,c1,c2) -> - let sigma, j = pretype_type ~program_mode empty_valcon env sigma c1 in + let sigma, j = pretype_type empty_valcon env sigma c1 in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let sigma, name, j' = match name with | Anonymous -> - let sigma, j = pretype_type ~program_mode empty_valcon env sigma c2 in + let sigma, j = pretype_type empty_valcon env sigma c2 in sigma, name, { j with utj_val = lift 1 j.utj_val } | Name _ -> - let var = LocalAssum (name, j.utj_val) in + let r = Sorts.relevance_of_sort j.utj_type in + let var = LocalAssum (make_annot name r, j.utj_val) in let var, env' = push_rel ~hypnaming sigma var env in - let sigma, c2_j = pretype_type ~program_mode empty_valcon env' sigma c2 in + let sigma, c2_j = pretype_type empty_valcon env' sigma c2 in sigma, get_name var, c2_j in let resj = @@ -747,24 +758,25 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo let sigma, tycon1 = match t with | Some t -> - let sigma, t_j = pretype_type ~program_mode empty_valcon env sigma t in + let sigma, t_j = pretype_type empty_valcon env sigma t in sigma, mk_tycon t_j.utj_val | None -> sigma, empty_tycon in - let sigma, j = pretype ~program_mode tycon1 env sigma c1 in + let sigma, j = pretype tycon1 env sigma c1 in let sigma, t = Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma j.uj_type in - let var = LocalDef (name, j.uj_val, t) in + let r = Retyping.relevance_of_term !!env sigma j.uj_val in + let var = LocalDef (make_annot name r, j.uj_val, t) in let tycon = lift_tycon 1 tycon in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let var, env = push_rel ~hypnaming sigma var env in - let sigma, j' = pretype ~program_mode tycon env sigma c2 in + let sigma, j' = pretype tycon env sigma c2 in let name = get_name var in - sigma, { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + sigma, { uj_val = mkLetIn (make_annot name r, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (nal,(na,po),c,d) -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type with Not_found -> @@ -788,10 +800,11 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo | Some ps -> let rec aux n k names l = match names, l with - | na :: names, (LocalAssum (_,t) :: l) -> + | na :: names, (LocalAssum (na', t) :: l) -> let t = EConstr.of_constr t in let proj = Projection.make ps.(cs.cs_nargs - k) true in - LocalDef (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) + LocalDef ({na' with binder_name = na}, + lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) :: aux (n+1) (k + 1) names l | na :: names, (decl :: l) -> set_name na decl :: aux (n+1) k names l @@ -801,27 +814,27 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo let fsign = Context.Rel.map (whd_betaiota sigma) fsign in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let fsign,env_f = push_rel_context ~hypnaming sigma fsign env in - let obj ind p v f = + let obj ind rci p v f = if not record then - let f = it_mkLambda_or_LetIn f fsign in - let ci = make_case_info !!env (fst ind) LetStyle in - mkCase (ci, p, cj.uj_val,[|f|]) + let f = it_mkLambda_or_LetIn f fsign in + let ci = make_case_info !!env (fst ind) rci LetStyle in + mkCase (ci, p, cj.uj_val,[|f|]) else it_mkLambda_or_LetIn f fsign in (* Make dependencies from arity signature impossible *) - let arsgn = - let arsgn,_ = get_arity !!env indf in - List.map (set_name Anonymous) arsgn + let arsgn, indr = + let arsgn,s = get_arity !!env indf in + List.map (set_name Anonymous) arsgn, Sorts.relevance_of_sort_family s in let indt = build_dependent_inductive !!env indf in - let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) + let psign = LocalAssum (make_annot na indr, indt) :: arsgn in (* For locating names in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in let nar = List.length arsgn in let psign',env_p = push_rel_context ~hypnaming ~force_names:true sigma psign predenv in (match po with | Some p -> - let sigma, pj = pretype_type ~program_mode empty_valcon env_p sigma p in + let sigma, pj = pretype_type empty_valcon env_p sigma p in let ccl = nf_evar sigma pj.utj_val in let p = it_mkLambda_or_LetIn ccl psign' in let inst = @@ -829,17 +842,17 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo @[EConstr.of_constr (build_dependent_constructor cs)] in let lp = lift cs.cs_nargs p in let fty = hnf_lam_applist !!env sigma lp inst in - let sigma, fj = pretype ~program_mode (mk_tycon fty) env_f sigma d in + let sigma, fj = pretype (mk_tycon fty) env_f sigma d in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort !!env sigma ind cj.uj_val p; - obj ind p cj.uj_val fj.uj_val - in + let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in + obj ind rci p cj.uj_val fj.uj_val + in sigma, { uj_val = v; uj_type = (substl (realargs@[cj.uj_val]) ccl) } | None -> let tycon = lift_tycon cs.cs_nargs tycon in - let sigma, fj = pretype ~program_mode tycon env_f sigma d in + let sigma, fj = pretype tycon env_f sigma d in let ccl = nf_evar sigma fj.uj_type in let ccl = if noccur_between sigma 1 cs.cs_nargs ccl then @@ -851,12 +864,12 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign' in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort !!env sigma ind cj.uj_val p; - obj ind p cj.uj_val fj.uj_val + let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in + obj ind rci p cj.uj_val fj.uj_val in sigma, { uj_val = v; uj_type = ccl }) | GIf (c,(na,po),b1,b2) -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type with Not_found -> @@ -867,21 +880,21 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo user_err ?loc (str "If is only for inductive types with two constructors."); - let arsgn = - let arsgn,_ = get_arity !!env indf in + let arsgn, indr = + let arsgn,s = get_arity !!env indf in (* Make dependencies from arity signature impossible *) - List.map (set_name Anonymous) arsgn + List.map (set_name Anonymous) arsgn, Sorts.relevance_of_sort_family s in let nar = List.length arsgn in let indt = build_dependent_inductive !!env indf in - let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) + let psign = LocalAssum (make_annot na indr, indt) :: arsgn in (* For locating names in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let psign,env_p = push_rel_context ~hypnaming sigma psign predenv in let sigma, pred, p = match po with | Some p -> - let sigma, pj = pretype_type ~program_mode empty_valcon env_p sigma p in + let sigma, pj = pretype_type empty_valcon env_p sigma p in let ccl = nf_evar sigma pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist sigma (pred,[cj.uj_val])) in @@ -904,38 +917,38 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo List.map (set_name Anonymous) cs_args in let _,env_c = push_rel_context ~hypnaming sigma csgn env in - let sigma, bj = pretype ~program_mode (mk_tycon pi) env_c sigma b in + let sigma, bj = pretype (mk_tycon pi) env_c sigma b in sigma, it_mkLambda_or_LetIn bj.uj_val cs_args in let sigma, b1 = f sigma cstrs.(0) b1 in let sigma, b2 = f sigma cstrs.(1) b2 in let v = let ind,_ = dest_ind_family indf in - let ci = make_case_info !!env (fst ind) IfStyle in let pred = nf_evar sigma pred in - Typing.check_allowed_sort !!env sigma ind cj.uj_val pred; - mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val pred in + let ci = make_case_info !!env (fst ind) rci IfStyle in + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in let cj = { uj_val = v; uj_type = p } in inh_conv_coerce_to_tycon ?loc env sigma cj tycon | GCases (sty,po,tml,eqns) -> - Cases.compile_cases ?loc ~program_mode sty (pretype ~program_mode, sigma) tycon env (po,tml,eqns) + Cases.compile_cases ?loc ~program_mode sty (pretype, sigma) tycon env (po,tml,eqns) | GCast (c,k) -> let sigma, cj = match k with | CastCoerce -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in Coercion.inh_coerce_to_base ?loc ~program_mode !!env sigma cj | CastConv t | CastVM t | CastNative t -> let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let sigma, tj = pretype_type ~program_mode empty_valcon env sigma t in + let sigma, tj = pretype_type empty_valcon env sigma t in let sigma, tval = Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma tj.utj_val in let tval = nf_evar sigma tval in let (sigma, cj), tval = match k with | VMcast -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in if not (occur_existential sigma cty || occur_existential sigma tval) then match Reductionops.vm_infer_conv !!env sigma cty tval with @@ -946,7 +959,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo else user_err ?loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in begin match Nativenorm.native_infer_conv !!env sigma cty tval with @@ -956,7 +969,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo (ConversionFailed (!!env,cty,tval)) end | _ -> - pretype ~program_mode (mk_tycon tval) env sigma c, tval + pretype (mk_tycon tval) env sigma c, tval in let v = mkCast (cj.uj_val, k, tval) in sigma, { uj_val = v; uj_type = tval } @@ -1060,9 +1073,9 @@ and pretype_type ~program_mode k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match valcon with | None -> sigma, tj | Some v -> - begin match cumul !!env sigma v tj.utj_val with - | Some sigma -> sigma, tj - | None -> + begin match Evarconv.unify_leq_delay !!env sigma v tj.utj_val with + | sigma -> sigma, tj + | exception Evarconv.UnableToUnify _ -> error_unexpected_type ?loc:(loc_of_glob_constr c) !!env sigma tj.utj_val v end diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index d0359b43f4..34a6cecc95 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -5,10 +5,10 @@ Pretype_errors Reductionops Inductiveops InferCumulativity -Vnorm Arguments_renaming -Nativenorm Retyping +Vnorm +Nativenorm Cbv Find_subterm Evardefine diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 98ca329117..71fbfe8716 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -12,6 +12,7 @@ open CErrors open Util open Names open Constr +open Context open Termops open Univ open Evd @@ -479,10 +480,10 @@ struct | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) - | Case (info,ty,br,alt) -> Case (info, f ty, Array.map f br, alt) - | Fix ((r,(na,ty,bo)),arg,alt) -> - Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg,alt) - | Cst (cst,curr,remains,params,alt) -> + | Case (info,ty,br,alt) -> Case (info, f ty, Array.map f br, alt) + | Fix ((r,(na,ty,bo)),arg,alt) -> + Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg,alt) + | Cst (cst,curr,remains,params,alt) -> Cst (cst,curr,remains,map f params,alt) | Primitive (p,c,args,kargs,cst_l) -> Primitive(p,c, map f args, kargs, cst_l) @@ -775,7 +776,7 @@ let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbo | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind) in + | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -817,7 +818,7 @@ let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind) in + | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -1062,7 +1063,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> apply_subst (fun _ -> whrec) [] sigma refold cst_l x stack | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> - let env' = push_rel (LocalAssum (na, t)) env in + let env' = push_rel (LocalAssum (na, t)) env in let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in (match EConstr.kind sigma (Stack.zip ~refold sigma (fst (whrec' (c, Stack.empty)))) with | App (f,cl) -> @@ -1520,7 +1521,9 @@ let plain_instance sigma s c = match EConstr.kind sigma g with | App _ -> let l' = Array.Fun1.Smart.map lift 1 l' in - mkLetIn (Name default_plain_instance_ident,g,t,mkApp(mkRel 1, l')) + let r = Sorts.Relevant in (* TODO fix relevance *) + let na = make_annot (Name default_plain_instance_ident) r in + mkLetIn (na,g,t,mkApp(mkRel 1, l')) | _ -> mkApp (g,l') with Not_found -> mkApp (f,l')) | _ -> mkApp (irec n f,l')) @@ -1623,11 +1626,11 @@ let splay_prod_assum env sigma = let t = whd_allnolet env sigma c in match EConstr.kind sigma t with | Prod (x,t,c) -> - prodec_rec (push_rel (LocalAssum (x,t)) env) - (Context.Rel.add (LocalAssum (x,t)) l) c + prodec_rec (push_rel (LocalAssum (x,t)) env) + (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> - prodec_rec (push_rel (LocalDef (x,b,t)) env) - (Context.Rel.add (LocalDef (x,b,t)) l) c + prodec_rec (push_rel (LocalDef (x,b,t)) env) + (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let t' = whd_all env sigma t in @@ -1648,8 +1651,8 @@ let splay_prod_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match EConstr.kind sigma (whd_all env sigma c) with | Prod (n,a,c0) -> - decrec (push_rel (LocalAssum (n,a)) env) - (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_prod_n" in decrec env n Context.Rel.empty @@ -1658,8 +1661,8 @@ let splay_lam_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match EConstr.kind sigma (whd_all env sigma c) with | Lambda (n,a,c0) -> - decrec (push_rel (LocalAssum (n,a)) env) - (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_lam_n" in decrec env n Context.Rel.empty diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index fae0b23b83..5938d9b367 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -235,9 +235,9 @@ val hnf_lam_app : env -> evar_map -> constr -> constr -> constr val hnf_lam_appvect : env -> evar_map -> constr -> constr array -> constr val hnf_lam_applist : env -> evar_map -> constr -> constr list -> constr -val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr -val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr -val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * ESorts.t +val splay_prod : env -> evar_map -> constr -> (Name.t Context.binder_annot * constr) list * constr +val splay_lam : env -> evar_map -> constr -> (Name.t Context.binder_annot * constr) list * constr +val splay_arity : env -> evar_map -> constr -> (Name.t Context.binder_annot * constr) list * ESorts.t val sort_of_arity : env -> evar_map -> constr -> ESorts.t val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index a76a203e37..20120f4182 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -13,6 +13,7 @@ open CErrors open Util open Term open Constr +open Context open Inductive open Inductiveops open Names @@ -79,7 +80,8 @@ let rec subst_type env sigma typ = function let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env n ar args = match EConstr.kind sigma (whd_all env sigma ar), args with - | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l + | Prod (na, t, b), h::l -> + concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l | Sort s, [] -> ESorts.kind sigma s | _ -> retype_error NotASort in concl_of_arity env 0 ft (Array.to_list args) @@ -150,8 +152,8 @@ let retype ?(polyprop=true) sigma = | Cast (c,_, s) when isSort sigma s -> destSort sigma s | Sort s -> begin match ESorts.kind sigma s with - | Prop | Set -> Sorts.type1 - | Type u -> Type (Univ.super u) + | SProp | Prop | Set -> Sorts.type1 + | Type u -> Sorts.sort_of_univ (Univ.super u) end | Prod (name,t,c2) -> let dom = sort_of env t in @@ -188,7 +190,7 @@ let get_sort_family_of ?(truncation_style=false) ?(polyprop=true) env sigma t = | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s) | Sort _ -> InType | Prod (name,t,c2) -> - let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in + let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in if not (is_impredicative_set env) && s2 == InSet && sort_family_of env t == InType then InType else s2 | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> @@ -256,3 +258,41 @@ let expand_projection env sigma pr c args = in mkApp (mkConstU (Projection.constant pr,u), Array.of_list (ind_args @ (c :: args))) + +let relevance_of_term env sigma c = + if Environ.sprop_allowed env then + let rec aux rels c = + match kind sigma c with + | Rel n -> Retypeops.relevance_of_rel_extra env rels n + | Var x -> Retypeops.relevance_of_var env x + | Sort _ -> Sorts.Relevant + | Cast (c, _, _) -> aux rels c + | Prod ({binder_relevance=r}, _, codom) -> + aux (r::rels) codom + | Lambda ({binder_relevance=r}, _, bdy) -> + aux (r::rels) bdy + | LetIn ({binder_relevance=r}, _, _, bdy) -> + aux (r::rels) bdy + | App (c, _) -> aux rels c + | Const (c,_) -> Retypeops.relevance_of_constant env c + | Ind _ -> Sorts.Relevant + | Construct (c,_) -> Retypeops.relevance_of_constructor env c + | Case (ci, _, _, _) -> ci.ci_relevance + | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance + | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance + | Proj (p, _) -> Retypeops.relevance_of_projection env p + | Int _ -> Sorts.Relevant + + | Meta _ | Evar _ -> Sorts.Relevant + + in + aux [] c + else Sorts.Relevant + +let relevance_of_type env sigma t = + let s = get_sort_family_of env sigma t in + Sorts.relevance_of_sort_family s + +let relevance_of_sort s = Sorts.relevance_of_sort (EConstr.Unsafe.to_sorts s) + +let relevance_of_sort_family f = Sorts.relevance_of_sort_family f diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 2aff0c7775..252bfb1a84 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -53,3 +53,8 @@ val sorts_of_context : env -> evar_map -> rel_context -> Sorts.t list val expand_projection : env -> evar_map -> Names.Projection.t -> constr -> constr list -> constr val print_retype_error : retype_error -> Pp.t + +val relevance_of_term : env -> evar_map -> constr -> Sorts.relevance +val relevance_of_type : env -> evar_map -> types -> Sorts.relevance +val relevance_of_sort : ESorts.t -> Sorts.relevance +val relevance_of_sort_family : Sorts.family -> Sorts.relevance diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 2308a541fb..bcc20a41b4 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -13,6 +13,7 @@ open CErrors open Util open Names open Constr +open Context open Libnames open Globnames open Termops @@ -229,7 +230,8 @@ let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = (* Heuristic to look if global names are associated to other components of a mutual fixpoint *) -let invert_name labs l na0 env sigma ref = function +let invert_name labs l {binder_name=na0} env sigma ref na = + match na.binder_name with | Name id -> let minfxargs = List.length l in begin match na0 with @@ -249,7 +251,7 @@ let invert_name labs l na0 env sigma ref = function | Some c -> let labs',ccl = decompose_lam sigma c in let _, l' = whd_betalet_stack sigma ccl in - let labs' = List.map snd labs' in + let labs' = List.map snd labs' in (* ppedrot: there used to be generic equality on terms here *) let eq_constr c1 c2 = EConstr.eq_constr sigma c1 c2 in if List.equal eq_constr labs' labs && @@ -269,7 +271,7 @@ let compute_consteval_direct env sigma ref = match EConstr.kind sigma c' with | Lambda (id,t,g) when List.is_empty l && not onlyproj -> let open Context.Rel.Declaration in - srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g + srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g | Fix fix when not onlyproj -> (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) @@ -289,7 +291,7 @@ let compute_consteval_mutual_fix env sigma ref = match EConstr.kind sigma c' with | Lambda (na,t,g) when List.is_empty l -> let open Context.Rel.Declaration in - srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g + srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g | Fix ((lv,i),(names,_,_)) -> (* Last known constant wrapping Fix is ref = [labs](Fix l) *) (match compute_consteval_direct env sigma ref with @@ -374,7 +376,8 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs = List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in let tij' = Vars.substl (List.rev subst) tij in - mkLambda (x,tij',c)) 1 body (List.rev lv) + let x = make_annot x Sorts.Relevant in (* TODO relevance *) + mkLambda (x,tij',c)) 1 body (List.rev lv) in Some (minargs,g) (* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: @@ -384,7 +387,8 @@ let dummy = mkProp let vfx = Id.of_string "_expanded_fix_" let vfun = Id.of_string "_eliminator_function_" let venv = let open Context.Named.Declaration in - val_of_named_context [LocalAssum (vfx, dummy); LocalAssum (vfun, dummy)] + val_of_named_context [LocalAssum (make_annot vfx Sorts.Relevant, dummy); + LocalAssum (make_annot vfun Sorts.Relevant, dummy)] (* Mark every occurrence of substituted vars (associated to a function) as a problem variable: an evar that can be instantiated either by @@ -513,7 +517,7 @@ let reduce_mind_case_use_function func env sigma mia = let minargs = List.length mia.mcargs in fun i -> if Int.equal i bodynum then Some (minargs,func) - else match names.(i) with + else match names.(i).binder_name with | Anonymous -> None | Name id -> (* In case of a call to another component of a block of @@ -627,12 +631,12 @@ let whd_nothing_for_iota env sigma s = | Rel n -> let open Context.Rel.Declaration in (match lookup_rel n env with - | LocalDef (_,body,_) -> whrec (lift n body, stack) + | LocalDef (_,body,_) -> whrec (lift n body, stack) | _ -> s) | Var id -> let open Context.Named.Declaration in (match lookup_named id env with - | LocalDef (_,body,_) -> whrec (body, stack) + | LocalDef (_,body,_) -> whrec (body, stack) | _ -> s) | Evar ev -> s | Meta ev -> @@ -838,10 +842,10 @@ let try_red_product env sigma c = | Cast (c,_,_) -> redrec env c | Prod (x,a,b) -> let open Context.Rel.Declaration in - mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) + mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) - | Proj (p, c) -> + | Proj (p, c) -> let c' = match EConstr.kind sigma c with | Construct _ -> c @@ -1105,6 +1109,7 @@ let unfoldoccs env sigma (occs,name) c = | AllOccurrences -> unfold env sigma name c | OnlyOccurrences l -> unfo true l | AllOccurrencesBut l -> unfo false l + | AtLeastOneOccurrence -> unfo false [] (* Unfold reduction tactic: *) let unfoldn loccname env sigma c = @@ -1149,6 +1154,7 @@ let compute = cbv_betadeltaiota let abstract_scheme env sigma (locc,a) (c, sigma) = let ta = Retyping.get_type_of env sigma a in let na = named_hd env sigma ta Anonymous in + let na = make_annot na Sorts.Relevant in (* TODO relevance *) if occur_meta sigma ta then user_err Pp.(str "Cannot find a type for the generalisation."); if occur_meta sigma a then mkLambda (na,ta,c), sigma @@ -1191,7 +1197,7 @@ let reduce_to_ind_gen allow_product env sigma t = | Prod (n,ty,t') -> let open Context.Rel.Declaration in if allow_product then - elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) + elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else user_err (str"Not an inductive definition.") | _ -> @@ -1269,7 +1275,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = | Prod (n,ty,t') -> if allow_product then let open Context.Rel.Declaration in - elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l) + elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else error_cannot_recognize ref | _ -> diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index d732544c5c..1496712bbc 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -124,12 +124,14 @@ let typeclass_univ_instance (cl, u) = let class_info c = try GlobRef.Map.find c !classes - with Not_found -> not_a_class (Global.env()) (EConstr.of_constr (printable_constr_of_global c)) + with Not_found -> + let env = Global.env() in + not_a_class env (Evd.from_env env) (EConstr.of_constr (printable_constr_of_global c)) let global_class_of_constr env sigma c = try let gr, u = Termops.global_of_constr sigma c in - class_info gr, u - with Not_found -> not_a_class env c + GlobRef.Map.find gr !classes, u + with Not_found -> not_a_class env sigma c let dest_class_app env sigma c = let cl, args = EConstr.decompose_app sigma c in diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index 2720a3e4de..af5b3016c9 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -20,10 +20,10 @@ type typeclass_error = | NotAClass of constr | UnboundMethod of GlobRef.t * lident (* Class name, method *) -exception TypeClassError of env * typeclass_error +exception TypeClassError of env * Evd.evar_map * typeclass_error -let typeclass_error env err = raise (TypeClassError (env, err)) +let typeclass_error env sigma err = raise (TypeClassError (env, sigma, err)) -let not_a_class env c = typeclass_error env (NotAClass c) +let not_a_class env sigma c = typeclass_error env sigma (NotAClass c) -let unbound_method env cid id = typeclass_error env (UnboundMethod (cid, id)) +let unbound_method env sigma cid id = typeclass_error env sigma (UnboundMethod (cid, id)) diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index 9831627a9a..fd75781ed5 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -18,9 +18,10 @@ type typeclass_error = | NotAClass of constr | UnboundMethod of GlobRef.t * lident (** Class name, method *) -exception TypeClassError of env * typeclass_error +exception TypeClassError of env * Evd.evar_map * typeclass_error -val not_a_class : env -> constr -> 'a +val typeclass_error : env -> Evd.evar_map -> typeclass_error -> 'a -val unbound_method : env -> GlobRef.t -> lident -> 'a +val not_a_class : env -> Evd.evar_map -> constr -> 'a +val unbound_method : env -> Evd.evar_map -> GlobRef.t -> lident -> 'a diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 2e50e1ab3f..89f72c874b 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -15,6 +15,7 @@ open CErrors open Util open Term open Constr +open Context open Environ open EConstr open Vars @@ -65,16 +66,16 @@ let judge_of_applied_inductive_knowing_parameters env sigma funj ind argjv = match EConstr.kind sigma (whd_all env sigma typ) with | Prod (_,c1,c2) -> sigma, (c1,c2) | Evar ev -> - let (sigma,t) = Evardefine.define_evar_as_product sigma ev in + let (sigma,t) = Evardefine.define_evar_as_product env sigma ev in let (_,c1,c2) = destProd sigma t in sigma, (c1,c2) | _ -> error_cant_apply_not_functional env sigma funj argjv in - begin match Evarconv.cumul env sigma hj.uj_type c1 with - | Some sigma -> + begin match Evarconv.unify_leq_delay env sigma hj.uj_type c1 with + | sigma -> apply_rec sigma (n+1) (subst1 hj.uj_val c2) restjl - | None -> + | exception Evarconv.UnableToUnify _ -> error_cant_apply_bad_type env sigma (n, c1, hj.uj_type) funj argjv end in @@ -90,16 +91,16 @@ let judge_of_apply env sigma funj argjv = match EConstr.kind sigma (whd_all env sigma typ) with | Prod (_,c1,c2) -> sigma, (c1,c2) | Evar ev -> - let (sigma,t) = Evardefine.define_evar_as_product sigma ev in + let (sigma,t) = Evardefine.define_evar_as_product env sigma ev in let (_,c1,c2) = destProd sigma t in sigma, (c1,c2) | _ -> error_cant_apply_not_functional env sigma funj argjv in - begin match Evarconv.cumul env sigma hj.uj_type c1 with - | Some sigma -> + begin match Evarconv.unify_leq_delay env sigma hj.uj_type c1 with + | sigma -> apply_rec sigma (n+1) (subst1 hj.uj_val c2) restjl - | None -> + | exception Evarconv.UnableToUnify _ -> error_cant_apply_bad_type env sigma (n, c1, hj.uj_type) funj argjv end in @@ -109,9 +110,9 @@ let check_branch_types env sigma (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then error_number_branches env sigma cj (Array.length explft); Array.fold_left2_i (fun i sigma lfj explft -> - match Evarconv.cumul env sigma lfj.uj_type explft with - | Some sigma -> sigma - | None -> + match Evarconv.unify_leq_delay env sigma lfj.uj_type explft with + | sigma -> sigma + | exception Evarconv.UnableToUnify _ -> error_ill_formed_branch env sigma cj.uj_val ((ind,i+1),u) lfj.uj_type explft) sigma lfj explft @@ -122,25 +123,25 @@ let max_sort l = let is_correct_arity env sigma c pj ind specif params = let arsign = make_arity_signature env sigma true (make_ind_family (ind,params)) in let allowed_sorts = elim_sorts specif in - let error () = Pretype_errors.error_elim_arity env sigma ind allowed_sorts c pj None in + let error () = Pretype_errors.error_elim_arity env sigma ind c pj None in let rec srec env sigma pt ar = let pt' = whd_all env sigma pt in match EConstr.kind sigma pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> - begin match Evarconv.cumul env sigma a1 a1' with - | None -> error () - | Some sigma -> + begin match Evarconv.unify_leq_delay env sigma a1 a1' with + | exception Evarconv.UnableToUnify _ -> error () + | sigma -> srec (push_rel (LocalAssum (na1,a1)) env) sigma t ar' end | Sort s, [] -> let s = ESorts.kind sigma s in if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () - else sigma + else sigma, s | Evar (ev,_), [] -> let sigma, s = Evd.fresh_sort_in_family sigma (max_sort allowed_sorts) in let sigma = Evd.define ev (mkSort s) sigma in - sigma + sigma, s | _, (LocalDef _ as d)::ar' -> srec (push_rel d env) sigma (lift 1 pt') ar' | _ -> @@ -165,20 +166,20 @@ let type_case_branches env sigma (ind,largs) pj c = let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in let params = List.map EConstr.Unsafe.to_constr params in - let sigma = is_correct_arity env sigma c pj ind specif params in + let sigma, ps = is_correct_arity env sigma c pj ind specif params in let lc = build_branches_type ind specif params (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in let lc = Array.map EConstr.of_constr lc in let n = (snd specif).Declarations.mind_nrealdecls in let ty = whd_betaiota sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in - sigma, (lc, ty) + sigma, (lc, ty, Sorts.relevance_of_sort ps) let judge_of_case env sigma ci pj cj lfj = let ((ind, u), spec) = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in let indspec = ((ind, EInstance.kind sigma u), spec) in - let _ = check_case_info env (fst indspec) ci in - let sigma, (bty,rslty) = type_case_branches env sigma indspec pj cj.uj_val in + let sigma, (bty,rslty,rci) = type_case_branches env sigma indspec pj cj.uj_val in + let () = check_case_info env (fst indspec) rci ci in let sigma = check_branch_types env sigma (fst indspec) cj (lfj,bty) in sigma, { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty } @@ -187,9 +188,9 @@ let check_type_fixpoint ?loc env sigma lna lar vdefj = let lt = Array.length vdefj in assert (Int.equal (Array.length lar) lt); Array.fold_left2_i (fun i sigma defj ar -> - match Evarconv.cumul env sigma defj.uj_type (lift lt ar) with - | Some sigma -> sigma - | None -> + match Evarconv.unify_leq_delay env sigma defj.uj_type (lift lt ar) with + | sigma -> sigma + | exception Evarconv.UnableToUnify _ -> error_ill_typed_rec_body ?loc env sigma i lna vdefj lar) sigma vdefj lar @@ -203,18 +204,20 @@ let check_allowed_sort env sigma ind c p = let _, s = splay_prod env sigma pj.uj_type in let ksort = match EConstr.kind sigma s with | Sort s -> Sorts.family (ESorts.kind sigma s) - | _ -> error_elim_arity env sigma ind sorts c pj None in + | _ -> error_elim_arity env sigma ind c pj None in if not (List.exists ((==) ksort) sorts) then let s = inductive_sort_family (snd specif) in - error_elim_arity env sigma ind sorts c pj - (Some(ksort,s,Type_errors.error_elim_explain ksort s)) + error_elim_arity env sigma ind c pj + (Some(sorts,ksort,s,Type_errors.error_elim_explain ksort s)) + else + Sorts.relevance_of_sort_family ksort let judge_of_cast env sigma cj k tj = let expected_type = tj.utj_val in - match Evarconv.cumul env sigma cj.uj_type expected_type with - | None -> + match Evarconv.unify_leq_delay env sigma cj.uj_type expected_type with + | exception Evarconv.UnableToUnify _ -> error_actual_type_core env sigma cj expected_type; - | Some sigma -> + | sigma -> sigma, { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type } @@ -230,6 +233,10 @@ let check_cofix env sigma pcofix = (* The typing machine with universes and existential variables. *) +let judge_of_sprop = + { uj_val = EConstr.mkSProp; + uj_type = EConstr.type1 } + let judge_of_prop = { uj_val = EConstr.mkProp; uj_type = EConstr.mkSort Sorts.type1 } @@ -262,16 +269,19 @@ let judge_of_projection env sigma p cj = uj_type = ty} let judge_of_abstraction env name var j = - { uj_val = mkLambda (name, var.utj_val, j.uj_val); - uj_type = mkProd (name, var.utj_val, j.uj_type) } + let r = Sorts.relevance_of_sort var.utj_type in + { uj_val = mkLambda (make_annot name r, var.utj_val, j.uj_val); + uj_type = mkProd (make_annot name r, var.utj_val, j.uj_type) } let judge_of_product env name t1 t2 = + let r = Sorts.relevance_of_sort t1.utj_type in let s = sort_of_product env t1.utj_type t2.utj_type in - { uj_val = mkProd (name, t1.utj_val, t2.utj_val); + { uj_val = mkProd (make_annot name r, t1.utj_val, t2.utj_val); uj_type = mkSort s } let judge_of_letin env name defj typj j = - { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ; + let r = Sorts.relevance_of_sort typj.utj_type in + { uj_val = mkLetIn (make_annot name r, defj.uj_val, typj.utj_val, j.uj_val) ; uj_type = subst1 defj.uj_val j.uj_type } let check_hyps_inclusion env sigma f x hyps = @@ -349,7 +359,7 @@ let rec execute env sigma cstr = | Fix ((vn,i as vni),recdef) -> let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in - let fix = (vni,recdef') in + let fix = (vni,recdef') in check_fix env sigma fix; sigma, make_judge (mkFix fix) tys.(i) @@ -361,6 +371,9 @@ let rec execute env sigma cstr = | Sort s -> begin match ESorts.kind sigma s with + | SProp -> + if Environ.sprop_allowed env then sigma, judge_of_sprop + else error_disallowed_sprop env sigma | Prop -> sigma, judge_of_prop | Set -> sigma, judge_of_set | Type u -> sigma, judge_of_type u @@ -384,26 +397,29 @@ let rec execute env sigma cstr = | Lambda (name,c1,c2) -> let sigma, j = execute env sigma c1 in let sigma, var = type_judgment env sigma j in - let env1 = push_rel (LocalAssum (name, var.utj_val)) env in + let name = check_binder_annot var.utj_type name in + let env1 = push_rel (LocalAssum (name, var.utj_val)) env in let sigma, j' = execute env1 sigma c2 in - sigma, judge_of_abstraction env1 name var j' + sigma, judge_of_abstraction env1 name.binder_name var j' | Prod (name,c1,c2) -> let sigma, j = execute env sigma c1 in let sigma, varj = type_judgment env sigma j in - let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in + let name = check_binder_annot varj.utj_type name in + let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in let sigma, j' = execute env1 sigma c2 in let sigma, varj' = type_judgment env1 sigma j' in - sigma, judge_of_product env name varj varj' + sigma, judge_of_product env name.binder_name varj varj' | LetIn (name,c1,c2,c3) -> let sigma, j1 = execute env sigma c1 in let sigma, j2 = execute env sigma c2 in let sigma, j2 = type_judgment env sigma j2 in let sigma, _ = judge_of_cast env sigma j1 DEFAULTcast j2 in + let name = check_binder_annot j2.utj_type name in let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in let sigma, j3 = execute env1 sigma c3 in - sigma, judge_of_letin env name j1 j2 j3 + sigma, judge_of_letin env name.binder_name j1 j2 j3 | Cast (c,k,t) -> let sigma, cj = execute env sigma c in @@ -427,10 +443,10 @@ and execute_array env = Array.fold_left_map (execute env) let check env sigma c t = let sigma, j = execute env sigma c in - match Evarconv.cumul env sigma j.uj_type t with - | None -> + match Evarconv.unify_leq_delay env sigma j.uj_type t with + | exception Evarconv.UnableToUnify _ -> error_actual_type_core env sigma j t - | Some sigma -> sigma + | sigma -> sigma (* Type of a constr *) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 1ea16bbf34..f68820429b 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -39,13 +39,14 @@ val solve_evars : env -> evar_map -> constr -> evar_map * constr (** Raise an error message if incorrect elimination for this inductive (first constr is term to match, second is return predicate) *) val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> - unit + Sorts.relevance (** Raise an error message if bodies have types not unifiable with the expected ones *) val check_type_fixpoint : ?loc:Loc.t -> env -> evar_map -> - Names.Name.t array -> types array -> unsafe_judgment array -> evar_map + Names.Name.t Context.binder_annot array -> types array -> unsafe_judgment array -> evar_map +val judge_of_sprop : unsafe_judgment val judge_of_prop : unsafe_judgment val judge_of_set : unsafe_judgment val judge_of_apply : env -> evar_map -> unsafe_judgment -> unsafe_judgment array -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index ac0b58b92b..9ba51dcfa9 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -13,6 +13,7 @@ open Pp open Util open Names open Constr +open Context open Termops open Environ open EConstr @@ -103,13 +104,13 @@ let occur_meta_evd sigma mv c = let abstract_scheme env evd c l lname_typ = let mkLambda_name env (n,a,b) = - mkLambda (named_hd env evd a n, a, b) + mkLambda (map_annot (named_hd env evd a) n, a, b) in List.fold_left2 (fun (t,evd) (locc,a) decl -> - let na = RelDecl.get_name decl in + let na = RelDecl.get_annot decl in let ta = RelDecl.get_type decl in - let na = match EConstr.kind evd a with Var id -> Name id | _ -> na in + let na = match EConstr.kind evd a with Var id -> {na with binder_name=Name id} | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... if occur_meta ta then error "cannot find a type for the generalisation" @@ -117,7 +118,7 @@ let abstract_scheme env evd c l lname_typ = if occur_meta evd a then mkLambda_name env (na,ta,t), evd else let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in - mkLambda_name env (na,ta,t'), evd') + mkLambda_name env (na,ta,t'), evd') (c,evd) (List.rev l) lname_typ @@ -141,7 +142,15 @@ let abstract_list_all env evd typ c l = evd,(p,typp) let set_occurrences_of_last_arg args = - Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) + Evarconv.AtOccurrences AllOccurrences :: + List.tl (Array.map_to_list (fun _ -> Evarconv.Unspecified Abstraction.Abstract) args) + +let occurrence_test _ _ _ env sigma _ c1 c2 = + match EConstr.eq_constr_universes env sigma c1 c2 with + | None -> false, sigma + | Some cstr -> + try true, Evd.add_universe_constraints sigma cstr + with UniversesDiffer -> false, sigma let abstract_list_all_with_dependencies env evd typ c l = let (evd, ev) = new_evar env evd typ in @@ -149,8 +158,9 @@ let abstract_list_all_with_dependencies env evd typ c l = let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in let evd,b = - Evarconv.second_order_matching TransparentState.empty - env evd ev' argoccs c in + Evarconv.second_order_matching + (Evarconv.default_flags_of TransparentState.empty) + env evd ev' (occurrence_test, argoccs) c in if b then let p = nf_evar evd ev in evd, p @@ -552,8 +562,8 @@ let is_rigid_head sigma flags t = | Ind (i,u) -> true | Construct _ | Int _ -> true | Fix _ | CoFix _ -> true - | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod (_, _, _) - | Lambda (_, _, _) | LetIn (_, _, _, _) | App (_, _) | Case (_, _, _, _) + | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod _ + | Lambda _ | LetIn _ | App (_, _) | Case (_, _, _, _) | Proj (_, _) -> false (* Why aren't Prod, Sort rigid heads ? *) let force_eqs c = @@ -653,7 +663,7 @@ let is_eta_constructor_app env sigma ts f l1 term = let mib = lookup_mind (fst ind) env in (match mib.Declarations.mind_record with | PrimRecord info when mib.Declarations.mind_finite == Declarations.BiFinite && - let (_, projs, _) = info.(i) in + let (_, projs, _, _) = info.(i) in Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> (* Check that the other term is neutral *) is_neutral env sigma ts term @@ -773,14 +783,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e with e when CErrors.noncritical e -> error_cannot_unify curenv sigma (m,n)) - | Lambda (na,t1,c1), Lambda (_,t2,c2) -> - unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} + | Lambda (na,t1,c1), Lambda (__,t2,c2) -> + unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 - | Prod (na,t1,c1), Prod (_,t2,c2) -> - unirec_rec (push (na,t1) curenvnb) pb {opt with at_top = true} + | Prod (na,t1,c1), Prod (_,t2,c2) -> + unirec_rec (push (na,t1) curenvnb) pb {opt with at_top = true} (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 - | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN - | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) + | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN + | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) (* Fast path for projections. *) | Proj (p1,c1), Proj (p2,c2) when Constant.equal @@ -791,11 +801,11 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e unify_not_same_head curenvnb pb opt substn cM cN) (* eta-expansion *) - | Lambda (na,t1,c1), _ when flags.modulo_eta -> - unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} substn + | Lambda (na,t1,c1), _ when flags.modulo_eta -> + unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} substn c1 (mkApp (lift 1 cN,[|mkRel 1|])) - | _, Lambda (na,t2,c2) when flags.modulo_eta -> - unirec_rec (push (na,t2) curenvnb) CONV {opt with at_top = true} substn + | _, Lambda (na,t2,c2) when flags.modulo_eta -> + unirec_rec (push (na,t2) curenvnb) CONV {opt with at_top = true} substn (mkApp (lift 1 cM,[|mkRel 1|])) c2 (* For records *) @@ -1315,8 +1325,8 @@ let order_metas metas = (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *) -let solve_simple_evar_eqn ts env evd ev rhs = - match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) with +let solve_simple_evar_eqn flags env evd ev rhs = + match solve_simple_eqn Evarconv.evar_unify flags env evd (None,ev,rhs) with | UnifFailure (evd,reason) -> error_cannot_unify env evd ~reason (mkEvar ev,rhs); | Success evd -> evd @@ -1326,6 +1336,7 @@ let solve_simple_evar_eqn ts env evd ev rhs = is true, unification of types of metas is required *) let w_merge env with_types flags (evd,metas,evars : subst0) = + let eflags = Evarconv.default_flags_of flags.modulo_delta_types in let rec w_merge_rec evd metas evars eqns = (* Process evars *) @@ -1350,14 +1361,14 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = else let evd' = let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in - try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'' + try solve_simple_evar_eqn eflags curenv evd' ev rhs'' with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev,rhs'') in w_merge_rec evd' metas evars' eqns | _ -> let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in let evd' = - try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'' + try solve_simple_evar_eqn eflags curenv evd' ev rhs'' with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev, rhs'') in w_merge_rec evd' metas evars' eqns @@ -1649,7 +1660,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = match occurrences_of_hyp hyp occs with | NoOccurrences, InHyp -> (push_named_context_val d sign,depdecls) - | AllOccurrences, InHyp as occ -> + | (AllOccurrences | AtLeastOneOccurrence), InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in let newdecl = replace_term_occ_decl_modulo sigma occ test mkvarid d in if Context.Named.Declaration.equal (EConstr.eq_constr sigma) d newdecl @@ -1765,7 +1776,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = matchrec c with ex when precatchable_exception ex -> iter_fail matchrec lf) - | LetIn(_,c1,_,c2) -> + | LetIn(_,c1,_,c2) -> (try matchrec c1 with ex when precatchable_exception ex -> @@ -1773,13 +1784,13 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = | Proj (p,c) -> matchrec c - | Fix(_,(_,types,terms)) -> + | Fix(_,(_,types,terms)) -> (try iter_fail matchrec types with ex when precatchable_exception ex -> iter_fail matchrec terms) - | CoFix(_,(_,types,terms)) -> + | CoFix(_,(_,types,terms)) -> (try iter_fail matchrec types with ex when precatchable_exception ex -> @@ -1850,13 +1861,13 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = | Proj (p,c) -> matchrec c - | LetIn(_,c1,_,c2) -> + | LetIn(_,c1,_,c2) -> bind (matchrec c1) (matchrec c2) - | Fix(_,(_,types,terms)) -> + | Fix(_,(_,types,terms)) -> bind (bind_iter matchrec types) (bind_iter matchrec terms) - | CoFix(_,(_,types,terms)) -> + | CoFix(_,(_,types,terms)) -> bind (bind_iter matchrec types) (bind_iter matchrec terms) | Prod (_,t,c) -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 083661a64b..62e9e477f7 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -13,6 +13,7 @@ open Names open Declarations open Term open Constr +open Context open Vars open Environ open Inductive @@ -31,10 +32,12 @@ module NamedDecl = Context.Named.Declaration let crazy_type = mkSet let decompose_prod env t = - let (name,dom,codom as res) = destProd (whd_all env t) in - match name with - | Anonymous -> (Name (Id.of_string "x"), dom, codom) - | Name _ -> res + let (name,dom,codom) = destProd (whd_all env t) in + let name = map_annot (function + | Anonymous -> Name (Id.of_string "x") + | Name _ as na -> na) name + in + (name,dom,codom) exception Find_at of int @@ -61,7 +64,8 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib u typ params = +let type_constructor mind mib u (ctx, typ) params = + let typ = it_mkProd_or_LetIn typ ctx in let s = ind_subst mind mib u in let ctyp = substl s typ in let ctyp = subst_instance_constr u ctyp in @@ -137,6 +141,8 @@ and nf_whd env sigma whd typ = let dom = nf_vtype env sigma (dom p) in let name = Name (Id.of_string "x") in let vc = reduce_fun (nb_rel env) (codom p) in + let r = Retyping.relevance_of_type env sigma (EConstr.of_constr dom) in + let name = make_annot name r in let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vc in mkProd(name,dom,codom) | Vfun f -> nf_fun env sigma f typ @@ -306,6 +312,8 @@ and nf_predicate env sigma ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in + let r = Inductive.relevance_of_inductive env (fst ind) in + let name = make_annot name r in let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vb in mkLambda(name,dom,body) | _ -> assert false @@ -316,7 +324,7 @@ and nf_args env sigma vargs ?from:(f=0) t = let args = Array.init len (fun i -> - let _,dom,codom = decompose_prod env !t in + let _,dom,codom = decompose_prod env !t in let c = nf_val env sigma (arg vargs (f+i)) dom in t := subst1 c codom; c) in !t,args @@ -327,7 +335,7 @@ and nf_bargs env sigma b ofs t = let args = Array.init len (fun i -> - let _,dom,codom = decompose_prod env !t in + let _,dom,codom = decompose_prod env !t in let c = nf_val env sigma (bfield b (i+ofs)) dom in t := subst1 c codom; c) in args @@ -352,14 +360,17 @@ and nf_fix env sigma f = let vb, vt = reduce_fix k f in let ndef = Array.length vt in let ft = Array.map (fun v -> nf_val env sigma v crazy_type) vt in - let name = Array.init ndef (fun _ -> (Name (Id.of_string "Ffix"))) in - (* Third argument of the tuple is ignored by push_rec_types *) - let env = push_rec_types (name,ft,ft) env in + let name = Name (Id.of_string "Ffix") in + let names = Array.map (fun t -> + make_annot name @@ + Retyping.relevance_of_type env sigma (EConstr.of_constr t)) ft in + (* Body argument of the tuple is ignored by push_rec_types *) + let env = push_rec_types (names,ft,ft) env in (* We lift here because the types of arguments (in tt) will be evaluated in an environment where the fixpoints have been pushed *) let norm_vb v t = nf_fun env sigma v (lift ndef t) in let fb = Util.Array.map2 norm_vb vb ft in - mkFix ((rec_args,init),(name,ft,fb)) + mkFix ((rec_args,init),(names,ft,fb)) and nf_fix_app env sigma f vargs = let fd = nf_fix env sigma f in @@ -372,12 +383,14 @@ and nf_cofix env sigma cf = let init = current_cofix cf in let k = nb_rel env in let vb,vt = reduce_cofix k cf in - let ndef = Array.length vt in let cft = Array.map (fun v -> nf_val env sigma v crazy_type) vt in - let name = Array.init ndef (fun _ -> (Name (Id.of_string "Fcofix"))) in - let env = push_rec_types (name,cft,cft) env in + let name = Name (Id.of_string "Fcofix") in + let names = Array.map (fun t -> + make_annot name @@ + Retyping.relevance_of_type env sigma (EConstr.of_constr t)) cft in + let env = push_rec_types (names,cft,cft) env in let cfb = Util.Array.map2 (fun v t -> nf_val env sigma v t) vb cft in - mkCoFix (init,(name,cft,cfb)) + mkCoFix (init,(names,cft,cfb)) let cbv_vm env sigma c t = if Termops.occur_meta sigma c then diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 26202ef4ca..ad2b51b23d 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -169,12 +169,14 @@ let tag_var = tag Tag.variable let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" let pr_glob_sort = let open Glob_term in function + | GSProp -> tag_type (str "SProp") | GProp -> tag_type (str "Prop") | GSet -> tag_type (str "Set") | GType [] -> tag_type (str "Type") | GType u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u) let pr_glob_level = let open Glob_term in function + | GSProp -> tag_type (str "SProp") | GProp -> tag_type (str "Prop") | GSet -> tag_type (str "Set") | GType UUnknown -> tag_type (str "Type") @@ -197,6 +199,8 @@ let tag_var = tag Tag.variable let pr_patvar = pr_id let pr_glob_sort_instance = let open Glob_term in function + | GSProp -> + tag_type (str "SProp") | GProp -> tag_type (str "Prop") | GSet -> diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 797b6faa08..8bf86e9ef6 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -505,9 +505,9 @@ let gallina_print_named_decl env sigma = let open Context.Named.Declaration in function | LocalAssum (id, typ) -> - print_named_assum env sigma (Id.to_string id) typ + print_named_assum env sigma (Id.to_string id.Context.binder_name) typ | LocalDef (id, body, typ) -> - print_named_def env sigma (Id.to_string id) body typ + print_named_def env sigma (Id.to_string id.Context.binder_name) body typ let assumptions_for_print lna = List.fold_right (fun na env -> add_name na env) lna empty_names_context diff --git a/printing/printer.ml b/printing/printer.ml index bc936975c2..fa55a28cb3 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -13,6 +13,7 @@ open CErrors open Util open Names open Constr +open Context open Environ open Globnames open Evd @@ -100,7 +101,7 @@ let pr_constr_under_binders_env_gen pr env sigma (ids,c) = (* Warning: clashes can occur with variables of same name in env but *) (* we also need to preserve the actual names of the patterns *) (* So what to do? *) - let assums = List.map (fun id -> (Name id,(* dummy *) mkProp)) ids in + let assums = List.map (fun id -> (make_annot (Name id) Sorts.Relevant,(* dummy *) mkProp)) ids in pr (Termops.push_rels_assum assums env) sigma c let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_econstr_env @@ -290,7 +291,7 @@ let pr_compacted_decl env sigma decl = let pb = if isCast c then surround pb else pb in ids, (str" := " ++ pb ++ cut ()), typ in - let pids = prlist_with_sep pr_comma pr_id ids in + let pids = prlist_with_sep pr_comma (fun id -> pr_id id.binder_name) ids in let pt = pr_ltype_env env sigma typ in let ptyp = (str" : " ++ pt) in hov 0 (pids ++ pbody ++ ptyp) diff --git a/printing/printmod.ml b/printing/printmod.ml index 3438063f76..f4986652b3 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -10,6 +10,7 @@ open Util open Constr +open Context open Pp open Names open Environ @@ -132,10 +133,10 @@ let get_fields = let rec prodec_rec l subst c = match kind c with | Prod (na,t,c) -> - let id = match na with Name id -> id | Anonymous -> Id.of_string "_" in + let id = match na.binder_name with Name id -> id | Anonymous -> Id.of_string "_" in prodec_rec ((id,true,Vars.substl subst t)::l) (mkVar id::subst) c | LetIn (na,b,_,c) -> - let id = match na with Name id -> id | Anonymous -> Id.of_string "_" in + let id = match na.binder_name with Name id -> id | Anonymous -> Id.of_string "_" in prodec_rec ((id,false,Vars.substl subst b)::l) (mkVar id::subst) c | _ -> List.rev l in diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 878e9f477b..5aa7b3c7bd 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -204,14 +204,14 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = List.rev !rv;; -type 'a hyp = (Names.Id.t list * 'a option * 'a) +type 'a hyp = (Names.Id.t Context.binder_annot list * 'a option * 'a) type 'a reified_goal = { name: string; ty: 'a; hyps: 'a hyp list; env : Environ.env; sigma: Evd.evar_map } (* XXX: Port to proofview, one day. *) (* open Proofview *) module CDC = Context.Compacted.Declaration -let to_tuple : Constr.compacted_declaration -> (Names.Id.t list * 'pc option * 'pc) = +let to_tuple : Constr.compacted_declaration -> (Names.Id.t Context.binder_annot list * 'pc option * 'pc) = let open CDC in function | LocalAssum(idl, tm) -> (idl, None, EConstr.of_constr tm) | LocalDef(idl,tdef,tm) -> (idl, Some (EConstr.of_constr tdef), EConstr.of_constr tm);; @@ -283,7 +283,7 @@ let goal_info goal sigma = let build_hyp_info env sigma hyp = let (names, body, ty) = hyp in let open Pp in - let idents = List.map (fun x -> Names.Id.to_string x) names in + let idents = List.map (fun x -> Names.Id.to_string x.Context.binder_name) names in line_idents := idents :: !line_idents; let mid = match body with diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 9540d3de44..2d2113b636 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -15,6 +15,7 @@ open Names open Nameops open Termops open Constr +open Context open Namegen open Environ open Evd @@ -69,7 +70,7 @@ let clenv_push_prod cl = | Prod (na,t,u) -> let mv = new_meta () in let dep = not (noccurn (cl_sigma cl) 1 u) in - let na' = if dep then na else Anonymous in + let na' = if dep then na.binder_name else Anonymous in let e' = meta_declare mv t ~name:na' cl.evd in let concl = if dep then subst1 (mkMeta mv) u else u in let def = applist (cl.templval.rebus,[mkMeta mv]) in @@ -103,7 +104,7 @@ let clenv_environments evd bound t = | (n, Prod (na,t1,t2)) -> let mv = new_meta () in let dep = not (noccurn evd 1 t2) in - let na' = if dep then na else Anonymous in + let na' = if dep then na.binder_name else Anonymous in let e' = meta_declare mv t1 ~name:na' e in clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n) (if dep then (subst1 (mkMeta mv) t2) else t2) @@ -277,7 +278,7 @@ let adjust_meta_source evd mv = function | loc,Evar_kinds.VarInstance id -> let rec match_name c l = match EConstr.kind evd c, l with - | Lambda (Name id,_,c), a::l when EConstr.eq_constr evd a (mkMeta mv) -> Some id + | Lambda ({binder_name=Name id},_,c), a::l when EConstr.eq_constr evd a (mkMeta mv) -> Some id | Lambda (_,_,c), a::l -> match_name c l | _ -> None in (* This is very ad hoc code so that an evar inherits the name of the binder @@ -623,7 +624,7 @@ let make_evar_clause env sigma ?len t = hole_type = t1; hole_deps = dep; (* We fix it later *) - hole_name = na; + hole_name = na.binder_name; } in let t2 = if dep then subst1 ev t2 else t2 in clrec (sigma, hole :: holes) inst (pred n) t2 diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 1b2756f49f..0f97a942ed 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -37,8 +37,8 @@ let define_and_solve_constraints evk c env evd = match List.fold_left (fun p (pbty,env,t1,t2) -> match p with - | Success evd -> Evarconv.evar_conv_x TransparentState.full env evd pbty t1 t2 - | UnifFailure _ as x -> x) (Success evd) + | Success evd -> Evarconv.evar_conv_x (Evarconv.default_flags_of TransparentState.full) env evd pbty t1 t2 + | UnifFailure _ as x -> x) (Success evd) pbs with | Success evd -> evd diff --git a/proofs/goal.ml b/proofs/goal.ml index 7245d4a004..e5688fe730 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -58,10 +58,11 @@ module V82 = struct created. *) let prev_future_goals = Evd.save_future_goals evars in let evi = { Evd.evar_hyps = hyps; - Evd.evar_concl = concl; - Evd.evar_filter = Evd.Filter.identity; - Evd.evar_body = Evd.Evar_empty; - Evd.evar_source = (Loc.tag Evar_kinds.GoalEvar); + Evd.evar_concl = concl; + Evd.evar_filter = Evd.Filter.identity; + Evd.evar_abstract_arguments = Evd.Abstraction.identity; + Evd.evar_body = Evd.Evar_empty; + Evd.evar_source = (Loc.tag Evar_kinds.GoalEvar); Evd.evar_candidates = None } in let (evars, evk) = Evarutil.new_pure_evar_full evars ~typeclass_candidate:false evi in diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index a47fa78f4d..6174b75a96 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -19,6 +19,7 @@ open Util open Pp open Names +open Context module NamedDecl = Context.Named.Declaration @@ -198,10 +199,10 @@ let set_used_variables l = let vars_of = Environ.global_vars_set in let aux env entry (ctx, all_safe as orig) = match entry with - | LocalAssum (x,_) -> + | LocalAssum ({binder_name=x},_) -> if Id.Set.mem x all_safe then orig else (ctx, all_safe) - | LocalDef (x,bo, ty) as decl -> + | 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 diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index df90354717..8196f5e198 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -172,7 +172,7 @@ module New = struct let env = Proofview.Goal.env gl in let sign = Environ.named_context env in List.map (function LocalAssum (id,x) - | LocalDef (id,_,x) -> id, EConstr.of_constr x) + | LocalDef (id,_,x) -> id.Context.binder_name, EConstr.of_constr x) sign let pf_last_hyp gl = diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 213ed7bfda..1454140dd7 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -29,7 +29,7 @@ val pf_concl : Goal.goal sigma -> types val pf_env : Goal.goal sigma -> env val pf_hyps : Goal.goal sigma -> named_context (*i val pf_untyped_hyps : Goal.goal sigma -> (Id.t * constr) list i*) -val pf_hyps_types : Goal.goal sigma -> (Id.t * types) list +val pf_hyps_types : Goal.goal sigma -> (Id.t Context.binder_annot * types) list val pf_nth_hyp_id : Goal.goal sigma -> int -> Id.t val pf_last_hyp : Goal.goal sigma -> named_declaration val pf_ids_of_hyps : Goal.goal sigma -> Id.t list diff --git a/stm/stm.ml b/stm/stm.ml index 8af1a2ebd2..ab388977a5 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -3205,10 +3205,9 @@ let edit_at ~doc id = let vcs = VCS.backup () in let on_cur_branch id = let rec aux cur = - if id = cur then true - else match VCS.visit cur with + match VCS.visit cur with | { step = `Fork _ } -> false - | { next } -> aux next in + | { next } -> if id = cur then true else aux next in aux (VCS.get_branch_pos (VCS.current_branch ())) in let rec is_pure_aux id = let view = VCS.visit id in diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index f824552705..3b8232d20a 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -145,7 +145,7 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = let try_do_hyps treat_id l = autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas in - if cl.concl_occs != AllOccurrences && + if not (Locusops.is_all_occurrences cl.concl_occs) && cl.concl_occs != NoOccurrences then Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 2f2bd8d2bc..06246ef584 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -77,7 +77,7 @@ let constr_val_discr_st sigma ts t = | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id when not (TransparentState.is_transparent_variable ts id) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) - | Lambda (n, d, c) -> + | Lambda (n, d, c) -> if List.is_empty l then Label(LambdaLabel, [d; c] @ l) else Everything diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index e505bb3a42..a3620f4081 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -230,8 +230,9 @@ let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in let term = applist (term, List.map (fun x -> x.hole_evar) cl.cl_holes) in let sigma' = - Evarconv.the_conv_x_leq env ~ts:flags.core_unify_flags.modulo_delta - cl.cl_concl concl sigma' + Evarconv.(unify_leq_delay + ~flags:(default_flags_of flags.core_unify_flags.modulo_delta) + env sigma' cl.cl_concl concl) in (sigma', term) end let unify_resolve_refine poly flags gl clenv = @@ -1111,7 +1112,7 @@ let initial_select_evars filter = let resolve_typeclass_evars debug depth unique env evd filter split fail = let evd = try Evarconv.solve_unif_constraints_with_heuristics - ~ts:(Typeclasses.classes_transparent_state ()) env evd + ~flags:(Evarconv.default_flags_of (Typeclasses.classes_transparent_state ())) env evd with e when CErrors.noncritical e -> evd in resolve_all_evars debug depth unique env diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index bd95a62532..3ff2e3852d 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -9,6 +9,7 @@ (************************************************************************) open Constr +open Context open EConstr open Hipattern open Tactics @@ -19,10 +20,10 @@ module NamedDecl = Context.Named.Declaration (* Absurd *) -let mk_absurd_proof coq_not t = +let mk_absurd_proof coq_not r t = let id = Namegen.default_dependent_ident in - mkLambda (Names.Name id,mkApp(coq_not,[|t|]), - mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) + mkLambda (make_annot (Names.Name id) Sorts.Relevant,mkApp(coq_not,[|t|]), + mkLambda (make_annot (Names.Name id) r,t,mkApp (mkRel 2,[|mkRel 1|]))) let absurd c = Proofview.Goal.enter begin fun gl -> @@ -31,12 +32,13 @@ let absurd c = let j = Retyping.get_judgment_of env sigma c in let sigma, j = Coercion.inh_coerce_to_sort env sigma j in let t = j.Environ.utj_val in + let r = Sorts.relevance_of_sort j.Environ.utj_type in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.pf_constr_of_global (Coqlib.(lib_ref "core.not.type")) >>= fun coqnot -> Tacticals.New.pf_constr_of_global (Coqlib.(lib_ref "core.False.type")) >>= fun coqfalse -> Tacticals.New.tclTHENLIST [ elim_type coqfalse; - Simple.apply (mk_absurd_proof coqnot t) + Simple.apply (mk_absurd_proof coqnot r t) ] end @@ -68,9 +70,9 @@ let contradiction_context = if is_empty_type sigma typ then simplest_elim (mkVar id) else match EConstr.kind sigma typ with - | Prod (na,t,u) when is_empty_type sigma u -> + | Prod (na,t,u) when is_empty_type sigma u -> let is_unit_or_eq = match_with_unit_or_eq_type sigma t in - Tacticals.New.tclORELSE + Tacticals.New.tclORELSE (match is_unit_or_eq with | Some _ -> let hd,args = decompose_app sigma t in diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 3b69d9922d..1fae4c3d9d 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -88,14 +88,27 @@ let ind_scheme_kind_from_type = declare_individual_scheme_object "_ind_nodep" (optimize_non_type_induction_scheme rec_scheme_kind_from_type false InProp) +let sind_scheme_kind_from_type = + declare_individual_scheme_object "_sind_nodep" + (fun _ x -> build_induction_scheme_in_type false InSProp x, Safe_typing.empty_private_constants) + let ind_dep_scheme_kind_from_type = declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" (optimize_non_type_induction_scheme rec_dep_scheme_kind_from_type true InProp) +let sind_dep_scheme_kind_from_type = + declare_individual_scheme_object "_sind" ~aux:"_sind_from_type" + (fun _ x -> build_induction_scheme_in_type true InSProp x, Safe_typing.empty_private_constants) + let ind_scheme_kind_from_prop = declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" (optimize_non_type_induction_scheme rec_scheme_kind_from_prop false InProp) +let sind_scheme_kind_from_prop = + declare_individual_scheme_object "_sind" ~aux:"_sind_from_prop" + (fun _ x -> build_induction_scheme_in_type false InSProp x, Safe_typing.empty_private_constants) + + (* Case analysis *) let build_case_analysis_scheme_in_type dep sort ind = diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index ece4124b8b..4472792449 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -22,11 +22,14 @@ val optimize_non_type_induction_scheme : val rect_scheme_kind_from_prop : individual scheme_kind val ind_scheme_kind_from_prop : individual scheme_kind +val sind_scheme_kind_from_prop : individual scheme_kind val rec_scheme_kind_from_prop : individual scheme_kind val rect_scheme_kind_from_type : individual scheme_kind val rect_dep_scheme_kind_from_type : individual scheme_kind val ind_scheme_kind_from_type : individual scheme_kind val ind_dep_scheme_kind_from_type : individual scheme_kind +val sind_scheme_kind_from_type : individual scheme_kind +val sind_dep_scheme_kind_from_type : individual scheme_kind val rec_scheme_kind_from_type : individual scheme_kind val rec_dep_scheme_kind_from_type : individual scheme_kind diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 6388aa2c33..e75a61d0c6 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -18,6 +18,7 @@ open Util open Names open Namegen open Constr +open Context open EConstr open Declarations open Tactics @@ -74,7 +75,8 @@ let generalize_right mk typ c1 c2 = let env = Proofview.Goal.env gl in Refine.refine ~typecheck:false begin fun sigma -> let na = Name (next_name_away_with_default "x" Anonymous (Termops.vars_of_env env)) in - let newconcl = mkProd (na, typ, mk typ c1 (mkRel 1)) in + let r = Retyping.relevance_of_type env sigma typ in + let newconcl = mkProd (make_annot na r, typ, mk typ c1 (mkRel 1)) in let (sigma, x) = Evarutil.new_evar env sigma ~principal:true newconcl in (sigma, mkApp (x, [|c2|])) end @@ -123,8 +125,8 @@ let mkGenDecideEqGoal rectype ops g = let hypnames = pf_ids_set_of_hyps g in let xname = next_ident_away idx hypnames and yname = next_ident_away idy hypnames in - (mkNamedProd xname rectype - (mkNamedProd yname rectype + (mkNamedProd (make_annot xname Sorts.Relevant) rectype + (mkNamedProd (make_annot yname Sorts.Relevant) rectype (mkDecideEqGoal true ops rectype (mkVar xname) (mkVar yname)))) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index b12018cd66..073d66e4aa 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -51,6 +51,7 @@ open Util open Names open Term open Constr +open Context open Vars open Declarations open Environ @@ -66,7 +67,7 @@ module RelDecl = Context.Rel.Declaration let hid = Id.of_string "H" let xid = Id.of_string "X" -let default_id_of_sort = function InProp | InSet -> hid | InType -> xid +let default_id_of_sort = function InSProp | InProp | InSet -> hid | InType -> xid let fresh env id = next_global_ident_away id Id.Set.empty let with_context_set ctx (b, ctx') = (b, Univ.ContextSet.union ctx ctx') @@ -80,8 +81,8 @@ let build_dependent_inductive ind (mib,mip) = let named_hd env t na = named_hd env (Evd.from_env env) (EConstr.of_constr t) na let name_assumption env = function -| LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) -| LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) +| LocalAssum (na,t) -> LocalAssum (map_annot (named_hd env t) na, t) +| LocalDef (na,c,t) -> LocalDef (map_annot (named_hd env c) na, c, t) let name_context env hyps = snd @@ -138,7 +139,7 @@ let get_sym_eq_data env (ind,u) = let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; - let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in + let constrsign,ccl = mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; (* This can be relaxed... *) @@ -173,7 +174,7 @@ let get_non_sym_eq_data env (ind,u) = let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported"; - let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in + let constrsign,ccl = mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; @@ -202,11 +203,14 @@ let build_sym_scheme env ind = get_sym_eq_data env indu in let cstr n = mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect mkRel n mib.mind_params_ctxt) in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let varH = fresh env (default_id_of_sort inds) in let applied_ind = build_dependent_inductive indu specif in + let indr = Sorts.relevance_of_sort_family inds in let realsign_ind = - name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in - let ci = make_case_info (Global.env()) ind RegularStyle in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind @@ -256,7 +260,9 @@ let build_sym_involutive_scheme env ind = let eq,eqrefl,ctx = get_coq_eq ctx in let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in let cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect mkRel n paramsctxt) in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let indr = Sorts.relevance_of_sort_family inds in + let varH = fresh env (default_id_of_sort inds) in let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp @@ -264,8 +270,9 @@ let build_sym_involutive_scheme env ind = (Context.Rel.to_extended_vect mkRel (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = - name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in - let ci = make_case_info (Global.env()) ind RegularStyle in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind @@ -368,7 +375,9 @@ let build_l2r_rew_scheme dep env ind kind = mkApp (mkConstructUi(indu,1), Array.concat [Context.Rel.to_extended_vect mkRel n paramsctxt1; rel_vect p nrealargs]) in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let indr = Sorts.relevance_of_sort_family inds in + let varH = fresh env (default_id_of_sort inds) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive indu specif in @@ -384,9 +393,9 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect 0 nrealargs]) in let realsign_P = lift_rel_context nrealargs realsign in let realsign_ind_P = - name_context env ((LocalAssum (Name varH,applied_ind_P))::realsign_P) in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind_P))::realsign_P) in let realsign_ind_G = - name_context env ((LocalAssum (Name varH,applied_ind_G)):: + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind_G)):: lift_rel_context (nrealargs+3) realsign) in let applied_sym_C n = mkApp(sym, @@ -400,8 +409,9 @@ let build_l2r_rew_scheme dep env ind kind = let s, ctx' = UnivGen.fresh_sort_in_family kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in - let ci = make_case_info (Global.env()) ind RegularStyle in - let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in + let cieq = make_case_info (Global.env()) (fst (destInd eq)) rci RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append (Context.Rel.to_extended_vect mkRel 1 realsign) (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in @@ -429,14 +439,14 @@ let build_l2r_rew_scheme dep env ind kind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign - (mkNamedLambda varP + (mkNamedLambda (make_annot varP indr) (my_it_mkProd_or_LetIn (if dep then realsign_ind_P else realsign_P) s) - (mkNamedLambda varHC applied_PC - (mkNamedLambda varH (lift 2 applied_ind) + (mkNamedLambda (make_annot varHC indr) applied_PC + (mkNamedLambda (make_annot varH indr) (lift 2 applied_ind) (if dep then (* we need a coercion *) mkCase (cieq, - mkLambda (Name varH,lift 3 applied_ind, - mkLambda (Anonymous, + mkLambda (make_annot (Name varH) indr,lift 3 applied_ind, + mkLambda (make_annot Anonymous indr, mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), applied_PR)), mkApp (sym_involutive, @@ -481,7 +491,9 @@ let build_l2r_forward_rew_scheme dep env ind kind = mkApp (mkConstructUi(indu,1), Array.concat [Context.Rel.to_extended_vect mkRel n paramsctxt1; rel_vect p nrealargs]) in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let indr = Sorts.relevance_of_sort_family inds in + let varH = fresh env (default_id_of_sort inds) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive indu specif in @@ -497,13 +509,14 @@ let build_l2r_forward_rew_scheme dep env ind kind = rel_vect (2*nrealargs+1) nrealargs]) in let realsign_P n = lift_rel_context (nrealargs*n+n) realsign in let realsign_ind = - name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in let realsign_ind_P n aP = - name_context env ((LocalAssum (Name varH,aP))::realsign_P n) in + name_context env ((LocalAssum (make_annot (Name varH) indr,aP))::realsign_P n) in let s, ctx' = UnivGen.fresh_sort_in_family kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in - let ci = make_case_info (Global.env()) ind RegularStyle in + let rci = Sorts.Relevant in + let ci = make_case_info (Global.env()) ind rci RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append (rel_vect (nrealargs*2+3) nrealargs) @@ -519,19 +532,19 @@ let build_l2r_forward_rew_scheme dep env ind kind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign - (mkNamedLambda varH applied_ind + (mkNamedLambda (make_annot varH indr) applied_ind (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) - (mkNamedProd varP + (mkNamedProd (make_annot varP indr) (my_it_mkProd_or_LetIn (if dep then realsign_ind_P 2 applied_ind_P else realsign_P 2) s) - (mkNamedProd varHC applied_PC applied_PG)), + (mkNamedProd (make_annot varHC indr) applied_PC applied_PG)), (mkVar varH), - [|mkNamedLambda varP + [|mkNamedLambda (make_annot varP indr) (my_it_mkProd_or_LetIn (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) - (mkNamedLambda varHC applied_PC' + (mkNamedLambda (make_annot varHC indr) applied_PC' (mkVar varHC))|]))))) in c, UState.of_context_set ctx @@ -572,16 +585,19 @@ let build_r2l_forward_rew_scheme dep env ind kind = let cstr n = mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect mkRel n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let indr = Sorts.relevance_of_sort_family inds in + let varH = fresh env (default_id_of_sort inds) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive indu specif in let realsign_ind = - name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in let s, ctx' = UnivGen.fresh_sort_in_family kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in - let ci = make_case_info (Global.env()) ind RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in let applied_PC = applist (mkVar varP,if dep then constrargs_cstr else constrargs) in let applied_PG = @@ -591,18 +607,18 @@ let build_r2l_forward_rew_scheme dep env ind kind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind - (mkNamedLambda varP + (mkNamedLambda (make_annot varP indr) (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1) (if dep then realsign_ind else realsign)) s) - (mkNamedLambda varHC (lift 1 applied_PG) + (mkNamedLambda (make_annot varHC indr) (lift 1 applied_PG) (mkApp (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+3) realsign_ind) - (mkArrow applied_PG (lift (2*nrealargs+5) applied_PC)), + (mkArrow applied_PG indr (lift (2*nrealargs+5) applied_PC)), mkRel 3 (* varH *), [|mkLambda - (Name varHC, + (make_annot (Name varHC) indr, lift (nrealargs+3) applied_PC, mkRel 1)|]), [|mkVar varHC|])))))) @@ -775,8 +791,11 @@ let build_congr env (eq,refl,ctx) ind = if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; let env_with_arity = push_rel_context arityctxt env in - let ty = RelDecl.get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in - let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in + let ty, tyr = + let decl = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in + RelDecl.get_type decl, RelDecl.get_relevance decl + in + let constrsign,ccl = mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; @@ -784,15 +803,16 @@ let build_congr env (eq,refl,ctx) ind = let varB = fresh env (Id.of_string "B") in let varH = fresh env (Id.of_string "H") in let varf = fresh env (Id.of_string "f") in - let ci = make_case_info (Global.env()) ind RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in let uni, ctx = Univ.extend_in_context_set (UnivGen.new_global_univ ()) ctx in let ctx = (fst ctx, Univ.enforce_leq uni (univ_of_eq env eq) (snd ctx)) in let c = my_it_mkLambda_or_LetIn paramsctxt - (mkNamedLambda varB (mkSort (Type uni)) - (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB)) + (mkNamedLambda (make_annot varB Sorts.Relevant) (mkType uni) + (mkNamedLambda (make_annot varf Sorts.Relevant) (mkArrow (lift 1 ty) tyr (mkVar varB)) (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign) - (mkNamedLambda varH + (mkNamedLambda (make_annot varH Sorts.Relevant) (applist (mkIndU indu, Context.Rel.to_extended_list mkRel (mip.mind_nrealargs+2) paramsctxt @ @@ -801,7 +821,7 @@ let build_congr env (eq,refl,ctx) ind = my_it_mkLambda_or_LetIn_name (lift_rel_context (mip.mind_nrealargs+3) realsign) (mkLambda - (Anonymous, + (make_annot Anonymous Sorts.Relevant, applist (mkIndU indu, Context.Rel.to_extended_list mkRel (2*mip.mind_nrealdecls+3) diff --git a/tactics/equality.ml b/tactics/equality.ml index 769e702da1..88ce9868af 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -16,6 +16,7 @@ open Names open Nameops open Term open Constr +open Context open Termops open EConstr open Vars @@ -437,7 +438,7 @@ let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac) let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac ((c,l) : constr with_bindings) with_evars = - if occs != AllOccurrences then ( + if not (Locusops.is_all_occurrences occs) then ( rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) else Proofview.Goal.enter begin fun gl -> @@ -595,15 +596,16 @@ let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else check_required_library ["Coq";"Setoids";"Setoid"] -let check_setoid cl = +let check_setoid cl = + let concloccs = Locusops.occurrences_map (fun x -> x) cl.concl_occs in Option.fold_left - ( List.fold_left + (List.fold_left (fun b ((occ,_),_) -> - b||(Locusops.occurrences_map (fun x -> x) occ <> AllOccurrences) + b||(not (Locusops.is_all_occurrences (Locusops.occurrences_map (fun x -> x) occ))) ) ) - ((Locusops.occurrences_map (fun x -> x) cl.concl_occs <> AllOccurrences) && - (Locusops.occurrences_map (fun x -> x) cl.concl_occs <> NoOccurrences)) + (not (Locusops.is_all_occurrences concloccs) && + (concloccs <> NoOccurrences)) cl.onhyps let replace_core clause l2r eq = @@ -635,7 +637,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = let evd = if unsafe then Some (Tacmach.New.project gl) else - try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl)) + try Some (Evarconv.unify_delay (Proofview.Goal.env gl) (Tacmach.New.project gl) t1 t2) with Evarconv.UnableToUnify _ -> None in match evd with @@ -886,7 +888,8 @@ let descend_then env sigma head dirn = let brl = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in - let ci = make_case_info env ind RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info env ind rci RegularStyle in Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable @@ -931,7 +934,8 @@ let build_selector env sigma dirn c ind special default = it_mkLambda_or_LetIn endpt args in let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in - let ci = make_case_info env ind RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info env ind rci RegularStyle in let ans = Inductiveops.make_case_or_project env sigma indf ci p c (Array.of_list brl) in ans @@ -996,7 +1000,7 @@ let discrimination_pf e (t,t1,t2) discriminator lbeq = Proofview.tclEFFECTS eff <*> pf_constr_of_global eq_elim >>= fun eq_elim -> Proofview.tclUNIT - (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term) + (applist (eq_elim, [t;t1;mkNamedLambda (make_annot e Sorts.Relevant) t discriminator;i;t2]), absurd_term) let eq_baseid = Id.of_string "e" @@ -1014,7 +1018,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = build_coq_True () >>= fun true_0 -> build_coq_False () >>= fun false_0 -> let e = next_ident_away eq_baseid (vars_of_env env) in - let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in + let e_env = push_named (Context.Named.Declaration.LocalAssum (make_annot e Sorts.Relevant,t)) env in let discriminator = try Proofview.tclUNIT @@ -1024,7 +1028,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = in discriminator >>= fun discriminator -> discrimination_pf e (t,t1,t2) discriminator lbeq >>= fun (pf, absurd_term) -> - let pf_ty = mkArrow eqn absurd_term in + let pf_ty = mkArrow eqn Sorts.Relevant absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in tclTHENS (assert_after Anonymous absurd_term) @@ -1113,7 +1117,7 @@ let make_tuple env sigma (rterm,rty) lind = assert (not (noccurn sigma lind rty)); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in - let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in + let na = Context.Rel.Declaration.get_annot (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) @@ -1193,9 +1197,8 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = (* is the default value typable with the expected type *) let dflt_typ = unsafe_type_of env sigma dflt in try - let sigma = Evarconv.the_conv_x_leq env dflt_typ p_i sigma in - let sigma = - Evarconv.solve_unif_constraints_with_heuristics env sigma in + let sigma = Evarconv.unify_leq_delay env sigma dflt_typ p_i in + let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in sigma, dflt with Evarconv.UnableToUnify _ -> user_err Pp.(str "Cannot solve a unification problem.") @@ -1210,11 +1213,11 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = match evopt with | Some w -> let w_type = unsafe_type_of env sigma w in - begin match Evarconv.cumul env sigma w_type a with - | Some sigma -> + begin match Evarconv.unify_leq_delay env sigma w_type a with + | sigma -> let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in sigma, applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) - | None -> + | exception Evarconv.UnableToUnify _ -> user_err Pp.(str "Cannot solve a unification problem.") end | None -> @@ -1374,13 +1377,13 @@ let simplify_args env sigma t = let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (vars_of_env env) in - let e_env = push_named (LocalAssum (e,t)) env in + let e_env = push_named (LocalAssum (make_annot e Sorts.Relevant,t)) env in let evdref = ref sigma in let filter (cpath, t1', t2') = try (* arbitrarily take t1' as the injector default value *) let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in - let injfun = mkNamedLambda e t injbody in + let injfun = mkNamedLambda (make_annot e Sorts.Relevant) t injbody in let sigma,congr = Evd.fresh_global env sigma eq.congr in let pf = applist(congr,[t;resty;injfun;t1;t2]) in let sigma, pf_typ = Typing.type_of env sigma pf in @@ -1565,9 +1568,9 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* We build the expected goal *) let abst_B = List.fold_right - (fun (e,t) body -> lambda_create env sigma (t,subst_term sigma e body)) e1_list b in + (fun (e,t) body -> lambda_create env sigma (Sorts.Relevant,t,subst_term sigma e body)) e1_list b in let pred_body = beta_applist sigma (abst_B,proj_list) in - let body = mkApp (lambda_create env sigma (typ,pred_body),[|dep_pair1|]) in + let body = mkApp (lambda_create env sigma (Sorts.Relevant,typ,pred_body),[|dep_pair1|]) in let expected_goal = beta_applist sigma (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota env sigma expected_goal in @@ -1724,7 +1727,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = tclTHENLIST ((if need_rewrite then [revert (List.map snd dephyps); - general_rewrite dir AllOccurrences true dep_proof_ok (mkVar hyp); + general_rewrite dir AtLeastOneOccurrence true dep_proof_ok (mkVar hyp); (tclMAP (fun (dest,id) -> intro_move (Some id) dest) dephyps)] else [Proofview.tclUNIT ()]) @ diff --git a/tactics/hints.ml b/tactics/hints.ml index c1f6365f5d..a04a9f9db9 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -13,6 +13,7 @@ open Util open CErrors open Names open Constr +open Context open Evd open EConstr open Vars @@ -1275,7 +1276,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = let id = next_ident_away_from default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; - mkNamedLambda id t (iter (replace_term sigma evar (mkVar id) c)) in + mkNamedLambda (make_annot id Sorts.Relevant) t (iter (replace_term sigma evar (mkVar id) c)) in let c' = iter c in let env = Global.env () in let empty_sigma = Evd.from_env env in @@ -1305,7 +1306,7 @@ let project_hint ~poly pri l2r r = 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 (lift 1 b);mkArrow b (lift 1 a);c|])) sign in + (mkApp (p,[|mkArrow a Sorts.Relevant (lift 1 b);mkArrow b Sorts.Relevant (lift 1 a);c|])) sign in let id = Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) in diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 708412720a..08131f6309 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -106,22 +106,24 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = && (Int.equal mip.mind_nrealargs 0) then if is_strict_conjunction style (* strict conjunction *) then - let ctx = - (prod_assum sigma (snd - (decompose_prod_n_assum sigma mib.mind_nparams (EConstr.of_constr mip.mind_nf_lc.(0))))) in + let (ctx, _) = mip.mind_nf_lc.(0) in + let ctx = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in if + (* Constructor has a type of the form + c : forall (a_0 ... a_n : Type) (x_0 : A_0) ... (x_n : A_n). T **) List.for_all (fun decl -> let c = RelDecl.get_type decl in is_local_assum decl && - isRel sigma c && - Int.equal (destRel sigma c) mib.mind_nparams) ctx + Constr.isRel c && + Int.equal (Constr.destRel c) mib.mind_nparams) ctx then Some (hdapp,args) else None else + let ctx, cty = mip.mind_nf_lc.(0) in + let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in let ctyp = whd_beta_prod sigma - (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) - (EConstr.of_constr mip.mind_nf_lc.(0)) args) in + (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) cty args) in let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then (* Record or non strict conjunction *) @@ -165,12 +167,13 @@ let is_tuple sigma t = it is strict if it has the form "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) -let test_strict_disjunction n lc = - let open Term in - Array.for_all_i (fun i c -> - match (prod_assum (snd (decompose_prod_n_assum n c))) with - | [LocalAssum (_,c)] -> Constr.isRel c && Int.equal (Constr.destRel c) (n - i) - | _ -> false) 0 lc +let test_strict_disjunction (mib, mip) = + let n = List.length mib.mind_params_ctxt in + let check i (ctx, _) = match List.skipn n (List.rev ctx) with + | [LocalAssum (_, c)] -> Constr.isRel c && Int.equal (Constr.destRel c) (n - i) + | _ -> false + in + Array.for_all_i check 0 mip.mind_nf_lc let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = let (hdapp,args) = decompose_app sigma t in @@ -179,19 +182,21 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = let car = constructors_nrealargs ind in let (mib,mip) = Global.lookup_inductive ind in if Array.for_all (fun ar -> Int.equal ar 1) car - && not (mis_is_recursive (ind,mib,mip)) - && (Int.equal mip.mind_nrealargs 0) + && not (mis_is_recursive (ind,mib,mip)) + && (Int.equal mip.mind_nrealargs 0) then - if strict then - if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then + if strict then + if test_strict_disjunction (mib, mip) then Some (hdapp,args) else None else - let cargs = - Array.map (fun ar -> pi2 (destProd sigma (prod_applist sigma (EConstr.of_constr ar) args))) - mip.mind_nf_lc in - Some (hdapp,Array.to_list cargs) + let map (ctx, cty) = + let ar = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in + pi2 (destProd sigma (prod_applist sigma ar args)) + in + let cargs = Array.map map mip.mind_nf_lc in + Some (hdapp,Array.to_list cargs) else None | _ -> None in @@ -225,10 +230,8 @@ let match_with_unit_or_eq_type sigma t = match EConstr.kind sigma hdapp with | Ind (ind , _) -> let (mib,mip) = Global.lookup_inductive ind in - let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in - let zero_args c = Int.equal (nb_prod sigma (EConstr.of_constr c)) mib.mind_nparams in - if Int.equal nconstr 1 && zero_args constr_types.(0) then + if Int.equal nconstr 1 && Int.equal mip.mind_consnrealargs.(0) 0 then Some hdapp else None @@ -308,11 +311,13 @@ let match_with_equation env sigma t = let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 1 then - if is_matching env sigma coq_refl_leibniz1_pattern (EConstr.of_constr constr_types.(0)) then + let (ctx, cty) = constr_types.(0) in + let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in + if is_matching env sigma coq_refl_leibniz1_pattern cty then None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) - else if is_matching env sigma coq_refl_leibniz2_pattern (EConstr.of_constr constr_types.(0)) then + else if is_matching env sigma coq_refl_leibniz2_pattern cty then None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if is_matching env sigma coq_refl_jm_pattern (EConstr.of_constr constr_types.(0)) then + else if is_matching env sigma coq_refl_jm_pattern cty then None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) else raise NoEquationFound else raise NoEquationFound @@ -378,8 +383,9 @@ let match_with_nodep_ind sigma t = | Ind (ind, _) -> let (mib,mip) = Global.lookup_inductive ind in if Array.length (mib.mind_packets)>1 then None else - let nodep_constr c = - has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) sigma (EConstr.of_constr c) in + let nodep_constr (ctx, cty) = + let c = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in + has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt) sigma c in if Array.for_all nodep_constr mip.mind_nf_lc then let params= if Int.equal mip.mind_nrealargs 0 then args else @@ -400,7 +406,7 @@ let match_with_sigma_type sigma t = && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) && has_nodep_prod_after (Context.Rel.length mib.mind_params_ctxt + 1) sigma - (EConstr.of_constr mip.mind_nf_lc.(0)) + (let (ctx, cty) = mip.mind_nf_lc.(0) in EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx)) then (*allowing only 1 existential*) Some (hdapp,args) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index f04cda1232..741f6713e3 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -86,7 +86,7 @@ val is_equality_type : testing_function val match_with_nottype : Environ.env -> (constr * constr) matching_function val is_nottype : Environ.env -> testing_function -val match_with_forall_term : (Name.t * constr * constr) matching_function +val match_with_forall_term : (Name.t Context.binder_annot * constr * constr) matching_function val is_forall_term : testing_function val match_with_imp_term : (constr * constr) matching_function diff --git a/tactics/inv.ml b/tactics/inv.ml index 2ae37ab471..776148d4cf 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -15,6 +15,7 @@ open Names open Term open Termops open Constr +open Context open EConstr open Vars open Namegen @@ -131,7 +132,7 @@ let make_inv_predicate env evd indf realargs id status concl = let eq_term = eqdata.Coqlib.eq in let eq = evd_comb1 (Evd.fresh_global env) evd eq_term in let eqn = applist (eq,[eqnty;lhs;rhs]) in - let eqns = (Anonymous, lift n eqn) :: eqns in + let eqns = (make_annot Anonymous Sorts.Relevant, lift n eqn) :: eqns in let refl_term = eqdata.Coqlib.refl in let refl_term = evd_comb1 (Evd.fresh_global env) evd refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 335f3c74ff..4aa4d13e1e 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -15,6 +15,7 @@ open Names open Termops open Environ open Constr +open Context open EConstr open Vars open Namegen @@ -120,13 +121,13 @@ let max_prefix_sign lid sign = let rec add_prods_sign env sigma t = match EConstr.kind sigma (whd_all env sigma t) with | Prod (na,c1,b) -> - let id = id_of_name_using_hdchar env sigma t na in + let id = id_of_name_using_hdchar env sigma t na.binder_name in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (LocalAssum (id,c1)) env) sigma b' + add_prods_sign (push_named (LocalAssum ({na with binder_name=id},c1)) env) sigma b' | LetIn (na,c1,t1,b) -> - let id = id_of_name_using_hdchar env sigma t na in + let id = id_of_name_using_hdchar env sigma t na.binder_name in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (LocalDef (id,c1,t1)) env) sigma b' + add_prods_sign (push_named (LocalDef ({na with binder_name=id},c1,t1)) env) sigma b' | _ -> (env,t) (* [dep_option] indicates whether the inversion lemma is dependent or not. @@ -149,9 +150,10 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let pty,goal = if dep_option then let pty = make_arity env sigma true indf sort in + let r = relevance_of_inductive_type env ind in let goal = mkProd - (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) + (make_annot Anonymous r, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) in pty,goal else @@ -169,11 +171,11 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = env ~init:([],[]) in let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in - let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in + let goal = mkArrow i Sorts.Relevant (applist(mkVar p, List.rev revargs)) in (pty,goal) in let npty = nf_all env sigma pty in - let extenv = push_named (LocalAssum (p,npty)) env in + let extenv = push_named (LocalAssum (make_annot p Sorts.Relevant,npty)) env in extenv, goal (* [inversion_scheme sign I] @@ -225,7 +227,7 @@ let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = let h = next_ident_away (Id.of_string "H") !avoid in let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in avoid := Id.Set.add h !avoid; - ownSign := Context.Named.add (LocalAssum (h,ty)) !ownSign; + ownSign := Context.Named.add (LocalAssum (make_annot h Sorts.Relevant,ty)) !ownSign; applist (mkVar h, inst) | _ -> EConstr.map sigma fill_holes c in diff --git a/tactics/ppred.ml b/tactics/ppred.ml index dd1bcd4699..d832dc279c 100644 --- a/tactics/ppred.ml +++ b/tactics/ppred.ml @@ -6,6 +6,7 @@ open Pputils let pr_with_occurrences pr keyword (occs,c) = match occs with + | AtLeastOneOccurrence -> hov 1 (pr c ++ spc () ++ keyword "at" ++ str" +") | AllOccurrences -> pr c | NoOccurrences -> diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bfbce8f6eb..ec8d4d0e14 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -20,6 +20,7 @@ open Tacmach open Clenv open Tactypes +module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration (************************************************************************) @@ -223,8 +224,8 @@ let compute_induction_names = compute_induction_names_gen true (* Compute the let-in signature of case analysis or standard induction scheme *) let compute_constructor_signatures ~rec_flag ((_,k as ity),u) = let rec analrec c recargs = - match Constr.kind c, recargs with - | Prod (_,_,c), recarg::rest -> + match c, recargs with + | RelDecl.LocalAssum _ :: c, recarg::rest -> let rest = analrec c rest in begin match Declareops.dest_recarg recarg with | Norec | Imbr _ -> true :: rest @@ -232,14 +233,13 @@ let compute_constructor_signatures ~rec_flag ((_,k as ity),u) = if rec_flag && Int.equal j k then true :: true :: rest else true :: rest end - | LetIn (_,_,_,c), rest -> false :: analrec c rest - | _, [] -> [] + | RelDecl.LocalDef _ :: c, rest -> false :: analrec c rest + | [], [] -> [] | _ -> anomaly (Pp.str "compute_constructor_signatures.") in let (mib,mip) = Global.lookup_inductive ity in - let n = mib.mind_nparams in - let lc = - Array.map (fun c -> snd (Term.decompose_prod_n_assum n c)) mip.mind_nf_lc in + let map (ctx, _) = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in + let lc = Array.map map mip.mind_nf_lc in let lrecargs = Declareops.dest_subterms mip.mind_recargs in Array.map2 analrec lc lrecargs diff --git a/tactics/tactics.ml b/tactics/tactics.ml index db59f7cfc2..b8308dc49b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -14,6 +14,7 @@ open Util open Names open Nameops open Constr +open Context open Termops open Environ open EConstr @@ -137,8 +138,8 @@ let introduction id = in let open Context.Named.Declaration in match EConstr.kind sigma concl with - | Prod (_, t, b) -> unsafe_intro env (LocalAssum (id, t)) b - | LetIn (_, c, t, b) -> unsafe_intro env (LocalDef (id, c, t)) b + | Prod (id0, t, b) -> unsafe_intro env (LocalAssum ({id0 with binder_name=id}, t)) b + | LetIn (id0, c, t, b) -> unsafe_intro env (LocalDef ({id0 with binder_name=id}, c, t)) b | _ -> raise (RefinerError (env, sigma, IntroNeedsProduct)) end @@ -366,8 +367,8 @@ let default_id env sigma decl = match decl with | LocalAssum (name,t) -> let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in - id_of_name_with_default dft name - | LocalDef (name,b,_) -> id_of_name_using_hdchar env sigma b name + id_of_name_with_default dft name.binder_name + | LocalDef (name,b,_) -> id_of_name_using_hdchar env sigma b name.binder_name (* Non primitive introduction tactics are treated by intro_then_gen There is possibly renaming, with possibly names to avoid and @@ -437,16 +438,17 @@ let internal_cut_gen ?(check=true) dir replace id t = let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let sign = named_context_val env in + let r = Retyping.relevance_of_type env sigma t in let sign',t,concl,sigma = if replace then let nexthyp = get_next_hyp_position env sigma id (named_context_of_val sign) in let sigma,sign',t,concl = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in - let sign' = insert_decl_in_named_context env sigma (LocalAssum (id,t)) nexthyp sign' in + let sign' = insert_decl_in_named_context env sigma (LocalAssum (make_annot id r,t)) nexthyp sign' in sign',t,concl,sigma else (if check && mem_named_context_val id sign then user_err (str "Variable " ++ Id.print id ++ str " is already declared."); - push_named_context_val (LocalAssum (id,t)) sign,t,concl,sigma) in + push_named_context_val (LocalAssum (make_annot id r,t)) sign,t,concl,sigma) in let nf_t = nf_betaiota env sigma t in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) @@ -460,7 +462,7 @@ let internal_cut_gen ?(check=true) dir replace id t = let (sigma, ev') = Evarutil.new_evar_from_context sign' sigma ~principal:true concl in let (sigma, ev) = Evarutil.new_evar_from_context sign sigma nf_t in (sigma,ev,ev') in - let term = mkLetIn (Name id, ev, t, EConstr.Vars.subst_var id ev') in + let term = mkLetIn (make_annot (Name id) r, ev, t, EConstr.Vars.subst_var id ev') in (sigma, term) end) end @@ -471,7 +473,7 @@ let internal_cut_rev ?(check=true) = internal_cut_gen ~check false let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> - let id = find_name b (LocalAssum (Anonymous,t)) naming gl in + let id = find_name b (LocalAssum (make_annot Anonymous Sorts.Relevant,t)) naming gl in Tacticals.New.tclTHENLAST (internal_cut b id t) (tac id) @@ -486,7 +488,7 @@ let assert_before_replacing id = assert_before_gen true (NamingMustBe (CAst.make let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> - let id = find_name b (LocalAssum (Anonymous,t)) naming gl in + let id = find_name b (LocalAssum (make_annot Anonymous Sorts.Relevant,t)) naming gl in Tacticals.New.tclTHENFIRST (internal_cut_rev b id t) (tac id) @@ -542,7 +544,7 @@ let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> if mem_named_context_val f sign then user_err ~hdr:"Logic.prim_refiner" (str "Name " ++ Id.print f ++ str " already used in the environment"); - mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth + mk_sign (push_named_context_val (LocalAssum (make_annot f Sorts.Relevant, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine ~typecheck:false begin fun sigma -> @@ -550,7 +552,8 @@ let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> let ids = List.map pi1 all in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in - let funnames = Array.of_list (List.map (fun i -> Name i) ids) in + (* TODO relevance *) + let funnames = Array.of_list (List.map (fun i -> make_annot (Name i) Sorts.Relevant) ids) in let typarray = Array.of_list (List.map pi3 all) in let bodies = Array.of_list evs in let oterm = mkFix ((indxs,0),(funnames,typarray,bodies)) in @@ -586,14 +589,15 @@ let mutual_cofix f others j = Proofview.Goal.enter begin fun gl -> let open Context.Named.Declaration in if mem_named_context_val f sign then error "Name already used in the environment."; - mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth + mk_sign (push_named_context_val (LocalAssum (make_annot f Sorts.Relevant, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine ~typecheck:false begin fun sigma -> let (ids, types) = List.split all in let (sigma, evs) = mk_holes nenv sigma types in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in - let funnames = Array.of_list (List.map (fun i -> Name i) ids) in + (* TODO relevance *) + let funnames = Array.of_list (List.map (fun i -> make_annot (Name i) Sorts.Relevant) ids) in let typarray = Array.of_list types in let bodies = Array.of_list evs in let oterm = mkCoFix (0, (funnames, typarray, bodies)) in @@ -616,7 +620,7 @@ let pf_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - user_err (Id.print id ++ str " has no value."); + user_err (Id.print id.binder_name ++ str " has no value."); LocalAssum (id,redfun' ty) | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in @@ -717,7 +721,7 @@ let pf_e_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - user_err (Id.print id ++ str " has no value."); + user_err (Id.print id.binder_name ++ str " has no value."); let (sigma, ty') = redfun sigma ty in (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> @@ -760,7 +764,7 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - user_err (Id.print id ++ str " has no value."); + user_err (Id.print id.binder_name ++ str " has no value."); let (sigma, ty') = redfun false env sigma ty in (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> @@ -947,7 +951,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let name = find_name false (LocalDef (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | Evar ev when force_flag -> - let sigma, t = Evardefine.define_evar_as_product sigma ev in + let sigma, t = Evardefine.define_evar_as_product env sigma ev in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (intro_then_gen name_flag move_flag force_flag dep_flag tac) @@ -1238,27 +1242,29 @@ let cut c = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in - let is_sort = + let relevance = try - (* Backward compat: ensure that [c] is well-typed. *) + (* Backward compat: ensure that [c] is well-typed. Plus we + need to know the relevance *) let typ = Typing.unsafe_type_of env sigma c in let typ = whd_all env sigma typ in match EConstr.kind sigma typ with - | Sort _ -> true - | _ -> false - with e when Pretype_errors.precatchable_exception e -> false + | Sort s -> Some (Sorts.relevance_of_sort (ESorts.kind sigma s)) + | _ -> None + with e when Pretype_errors.precatchable_exception e -> None in - if is_sort then + match relevance with + | Some r -> let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in (* Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in Refine.refine ~typecheck:false begin fun h -> - let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in + let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c r (Vars.lift 1 concl)) in let (h, x) = Evarutil.new_evar env h c in - let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in + let f = mkLetIn (make_annot (Name id) r, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in (h, f) end - else + | None -> Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") end @@ -1823,7 +1829,7 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta let sigma = Tacmach.New.project gl in let t' = Tacmach.New.pf_get_hyp_typ id gl in let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in - let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in + let targetid = find_name true (LocalAssum (make_annot Anonymous Sorts.Relevant,t')) naming gl in let rec aux idstoclear with_destruct c = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1890,7 +1896,7 @@ let cut_and_apply c = let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in Refine.refine ~typecheck:false begin fun sigma -> - let typ = mkProd (Anonymous, c2, concl) in + let typ = mkProd (make_annot Anonymous Sorts.Relevant, c2, concl) in let (sigma, f) = Evarutil.new_evar env sigma typ in let (sigma, x) = Evarutil.new_evar env sigma c1 in (sigma, mkApp (f, [|mkApp (c, [|x|])|])) @@ -2013,12 +2019,12 @@ let clear_body ids = let ctx = named_context env in let map = function | LocalAssum (id,t) as decl -> - let () = if List.mem_f Id.equal id ids then - user_err (str "Hypothesis " ++ Id.print id ++ str " is not a local definition") + let () = if List.mem_f Id.equal id.binder_name ids then + user_err (str "Hypothesis " ++ Id.print id.binder_name ++ str " is not a local definition") in decl | LocalDef (id,_,t) as decl -> - if List.mem_f Id.equal id ids then LocalAssum (id, t) else decl + if List.mem_f Id.equal id.binder_name ids then LocalAssum (id, t) else decl in let ctx = List.map map ctx in let base_env = reset_context env in @@ -2624,7 +2630,8 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in - let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in + let term = mkNamedLetIn (make_annot id Sorts.Relevant) c t + (mkLetIn (make_annot (Name heq) Sorts.Relevant, refl, eq, ccl)) in let sigma, _ = Typing.type_of env sigma term in let ans = term, Tacticals.New.tclTHENLIST @@ -2634,7 +2641,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = in (sigma, ans) | None -> - (sigma, (mkNamedLetIn id c t ccl, Proofview.tclUNIT ())) + (sigma, (mkNamedLetIn (make_annot id Sorts.Relevant) c t ccl, Proofview.tclUNIT ())) in Tacticals.New.tclTHENLIST [ Proofview.Unsafe.tclEVARS sigma; @@ -2669,8 +2676,9 @@ let mk_eq_name env id {CAst.loc;v=ido} = let mkletin_goal env sigma with_eq dep (id,lastlhyp,ccl,c) ty = let open Context.Named.Declaration in let t = match ty with Some t -> t | _ -> typ_of env sigma c in - let decl = if dep then LocalDef (id,c,t) - else LocalAssum (id,t) + let r = Retyping.relevance_of_type env sigma t in + let decl = if dep then LocalDef (make_annot id r,c,t) + else LocalAssum (make_annot id r,t) in match with_eq with | Some (lr,heq) -> @@ -2680,13 +2688,14 @@ let mkletin_goal env sigma with_eq dep (id,lastlhyp,ccl,c) ty = let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in - let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in + let newenv = insert_before [LocalAssum (make_annot heq Sorts.Relevant,eq); decl] lastlhyp env in let (sigma, x) = new_evar newenv sigma ~principal:true ccl in - (sigma, mkNamedLetIn id c t (mkNamedLetIn heq refl eq x)) + (sigma, mkNamedLetIn (make_annot id r) c t + (mkNamedLetIn (make_annot heq Sorts.Relevant) refl eq x)) | None -> let newenv = insert_before [decl] lastlhyp env in let (sigma, x) = new_evar newenv sigma ~principal:true ccl in - (sigma, mkNamedLetIn id c t x) + (sigma, mkNamedLetIn (make_annot id r) c t x) let pose_tac na c = Proofview.Goal.enter begin fun gl -> @@ -2708,11 +2717,13 @@ let pose_tac na c = in Proofview.Unsafe.tclEVARS sigma <*> Refine.refine ~typecheck:false begin fun sigma -> + (* TODO relevance *) + 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 - (sigma, mkLetIn (Name id, c, t, body)) + (sigma, mkLetIn (map_annot Name.mk_name id, c, t, body)) end end @@ -2806,9 +2817,10 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let newdecls,_ = decompose_prod_n_assum sigma i (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod) in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name env sigma c t ids cl' na in + let r = Retyping.relevance_of_type env sigma t in let decl = match b with - | None -> LocalAssum (na,t) - | Some b -> LocalDef (na,b,t) + | None -> LocalAssum (make_annot na r,t) + | Some b -> LocalDef (make_annot na r,b,t) in mkProd_or_LetIn decl cl', sigma' @@ -2948,8 +2960,8 @@ let specialize (c,lbind) ipat = (* If the term is lambda then we put a letin to put avoid interaction between the term and the bindings. *) let c = match EConstr.kind sigma c with - | Lambda(_,_,_) -> - mkLetIn(Name.Anonymous, c, typ_of_c, (mkRel 1)) + | Lambda _ -> + mkLetIn(make_annot Name.Anonymous Sorts.Relevant, c, typ_of_c, (mkRel 1)) | _ -> c in let clause = make_clenv_binding env sigma (c,typ_of_c) lbind in let flags = { (default_unify_flags ()) with resolve_evars = true } in @@ -2973,14 +2985,15 @@ let specialize (c,lbind) ipat = (* nme has not been resolved, let us re-abstract it. Same name but type updated by instanciation of other args. *) let sigma,new_typ_of_t = Typing.type_of clause.env sigma t in + let r = Retyping.relevance_of_type env sigma new_typ_of_t in let liftedargs = List.map liftrel args in (* lifting rels in the accumulator args *) let sigma,hd' = rebuild_lambdas sigma lp' (liftedargs@[mkRel 1 ]) hd l' in (* replace meta variable by the abstracted variable *) let hd'' = subst_term sigma t hd' in (* lambda expansion *) - sigma,mkLambda (nme,new_typ_of_t,hd'') - | Context.Rel.Declaration.LocalAssum(_,_)::lp' , t::l' -> + sigma,mkLambda ({nme with binder_relevance=r},new_typ_of_t,hd'') + | Context.Rel.Declaration.LocalAssum _::lp' , t::l' -> let sigma,hd' = rebuild_lambdas sigma lp' (args@[t]) hd l' in sigma,hd' | _ ,_ -> assert false in @@ -3631,15 +3644,18 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = let homogeneous = Reductionops.is_conv env sigma ty typ in let sigma, (eq, refl) = mk_term_eq homogeneous (push_rel_context ctx env) sigma ty (mkRel 1) typ (mkVar id) in - sigma, mkProd (Anonymous, eq, lift 1 concl), [| refl |] + sigma, mkProd (make_annot Anonymous Sorts.Relevant, eq, lift 1 concl), [| refl |] else sigma, concl, [||] in (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) - let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> LocalAssum (Anonymous, x)) eqs) in + let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) + (List.map (fun x -> LocalAssum (make_annot Anonymous Sorts.Relevant, x)) eqs) + in + let r = Sorts.Relevant in (* TODO relevance *) let decl = match body with - | None -> LocalAssum (Name id, c) - | Some body -> LocalDef (Name id, body, c) + | None -> LocalAssum (make_annot (Name id) r, c) + | Some body -> LocalDef (make_annot (Name id) r, body, c) in (* Abstract by the "generalized" hypothesis. *) let genarg = mkProd_or_LetIn decl abseqs in @@ -3714,10 +3730,10 @@ let abstract_args gl generalize_vars dep id defined f args = eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = - let name, ty, arity = + let name, ty_relevance, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in let decl = List.hd rel in - RelDecl.get_name decl, RelDecl.get_type decl, c + RelDecl.get_name decl, RelDecl.get_relevance decl, RelDecl.get_type decl, c in let argty = Tacmach.New.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in @@ -3731,7 +3747,7 @@ let abstract_args gl generalize_vars dep id defined f args = Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> let name = get_id name in - let decl = LocalAssum (Name name, ty) in + let decl = LocalAssum (make_annot (Name name) ty_relevance, ty) in let ctx = decl :: ctx in let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in @@ -3840,9 +3856,9 @@ let specialize_eqs id = let evars = ref (Proofview.Goal.sigma gl) in let unif env evars c1 c2 = compare_upto_variables !evars c1 c2 && - (match Evarconv.conv env !evars c1 c2 with - | Some sigma -> evars := sigma; true - | None -> false) + (match Evarconv.unify_delay env !evars c1 c2 with + | sigma -> evars := sigma; true + | exception Evarconv.UnableToUnify _ -> false) in let rec aux in_eqs ctx acc ty = match EConstr.kind !evars ty with @@ -3869,7 +3885,7 @@ let specialize_eqs id = else let sigma, e = Evarutil.new_evar (push_rel_context ctx env) !evars t in evars := sigma; - aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) + aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in @@ -3917,7 +3933,7 @@ let decompose_paramspred_branch_args sigma elimt = | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app sigma (snd (decompose_prod_assum sigma tpe)) in if not (occur_rel sigma 1 elimt') && isRel sigma hd_tpe - then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) + then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) else let acc3,ccl = decompose_prod_assum sigma elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in @@ -3999,8 +4015,8 @@ let compute_elim_sig sigma ?elimc elimt = (* 3- Look at last arg: is it the indarg? *) ignore ( match List.hd args_indargs with - | LocalDef (hiname,_,hi) -> error_ind_scheme "" - | LocalAssum (hiname,hi) -> + | LocalDef (hiname,_,hi) -> error_ind_scheme "" + | LocalAssum (hiname,hi) -> let hi_ind, hi_args = decompose_app sigma hi in let hi_is_ind = (* hi est d'un type globalisable *) match EConstr.kind sigma hi_ind with @@ -4398,7 +4414,9 @@ let check_expected_type env sigma (elimc,bl) elimt = let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in let (_,u,_) = destProd sigma cl.cl_concl in - fun t -> Option.has_some (Evarconv.cumul env sigma t u) + fun t -> match Evarconv.unify_leq_delay env sigma t u with + | _sigma -> true + | exception Evarconv.UnableToUnify _ -> false let check_enough_applied env sigma elim = (* A heuristic to decide whether the induction arg is enough applied *) diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index e8a66f1889..2831aec9f6 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -316,7 +316,7 @@ struct Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca)) | Cast (c,_,_) -> pat_of_constr c | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c)) - | (Prod (_,_,_) | LetIn(_,_,_,_)) -> + | (Prod _ | LetIn _) -> let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c)) | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) diff --git a/test-suite/Makefile b/test-suite/Makefile index 5582503d89..ba591ede20 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -38,9 +38,9 @@ include ../Makefile.common BIN := $(shell cd ..; pwd)/bin/ COQFLAGS?= +COQLIB?= ifeq ($(COQLIB),) - # This method of setting `pwd` won't work on win32 OCaml - COQLIB := $(shell cd ..; pwd) + COQLIB := $(shell ocaml ocaml_pwd.ml ..) endif export COQLIB @@ -317,8 +317,6 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v echo " $<...correctly prepared" ; \ fi; \ } > "$@" - @echo "CHECK $<" - $(HIDE)$(coqchk) -norec TestSuite.$(shell basename $< .v) > $(shell dirname $<)/$(shell basename $< .v).chk.log 2>&1 ssr: $(wildcard ssr/*.v:%.v=%.v.log) $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v arithmetic/*.v)): %.v.log: %.v $(PREREQUISITELOG) diff --git a/test-suite/bugs/closed/bug_3325.v b/test-suite/bugs/closed/bug_3325.v index 36c065ebe8..835b8a7f33 100644 --- a/test-suite/bugs/closed/bug_3325.v +++ b/test-suite/bugs/closed/bug_3325.v @@ -1,13 +1,13 @@ Typeclasses eauto := debug. Set Printing All. -Axiom SProp : Set. -Axiom sp : SProp. +Axiom sProp : Set. +Axiom sp : sProp. (* If we hardcode valueType := nat, it goes through *) Class StateIs := { valueType : Type; - stateIs : valueType -> SProp + stateIs : valueType -> sProp }. Instance NatStateIs : StateIs := { @@ -17,17 +17,17 @@ Instance NatStateIs : StateIs := { Canonical Structure NatStateIs. Class LogicOps F := { land: F -> F }. -Instance : LogicOps SProp. Admitted. +Instance : LogicOps sProp. Admitted. Instance : LogicOps Prop. Admitted. Parameter (n : nat). (* If this is a [Definition], the resolution goes through fine. *) Notation vn := (@stateIs _ n). Definition vn' := (@stateIs _ n). -Definition GOOD : SProp := +Definition GOOD : sProp := @land _ _ vn'. (* This doesn't resolve, if PropLogicOps is defined later than SPropLogicOps *) -Definition BAD : SProp := +Definition BAD : sProp := @land _ _ vn. diff --git a/test-suite/bugs/closed/bug_9526.v b/test-suite/bugs/closed/bug_9526.v new file mode 100644 index 0000000000..344d42083f --- /dev/null +++ b/test-suite/bugs/closed/bug_9526.v @@ -0,0 +1,30 @@ +Primitive int := #int63_type. + +Module bad1. +Polymorphic Inductive badcarry1 (A:Type) : Type := +| C0: A -> badcarry1 A +| C1: A -> badcarry1 A. + +Fail Register badcarry1 as kernel.ind_carry. + +End bad1. + +Module bad2. + +Inductive badcarry2 (A:Set) : Set := +| C0: A -> badcarry2 A +| C1: A -> badcarry2 A. + +Fail Register badcarry2 as kernel.ind_carry. + +End bad2. + +Module bad3. + +Inductive badcarry3 : Type -> Type := +| C0: forall A, A -> badcarry3 A +| C1: forall A, A -> badcarry3 A. + +Fail Register badcarry3 as kernel.ind_carry. + +End bad3. diff --git a/test-suite/bugs/closed/bug_9595.v b/test-suite/bugs/closed/bug_9595.v new file mode 100644 index 0000000000..312ed7d045 --- /dev/null +++ b/test-suite/bugs/closed/bug_9595.v @@ -0,0 +1,11 @@ +Set Primitive Projections. +Set Warnings "+non-primitive-record". + +(* 0 fields *) +Fail Record foo := { a := 0 }. + +(* anonymous field *) +Fail Record foo := { _ : nat }. + +(* squashed *) +Fail Record foo : Prop := { a : nat }. diff --git a/test-suite/bugs/closed/bug_9631.v b/test-suite/bugs/closed/bug_9631.v new file mode 100644 index 0000000000..8afeccccd4 --- /dev/null +++ b/test-suite/bugs/closed/bug_9631.v @@ -0,0 +1,7 @@ + +Fail Instance x : _. + +Existing Class True. +(* the type is checked for typeclass-ness before interping the body so + this is the same error *) +Fail Instance x : _ := I. diff --git a/test-suite/bugs/closed/bug_sprop_13.v b/test-suite/bugs/closed/bug_sprop_13.v new file mode 100644 index 0000000000..ae80c9c51f --- /dev/null +++ b/test-suite/bugs/closed/bug_sprop_13.v @@ -0,0 +1,7 @@ +(* -*- mode: coq; coq-prog-args: ("-allow-sprop") -*- *) +Goal forall (P : SProp), P -> P. +Proof. + intros P H. set (H0 := H). + (* goal is now H0 *) + exact H0. +Qed. diff --git a/test-suite/bugs/closed/bug_sprop_14.v b/test-suite/bugs/closed/bug_sprop_14.v new file mode 100644 index 0000000000..1e6e9b30de --- /dev/null +++ b/test-suite/bugs/closed/bug_sprop_14.v @@ -0,0 +1,26 @@ +(* -*- coq-prog-args: ("-allow-sprop"); -*- *) + +Set Universe Polymorphism. + +Inductive False : SProp :=. + +Axiom ℙ@{} : SProp. + +Definition TYPE@{i} := ℙ -> Type@{i}. +Definition PROP@{} := ℙ -> SProp. + +Definition El@{i} (A : TYPE@{i}) := forall p, A p. +Definition sEl@{} (A : PROP@{}) : SProp := forall p, A p. + +Definition SPropᶠ@{} := fun (p : ℙ) => SProp. + +Definition sProdᶠ@{i} + (A : TYPE@{i}) + (B : forall (p : ℙ), El A -> SProp) : PROP := fun (p : ℙ) => forall x : El A, B p x. + +Definition Falseᶠ : El SPropᶠ := fun p => False. + +Definition EMᶠ : sEl (sProdᶠ SPropᶠ (fun p A => ((sProdᶠ A (fun p _ => Falseᶠ p))) p)). +Proof. +Fail Admitted. +Abort. diff --git a/test-suite/dune b/test-suite/dune index 9efc1e2dc1..c430400ba5 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -6,7 +6,7 @@ (rule (targets libpath.inc) - (action (with-stdout-to %{targets} (run ./ocaml_pwd.exe ../../install/%{context_name}/lib/coq/ )))) + (action (with-stdout-to %{targets} (run ./ocaml_pwd.exe -quoted ../../install/%{context_name}/lib/coq/ )))) (rule (targets summary.log) diff --git a/test-suite/ide/reopen1.fake b/test-suite/ide/reopen1.fake new file mode 100644 index 0000000000..2c4f13de86 --- /dev/null +++ b/test-suite/ide/reopen1.fake @@ -0,0 +1,22 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# jumping outside the focused zone should signal an unfocus. + +# first proof +ADD here { Goal True. } +ADD here1 { Proof. } +ADD { Qed. } +WAIT +EDIT_AT here1 +EDIT_AT here +# fwd again +ADD here2 { Proof. } +ADD here3 { Qed. } +WAIT +EDIT_AT here2 +# Fixing the proof +ADD { Proof. } +ADD { trivial. } +ADD { Qed. } +JOIN diff --git a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml index f5043db099..adabb7a0a0 100644 --- a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml +++ b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml @@ -16,7 +16,7 @@ let evil t f = let fe = Declare.definition_entry ~univs:(Polymorphic_entry ([|Anonymous|], UContext.make (Instance.of_array [|u|],Constraint.empty))) - ~types:(Term.mkArrow tc tu) - (mkLambda (Name.Name (Id.of_string "x"), tc, mkRel 1)) + ~types:(Term.mkArrowR tc tu) + (mkLambda (Context.nameR (Id.of_string "x"), tc, mkRel 1)) in ignore (Declare.declare_constant f (DefinitionEntry fe, k)) diff --git a/test-suite/ocaml_pwd.ml b/test-suite/ocaml_pwd.ml index 10ca52a4a9..afa3deea3a 100644 --- a/test-suite/ocaml_pwd.ml +++ b/test-suite/ocaml_pwd.ml @@ -1,7 +1,7 @@ let _ = - let ch_dir = Sys.argv.(1) in + let quoted = Sys.argv.(1) = "-quoted" in + let ch_dir = Sys.argv.(if quoted then 2 else 1) in Sys.chdir ch_dir; let dir = Sys.getcwd () in - (* Needed for windows *) - let dir = Filename.quote dir in + let dir = if quoted then Filename.quote dir else dir in Format.printf "%s%!" dir diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.v b/test-suite/output-modulo-time/ltacprof_cutoff.v deleted file mode 100644 index b7c98aa134..0000000000 --- a/test-suite/output-modulo-time/ltacprof_cutoff.v +++ /dev/null @@ -1,28 +0,0 @@ -(* -*- coq-prog-args: ("-async-proofs" "off" "-profile-ltac") -*- *) -Require Coq.ZArith.BinInt. -Module WithIdTac. - Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). - - Ltac foo0 := idtac; sleep. - Ltac foo1 := sleep; foo0. - Ltac foo2 := sleep; foo1. - Goal True. - foo2. - Show Ltac Profile CutOff 47. - constructor. - Qed. -End WithIdTac. - -Module TestEval. - Ltac sleep := let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac. - - Ltac foo0 := idtac; do 50 (idtac; sleep). - Ltac foo1 := sleep; foo0. - Ltac foo2 := sleep; foo1. - Goal True. - Reset Ltac Profile. - foo2. - Show Ltac Profile CutOff 47. - constructor. - Qed. -End TestEval. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index ba4bc070c6..3f0717666c 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -113,7 +113,8 @@ Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: Some argument names are duplicated: F The command has indeed failed with message: -Argument z cannot be declared implicit. +Argument number 2 (anonymous in original definition) cannot be declared +implicit. The command has indeed failed with message: Extra arguments: y. The command has indeed failed with message: diff --git a/test-suite/output/PrintInfos.v b/test-suite/output/PrintInfos.v index d7c271c3ec..d95cc0e32f 100644 --- a/test-suite/output/PrintInfos.v +++ b/test-suite/output/PrintInfos.v @@ -22,7 +22,7 @@ Print comparison. Definition foo := forall x, x = 0. Parameter bar : foo. -Arguments bar [x]. +Arguments bar {x}. About bar. Print bar. diff --git a/test-suite/output/RealSyntax.v b/test-suite/output/RealSyntax.v index 15ae66010e..44e8c7a50c 100644 --- a/test-suite/output/RealSyntax.v +++ b/test-suite/output/RealSyntax.v @@ -1,3 +1,3 @@ -Require Import Reals. +Require Import Reals.Rdefinitions. Check 32%R. Check (-31)%R. diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index f4544a0df3..ffba1d35cc 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -1,59 +1,72 @@ le_n: forall n : nat, n <= n le_0_n: forall n : nat, 0 <= n le_S: forall n m : nat, n <= m -> n <= S m -le_n_S: forall n m : nat, n <= m -> S n <= S m -le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m le_S_n: forall n m : nat, S n <= S m -> n <= m -min_l: forall n m : nat, n <= m -> Nat.min n m = n +le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m +le_n_S: forall n m : nat, n <= m -> S n <= S m +max_l: forall n m : nat, m <= n -> Nat.max n m = n max_r: forall n m : nat, n <= m -> Nat.max n m = m min_r: forall n m : nat, m <= n -> Nat.min n m = m -max_l: forall n m : nat, m <= n -> Nat.max n m = n +min_l: forall n m : nat, n <= m -> Nat.min n m = n le_ind: forall (n : nat) (P : nat -> Prop), P n -> (forall m : nat, n <= m -> P m -> P (S m)) -> forall n0 : nat, n <= n0 -> P n0 +le_sind: + forall (n : nat) (P : nat -> SProp), + P n -> + (forall m : nat, n <= m -> P m -> P (S m)) -> + forall n0 : nat, n <= n0 -> P n0 false: bool true: bool +eq_true: bool -> Prop is_true: bool -> Prop negb: bool -> bool -eq_true: bool -> Prop -implb: bool -> bool -> bool -orb: bool -> bool -> bool andb: bool -> bool -> bool +orb: bool -> bool -> bool +implb: bool -> bool -> bool xorb: bool -> bool -> bool Nat.even: nat -> bool Nat.odd: nat -> bool BoolSpec: Prop -> Prop -> bool -> Prop -Nat.eqb: nat -> nat -> bool -Nat.testbit: nat -> nat -> bool Nat.ltb: nat -> nat -> bool +Nat.testbit: nat -> nat -> bool +Nat.eqb: nat -> nat -> bool Nat.leb: nat -> nat -> bool Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat -bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b +eq_true_ind_r: + forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true eq_true_rec: forall P : bool -> Set, P true -> forall b : bool, eq_true b -> P b -bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b -eq_true_rect_r: - forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true -eq_true_rec_r: - forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true +bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b eq_true_rect: forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b +eq_true_sind: + forall P : bool -> SProp, P true -> forall b : bool, eq_true b -> P b +bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b eq_true_ind: forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b -eq_true_ind_r: - forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true +eq_true_rec_r: + forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true +eq_true_rect_r: + forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true +bool_sind: + forall P : bool -> SProp, P true -> P false -> forall b : bool, P b Byte.to_bits: Byte.byte -> bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) Byte.of_bits: bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) -> Byte.byte +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true andb_true_intro: forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true -andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +BoolSpec_sind: + forall (P Q : Prop) (P0 : bool -> SProp), + (P -> P0 true) -> + (Q -> P0 false) -> forall b : bool, BoolSpec P Q b -> P0 b BoolSpec_ind: forall (P Q : Prop) (P0 : bool -> Prop), (P -> P0 true) -> diff --git a/test-suite/success/sprop.v b/test-suite/success/sprop.v new file mode 100644 index 0000000000..268c1880d2 --- /dev/null +++ b/test-suite/success/sprop.v @@ -0,0 +1,189 @@ +(* -*- mode: coq; coq-prog-args: ("-allow-sprop") -*- *) + +Set Primitive Projections. +Set Warnings "+non-primitive-record". +Set Warnings "+bad-relevance". + +Check SProp. + +Definition iUnit : SProp := forall A : SProp, A -> A. + +Definition itt : iUnit := fun A a => a. + +Definition iUnit_irr (P : iUnit -> Type) (x y : iUnit) : P x -> P y + := fun v => v. + +Definition iSquash (A:Type) : SProp + := forall P : SProp, (A -> P) -> P. +Definition isquash A : A -> iSquash A + := fun a P f => f a. +Definition iSquash_rect A (P : iSquash A -> SProp) (H : forall x : A, P (isquash A x)) + : forall x : iSquash A, P x + := fun x => x (P x) (H : A -> P x). + +Fail Check (fun A : SProp => A : Type). + +Lemma foo : Prop. +Proof. pose (fun A : SProp => A : Type); exact True. Fail Qed. Abort. + +(* define evar as product *) +Check (fun (f:(_:SProp)) => f _). + +Inductive sBox (A:SProp) : Prop + := sbox : A -> sBox A. + +Definition uBox := sBox iUnit. + +Definition sBox_irr A (x y : sBox A) : x = y. +Proof. + Fail reflexivity. + destruct x as [x], y as [y]. + reflexivity. +Defined. + +(* Primitive record with all fields in SProp has the eta property of SProp so must be SProp. *) +Fail Record rBox (A:SProp) : Prop := rmkbox { runbox : A }. +Section Opt. + Local Unset Primitive Projections. + Record rBox (A:SProp) : Prop := rmkbox { runbox : A }. +End Opt. + +(* Check that defining as an emulated record worked *) +Check runbox. + +(* Check that it doesn't have eta *) +Fail Check (fun (A : SProp) (x : rBox A) => eq_refl : x = @rmkbox _ (@runbox _ x)). + +Inductive sEmpty : SProp := . + +Inductive sUnit : SProp := stt. + +Inductive BIG : SProp := foo | bar. + +Inductive Squash (A:Type) : SProp + := squash : A -> Squash A. + +Definition BIG_flip : BIG -> BIG. +Proof. + intros [|]. exact bar. exact foo. +Defined. + +Inductive pb : Prop := pt | pf. + +Definition pb_big : pb -> BIG. +Proof. + intros [|]. exact foo. exact bar. +Defined. + +Fail Definition big_pb (b:BIG) : pb := + match b return pb with foo => pt | bar => pf end. + +Inductive which_pb : pb -> SProp := +| is_pt : which_pb pt +| is_pf : which_pb pf. + +Fail Definition pb_which b (w:which_pb b) : bool + := match w with + | is_pt => true + | is_pf => false + end. + +(* Non primitive because no arguments, but maybe we should allow it for sprops? *) +Fail Record UnitRecord : SProp := {}. + +Section Opt. + Local Unset Primitive Projections. + Record UnitRecord' : SProp := {}. +End Opt. +Fail Scheme Induction for UnitRecord' Sort Set. + +Record sProd (A B : SProp) : SProp := sPair { sFst : A; sSnd : B }. + +Scheme Induction for sProd Sort Set. + +Unset Primitive Projections. +Record sProd' (A B : SProp) : SProp := sPair' { sFst' : A; sSnd' : B }. +Set Primitive Projections. + +Fail Scheme Induction for sProd' Sort Set. + +Inductive Istrue : bool -> SProp := istrue : Istrue true. + +Definition Istrue_sym (b:bool) := if b then sUnit else sEmpty. +Definition Istrue_to_sym b (i:Istrue b) : Istrue_sym b := match i with istrue => stt end. + +Definition Istrue_rec (P:forall b, Istrue b -> Set) (H:P true istrue) b (i:Istrue b) : P b i. +Proof. + destruct b. + - exact_no_check H. + - apply sEmpty_rec. apply Istrue_to_sym in i. exact i. +Defined. + +Check (fun P v (e:Istrue true) => eq_refl : Istrue_rec P v _ e = v). + +Record Truepack := truepack { trueval :> bool; trueprop : Istrue trueval }. + +Definition Truepack_eta (x : Truepack) (i : Istrue x) : x = truepack x i := @eq_refl Truepack x. + +Class emptyclass : SProp := emptyinstance : forall A:SProp, A. + +(** Sigma in SProp can be done through Squash and relevant sigma. *) +Definition sSigma (A:SProp) (B:A -> SProp) : SProp + := Squash (@sigT (rBox A) (fun x => rBox (B (runbox _ x)))). + +Definition spair (A:SProp) (B:A->SProp) (x:A) (y:B x) : sSigma A B + := squash _ (existT _ (rmkbox _ x) (rmkbox _ y)). + +Definition spr1 (A:SProp) (B:A->SProp) (p:sSigma A B) : A + := let 'squash _ (existT _ x y) := p in runbox _ x. + +Definition spr2 (A:SProp) (B:A->SProp) (p:sSigma A B) : B (spr1 A B p) + := let 'squash _ (existT _ x y) := p return B (spr1 A B p) in runbox _ y. +(* it's SProp so it computes properly *) + +(** Fixpoints on SProp values are only allowed to produce SProp results *) +Inductive sAcc (x:nat) : SProp := sAcc_in : (forall y, y < x -> sAcc y) -> sAcc x. + +Definition sAcc_inv x (s:sAcc x) : forall y, y < x -> sAcc y. +Proof. + destruct s as [H]. exact H. +Defined. + +Section sFix_fail. + Variable P : nat -> Type. + Variable F : forall x:nat, (forall y:nat, y < x -> P y) -> P x. + + Fail Fixpoint sFix (x:nat) (a:sAcc x) {struct a} : P x := + F x (fun (y:nat) (h: y < x) => sFix y (sAcc_inv x a y h)). +End sFix_fail. + +Section sFix. + Variable P : nat -> SProp. + Variable F : forall x:nat, (forall y:nat, y < x -> P y) -> P x. + + Fixpoint sFix (x:nat) (a:sAcc x) {struct a} : P x := + F x (fun (y:nat) (h: y < x) => sFix y (sAcc_inv x a y h)). + +End sFix. + +(** Relevance repairs *) + +Fail Definition fix_relevance : _ -> nat := fun _ : iUnit => 0. + +Require Import ssreflect. + +Goal forall T : SProp, T -> True. +Proof. + move=> T +. + intros X;exact I. +Qed. + +Set Warnings "-bad-relevance". +Definition fix_relevance : _ -> nat := fun _ : iUnit => 0. + +(* relevance isn't fixed when checking P x == P y *) +Fail Definition relevance_unfixed := fun (A:SProp) (P:A -> Prop) x y (v:P x) => v : P y. + +(* but the kernel is fine *) +Definition relevance_unfixed := fun (A:SProp) (P:A -> Prop) x y (v:P x) => + ltac:(exact_no_check v) : P y. diff --git a/test-suite/success/sprop_hcons.v b/test-suite/success/sprop_hcons.v new file mode 100644 index 0000000000..14772dd62b --- /dev/null +++ b/test-suite/success/sprop_hcons.v @@ -0,0 +1,52 @@ +(* -*- coq-prog-args: ("-allow-sprop"); -*- *) + +(* A bug due to bad hashconsing of case info *) + +Inductive sBox (A : SProp) : Type := + sbox : A -> sBox A. + +Definition ubox {A : SProp} (bA : sBox A) : A := + match bA with + sbox _ X => X + end. + +Inductive sle : nat -> nat -> SProp := + sle_0 : forall n, sle 0 n +| sle_S : forall n m : nat, sle n m -> sle (S n) (S m). + +Definition sle_Sn (n : nat) : sle n (S n). +Proof. + induction n; constructor; auto. +Defined. + +Definition sle_trans {n m p} (H : sle n m) (H': sle m p) : sle n p. +Proof. + revert H'. revert p. induction H. + - intros p H'. apply sle_0. + - intros p H'. inversion H'. apply ubox. subst. apply sbox. apply sle_S. apply IHsle;auto. +Defined. + +Lemma sle_Sn_m {n m} : sle n m -> sle n (S m). +Proof. + intros H. destruct n. + - constructor. + - constructor;auto. assert (H1 : sle n (S n)) by apply sle_Sn. + exact (sle_trans H1 H ). +Defined. + +Definition sle_Sn_Sm {n m} : sle (S n) (S m) -> sle n m. +Proof. + intros H. + inversion H. apply ubox. subst. apply sbox. exact H2. +Qed. + + +Notation "g ∘ f" := (sle_trans g f) (at level 40). + +Lemma bazz q0 m (f : sle (S q0) (S m)) : + sbox _ (sle_Sn q0 ∘ f) = sbox _ (sle_Sn_m (sle_Sn_Sm f)). +Proof. + reflexivity. (* used to fail *) + (* NB: exact eq_refl succeeded even with the bug so no guarantee + that this test will continue to test the right thing. *) +Qed. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index 8a04206bb2..8732305953 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -23,7 +23,7 @@ Typeclasses Opaque id const flip compose arrow impl iff not all. (** Apply using the same opacity information as typeclass proof search. *) -Ltac class_apply c := autoapply c using typeclass_instances. +Ltac class_apply c := autoapply c with typeclass_instances. (** The unconvertible typeclass, to test that two objects of the same type are actually different. *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index b607be4f94..1a391ed799 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -402,6 +402,12 @@ Section Logic_lemmas. End equality. + Definition eq_sind_r : + forall (A:Type) (x:A) (P:A -> SProp), P x -> forall y:A, y = x -> P y. + Proof. + intros A x P H y H0. elim eq_sym with (1 := H0); assumption. + Defined. + Definition eq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y. intros A x P H y H0. elim eq_sym with (1 := H0); assumption. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index af9050da29..a48e9929c4 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1033,7 +1033,7 @@ Lemma map_ext_in_iff : forall (A B : Type)(f g:A->B) l, map f l = map g l <-> forall a, In a l -> f a = g a. Proof. split; [apply ext_in_map | apply map_ext_in]. Qed. -Arguments map_ext_in_iff [A B f g l]. +Arguments map_ext_in_iff {A B f g l}. Lemma map_ext : forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l. diff --git a/theories/Logic/StrictProp.v b/theories/Logic/StrictProp.v new file mode 100644 index 0000000000..99ee54e42f --- /dev/null +++ b/theories/Logic/StrictProp.v @@ -0,0 +1,40 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Utilities for SProp users. *) + +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. + +Record Box (A:SProp) : Prop := box { unbox : A }. +Arguments box {_} _. +Arguments unbox {_} _. + +Inductive Squash (A:Type) : SProp := squash : A -> Squash A. +Arguments squash {_} _. + +Inductive sEmpty : SProp :=. + +Inductive sUnit : SProp := stt. +Definition sUnit_rect (P:sUnit -> Type) (v:P stt) (u:sUnit) : P u := v. +Definition sUnit_rec (P:sUnit -> Set) (v:P stt) (u:sUnit) : P u := v. +Definition sUnit_ind (P:sUnit -> Prop) (v:P stt) (u:sUnit) : P u := v. + +Set Primitive Projections. +Record Ssig {A:Type} (P:A->SProp) := Sexists { Spr1 : A; Spr2 : P Spr1 }. +Arguments Sexists {_} _ _ _. +Arguments Spr1 {_ _} _. +Arguments Spr2 {_ _} _. + +Lemma Spr1_inj {A P} {a b : @Ssig A P} (e : Spr1 a = Spr1 b) : a = b. +Proof. + destruct a,b;simpl in e. + destruct e. reflexivity. +Defined. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 8fc3ab56c9..542d169e66 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1259,6 +1259,30 @@ Proof. f_equal. now rewrite <- add_assoc, add_opp_diag_r, add_0_r. Qed. +(** * [testbit] in terms of comparision. *) + +Lemma testbit_mod_pow2 a n i (H : 0 <= n) + : testbit (a mod 2 ^ n) i = ((i <? n) && testbit a i)%bool. +Proof. + destruct (ltb_spec i n); rewrite + ?mod_pow2_bits_low, ?mod_pow2_bits_high by auto; auto. +Qed. + +Lemma testbit_ones n i (H : 0 <= n) + : testbit (ones n) i = ((0 <=? i) && (i <? n))%bool. +Proof. + destruct (leb_spec 0 i), (ltb_spec i n); cbn; + rewrite ?testbit_neg_r, ?ones_spec_low, ?ones_spec_high by auto; trivial. +Qed. + +Lemma testbit_ones_nonneg n i (Hn : 0 <= n) (Hi: 0 <= i) + : testbit (ones n) i = (i <? n). +Proof. + rewrite testbit_ones by auto. + destruct (leb_spec 0 i); cbn; solve + [ trivial | destruct (proj1 (Z.le_ngt _ _) Hi ltac:(eassumption)) ]. +Qed. + End Z. Bind Scope Z_scope with Z.t Z. diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index 8564aeff64..854dd25b75 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -2,7 +2,8 @@ from __future__ import with_statement from __future__ import division from __future__ import unicode_literals from __future__ import print_function -import os, sys, re +import sys +import re from io import open # This script parses the output of `make TIMED=1` into a dictionary diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 62a871aa0e..fa8b771a74 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -127,6 +127,7 @@ module Options = struct let all_opts = [ { enabled = false; cmd = "-debug"; } ; { enabled = false; cmd = "-native_compiler"; } + ; { enabled = true; cmd = "-allow-sprop"; } ] let build_coq_flags () = @@ -235,6 +236,12 @@ let scan_plugins m = let dirs = Sys.(List.filter (fun f -> is_plugin_directory @@ bpath ["plugins";f]) Array.(to_list @@ readdir "plugins")) in List.fold_left scan_mlg m dirs +(* This will be removed when we drop support for Make *) +let fix_cmo_cma file = + if String.equal Filename.(extension file) ".cmo" + then replace_ext ~file ~newext:".cma" + else file + (* Process .vfiles.d and generate a skeleton for the dune file *) let parse_coqdep_line l = match Str.(split (regexp ":") l) with @@ -249,6 +256,7 @@ let parse_coqdep_line l = the platform. Anyways, I hope we can link to coqdep instead of having to parse its output soon, that should solve this kind of issues *) + let deps = List.map fix_cmo_cma deps in Some (String.split_on_char '/' dir, VO { target; deps; }) (* Otherwise a vio file, we ignore *) | _ -> None diff --git a/topbin/dune b/topbin/dune index f42e4d6fc2..e35a3de54b 100644 --- a/topbin/dune +++ b/topbin/dune @@ -36,3 +36,8 @@ (modules :standard \ coqtop_byte_bin coqtop_bin coqc_bin) (libraries coq.toplevel) (link_flags -linkall)) + +; Workers installed targets +(alias + (name topworkers) + (deps %{bin:coqqueryworker.opt} %{bin:coqtacticworker.opt} %{bin:coqproofworker.opt})) diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index abfda07426..d682d3641f 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -60,6 +60,8 @@ type t = { indices_matter : bool; enable_VM : bool; native_compiler : native_compiler; + allow_sprop : bool; + cumulative_sprop : bool; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; @@ -110,6 +112,8 @@ let default = { indices_matter = false; enable_VM = true; native_compiler = default_native; + allow_sprop = false; + cumulative_sprop = false; stm_flags = Stm.AsyncOpts.default_opts; debug = false; @@ -457,7 +461,7 @@ let parse_args ~help ~init arglist : t * string list = |"-batch" -> Flags.quiet := true; { oval with batch = true } - |"-test-mode" -> Flags.test_mode := true; oval + |"-test-mode" -> Vernacentries.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval |"-boot" -> warn_deprecated_boot (); @@ -477,6 +481,9 @@ let parse_args ~help ~init arglist : t * string list = |"-filteropts" -> { oval with filter_opts = true } |"-impredicative-set" -> { oval with impredicative_set = Declarations.ImpredicativeSet } + |"-allow-sprop" -> { oval with allow_sprop = true } + |"-disallow-sprop" -> { oval with allow_sprop = false } + |"-sprop-cumulative" -> { oval with cumulative_sprop = true } |"-indices-matter" -> { oval with indices_matter = true } |"-m"|"--memory" -> { oval with memory_stat = true } |"-noinit"|"-nois" -> { oval with load_init = false } diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index b89a88d1f6..97a62e97e4 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -35,6 +35,8 @@ type t = { indices_matter : bool; enable_VM : bool; native_compiler : native_compiler; + allow_sprop : bool; + cumulative_sprop : bool; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 92ac200bc0..f7fb26fe3a 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -189,6 +189,8 @@ let init_toplevel ~help ~init custom_init arglist = Global.set_indices_matter opts.indices_matter; Global.set_VM opts.enable_VM; Global.set_native_compiler (match opts.native_compiler with NativeOff -> false | NativeOn _ -> true); + Global.set_allow_sprop opts.allow_sprop; + if opts.cumulative_sprop then Global.make_sprop_cumulative (); (* Allow the user to load an arbitrary state here *) inputstate opts; diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 94ec6bb70d..513374c2af 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -69,6 +69,8 @@ let print_usage_common co command = \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ +\n -allow-sprop allow using the proof irrelevant SProp sort\ +\n -sprop-cumulative make sort SProp cumulative with the rest of the hierarchy\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -mangle-names x mangle auto-generated names using prefix x\ diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index b5cc74b594..445f10ecc1 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -21,6 +21,7 @@ open CErrors open Util open Names open Constr +open Context open Declarations open Mod_subst open Globnames @@ -238,8 +239,9 @@ and traverse_inductive (curr, data, ax2ty) mind obj = Array.fold_left (fun accu oib -> let pspecif = Univ.in_punivs (mib, oib) in let ind_type = Inductive.type_of_inductive global_env pspecif in + let indr = oib.mind_relevance in let ind_name = Name oib.mind_typename in - Context.Rel.add (Context.Rel.Declaration.LocalAssum (ind_name, ind_type)) accu) + Context.Rel.add (Context.Rel.Declaration.LocalAssum (make_annot ind_name indr, ind_type)) accu) Context.Rel.empty mib.mind_packets in (* For each inductive, collects references in their arity and in the type diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 868a6ed3e9..528829f3a5 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -16,6 +16,7 @@ open Util open Pp open Term open Constr +open Context open Vars open Termops open Declarations @@ -144,7 +145,7 @@ let build_beq_scheme mode kn = in (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *) let create_input c = - let myArrow u v = mkArrow u (lift 1 v) + let myArrow u v = mkArrow u Sorts.Relevant (lift 1 v) and eqName = function | Name s -> Id.of_string ("eq_"^(Id.to_string s)) | Anonymous -> Id.of_string "eq_A" @@ -161,14 +162,16 @@ let build_beq_scheme mode kn = ( fun a b decl -> (* mkLambda(n,b,a) ) *) (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (eqName (RelDecl.get_name decl)) b a ) + mkNamedLambda (map_annot eqName (RelDecl.get_annot decl)) b a ) c (List.rev eqs_typ) lnamesparrec in List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) - (* Same here , hoping the auto renaming will do something good ;) *) - mkNamedLambda - (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_type decl) a) eq_input lnamesparrec + (* Same here , hoping the auto renaming will do something good ;) *) + let x = map_annot + (function Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_annot decl) + in + mkNamedLambda x (RelDecl.get_type decl) a) eq_input lnamesparrec in let make_one_eq cur = let u = Univ.Instance.empty in @@ -251,8 +254,8 @@ let build_beq_scheme mode kn = in (* construct the predicate for the Case part*) let do_predicate rel_list n = - List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) - (mkLambda (Anonymous, + List.fold_left (fun a b -> mkLambda(make_annot Anonymous Sorts.Relevant,b,a)) + (mkLambda (make_annot Anonymous Sorts.Relevant, mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), (bb ()))) (List.rev rettyp_l) in @@ -260,7 +263,8 @@ let build_beq_scheme mode kn = (* do the [| C1 ... => match Y with ... end ... Cn => match Y with ... end |] part *) - let ci = make_case_info env (fst ind) MatchStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info env (fst ind) rci MatchStyle in let constrs n = get_constructors env (make_ind_family (ind, Context.Rel.to_extended_list mkRel (n+nb_ind-1) mib.mind_params_ctxt)) in let constrsi = constrs (3+nparrec) in @@ -296,32 +300,32 @@ let build_beq_scheme mode kn = (Array.sub eqs 1 (nb_cstr_args - 1)) ) in - (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) cc + (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) cc (constrsj.(j).cs_args) ) else ar2.(j) <- (List.fold_left (fun a decl -> - mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (ff ()) (constrsj.(j).cs_args) ) - done; + mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) (ff ()) (constrsj.(j).cs_args) ) + done; - ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) + ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, mkVar (Id.of_string "Y") ,ar2)) (constrsi.(i).cs_args)) - done; - mkNamedLambda (Id.of_string "X") (mkFullInd ind (nb_ind-1+1)) ( - mkNamedLambda (Id.of_string "Y") (mkFullInd ind (nb_ind-1+2)) ( + done; + mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( + mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))), !eff in (* build_beq_scheme *) - let names = Array.make nb_ind Anonymous and + let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in let eff = ref Safe_typing.empty_private_constants in let u = Univ.Instance.empty in for i=0 to (nb_ind-1) do - names.(i) <- Name (Id.of_string (rec_name i)); - types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) - (mkArrow (mkFullInd ((kn,i),u) 1) (bb ())); + names.(i) <- make_annot (Name (Id.of_string (rec_name i))) Sorts.Relevant; + types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) Sorts.Relevant + (mkArrow (mkFullInd ((kn,i),u) 1) Sorts.Relevant (bb ())); let c, eff' = make_one_eq i in cores.(i) <- c; eff := Safe_typing.concat_private eff' !eff @@ -562,34 +566,39 @@ let compute_bl_goal ind lnamesparrec nparrec = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in let bl_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( mkArrow ( mkApp(eq (),[|bb (); mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt () |])) + Sorts.Relevant ( mkApp(eq (),[|mkVar s;mkVar x;mkVar y|])) )) ) list_id in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> - mkNamedProd sbl b a + mkNamedProd (make_annot sbl Sorts.Relevant) b a ) c (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(bb ()))) + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s,mkProd(make_annot Anonymous Sorts.Relevant,mkVar s,(bb ()))) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> - mkNamedProd seq b a + mkNamedProd (make_annot seq Sorts.Relevant) b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a decl -> mkNamedProd - (match RelDecl.get_name decl with Name s -> s | Anonymous -> next_ident_away (Id.of_string "A") avoid) - (RelDecl.get_type decl) a) eq_input lnamesparrec + List.fold_left (fun a decl -> + let x = map_annot + (function Name s -> s | Anonymous -> next_ident_away (Id.of_string "A") avoid) + (RelDecl.get_annot decl) + in + mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in let n = next_ident_away (Id.of_string "x") avoid and m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( - mkNamedProd n (mkFullInd (ind,u) nparrec) ( - mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( + mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( + mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( mkArrow (mkApp(eq (),[|bb ();mkApp(eqI,[|mkVar n;mkVar m|]);tt ()|])) + Sorts.Relevant (mkApp(eq (),[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) ))), eff @@ -706,34 +715,40 @@ let compute_lb_goal ind lnamesparrec nparrec = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( mkArrow - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) + ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + Sorts.Relevant + ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> - mkNamedProd slb b a + mkNamedProd (make_annot slb Sorts.Relevant) b a ) c (List.rev list_id) (List.rev lb_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s, + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> - mkNamedProd seq b a + mkNamedProd (make_annot seq Sorts.Relevant) b a ) lb_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a decl -> mkNamedProd - (match (RelDecl.get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_type decl) a) eq_input lnamesparrec + List.fold_left (fun a decl -> + let x = map_annot + (function Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_annot decl) + in + mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in let n = next_ident_away (Id.of_string "x") avoid and m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( - mkNamedProd n (mkFullInd (ind,u) nparrec) ( - mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( + mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( + mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( mkArrow (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|])) + Sorts.Relevant (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) ))), eff @@ -835,45 +850,51 @@ let compute_dec_goal ind lnamesparrec nparrec = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( mkArrow - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) + ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + Sorts.Relevant + ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) ) list_id in let bl_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( mkArrow - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) + Sorts.Relevant + ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) )) ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> - mkNamedProd slb b a + mkNamedProd (make_annot slb Sorts.Relevant) b a ) c (List.rev list_id) (List.rev lb_typ) in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> - mkNamedProd sbl b a + mkNamedProd (make_annot sbl Sorts.Relevant) b a ) lb_input (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s, + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> - mkNamedProd seq b a + mkNamedProd (make_annot seq Sorts.Relevant) b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a decl -> mkNamedProd - (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_type decl) a) eq_input lnamesparrec + List.fold_left (fun a decl -> + let x = map_annot + (function Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_annot decl) + in + mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in let n = next_ident_away (Id.of_string "x") avoid and m = next_ident_away (Id.of_string "y") avoid in let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in create_input ( - mkNamedProd n (mkFullInd ind (2*nparrec)) ( - mkNamedProd m (mkFullInd ind (2*nparrec+1)) ( + mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd ind (2*nparrec)) ( + mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd ind (2*nparrec+1)) ( mkApp(sumbool(),[|eqnm;mkApp (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.not.type",[|eqnm|])|]) ) ) diff --git a/vernac/class.ml b/vernac/class.ml index a6b3242cae..0837beccee 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -14,6 +14,7 @@ open Pp open Names open Term open Constr +open Context open Vars open Termops open Entries @@ -188,14 +189,14 @@ let build_id_coercion idf_opt source poly = let lams,t = decompose_lam_assum c in let val_f = it_mkLambda_or_LetIn - (mkLambda (Name Namegen.default_dependent_ident, + (mkLambda (make_annot (Name Namegen.default_dependent_ident) Sorts.Relevant, applistc vs (Context.Rel.to_extended_list mkRel 0 lams), mkRel 1)) lams in let typ_f = List.fold_left (fun d c -> Term.mkProd_wo_LetIn c d) - (mkProd (Anonymous, applistc vs (Context.Rel.to_extended_list mkRel 0 lams), lift 1 t)) + (mkProd (make_annot Anonymous Sorts.Relevant, applistc vs (Context.Rel.to_extended_list mkRel 0 lams), lift 1 t)) lams in (* juste pour verification *) diff --git a/vernac/classes.ml b/vernac/classes.ml index 263ebf5f5a..1981e24ae4 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -149,7 +149,7 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id if program_mode then let hook _ _ vis gr = let cst = match gr with ConstRef kn -> kn | _ -> assert false in - Impargs.declare_manual_implicits false gr [imps]; + Impargs.declare_manual_implicits false gr imps; let pri = intern_info pri in Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst) in @@ -234,7 +234,7 @@ let do_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode ct in match rest with | (n, _) :: _ -> - unbound_method env' k.cl_impl (get_id n) + unbound_method env' sigma k.cl_impl (get_id n) | _ -> let kcl_props = List.map (Termops.map_rel_decl of_constr) k.cl_props in let sigma, res = type_ctx_instance ~program_mode (push_rel_context ctx' env') sigma kcl_props props subst in @@ -352,8 +352,8 @@ let named_of_rel_context l = (fun decl (subst, ctx) -> let id = match RelDecl.get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in let d = match decl with - | LocalAssum (_,t) -> id, None, substl subst t - | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in + | LocalAssum (_,t) -> id, None, substl subst t + | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in (mkVar id :: subst, d :: ctx)) l ([], []) in ctx diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 35d8be5c56..37a33daf8f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -13,6 +13,7 @@ open Util open Vars open Declare open Names +open Context open Globnames open Constrexpr_ops open Constrintern @@ -148,8 +149,9 @@ let do_assumptions ~program_mode kind nl l = (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) let (sigma,_,_),l = List.fold_left_map (fun (sigma,env,ienv) (is_coe,(idl,c)) -> let sigma,(t,imps) = interp_assumption ~program_mode sigma env ienv c in + let r = Retyping.relevance_of_type env sigma t in let env = - EConstr.push_named_context (List.map (fun {CAst.v=id} -> LocalAssum (id,t)) idl) env in + 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 Id.Map.add id impls ienv) idl ienv in diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 5229d9e8e8..2f00b41b7c 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -12,6 +12,7 @@ open Pp open CErrors open Util open Constr +open Context open Vars open Termops open Declare @@ -126,7 +127,9 @@ let interp_fix_context ~program_mode ~cofix env sigma fix = sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) let interp_fix_ccl ~program_mode sigma impls (env,_) fix = - interp_type_evars_impls ~program_mode ~impls env sigma fix.fix_type + let sigma, (c, impl) = interp_type_evars_impls ~program_mode ~impls env sigma fix.fix_type in + let r = Retyping.relevance_of_type env sigma c in + sigma, (c, r, impl) let interp_fix_body ~program_mode env_rec sigma impls (_,ctx) fix ccl = let open EConstr in @@ -137,9 +140,9 @@ let interp_fix_body ~program_mode env_rec sigma impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx -let prepare_recursive_declaration fixnames fixtypes fixdefs = +let prepare_recursive_declaration fixnames fixrs fixtypes fixdefs = let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in - let names = List.map (fun id -> Name id) fixnames in + let names = List.map2 (fun id r -> make_annot (Name id) r) fixnames fixrs in (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) (* Jump over let-bindings. *) @@ -158,7 +161,7 @@ let compute_possible_guardness_evidences (ctx,_,recindex) = List.interval 0 (Context.Rel.nhyps ctx - 1) type recursive_preentry = - Id.t list * constr option list * types list + Id.t list * Sorts.relevance list * constr option list * types list (* Wellfounded definition *) @@ -188,8 +191,8 @@ let interp_recursive ~program_mode ~cofix fixl notations = on_snd List.split3 @@ List.fold_left_map (fun sigma -> interp_fix_context ~program_mode env sigma ~cofix) sigma fixl in let fixctximpenvs, fixctximps = List.split fiximppairs in - let sigma, (fixccls,fixcclimps) = - on_snd List.split @@ + let sigma, (fixccls,fixrs,fixcclimps) = + on_snd List.split3 @@ List.fold_left3_map (interp_fix_ccl ~program_mode) sigma fixctximpenvs fixctxs fixl in let fixtypes = List.map2 build_fix_type fixctxs fixccls in let fixtypes = List.map (fun c -> nf_evar sigma c) fixtypes in @@ -208,8 +211,8 @@ let interp_recursive ~program_mode ~cofix fixl notations = Typing.solve_evars env sigma app with e when CErrors.noncritical e -> sigma, t in - sigma, LocalAssum (id,fixprot) :: env' - else sigma, LocalAssum (id,t) :: env') + sigma, LocalAssum (make_annot id Sorts.Relevant,fixprot) :: env' + else sigma, LocalAssum (make_annot id Sorts.Relevant,t) :: env') (sigma,[]) fixnames fixtypes in let env_rec = push_named_context rec_sign env in @@ -232,19 +235,19 @@ let interp_recursive ~program_mode ~cofix fixl notations = let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in (* Build the fix declaration block *) - (env,rec_sign,decl,sigma), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots + (env,rec_sign,decl,sigma), (fixnames,fixrs,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots -let check_recursive isfix env evd (fixnames,fixdefs,_) = +let check_recursive isfix env evd (fixnames,_,fixdefs,_) = if List.for_all Option.has_some fixdefs then begin let fixdefs = List.map Option.get fixdefs in check_mutuality env evd isfix (List.combine fixnames fixdefs) end -let ground_fixpoint env evd (fixnames,fixdefs,fixtypes) = +let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = check_evars_are_solved ~program_mode:false env evd; let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr evd) c) fixdefs in let fixtypes = List.map EConstr.(to_constr evd) fixtypes in - Evd.evar_universe_context evd, (fixnames,fixdefs,fixtypes) + Evd.evar_universe_context evd, (fixnames,fixrs,fixdefs,fixtypes) let interp_fixpoint ~cofix l ntns = let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l ntns in @@ -252,7 +255,7 @@ let interp_fixpoint ~cofix l ntns = let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) -let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = +let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -267,7 +270,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in let env = Global.env() in let indexes = search_guard env indexes fixdecls in let fiximps = List.map (fun (n,r,p) -> r) fiximps in @@ -287,7 +290,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns -let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns = +let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -302,7 +305,7 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let vars = Vars.universes_of_constr (List.hd fixdecls) in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 338dfa5ef5..9bcb53697b 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -51,7 +51,7 @@ val interp_recursive : (* env / signature / univs / evar_map *) (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) * (* names / defs / types *) - (Id.t list * EConstr.constr option list * EConstr.types list) * + (Id.t list * Sorts.relevance list * EConstr.constr option list * EConstr.types list) * (* ctx per mutual def / implicits / struct annotations *) (EConstr.rel_context * Impargs.manual_explicitation list * int option) list @@ -69,7 +69,7 @@ val extract_cofixpoint_components : structured_fixpoint_expr list * decl_notation list type recursive_preentry = - Id.t list * constr option list * types list + Id.t list * Sorts.relevance list * constr option list * types list val interp_fixpoint : cofix:bool -> diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 9bbfb8eec6..977e804da2 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -13,6 +13,7 @@ open CErrors open Sorts open Util open Constr +open Context open Environ open Declare open Names @@ -70,9 +71,9 @@ let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function | c -> c ) -let push_types env idl tl = - List.fold_left2 (fun env id t -> EConstr.push_rel (LocalAssum (Name id,t)) env) - env idl tl +let push_types env idl rl tl = + List.fold_left3 (fun env id r t -> EConstr.push_rel (LocalAssum (make_annot (Name id) r,t)) env) + env idl rl tl type structured_one_inductive_expr = { ind_name : Id.t; @@ -139,9 +140,6 @@ let make_conclusion_flexible sigma = function | None -> sigma) | _ -> sigma) -let is_impredicative env u = - u = Prop || (is_impredicative_set env && u = Set) - let interp_ind_arity env sigma ind = let c = intern_gen IsType env sigma ind.ind_arity in let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in @@ -152,7 +150,7 @@ let interp_ind_arity env sigma ind = user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") | s -> let concl = if pseudo_poly then Some s else None in - sigma, (t, concl, impls) + sigma, (t, Retyping.relevance_of_sort s, concl, impls) let interp_cstrs env sigma impls mldata arity ind = let cnames,ctyps = List.split ind.ind_lc in @@ -176,14 +174,14 @@ let sign_level env evd sign = in let u = univ_of_sort s in (Univ.sup u lev, push_rel d env)) - sign (Univ.type0m_univ,env)) + sign (Univ.Universe.sprop,env)) let sup_list min = List.fold_left Univ.sup min let extract_level env evd min tys = let sorts = List.map (fun ty -> let ctx, concl = Reduction.dest_prod_assum env ty in - sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys + sign_level env evd (LocalAssum (make_annot Anonymous Sorts.Relevant, concl) :: ctx)) tys in sup_list min sorts let is_flexible_sort evd u = @@ -260,7 +258,7 @@ let solve_constraints_system levels level_bounds = let inductive_levels env evd poly arities inds = let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in let levels = List.map (fun (x,(ctx,a)) -> - if a = Prop then None + if Sorts.is_prop a || Sorts.is_sprop a then None else Some (univ_of_sort a)) destarities in let cstrs_levels, min_levels, sizes = @@ -269,7 +267,7 @@ let inductive_levels env evd poly arities inds = let len = List.length tys in let minlev = Sorts.univ_of_sort du in let minlev = - if len > 1 && not (is_impredicative env du) then + if len > 1 && not (is_impredicative_sort env du) then Univ.sup minlev Univ.type0_univ else minlev in @@ -290,7 +288,7 @@ let inductive_levels env evd poly arities inds = in let evd, arities = CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> - if is_impredicative env du then + if is_impredicative_sort env du then (* Any product is allowed here. *) evd, arity :: arities else (* If in a predicative sort, or asked to infer the type, @@ -313,16 +311,16 @@ let inductive_levels env evd poly arities inds = (* "Polymorphic" type constraint and more than one constructor, should not land in Prop. Add constraint only if it would land in Prop directly (no informative arguments as well). *) - Evd.set_leq_sort env evd Set du + Evd.set_leq_sort env evd Sorts.set du else evd in let duu = Sorts.univ_of_sort du in let evd = if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then - Evd.set_eq_sort env evd Prop du + Evd.set_eq_sort env evd Sorts.prop du else evd - else Evd.set_eq_sort env evd (Type cu) du + else Evd.set_eq_sort env evd (sort_of_univ cu) du in (evd, arity :: arities)) (evd,[]) (Array.to_list levels') destarities sizes @@ -370,15 +368,15 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not (* Interpret the arities *) let sigma, arities = List.fold_left_map (fun sigma -> interp_ind_arity env_params sigma) sigma indl in + let arities, relevances, arityconcl, indimpls = List.split4 arities in - let fullarities = List.map (fun (c, _, _) -> EConstr.it_mkProd_or_LetIn c ctx_params) arities in - let env_ar = push_types env_uparams indnames fullarities in + let fullarities = List.map (fun c -> EConstr.it_mkProd_or_LetIn c ctx_params) arities in + let env_ar = push_types env_uparams indnames relevances fullarities in let env_ar_params = EConstr.push_rel_context ctx_params env_ar in (* Compute interpretation metadatas *) - let indimpls = List.map (fun (_, _, impls) -> userimpls @ - lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in - let arities = List.map pi1 arities and arityconcl = List.map pi2 arities in + let indimpls = List.map (fun impls -> userimpls @ + lift_implicits (Context.Rel.nhyps ctx_params) impls) indimpls in let impls = compute_internalization_env env_uparams sigma ~impls (Inductive (params,true)) indnames fullarities indimpls in let ntn_impls = compute_internalization_env env_uparams sigma (Inductive (params,true)) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data sigma env_params params) arities indnames in @@ -407,7 +405,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let userimpls = useruimpls @ (lift_implicits (Context.Rel.nhyps ctx_uparams) userimpls) in let indimpls = List.map (fun iimpl -> useruimpls @ (lift_implicits (Context.Rel.nhyps ctx_uparams) iimpl)) indimpls in let fullarities = List.map (fun c -> EConstr.it_mkProd_or_LetIn c ctx_uparams) fullarities in - let env_ar = push_types env0 indnames fullarities in + let env_ar = push_types env0 indnames relevances fullarities in let env_ar_params = EConstr.push_rel_context ctx_params env_ar in (* Try further to solve evars, and instantiate them *) @@ -529,7 +527,7 @@ let warn_non_primitive_record = (hov 0 (str "The record " ++ Nametab.pr_global_env Id.Set.empty (IndRef indsp) ++ strbrk" could not be defined as a primitive record"))) -let declare_mutual_inductive_with_eliminations mie pl impls = +let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie pl impls = (* spiwack: raises an error if the structure is supposed to be non-recursive, but isn't *) begin match mie.mind_entry_finite with @@ -543,8 +541,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls = let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in let (_, kn), prim = declare_mind mie in let mind = Global.mind_of_delta_kn kn in - if match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false - then warn_non_primitive_record (mind,0); + if primitive_expected && not prim then warn_non_primitive_record (mind,0); Declare.declare_univ_binders (IndRef (mind,0)) pl; List.iteri (fun i (indimpls, constrimpls) -> let ind = (mind,i) in diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 1d6f652385..224cce67ad 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -43,6 +43,7 @@ type one_inductive_impls = Impargs.manual_implicits list (* for constrs *) val declare_mutual_inductive_with_eliminations : + ?primitive_expected:bool -> mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> MutInd.t diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index cc9c83bd17..ad7c65b70c 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -12,6 +12,7 @@ open Pp open CErrors open Util open Constr +open Context open Entries open Vars open Declare @@ -41,7 +42,7 @@ let well_founded sigma = init_constant sigma (lib_ref "core.wf.well_founded") let mkSubset sigma name typ prop = let open EConstr in let sigma, app_h = Evarutil.new_global sigma (delayed_force build_sigma).typ in - sigma, mkApp (app_h, [| typ; mkLambda (name, typ, prop) |]) + sigma, mkApp (app_h, [| typ; mkLambda (make_annot name Sorts.Relevant, typ, prop) |]) let make_qref s = qualid_of_string s let lt_ref = make_qref "Init.Peano.lt" @@ -58,7 +59,7 @@ let rec telescope sigma l = List.fold_left (fun (sigma, ty, tys, (k, constr)) decl -> let t = RelDecl.get_type decl in - let pred = mkLambda (RelDecl.get_name decl, t, ty) in + let pred = mkLambda (RelDecl.get_annot decl, t, ty) in let sigma, ty = Evarutil.new_global sigma (lib_ref "core.sigT.type") in let sigma, intro = Evarutil.new_global sigma (lib_ref "core.sigT.intro") in let sigty = mkApp (ty, [|t; pred|]) in @@ -73,7 +74,7 @@ let rec telescope sigma l = let sigma, p2 = Evarutil.new_global sigma (lib_ref "core.sigT.proj2") in let proj1 = applist (p1, [t; pred; prev]) in let proj2 = applist (p2, [t; pred; prev]) in - (sigma, lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) + (sigma, lift 1 proj2, LocalDef (get_annot decl, proj1, t) :: subst)) (List.rev tys) tl (sigma, mkRel 1, []) in sigma, ty, (LocalDef (n, last, t) :: subst), constr @@ -98,7 +99,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let full_arity = it_mkProd_or_LetIn top_arity binders_rel in let sigma, argtyp, letbinders, make = telescope sigma binders_rel in let argname = Id.of_string "recarg" in - let arg = LocalAssum (Name argname, argtyp) in + let arg = LocalAssum (make_annot (Name argname) Sorts.Relevant, argtyp) in let binders = letbinders @ [arg] in let binders_env = push_rel_context binders_rel env in let sigma, (rel, _) = interp_constr_evars_impls ~program_mode:true env sigma r in @@ -135,7 +136,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let argid' = Id.of_string (Id.to_string argname ^ "'") in let wfarg sigma len = let sigma, ss_term = mkSubset sigma (Name argid') argtyp (wf_rel_fun (mkRel 1) (mkRel (len + 1))) in - sigma, LocalAssum (Name argid', ss_term) + sigma, LocalAssum (make_annot (Name argid') Sorts.Relevant, ss_term) in let sigma, intern_bl = let sigma, wfa = wfarg sigma 1 in @@ -143,7 +144,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = in let _intern_env = push_rel_context intern_bl env in let sigma, proj = Evarutil.new_global sigma (delayed_force build_sigma).Coqlib.proj1 in - let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in + let wfargpred = mkLambda (make_annot (Name argid') Sorts.Relevant, argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) in @@ -153,22 +154,23 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = now intern_arity is in wfarg :: arg *) let sigma, wfa = wfarg sigma 1 in let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfa] in - let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in + let intern_fun_binder = LocalAssum (make_annot (Name (add_suffix recname "'")) Sorts.Relevant, + intern_fun_arity_prod) in let sigma, curry_fun = - let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in + let wfpred = mkLambda (make_annot (Name argid') Sorts.Relevant, argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in let sigma, intro = Evarutil.new_global sigma (delayed_force build_sigma).Coqlib.intro in let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in - let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in + let lam = LocalAssum (make_annot (Name (Id.of_string "recproof")) Sorts.Relevant, rcurry) in let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in - sigma, LocalDef (Name recname, body, ty) + sigma, LocalDef (make_annot (Name recname) Sorts.Relevant, body, ty) in let fun_bl = intern_fun_binder :: [arg] in let lift_lets = lift_rel_context 1 letbinders in let sigma, intern_body = - let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in + let ctx = LocalAssum (make_annot (Name recname) Sorts.Relevant, get_type curry_fun) :: binders_rel in let (r, l, impls, scopes) = Constrintern.compute_internalization_data env sigma Constrintern.Recursive full_arity impls @@ -180,7 +182,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = ~impls:newimpls body (lift 1 top_arity) in let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in - let prop = mkLambda (Name argname, argtyp, top_arity_let) in + let prop = mkLambda (make_annot (Name argname) Sorts.Relevant, argtyp, top_arity_let) in (* XXX: Previous code did parallel evdref update, so possible old weak ordering semantics may bite here. *) let sigma, def = @@ -215,7 +217,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] + Impargs.declare_manual_implicits false gr impls in let typ = it_mkProd_or_LetIn top_arity binders in hook, name, typ @@ -223,7 +225,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let typ = it_mkProd_or_LetIn top_arity binders_rel in let hook sigma _ _ l gr = if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] + Impargs.declare_manual_implicits false gr impls in hook, recname, typ in (* XXX: Capturing sigma here... bad bad *) @@ -272,7 +274,7 @@ let do_program_recursive local poly fixkind fixl ntns = (List.length rec_sign) def typ in (id, def, typ, imps, evars) in - let (fixnames,fixdefs,fixtypes) = fix in + let (fixnames,fixrs,fixdefs,fixtypes) = fix in let fiximps = List.map pi2 info in let fixdefs = List.map out_def fixdefs in let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in @@ -281,7 +283,7 @@ let do_program_recursive local poly fixkind fixl ntns = (* XXX: are we allowed to have evars here? *) let fixtypes = List.map (EConstr.to_constr ~abort_on_undefined_evars:false evd) fixtypes in let fixdefs = List.map (EConstr.to_constr ~abort_on_undefined_evars:false evd) fixdefs in - let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), + let fixdecls = Array.of_list (List.map2 (fun x r -> make_annot (Name x) r) fixnames fixrs), Array.of_list fixtypes, Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) in diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 06428b53f2..2bc95dbfcd 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -64,8 +64,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) | Notation.PrimTokenNotationError(kind,ctx,sigma,te) -> wrap_vernac_error exn (Himsg.explain_prim_token_notation_error kind ctx sigma te) - | Typeclasses_errors.TypeClassError(env, te) -> - wrap_vernac_error exn (Himsg.explain_typeclass_error env te) + | Typeclasses_errors.TypeClassError(env, sigma, te) -> + wrap_vernac_error exn (Himsg.explain_typeclass_error env sigma te) | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) -> wrap_vernac_error exn (Himsg.explain_mismatched_contexts e c l x) | InductiveError e -> diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 42bee25da3..589b15fd41 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -16,6 +16,7 @@ open Util open Names open Glob_term open Vernacexpr +open Impargs open Constrexpr open Constrexpr_ops open Extend @@ -836,11 +837,11 @@ GRAMMAR EXTEND Gram ]; (* Same as [argument_spec_block], but with only implicit status and names *) more_implicits_block: [ - [ name = name -> { [(name.CAst.v, Vernacexpr.NotImplicit)] } + [ name = name -> { [(name.CAst.v, NotImplicit)] } | "["; items = LIST1 name; "]" -> - { List.map (fun name -> (name.CAst.v, Vernacexpr.Implicit)) items } + { List.map (fun name -> (name.CAst.v, Impargs.Implicit)) items } | "{"; items = LIST1 name; "}" -> - { List.map (fun name -> (name.CAst.v, Vernacexpr.MaximallyImplicit)) items } + { List.map (fun name -> (name.CAst.v, MaximallyImplicit)) items } ] ]; strategy_level: diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 9dd321be51..1c58abc2fd 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -14,6 +14,7 @@ open Names open Nameops open Namegen open Constr +open Context open Termops open Environ open Pretype_errors @@ -103,9 +104,9 @@ let canonize_constr sigma c = let dn = Name.Anonymous in let rec canonize_binders c = match EConstr.kind sigma c with - | Prod (_,t,b) -> mkProd(dn,t,b) - | Lambda (_,t,b) -> mkLambda(dn,t,b) - | LetIn (_,u,t,b) -> mkLetIn(dn,u,t,b) + | Prod (x,t,b) -> mkProd({x with binder_name=dn},t,b) + | Lambda (x,t,b) -> mkLambda({x with binder_name=dn},t,b) + | LetIn (x,u,t,b) -> mkLetIn({x with binder_name=dn},u,t,b) | _ -> EConstr.map sigma canonize_binders c in canonize_binders c @@ -193,13 +194,13 @@ let rec pr_disjunction pr = function | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l | [] -> assert false -let explain_elim_arity env sigma ind sorts c pj okinds = +let explain_elim_arity env sigma ind c pj okinds = let open EConstr in let env = make_all_name_different env sigma in let pi = pr_inductive env (fst ind) in let pc = pr_leconstr_env env sigma c in let msg = match okinds with - | Some(kp,ki,explanation) -> + | Some(sorts,kp,ki,explanation) -> let pki = Sorts.pr_sort_family ki in let pkp = Sorts.pr_sort_family kp in let explanation = match explanation with @@ -262,7 +263,7 @@ let explain_ill_formed_branch env sigma c ci actty expty = let explain_generalization env sigma (name,var) j = let pe = pr_ne_context_of (str "In environment") env sigma in let pv = pr_letype_env env sigma var in - let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) sigma j in + let (pc,pt) = pr_ljudge_env (push_rel_assum (make_annot name Sorts.Relevant,var) env) sigma j in pe ++ str "Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ str "over" ++ brk(1,1) ++ pc ++ str "," ++ spc () ++ str "it has type" ++ spc () ++ pt ++ @@ -307,7 +308,7 @@ let explain_unification_error env sigma p1 p2 = function | UnifUnivInconsistency p -> if !Constrextern.print_universes then [str "universe inconsistency: " ++ - Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes p] + Univ.explain_universe_inconsistency (Termops.pr_evd_level sigma) p] else [str "universe inconsistency"] | CannotSolveConstraint ((pb,env,t,u),e) -> @@ -339,6 +340,20 @@ let explain_actual_type env sigma j t reason = str "while it is expected to have type" ++ brk(1,1) ++ pt ++ ppreason ++ str ".") +let explain_incorrect_primitive env sigma j exp = + let env = make_all_name_different env sigma in + let {uj_val=p;uj_type=t} = j in + let t = Reductionops.nf_betaiota env sigma t in + let exp = Reductionops.nf_betaiota env sigma exp in + (* Actually print *) + let pe = pr_ne_context_of (str "In environment") env sigma in + let (pt, pct) = pr_explicit env sigma exp t in + pe ++ + hov 0 ( + str "The primitive" ++ brk(1,1) ++ str (CPrimitives.op_or_type_to_string p) ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ spc () ++ + str "while it is expected to have type" ++ brk(1,1) ++ pt ++ str ".") + let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = let randl = jv_nf_betaiotaevar env sigma randl in let actualtyp = Reductionops.nf_betaiota env sigma actualtyp in @@ -400,7 +415,7 @@ let explain_not_product env sigma c = let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = let pr_lconstr_env env sigma c = pr_leconstr_env env sigma c in let prt_name i = - match names.(i) with + match names.(i).binder_name with Name id -> str "Recursive definition of " ++ Id.print id | Anonymous -> str "The " ++ pr_nth i ++ str " definition" in @@ -415,7 +430,7 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) -> let arg_env = make_all_name_different arg_env sigma in let called = - match names.(j) with + match names.(j).binder_name with Name id -> Id.print id | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in let pr_db x = quote (pr_db env x) in @@ -435,7 +450,7 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = | NotEnoughArgumentsForFixCall j -> let called = - match names.(j) with + match names.(j).binder_name with Name id -> Id.print id | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in str "Recursive call to " ++ called ++ str " has not enough arguments" @@ -474,6 +489,8 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = str "The return clause of the following pattern matching should be" ++ strbrk " a coinductive type:" ++ spc () ++ pr_lconstr_env env sigma c + | FixpointOnIrrelevantInductive -> + strbrk "Fixpoints on proof irrelevant inductive types should produce proof irrelevant values" in prt_name i ++ str " is ill-formed." ++ fnl () ++ pr_ne_context_of (str "In environment") env sigma ++ @@ -696,6 +713,12 @@ let explain_undeclared_universe env sigma l = Termops.pr_evd_level sigma l ++ spc () ++ str "(maybe a bugged tactic)." +let explain_disallowed_sprop () = + Pp.(str "SProp not allowed, you need to use -allow-sprop.") + +let explain_bad_relevance env = + strbrk "Bad relevance (maybe a bugged tactic)." + let explain_type_error env sigma err = let env = make_all_name_different env sigma in match err with @@ -709,8 +732,8 @@ let explain_type_error env sigma err = explain_bad_assumption env sigma c | ReferenceVariables (id,c) -> explain_reference_variables sigma id c - | ElimArity (ind, aritylst, c, pj, okinds) -> - explain_elim_arity env sigma ind aritylst c pj okinds + | ElimArity (ind, c, pj, okinds) -> + explain_elim_arity env sigma ind c pj okinds | CaseNotInductive cj -> explain_case_not_inductive env sigma cj | NumberBranches (cj, n) -> @@ -720,7 +743,9 @@ let explain_type_error env sigma err = | Generalization (nvar, c) -> explain_generalization env sigma nvar c | ActualType (j, pt) -> - explain_actual_type env sigma j pt None + explain_actual_type env sigma j pt None + | IncorrectPrimitive (j, t) -> + explain_incorrect_primitive env sigma j t | CantApplyBadType (t, rator, randl) -> explain_cant_apply_bad_type env sigma t rator randl | CantApplyNonFunctional (rator, randl) -> @@ -735,6 +760,8 @@ let explain_type_error env sigma err = explain_unsatisfied_constraints env sigma cst | UndeclaredUniverse l -> explain_undeclared_universe env sigma l + | DisallowedSProp -> explain_disallowed_sprop () + | BadRelevance -> explain_bad_relevance env let pr_position (cl,pos) = let clpos = match cl with @@ -848,6 +875,7 @@ let explain_pretype_error env sigma err = | TypingError t -> explain_type_error env sigma t | CannotUnifyOccurrences (b,c1,c2,e) -> explain_cannot_unify_occurrences env sigma b c1 c2 e | UnsatisfiableConstraints (c,comp) -> explain_unsatisfiable_constraints env sigma c comp + | DisallowedSProp -> explain_disallowed_sprop () (* Module errors *) @@ -1039,12 +1067,10 @@ let explain_module_internalization_error = function (* Typeclass errors *) -let explain_not_a_class env c = - let sigma = Evd.from_env env in - let c = EConstr.to_constr sigma c in - pr_constr_env env sigma c ++ str" is not a declared type class." +let explain_not_a_class env sigma c = + pr_econstr_env env sigma c ++ str" is not a declared type class." -let explain_unbound_method env cid { CAst.v = id } = +let explain_unbound_method env sigma cid { CAst.v = id } = str "Unbound method name " ++ Id.print (id) ++ spc () ++ str"of class" ++ spc () ++ pr_global cid ++ str "." @@ -1059,9 +1085,9 @@ let explain_mismatched_contexts env c i j = fnl () ++ brk (1,1) ++ hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) -let explain_typeclass_error env = function - | NotAClass c -> explain_not_a_class env c - | UnboundMethod (cid, id) -> explain_unbound_method env cid id +let explain_typeclass_error env sigma = function + | NotAClass c -> explain_not_a_class env sigma c + | UnboundMethod (cid, id) -> explain_unbound_method env sigma cid id (* Refiner errors *) @@ -1181,7 +1207,7 @@ let error_large_non_prop_inductive_not_in_type () = str "Large non-propositional inductive types must be in Type." let error_inductive_bad_univs () = - str "Incorrect universe constrains declared for inductive type." + str "Incorrect universe constraints declared for inductive type." (* Recursion schemes errors *) diff --git a/vernac/himsg.mli b/vernac/himsg.mli index f22354cdbf..d0f42ea16b 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -26,7 +26,7 @@ val explain_inductive_error : inductive_error -> Pp.t val explain_mismatched_contexts : env -> contexts -> Constrexpr.constr_expr list -> Constr.rel_context -> Pp.t -val explain_typeclass_error : env -> typeclass_error -> Pp.t +val explain_typeclass_error : env -> Evd.evar_map -> typeclass_error -> Pp.t val explain_recursion_scheme_error : env -> recursion_scheme_error -> Pp.t diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index caafd6ac2f..1e733acc59 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -228,17 +228,20 @@ let declare_one_case_analysis_scheme ind = let kinds_from_prop = [InType,rect_scheme_kind_from_prop; InProp,ind_scheme_kind_from_prop; - InSet,rec_scheme_kind_from_prop] + InSet,rec_scheme_kind_from_prop; + InSProp,sind_scheme_kind_from_prop] let kinds_from_type = [InType,rect_dep_scheme_kind_from_type; InProp,ind_dep_scheme_kind_from_type; - InSet,rec_dep_scheme_kind_from_type] + InSet,rec_dep_scheme_kind_from_type; + InSProp,sind_dep_scheme_kind_from_type] let nondep_kinds_from_type = [InType,rect_scheme_kind_from_type; InProp,ind_scheme_kind_from_type; - InSet,rec_scheme_kind_from_type] + InSet,rec_scheme_kind_from_type; + InSProp,sind_scheme_kind_from_type] let declare_one_induction_scheme ind = let (mib,mip) = Global.lookup_inductive ind in @@ -246,6 +249,9 @@ let declare_one_induction_scheme ind = let from_prop = kind == InProp in let depelim = Inductiveops.has_dependent_elim mib in let kelim = elim_sorts (mib,mip) in + let kelim = if Global.sprop_allowed () then kelim + else List.filter (fun s -> s <> InSProp) kelim + in let elims = List.map_filter (fun (sort,kind) -> if Sorts.List.mem sort kelim then Some kind else None) @@ -347,19 +353,23 @@ requested match sort_of_ind with | InProp -> if isdep then (match z with + | InSProp -> inds ^ "s_dep" | InProp -> inds ^ "_dep" | InSet -> recs ^ "_dep" | InType -> recs ^ "t_dep") else ( match z with + | InSProp -> inds ^ "s" | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) | _ -> if isdep then (match z with + | InSProp -> inds ^ "s" | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) else (match z with + | InSProp -> inds ^ "s_nodep" | InProp -> inds ^ "_nodep" | InSet -> recs ^ "_nodep" | InType -> recs ^ "t_nodep") diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 77f125e878..0d0732cbb4 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -330,7 +330,7 @@ let initialize_named_context_for_proof () = List.fold_right (fun d signv -> let id = NamedDecl.get_id d in - let d = if variable_opacity id then NamedDecl.LocalAssum (id, NamedDecl.get_type d) else d in + let d = if variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?(hook : declaration_hook option) c = diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 38cdfc2d7a..9aca48f529 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -13,6 +13,7 @@ open Declare open Term open Constr +open Context open Vars open Names open Evd @@ -124,11 +125,11 @@ let etype_of_evar evs hyps concl = | LocalDef (id,c,_) -> let c', s'', trans'' = subst_evar_constr evs n mkVar c in let c' = subst_vars acc 0 c' in - mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, + mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, Int.Set.union s'' s', Id.Set.union trans'' trans' - | LocalAssum (id,_) -> - mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') + | LocalAssum (id,_) -> + mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') | [] -> let t', s, trans = subst_evar_constr evs n mkVar concl in subst_vars acc 0 t', s, trans @@ -479,7 +480,7 @@ let declare_definition prg = let rec lam_index n t acc = match Constr.kind t with - | Lambda (Name n', _, _) when Id.equal n n' -> + | Lambda ({binder_name=Name n'}, _, _) when Id.equal n n' -> acc | Lambda (_, _, b) -> lam_index n b (succ acc) @@ -508,11 +509,12 @@ let declare_mutual_definition l = let subs, typ = subst_prog oblsubst x in let env = Global.env () in let sigma = Evd.from_ctx x.prg_ctx in + let r = Retyping.relevance_of_type env sigma (EConstr.of_constr typ) in let term = snd (Reductionops.splay_lam_n env sigma len (EConstr.of_constr subs)) in let typ = snd (Reductionops.splay_prod_n env sigma len (EConstr.of_constr typ)) in let term = EConstr.to_constr sigma term in let typ = EConstr.to_constr sigma typ in - let def = (x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) in + let def = (x.prg_reduce term, r, x.prg_reduce typ, x.prg_implicits) in let oblsubst = List.map (fun (id, (_, c)) -> id, c) oblsubst in def, oblsubst in @@ -522,10 +524,12 @@ let declare_mutual_definition l = (xdef :: defs, xobls @ obls)) l ([], []) in (* let fixdefs = List.map reduce_fix fixdefs in *) - let fixdefs, fixtypes, fiximps = List.split3 defs in + let fixdefs, fixrs, fixtypes, fiximps = List.split4 defs in let fixkind = Option.get first.prg_fixkind in let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in - let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in + let rvec = Array.of_list fixrs in + let namevec = Array.of_list (List.map (fun x -> Name x.prg_name) l) in + let fixdecls = (Array.map2 make_annot namevec rvec, arrrec, recvec) in let (local,poly,kind) = first.prg_kind in let fixnames = first.prg_deps in let opaque = first.prg_opaque in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index d22e52e960..f705f347a3 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -1033,9 +1033,9 @@ open Pputils let pr_s = function None -> str"" | Some {v=s} -> str "%" ++ str s in let pr_if b x = if b then x else str "" in let pr_br imp x = match imp with - | Vernacexpr.Implicit -> str "[" ++ x ++ str "]" - | Vernacexpr.MaximallyImplicit -> str "{" ++ x ++ str "}" - | Vernacexpr.NotImplicit -> x in + | Impargs.Implicit -> str "[" ++ x ++ str "]" + | Impargs.MaximallyImplicit -> str "{" ++ x ++ str "}" + | Impargs.NotImplicit -> x in let rec print_arguments n l = match n, l with | Some 0, l -> spc () ++ str"/" ++ print_arguments None l diff --git a/vernac/record.ml b/vernac/record.ml index 0bd15e203b..23274040b0 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -17,6 +17,7 @@ open Names open Globnames open Nameops open Constr +open Context open Vars open Environ open Declarations @@ -66,6 +67,7 @@ let interp_fields_evars env sigma impls_env nots l = List.fold_left2 (fun (env, sigma, uimpls, params, impls) no ({CAst.loc;v=i}, b, t) -> let sigma, (t', impl) = interp_type_evars_impls ~program_mode:false env sigma ~impls t in + let r = Retyping.relevance_of_type env sigma t' in let sigma, b' = Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ interp_casted_constr_evars_impls ~program_mode:false env sigma ~impls x t') (sigma,None) b in @@ -75,8 +77,8 @@ let interp_fields_evars env sigma impls_env nots l = | Name id -> Id.Map.add id (compute_internalization_data env sigma Constrintern.Method t' impl) impls in let d = match b' with - | None -> LocalAssum (i,t') - | Some b' -> LocalDef (i,b',t') + | None -> LocalAssum (make_annot i r,t') + | Some b' -> LocalDef (make_annot i r,b',t') in List.iter (Metasyntax.set_notation_for_interpretation env impls) no; (EConstr.push_rel d env, sigma, impl :: uimpls, d::params, impls)) @@ -90,7 +92,7 @@ let compute_constructor_level evars env l = Univ.sup (univ_of_sort s) univ else univ in (EConstr.push_rel d env, univ)) - l (env, Univ.type0m_univ) + l (env, Univ.Universe.sprop) let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) @@ -144,8 +146,10 @@ let typecheck_params_and_fields finite def poly pl ps records = in let (sigma, template), typs = List.fold_left_map fold (sigma, true) records in let arities = List.map (fun (typ, _) -> EConstr.it_mkProd_or_LetIn typ newps) typs in - let fold accu (id, _, _, _) arity = EConstr.push_rel (LocalAssum (Name id,arity)) accu in - let env_ar = EConstr.push_rel_context newps (List.fold_left2 fold env0 records arities) in + let relevances = List.map (fun (_,s) -> Sorts.relevance_of_sort s) typs in + let fold accu (id, _, _, _) arity r = + EConstr.push_rel (LocalAssum (make_annot (Name id) r,arity)) accu in + let env_ar = EConstr.push_rel_context newps (List.fold_left3 fold env0 records arities relevances) in let assums = List.filter is_local_assum newps in let impls_env = let params = List.map (RelDecl.get_name %> Name.get_id) assums in @@ -163,16 +167,16 @@ let typecheck_params_and_fields finite def poly pl ps records = Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma in let fold sigma (typ, sort) (_, newfs) = let _, univ = compute_constructor_level sigma env_ar newfs in - if not def && (Sorts.is_prop sort || - (Sorts.is_set sort && is_impredicative_set env0)) then + let univ = if Sorts.is_sprop sort then univ else Univ.Universe.sup univ Univ.type0m_univ in + if not def && is_impredicative_sort env0 sort then sigma, typ else - let sigma = Evd.set_leq_sort env_ar sigma (Type univ) sort in - if Univ.is_small_univ univ && + let sigma = Evd.set_leq_sort env_ar sigma (Sorts.sort_of_univ univ) sort in + if Univ.is_small_univ univ && Option.cata (Evd.is_flexible_level sigma) false (Evd.is_sort_variable sigma sort) then (* We can assume that the level in aritysort is not constrained and clear it, if it is flexible *) - Evd.set_eq_sort env_ar sigma Set sort, EConstr.mkSort (Sorts.sort_of_univ univ) + Evd.set_eq_sort env_ar sigma Sorts.set sort, EConstr.mkSort (Sorts.sort_of_univ univ) else sigma, typ in let (sigma, typs) = List.fold_left2_map fold sigma typs data in @@ -213,12 +217,12 @@ let warning_or_error coe indsp err = strbrk " not defined.") | BadTypedProj (fi,ctx,te) -> match te with - | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) -> + | ElimArity (_,_,_,Some (_,_,_,NonInformativeToInformative)) -> (Id.print fi ++ strbrk" cannot be defined because it is informative and " ++ Printer.pr_inductive (Global.env()) indsp ++ strbrk " is not.") - | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) -> + | ElimArity (_,_,_,Some (_,_,_,StrongEliminationOnNonSmallType)) -> (Id.print fi ++ strbrk" cannot be defined because it is large and " ++ Printer.pr_inductive (Global.env()) indsp ++ @@ -284,7 +288,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f let r = mkIndU (indsp,u) in let rp = applist (r, Context.Rel.to_extended_list mkRel 0 paramdecls) in let paramargs = Context.Rel.to_extended_list mkRel 1 paramdecls in (*def in [[params;x:rp]]*) - let x = Name binder_name in + let x = make_annot (Name binder_name) mip.mind_relevance in let fields = instantiate_possibly_recursive_type (fst indsp) u mib.mind_ntypes paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in let primitive = @@ -316,18 +320,19 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f else let ccl = subst_projection fid subst ti in let body = match decl with - | LocalDef (_,ci,_) -> subst_projection fid subst ci - | LocalAssum _ -> + | 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 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 LetStyle in - mkCase (ci, p, mkRel 1, [|branch|]) - 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 + it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in try @@ -416,8 +421,6 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki let primitive = !primitive_flag && List.for_all (fun (_,_,_,_,fields,_,_) -> List.exists is_local_assum fields) record_data - (* will warn_non_primitive_record in declare_projections if we try - to declare a 0-field record *) in let mie = { mind_entry_params = params; @@ -431,7 +434,9 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki in let mie = InferCumulativity.infer_inductive (Global.env ()) mie in let impls = List.map (fun _ -> paramimpls, []) record_data in - let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders impls in + let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders impls + ~primitive_expected:!primitive_flag + in let map i (_, _, _, fieldimpls, fields, is_coe, coers) = let rsp = (kn, i) in (* This is ind path of idstruc *) let cstr = (rsp, 1) in @@ -463,7 +468,9 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity let binder_name = Namegen.next_ident_away id (Termops.vars_of_env (Global.env())) in let data = match fields with - | [LocalAssum (Name proj_name, field) | LocalDef (Name proj_name, _, field)] when def -> + | [LocalAssum ({binder_name=Name proj_name} as binder, field) + | LocalDef ({binder_name=Name proj_name} as binder, _, field)] when def -> + let binder = {binder with binder_name=Name binder_name} in let class_body = it_mkLambda_or_LetIn field params in let class_type = it_mkProd_or_LetIn arity params in let class_entry = @@ -477,18 +484,18 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity in let cstu = (cst, inst) in let inst_type = appvectc (mkConstU cstu) - (Termops.rel_vect 0 (List.length params)) in + (Termops.rel_vect 0 (List.length params)) in let proj_type = - it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in + it_mkProd_or_LetIn (mkProd(binder, inst_type, lift 1 field)) params in let proj_body = - it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in + it_mkLambda_or_LetIn (mkLambda (binder, inst_type, mkRel 1)) params in let proj_entry = Declare.definition_entry ~types:proj_type ~univs proj_body in let proj_cst = Declare.declare_constant proj_name (DefinitionEntry proj_entry, IsDefinition Definition) in let cref = ConstRef cst in - Impargs.declare_manual_implicits false cref [paramimpls]; - Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; + Impargs.declare_manual_implicits false cref paramimpls; + Impargs.declare_manual_implicits false (ConstRef proj_cst) (List.hd fieldimpls); Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with | Some b -> Some ((if b then Backward else Forward), List.hd priorities) @@ -548,12 +555,13 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity let add_constant_class env cst = let ty, univs = Typeops.type_of_global_in_context env (ConstRef cst) in + let r = (Environ.lookup_constant cst env).const_relevance in let ctx, arity = decompose_prod_assum ty in let tc = { cl_univs = univs; cl_impl = ConstRef cst; cl_context = (List.map (const None) ctx, ctx); - cl_props = [LocalAssum (Anonymous, arity)]; + cl_props = [LocalAssum (make_annot Anonymous r, arity)]; cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique @@ -570,10 +578,11 @@ let add_inductive_class env ind = let env = push_rel_context ctx env in let inst = Univ.make_abstract_instance univs in let ty = Inductive.type_of_inductive env ((mind, oneind), inst) in + let r = Inductive.relevance_of_inductive env ind in { cl_univs = univs; cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; - cl_props = [LocalAssum (Anonymous, ty)]; + cl_props = [LocalAssum (make_annot Anonymous r, ty)]; cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique } diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 11b64a5247..4250ddb02c 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -16,7 +16,6 @@ open CAst open Util open Names open Nameops -open Term open Tacmach open Constrintern open Prettyp @@ -32,6 +31,7 @@ open Lemmas open Locality open Attributes +module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration (** TODO: make this function independent of Ltac *) @@ -133,22 +133,23 @@ let show_intro all = *) let make_cases_aux glob_ref = + let open Declarations in match glob_ref with | Globnames.IndRef ind -> - let {Declarations.mind_nparams = np} , {Declarations.mind_nf_lc = tarr} = Global.lookup_inductive ind in + let mib, mip = Global.lookup_inductive ind in Util.Array.fold_right_i - (fun i typ l -> - let al = List.rev (fst (decompose_prod typ)) in - let al = Util.List.skipn np al in + (fun i (ctx, _) l -> + let al = Util.List.skipn (List.length mib.mind_params_ctxt) (List.rev ctx) in let rec rename avoid = function | [] -> [] - | (n,_)::l -> - let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n avoid in - Id.to_string n' :: rename (Id.Set.add n' avoid) l in + | RelDecl.LocalDef _ :: l -> "_" :: rename avoid l + | RelDecl.LocalAssum (n, _)::l -> + let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n.Context.binder_name avoid in + Id.to_string n' :: rename (Id.Set.add n' avoid) l in let al' = rename Id.Set.empty al in let consref = ConstructRef (ith_constructor_of_inductive ind (i + 1)) in (Libnames.string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty consref) :: al') :: l) - tarr [] + mip.mind_nf_lc [] | _ -> raise Not_found let make_cases s = @@ -1173,14 +1174,6 @@ let vernac_syntactic_definition ~module_local lid x y = Dumpglob.dump_definition lid false "syndef"; Metasyntax.add_syntactic_definition (Global.env()) lid.v x module_local y -let vernac_declare_implicits ~section_local r l = - match l with - | [] -> - Impargs.declare_implicits section_local (smart_global r) - | _::_ as imps -> - Impargs.declare_manual_implicits section_local (smart_global r) ~enriching:false - (List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps) - let warn_arguments_assert = CWarnings.create ~name:"arguments-assert" ~category:"vernacular" (fun sr -> @@ -1336,43 +1329,15 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red user_err (strbrk "Some argument names are duplicated: " ++ duplicates) end; - (* Parts of this code are overly complicated because the implicit arguments - API is completely crazy: positions (ExplByPos) are elaborated to - names. This is broken by design, since not all arguments have names. So - even though we eventually want to map only positions to implicit statuses, - we have to check whether the corresponding arguments have names, not to - trigger an error in the impargs code. Even better, the names we have to - check are not the current ones (after previous renamings), but the original - ones (inferred from the type). *) - let implicits = List.map (fun { name; implicit_status = i } -> (name,i)) args in let implicits = implicits :: more_implicits in - let open Vernacexpr in - let rec build_implicits inf_names implicits = - match inf_names, implicits with - | _, [] -> [] - | _ :: inf_names, (_, NotImplicit) :: implicits -> - build_implicits inf_names implicits - - (* With the current impargs API, it is impossible to make an originally - anonymous argument implicit *) - | Anonymous :: _, (name, _) :: _ -> - user_err ~hdr:"vernac_declare_arguments" - (strbrk"Argument "++ Name.print name ++ - strbrk " cannot be declared implicit.") - - | Name id :: inf_names, (name, impl) :: implicits -> - let max = impl = MaximallyImplicit in - (ExplByName id,max,false) :: build_implicits inf_names implicits - - | _ -> assert false (* already checked in [names_union] *) - in - - let implicits = List.map (build_implicits inf_names) implicits in - let implicits_specified = match implicits with [[]] -> false | _ -> true in + let implicits = List.map (List.map snd) implicits in + let implicits_specified = match implicits with + | [l] -> List.exists (function Impargs.NotImplicit -> false | _ -> true) l + | _ -> true in if implicits_specified && clear_implicits_flag then user_err Pp.(str "The \"clear implicits\" flag is incompatible with implicit annotations"); @@ -1415,10 +1380,10 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red end; if implicits_specified || clear_implicits_flag then - vernac_declare_implicits ~section_local reference implicits; + Impargs.set_implicits section_local (smart_global reference) implicits; if default_implicits_flag then - vernac_declare_implicits ~section_local reference []; + Impargs.declare_implicits section_local (smart_global reference); if red_modifiers_specified then begin match sr with @@ -1459,6 +1424,14 @@ let vernac_generalizable ~local = let () = declare_bool_option { optdepr = false; + optname = "allow sprop"; + optkey = ["Allow";"StrictProp"]; + optread = (fun () -> Global.sprop_allowed()); + optwrite = Global.set_allow_sprop } + +let () = + declare_bool_option + { optdepr = false; optname = "silent"; optkey = ["Silent"]; optread = (fun () -> !Flags.quiet); @@ -2377,6 +2350,8 @@ let locate_if_not_already ?loc (e, info) = exception HasNotFailed exception HasFailed of Pp.t +let test_mode = ref false + (* XXX STATE: this type hints that restoring the state should be the caller's responsibility *) let with_fail st b f = @@ -2402,7 +2377,7 @@ let with_fail st b f = | HasNotFailed -> user_err ~hdr:"Fail" (str "The command has not failed!") | HasFailed msg -> - if not !Flags.quiet || !Flags.test_mode then Feedback.msg_info + if not !Flags.quiet || !test_mode then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) | _ -> assert false end diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 4fbd3849b0..f43cec48e9 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -41,3 +41,7 @@ val command_focus : unit Proof.focus_kind val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t + +(* Flag set when the test-suite is called. Its only effect to display + verbose information for `Fail` *) +val test_mode : bool ref diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 2eb901890b..d1da7c0602 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -237,13 +237,11 @@ type vernac_cumulative = VernacCumulative | VernacNonCumulative (** {6 The type of vernacular expressions} *) -type vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit - type vernac_argument_status = { name : Name.t; recarg_like : bool; notation_scope : string CAst.t option; - implicit_status : vernac_implicit_status; + implicit_status : Impargs.implicit_kind; } type extend_name = @@ -355,7 +353,7 @@ type nonrec vernac_expr = onlyparsing_flag | VernacArguments of qualid or_by_notation * vernac_argument_status list (* Main arguments status list *) * - (Name.t * vernac_implicit_status) list list (* Extra implicit status lists *) * + (Name.t * Impargs.implicit_kind) list list (* Extra implicit status lists *) * int option (* Number of args to trigger reduction *) * [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | @@ -409,3 +407,9 @@ type vernac_control = | VernacRedirect of string * vernac_control CAst.t | VernacTimeout of int * vernac_control | VernacFail of vernac_control + +(** Deprecated *) + +type vernac_implicit_status = Impargs.implicit_kind = + | Implicit [@ocaml.deprecated] | MaximallyImplicit [@ocaml.deprecated] | NotImplicit [@ocaml.deprecated] +[@@ocaml.deprecated "Use [Impargs.implicit_kind]"] |