diff options
222 files changed, 11004 insertions, 9599 deletions
diff --git a/.github/SUPPORT.md b/.github/SUPPORT.md index b6f2e942e9..978f011f23 100644 --- a/.github/SUPPORT.md +++ b/.github/SUPPORT.md @@ -1,28 +1,22 @@ -# Support # +[![Zulip][zulip-badge]][zulip-link] +[![Discourse][discourse-badge]][discourse-link] + +[discourse-badge]: https://img.shields.io/badge/Discourse-forum-informational.svg +[discourse-link]: https://coq.discourse.group/ -Get in touch with the user community and ask questions about Coq on -our [Discourse forum][]. Posts in other languages than English are -explicitly welcome there. There is also a historic mailing list called -the [Coq-Club][] which has lots of subscribers, and an IRC channel -(`irc://irc.freenode.net/#coq`). +[zulip-badge]: https://img.shields.io/badge/Zulip-chat-informational.svg +[zulip-link]: https://coq.zulipchat.com/ + +# Support # -In addition, you may also ask questions about Coq on [Stack -Overflow][] (use the tag [coq][Stack Overflow tag]) or on the -meta-theory of Coq on the [TCS Stack Exchange][] (which also has a -[coq][TCS SE tag] tag). +<!-- content copied verbatim from "Questions and discussion" in README.md --> -You can reach the Coq development team through the [development -category][] of the above mentioned Discourse forum, the [Gitter -channel][], and of course the bug tracker. +We have a number of channels to reach the user community and the +development team: -See also [coq.inria.fr/community](https://coq.inria.fr/community.html). +- Our [Zulip chat][zulip-link], for casual and high traffic discussions. +- Our [Discourse forum][discourse-link], for more structured and easily browsable discussions and Q&A. +- Our historical mailing list, the [Coq-Club](https://sympa.inria.fr/sympa/info/coq-club). -[Discourse forum]: https://coq.discourse.group -[Coq-Club]: https://sympa.inria.fr/sympa/arc/coq-club -[Stack Overflow]: https://stackoverflow.com -[Stack Overflow tag]: https://stackoverflow.com/questions/tagged/coq -[TCS Stack Exchange]: https://cstheory.stackexchange.com/ -[TCS SE tag]: https://cstheory.stackexchange.com/questions/tagged/coq -[development category]: https://coq.discourse.group/c/coq-development -[Gitter channel]: https://gitter.im/coq/coq -[bug tracker]: https://github.com/coq/coq/issues +See also [coq.inria.fr/community](https://coq.inria.fr/community.html), which +lists several other active platforms. diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e8ee0c537b..87101ecae7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2020-05-06-V70" + CACHEKEY: "bionic_coq-V2020-05-19-V33" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -366,12 +366,11 @@ pkg:opam: dependencies: [] script: - set -e - - opam pin add --kind=path coq.$COQ_VERSION . - - opam pin add --kind=path coqide-server.$COQ_VERSION . - - opam pin add --kind=path coqide.$COQ_VERSION . + - opam pin add --kind=path coq.dev . + - opam pin add --kind=path coqide-server.dev . + - opam pin add --kind=path coqide.dev . - set +e variables: - COQ_VERSION: "8.12" OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" only: *full-ci @@ -699,6 +698,9 @@ library:ci-coquelicot: library:ci-cross_crypto: extends: .ci-template +library:ci-engine_bench: + extends: .ci-template + library:ci-fcsl_pcm: extends: .ci-template diff --git a/.ocamlformat b/.ocamlformat index 62e609fb55..a0d4ef6bbb 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.14.0 +version=0.14.2 profile=ocamlformat # to enable a whole directory, put "disable=false" in dir/.ocamlformat @@ -11,4 +11,4 @@ cases-exp-indent=2 field-space=loose exp-grouping=preserve break-cases=fit -doc-comments-val=before +doc-comments=before diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md index 0720cf6210..0d8751de7e 100644 --- a/CODE_OF_CONDUCT.md +++ b/CODE_OF_CONDUCT.md @@ -11,7 +11,7 @@ Their goal is that everyone feels safe and welcome when contributing to Coq or interacting with others in Coq related forums. These rules apply to all spaces managed by the Coq development team. -This includes the GitHub repository, the mailing lists, the Gitter channel, +This includes the GitHub repository, the Discourse forum, the Zulip chat, the mailing lists, physical events like Coq working groups and workshops, and any other forums created or managed by the development team which the community uses for communication. In addition, violations of these rules outside these spaces may diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 525ced7fee..8a09e43c94 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -179,7 +179,8 @@ Learn how to write a Coq plugin, and about best practices, in the Coq progress, so do not hesitate to expand it, or ask questions. If you want quick feedback on best practices, or how to talk to the -Coq API, a good place to hang out is the Coq [Gitter channel][Gitter]. +Coq API, a good place to hang out is the [Coq devs & plugin devs +stream][Zulip-dev] of our Zulip chat. Finally, we strongly encourage authors of plugins to submit their plugins to join Coq's continuous integration (CI) early on. Indeed, @@ -285,7 +286,7 @@ GitHub account). You can file a bug for any of the following: 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][Discourse] or [Gitter chat][Gitter] +ask on our [Discourse forum][Discourse] or [Zulip chat][Zulip] before, after, or while writing a bug report. It is better if you can test that your bug is still present in the @@ -364,7 +365,7 @@ Being in this team will grant you the following access: idea for a new feature). - **Creating new labels:** if you feel a `part:` label is missing, do not hesitate to create it. If you are not sure, you may discuss it - with other contributors and developers on [Gitter][] first. + with other contributors and developers on [Zulip][Zulip-dev] first. - **Closing issues:** if a bug cannot be reproduced anymore, is a duplicate, or should not be considered a bug report in the first place, you should close it. When doing so, try putting an @@ -1133,7 +1134,7 @@ before a change is ready on your side. When opening a draft PR, make sure to give it a descriptive enough title so that interested developers still notice it in their notification feed. You may also advertise it by talking about it in -our [developer chat][Gitter]. If you know which developer would be +our [developer chat][Zulip-dev]. If you know which developer would be able to provide useful feedback to you, you may also ping them. ###### Turning a PR into draft mode ###### @@ -1182,8 +1183,9 @@ documentation is still a work-in-progress. ### Online forum and chat to talk to developers ### We have a [Discourse forum][Discourse] (see in particular the [Coq -development category][Discourse-development-category]) and a [Gitter -chat][Gitter]. Feel free to join any of them and ask questions. +development][Discourse-development-category] category) and a [Zulip +chat][Zulip] (see in particular the [Coq devs & plugin devs][Zulip-dev] +stream). Feel free to join any of them and ask questions. People are generally happy to help and very reactive. Obviously, the issue tracker is also a good place to ask questions, @@ -1267,7 +1269,6 @@ can be found [on the wiki][wiki-CUDW]. [GitHub-wiki-extensions]: https://help.github.com/en/articles/editing-wiki-content [GitLab-coq]: https://gitlab.com/coq [GitLab-doc]: https://docs.gitlab.com/ -[Gitter]: https://gitter.im/coq/coq [JasonGross-coq-tools]: https://github.com/JasonGross/coq-tools [jenkins-doc]: https://github.com/coq/coq/wiki/Jenkins-(automated-benchmarking) [kind-documentation]: https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22 @@ -1311,3 +1312,5 @@ can be found [on the wiki][wiki-CUDW]. [wiki-CUDW]: https://github.com/coq/coq/wiki/CoqImplementorsWorkshop [wiki-WG]: https://github.com/coq/coq/wiki/Coq-Working-Groups [YouTube]: https://www.youtube.com/channel/UCbJo6gYYr0OF18x01M4THdQ +[Zulip]: https://coq.zulipchat.com +[Zulip-dev]: https://coq.zulipchat.com/#narrow/stream/237656-Coq-devs.20.26.20plugin.20devs diff --git a/META.coq.in b/META.coq.in index 377dbd9b7e..095f54dde7 100644 --- a/META.coq.in +++ b/META.coq.in @@ -1,7 +1,7 @@ # TODO: Generate automatically with Dune description = "The Coq Proof Assistant Plugin API" -version = "8.12" +version = "8.13" directory = "" requires = "" @@ -9,7 +9,7 @@ requires = "" package "config" ( description = "Coq Configuration Variables" - version = "8.12" + version = "8.13" directory = "config" @@ -19,7 +19,7 @@ package "config" ( package "clib" ( description = "Base General Coq Library" - version = "8.12" + version = "8.13" directory = "clib" requires = "str, unix, threads" @@ -31,7 +31,7 @@ package "clib" ( package "lib" ( description = "Base Coq-Specific Library" - version = "8.12" + version = "8.13" directory = "lib" @@ -45,7 +45,7 @@ package "lib" ( package "vm" ( description = "Coq VM" - version = "8.12" + version = "8.13" directory = "kernel/byterun" @@ -64,7 +64,7 @@ package "vm" ( package "kernel" ( description = "Coq's Kernel" - version = "8.12" + version = "8.13" directory = "kernel" @@ -78,7 +78,7 @@ package "kernel" ( package "library" ( description = "Coq Libraries (vo) support" - version = "8.12" + version = "8.13" requires = "coq.kernel" @@ -92,7 +92,7 @@ package "library" ( package "engine" ( description = "Coq Tactic Engine" - version = "8.12" + version = "8.13" requires = "coq.library" directory = "engine" @@ -105,7 +105,7 @@ package "engine" ( package "pretyping" ( description = "Coq Pretyper" - version = "8.12" + version = "8.13" requires = "coq.engine" directory = "pretyping" @@ -118,7 +118,7 @@ package "pretyping" ( package "interp" ( description = "Coq Term Interpretation" - version = "8.12" + version = "8.13" requires = "coq.pretyping" directory = "interp" @@ -131,7 +131,7 @@ package "interp" ( package "proofs" ( description = "Coq Proof Engine" - version = "8.12" + version = "8.13" requires = "coq.interp" directory = "proofs" @@ -144,7 +144,7 @@ package "proofs" ( package "gramlib" ( description = "Coq Grammar Engine" - version = "8.12" + version = "8.13" requires = "coq.lib" directory = "gramlib/.pack" @@ -156,7 +156,7 @@ package "gramlib" ( package "parsing" ( description = "Coq Parsing Engine" - version = "8.12" + version = "8.13" requires = "coq.gramlib, coq.proofs" directory = "parsing" @@ -169,7 +169,7 @@ package "parsing" ( package "printing" ( description = "Coq Printing Engine" - version = "8.12" + version = "8.13" requires = "coq.parsing" directory = "printing" @@ -182,7 +182,7 @@ package "printing" ( package "tactics" ( description = "Coq Basic Tactics" - version = "8.12" + version = "8.13" requires = "coq.printing" directory = "tactics" @@ -195,7 +195,7 @@ package "tactics" ( package "vernac" ( description = "Coq Vernacular Interpreter" - version = "8.12" + version = "8.13" requires = "coq.tactics" directory = "vernac" @@ -208,7 +208,7 @@ package "vernac" ( package "stm" ( description = "Coq State Transactional Machine" - version = "8.12" + version = "8.13" requires = "coq.vernac" directory = "stm" @@ -221,7 +221,7 @@ package "stm" ( package "toplevel" ( description = "Coq Toplevel" - version = "8.12" + version = "8.13" requires = "num, coq.stm" directory = "toplevel" @@ -234,7 +234,7 @@ package "toplevel" ( package "idetop" ( description = "Coq IDE Libraries" - version = "8.12" + version = "8.13" requires = "coq.toplevel" directory = "ide" @@ -247,7 +247,7 @@ package "idetop" ( package "ide" ( description = "Coq IDE Libraries" - version = "8.12" + version = "8.13" requires = "coq.lib, coq.ideprotocol, lablgtk3, lablgtk3-sourceview3" directory = "ide" @@ -260,7 +260,7 @@ package "ide" ( package "ideprotocol" ( description = "Coq IDE protocol" - version = "8.12" + version = "8.13" requires = "coq.toplevel" directory = "ide/protocol" @@ -273,14 +273,14 @@ package "ideprotocol" ( package "plugins" ( description = "Coq built-in plugins" - version = "8.12" + version = "8.13" directory = "plugins" package "ltac" ( description = "Coq LTAC Plugin" - version = "8.12" + version = "8.13" requires = "coq.stm" directory = "ltac" @@ -295,7 +295,7 @@ package "plugins" ( package "tauto" ( description = "Coq tauto plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "ltac" @@ -310,7 +310,7 @@ package "plugins" ( package "omega" ( description = "Coq omega plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "omega" @@ -325,7 +325,7 @@ package "plugins" ( package "micromega" ( description = "Coq micromega plugin" - version = "8.12" + version = "8.13" requires = "num,coq.plugins.ltac" directory = "micromega" @@ -340,7 +340,7 @@ package "plugins" ( package "zify" ( description = "Coq Zify plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "micromega" @@ -355,7 +355,7 @@ package "plugins" ( package "setoid_ring" ( description = "Coq newring plugin" - version = "8.12" + version = "8.13" requires = "" directory = "setoid_ring" @@ -370,7 +370,7 @@ package "plugins" ( package "extraction" ( description = "Coq extraction plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "extraction" @@ -385,7 +385,7 @@ package "plugins" ( package "cc" ( description = "Coq cc plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "cc" @@ -400,7 +400,7 @@ package "plugins" ( package "firstorder" ( description = "Coq ground plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "firstorder" @@ -415,7 +415,7 @@ package "plugins" ( package "rtauto" ( description = "Coq rtauto plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "rtauto" @@ -430,7 +430,7 @@ package "plugins" ( package "btauto" ( description = "Coq btauto plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "btauto" @@ -445,7 +445,7 @@ package "plugins" ( package "funind" ( description = "Coq recdef plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.extraction" directory = "funind" @@ -460,7 +460,7 @@ package "plugins" ( package "nsatz" ( description = "Coq nsatz plugin" - version = "8.12" + version = "8.13" requires = "num,coq.plugins.ltac" directory = "nsatz" @@ -475,7 +475,7 @@ package "plugins" ( package "rsyntax" ( description = "Coq rsyntax plugin" - version = "8.12" + version = "8.13" requires = "" directory = "syntax" @@ -490,7 +490,7 @@ package "plugins" ( package "int63syntax" ( description = "Coq int63syntax plugin" - version = "8.12" + version = "8.13" requires = "" directory = "syntax" @@ -505,7 +505,7 @@ package "plugins" ( package "string_notation" ( description = "Coq string_notation plugin" - version = "8.12" + version = "8.13" requires = "" directory = "syntax" @@ -520,7 +520,7 @@ package "plugins" ( package "derive" ( description = "Coq derive plugin" - version = "8.12" + version = "8.13" requires = "" directory = "derive" @@ -535,7 +535,7 @@ package "plugins" ( package "ssrmatching" ( description = "Coq ssrmatching plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "ssrmatching" @@ -550,7 +550,7 @@ package "plugins" ( package "ssreflect" ( description = "Coq ssreflect plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ssrmatching" directory = "ssr" @@ -565,7 +565,7 @@ package "plugins" ( package "ltac2" ( description = "Coq Ltac2 Plugin" - version = "8.12" + version = "8.13" requires = "coq.plugins.ltac" directory = "../user-contrib/Ltac2" diff --git a/Makefile.ci b/Makefile.ci index af92d476ba..9b7008f765 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -23,6 +23,7 @@ CI_TARGETS= \ ci-coq_tools \ ci-coqprime \ ci-elpi \ + ci-engine_bench \ ci-ext_lib \ ci-equations \ ci-fcsl_pcm \ diff --git a/Makefile.common b/Makefile.common index d435d7dfad..8f880e93fb 100644 --- a/Makefile.common +++ b/Makefile.common @@ -106,7 +106,7 @@ PLUGINDIRS:=\ setoid_ring extraction \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ - ssrmatching ltac ssr + ssrmatching ltac ssr ssrsearch USERCONTRIBDIRS:=\ Ltac2 @@ -158,6 +158,7 @@ DERIVECMO:=plugins/derive/derive_plugin.cmo LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo SSRCMO:=plugins/ssr/ssreflect_plugin.cmo +SSRSEARCHCMO=plugins/ssrsearch/ssrsearch_plugin.cmo LTAC2CMO:=user-contrib/Ltac2/ltac2_plugin.cmo ZIFYCMO:=plugins/micromega/zify_plugin.cmo @@ -166,7 +167,7 @@ PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(MICROMEGACMO) \ $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(SYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) $(LTAC2CMO) $(ZIFYCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) $(SSRSEARCHCMO) $(LTAC2CMO) $(ZIFYCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) @@ -2,7 +2,8 @@ [![GitLab][gitlab-badge]][gitlab-link] [![Azure Pipelines][azure-badge]][azure-link] -[![Gitter][gitter-badge]][gitter-link] +[![Zulip][zulip-badge]][zulip-link] +[![Discourse][discourse-badge]][discourse-link] [![DOI][doi-badge]][doi-link] [gitlab-badge]: https://gitlab.com/coq/coq/badges/master/pipeline.svg @@ -11,8 +12,11 @@ [azure-badge]: https://dev.azure.com/coq/coq/_apis/build/status/coq.coq?branchName=master [azure-link]: https://dev.azure.com/coq/coq/_build/latest?definitionId=1?branchName=master -[gitter-badge]: https://badges.gitter.im/coq/coq.svg -[gitter-link]: https://gitter.im/coq/coq +[discourse-badge]: https://img.shields.io/badge/Discourse-forum-informational.svg +[discourse-link]: https://coq.discourse.group/ + +[zulip-badge]: https://img.shields.io/badge/Zulip-chat-informational.svg +[zulip-link]: https://coq.zulipchat.com/ [doi-badge]: https://zenodo.org/badge/DOI/10.5281/zenodo.1003420.svg [doi-link]: https://doi.org/10.5281/zenodo.1003420 @@ -102,12 +106,12 @@ approach some problems you may encounter. We have a number of channels to reach the user community and the development team: -- 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. +- Our [Zulip chat][zulip-link], for casual and high traffic discussions. +- Our [Discourse forum][discourse-link], for more structured and easily browsable discussions and Q&A. +- Our historical mailing list, the [Coq-Club](https://sympa.inria.fr/sympa/info/coq-club). -See also [coq.inria.fr/community](https://coq.inria.fr/community.html). +See also [coq.inria.fr/community](https://coq.inria.fr/community.html), which +lists several other active platforms. ## Bug reports diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 770cc5193e..305c6a627e 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -6,37 +6,47 @@ variables: NJOBS: "2" jobs: -#- job: Windows -# pool: -# vmImage: 'vs2017-win2016' +- job: Windows + pool: + vmImage: 'vs2017-win2016' + + # Equivalent to allow_failure: true + # continueOnError: true -# steps: -# - checkout: self -# fetchDepth: 10 + steps: + - checkout: self + fetchDepth: 10 # cygwin package list not checked for minimality -# - script: | -# powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" -# SET CYGROOT=C:\cygwin64 -# SET CYGCACHE=%CYGROOT%\var\cache\setup -# setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python3 + - script: | + powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" + SET CYGROOT=C:\cygwin64 + SET CYGCACHE=%CYGROOT%\var\cache\setup + setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python3 + + SET TARGET_ARCH=x86_64-w64-mingw32 + SET CD_MFMT=%cd:\=/% + SET RESULT_INSTALLDIR_CFMT=%CD_MFMT:C:/=/cygdrive/c/% + C:\cygwin64\bin\bash -l %cd%\dev\build\windows\configure_profile.sh + displayName: 'Install cygwin' + env: + CYGMIRROR: "http://mirror.cs.vt.edu/pub/cygwin/cygwin" -# SET TARGET_ARCH=x86_64-w64-mingw32 -# SET CD_MFMT=%cd:\=/% -# SET RESULT_INSTALLDIR_CFMT=%CD_MFMT:C:/=/cygdrive/c/% -# C:\cygwin64\bin\bash -l %cd%\dev\build\windows\configure_profile.sh -# displayName: 'Install cygwin' -# env: -# CYGMIRROR: "http://mirror.easyname.at/cygwin" + - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-opam.sh + displayName: 'Install opam' -# - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-opam.sh -# displayName: 'Install opam' + - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-build.sh + displayName: 'Build Coq' -# - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-build.sh -# displayName: 'Build Coq' + # We are hitting a bug where Dune is rebuilding Coq to run the + # test-suite, also it seems to time out, so we just build for now + # + # - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-test.sh + # displayName: 'Test Coq' -# - script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-test.sh -# displayName: 'Test Coq' + - publish: _build/log + artifact: Dune Build Log + condition: always() - job: macOS pool: @@ -46,6 +56,7 @@ jobs: MACOSX_DEPLOYMENT_TARGET: '10.11' steps: + - checkout: self fetchDepth: 10 @@ -87,6 +98,7 @@ jobs: - script: | eval $(opam env) + export OCAMLPATH=$(pwd):"$OCAMLPATH" make -j "$NJOBS" test-suite PRINT_LOGS=1 displayName: 'Run Coq Test Suite' diff --git a/clib/cList.mli b/clib/cList.mli index 07f42770f9..c8e471f989 100644 --- a/clib/cList.mli +++ b/clib/cList.mli @@ -265,7 +265,7 @@ sig This is the second part of [chop]. *) val skipn_at_least : int -> 'a list -> 'a list - (** Same as [skipn] but returns [] if [n] is larger than the list of + (** Same as [skipn] but returns [] if [n] is larger than the length of the list. *) val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list diff --git a/clib/cSig.mli b/clib/cSig.mli index ca888f875a..1305be42bd 100644 --- a/clib/cSig.mli +++ b/clib/cSig.mli @@ -83,6 +83,7 @@ sig val min_binding: 'a t -> (key * 'a) val max_binding: 'a t -> (key * 'a) val choose: 'a t -> (key * 'a) + val choose_opt: 'a t -> (key * 'a) option val split: key -> 'a t -> 'a t * 'a option * 'a t val find: key -> 'a t -> 'a val find_opt : key -> 'a t -> 'a option diff --git a/clib/hMap.ml b/clib/hMap.ml index 3baa105fb0..210c48786b 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -356,6 +356,10 @@ struct let (_, m) = Int.Map.choose s in Map.choose m + let choose_opt s = + try Some (choose s) + with Not_found -> None + let find k s = let h = M.hash k in let m = Int.Map.find h s in diff --git a/configure.ml b/configure.ml index 75c11dab5f..9cfa9d409e 100644 --- a/configure.ml +++ b/configure.ml @@ -12,11 +12,11 @@ #load "str.cma" open Printf -let coq_version = "8.12+alpha" -let coq_macos_version = "8.11.90" (** "[...] should be a string comprised of +let coq_version = "8.13+alpha" +let coq_macos_version = "8.12.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 81191 -let state_magic = 581191 +let vo_magic = 81291 +let state_magic = 581291 let is_a_released_version = false let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; diff --git a/default.nix b/default.nix index 841bccb129..6b0e396d23 100644 --- a/default.nix +++ b/default.nix @@ -29,7 +29,7 @@ , shell ? false # We don't use lib.inNixShell because that would also apply # when in a nix-shell of some package depending on this one. -, coq-version ? "8.12-git" +, coq-version ? "8.13-git" }: with pkgs; diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index d5c6096100..801e29ac95 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -179,6 +179,11 @@ but if you wish to save more time you can skip the job by setting This means you will need to change its value when the Docker image needs to be updated. You can do so for a single pipeline by starting -it through the web interface. +it through the web interface. Here is a direct link that you can use +to trigger such a build: +`https://gitlab.com/coq/coq/pipelines/new?var[SKIP_DOCKER]=false&ref=pr-XXXXX`. +Note that this link will give a 404 error if you are not logged in or +a member of the Coq organization on GitLab. To request to join the +Coq organization, go to https://gitlab.com/coq to request access. See also [`docker/README.md`](docker/README.md). diff --git a/dev/ci/azure-build.sh b/dev/ci/azure-build.sh index 04c7d5db91..494651c5bf 100755 --- a/dev/ci/azure-build.sh +++ b/dev/ci/azure-build.sh @@ -4,4 +4,4 @@ set -e -x cd $(dirname $0)/../.. -make -f Makefile.dune coq coqide-server +dune build coq.install coqide-server.install diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 5f7d0b5789..19ba9de245 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -239,6 +239,13 @@ : "${elpi_hb_CI_ARCHIVEURL:=${elpi_hb_CI_GITURL}/archive}" ######################################################################## +# Engine-Bench +######################################################################## +: "${engine_bench_CI_REF:=master}" +: "${engine_bench_CI_GITURL:=https://github.com/mit-plv/engine-bench}" +: "${engine_bench_CI_ARCHIVEURL:=${engine_bench_CI_GITURL}/archive}" + +######################################################################## # fcsl-pcm ######################################################################## : "${fcsl_pcm_CI_REF:=master}" diff --git a/dev/ci/ci-engine_bench.sh b/dev/ci/ci-engine_bench.sh new file mode 100755 index 0000000000..fda7649f88 --- /dev/null +++ b/dev/ci/ci-engine_bench.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download engine_bench + +( cd "${CI_BUILD_DIR}/engine_bench" && make coq && make coq-perf-Sanity ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 9ee6496ee5..0d2f1dfbc7 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-05-06-V70" +# CACHEKEY: "bionic_coq-V2020-05-19-V33" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -14,12 +14,13 @@ RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ # Dependencies of stdlib and sphinx doc texlive-latex-extra texlive-fonts-recommended texlive-xetex latexmk \ xindy python3-pip python3-setuptools python3-pexpect python3-bs4 \ + fonts-freefont-otf \ # Dependencies of source-doc and coq-makefile texlive-science tipa # More dependencies of the sphinx doc -RUN pip3 install sphinx==1.8.0 sphinx_rtd_theme==0.2.5b2 \ - antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 +RUN pip3 install sphinx==2.3.1 sphinx_rtd_theme==0.4.3 \ + antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.2 # We need to install OPAM 2.0 manually for now. RUN wget https://github.com/ocaml/opam/releases/download/2.0.6/opam-2.0.6-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam @@ -57,7 +58,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ # EDGE switch ENV COMPILER_EDGE="4.10.0" \ - BASE_OPAM_EDGE="dune.2.5.0 dune-release.1.3.3 ocamlformat.0.14.0" + BASE_OPAM_EDGE="dune.2.5.1 dune-release.1.3.3 ocamlformat.0.14.2" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/user-overlays/10185-SkySkimmer-instance-no-bang.sh b/dev/ci/user-overlays/10185-SkySkimmer-instance-no-bang.sh deleted file mode 100644 index c584438b21..0000000000 --- a/dev/ci/user-overlays/10185-SkySkimmer-instance-no-bang.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10185" ] || [ "$CI_BRANCH" = "instance-no-bang" ]; then - - quickchick_CI_REF=instance-no-bang - quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick - -fi diff --git a/dev/ci/user-overlays/11566-ejgallego-exninfo+coercion.sh b/dev/ci/user-overlays/11566-ejgallego-exninfo+coercion.sh new file mode 100644 index 0000000000..05192facbe --- /dev/null +++ b/dev/ci/user-overlays/11566-ejgallego-exninfo+coercion.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11566" ] || [ "$CI_BRANCH" = "exninfo+coercion" ]; then + + mtac2_CI_REF=exninfo+coercion + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + +fi diff --git a/dev/ci/user-overlays/11703-herbelin-master+turning-numTok-into-a-numeral-API.sh b/dev/ci/user-overlays/11703-herbelin-master+turning-numTok-into-a-numeral-API.sh deleted file mode 100644 index 8a734feada..0000000000 --- a/dev/ci/user-overlays/11703-herbelin-master+turning-numTok-into-a-numeral-API.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11703" ] || [ "$CI_BRANCH" = "master+turning-numTok-into-a-numeral-API" ]; then - - quickchick_CI_REF=master+adapting-numTok-new-api-pr11703 - quickchick_CI_GITURL=https://github.com/herbelin/QuickChick - -fi diff --git a/dev/ci/user-overlays/11731-ejgallego-proof+more_naming_unif.sh b/dev/ci/user-overlays/11731-ejgallego-proof+more_naming_unif.sh deleted file mode 100644 index 6928925e54..0000000000 --- a/dev/ci/user-overlays/11731-ejgallego-proof+more_naming_unif.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11731" ] || [ "$CI_BRANCH" = "proof+more_naming_unif" ]; then - - equations_CI_REF=proof+more_naming_unif - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - rewriter_CI_REF=proof+more_naming_unif - rewriter_CI_GITURL=https://github.com/ejgallego/rewriter - - elpi_CI_REF=proof+more_naming_unif - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -fi diff --git a/dev/ci/user-overlays/11812-ppedrot-export-hint-globality.sh b/dev/ci/user-overlays/11812-ppedrot-export-hint-globality.sh deleted file mode 100644 index 8dae29adb6..0000000000 --- a/dev/ci/user-overlays/11812-ppedrot-export-hint-globality.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11812" ] || [ "$CI_BRANCH" = "export-hint-globality" ]; then - - equations_CI_REF="export-hint-globality" - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - fiat_parsers_CI_REF="export-hint-globality" - fiat_parsers_CI_GITURL=https://github.com/ppedrot/fiat - -fi diff --git a/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh b/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh deleted file mode 100644 index e3a8eb07f3..0000000000 --- a/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11818" ] || [ "$CI_BRANCH" = "proof+remove_special_case_first_declaration_in_mutual" ]; then - - metacoq_CI_REF=proof+remove_special_case_first_declaration_in_mutual - metacoq_CI_GITURL=https://github.com/ejgallego/metacoq - - elpi_CI_REF=proof+remove_special_case_first_declaration_in_mutual - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - paramcoq_CI_REF=proof+remove_special_case_first_declaration_in_mutual - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - - equations_CI_REF=proof+remove_special_case_first_declaration_in_mutual - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh b/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh deleted file mode 100644 index 4170799be7..0000000000 --- a/dev/ci/user-overlays/11820-SkySkimmer-partial-import.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11820" ] || [ "$CI_BRANCH" = "partial-import" ]; then - - elpi_CI_REF=partial-import - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - -fi diff --git a/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh b/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh deleted file mode 100644 index cd6b408813..0000000000 --- a/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh +++ /dev/null @@ -1,24 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11896" ] || [ "$CI_BRANCH" = "evar-inst-list" ]; then - - coqhammer_CI_REF="evar-inst-list" - coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer - - elpi_CI_REF="evar-inst-list" - elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi - - equations_CI_REF="evar-inst-list" - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - metacoq_CI_REF="evar-inst-list" - metacoq_CI_GITURL=https://github.com/ppedrot/metacoq - - mtac2_CI_REF="evar-inst-list" - mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 - - quickchick_CI_REF="evar-inst-list" - quickchick_CI_GITURL=https://github.com/ppedrot/QuickChick - - unicoq_CI_REF="evar-inst-list" - unicoq_CI_GITURL=https://github.com/ppedrot/unicoq - -fi diff --git a/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh b/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh deleted file mode 100644 index 6bee3c7bb6..0000000000 --- a/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12023" ] || [ "$CI_BRANCH" = "master+fixing-empty-Ltac-v-file" ]; then - - fiat_crypto_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file - fiat_crypto_CI_GITURL=https://github.com/herbelin/fiat-crypto - - mtac2_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file - mtac2_CI_GITURL=https://github.com/herbelin/Mtac2 - - metacoq_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file - metacoq_CI_GITURL=https://github.com/herbelin/template-coq - - unimath_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file - unimath_CI_GITURL=https://github.com/herbelin/UniMath - -fi diff --git a/dev/ci/user-overlays/12107-SkySkimmer-no-mod-univs.sh b/dev/ci/user-overlays/12107-SkySkimmer-no-mod-univs.sh deleted file mode 100644 index b5faabcfe1..0000000000 --- a/dev/ci/user-overlays/12107-SkySkimmer-no-mod-univs.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12107" ] || [ "$CI_BRANCH" = "no-mod-univs" ]; then - - elpi_CI_REF=no-mod-univs - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - -fi diff --git a/dev/ci/user-overlays/12227-ppedrot-refiner-rm-v82.sh b/dev/ci/user-overlays/12227-ppedrot-refiner-rm-v82.sh deleted file mode 100644 index 0f8daf418c..0000000000 --- a/dev/ci/user-overlays/12227-ppedrot-refiner-rm-v82.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12227" ] || [ "$CI_BRANCH" = "refiner-rm-v82" ]; then - - equations_CI_REF="refiner-rm-v82" - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/8855-herbelin-master+more-search-options.sh b/dev/ci/user-overlays/8855-herbelin-master+more-search-options.sh new file mode 100644 index 0000000000..3b3b20baf1 --- /dev/null +++ b/dev/ci/user-overlays/8855-herbelin-master+more-search-options.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "8855" ] || [ "$CI_BRANCH" = "master+more-search-options" ]; then + + coqhammer_CI_REF=master+adapt-pr8855-search-api + coqhammer_CI_GITURL=https://github.com/herbelin/coqhammer + + coq_dpdgraph_CI_REF=coq-master+adapt-pr8855-search-api + coq_dpdgraph_CI_GITURL=https://github.com/herbelin/coq-dpdgraph + +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 9498ab8bbb..ae4c6328b5 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,3 +1,5 @@ +## Changes between Coq 8.12 and Coq 8.13 + ## Changes between Coq 8.11 and Coq 8.12 ### Code formatting diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 340b66bbd0..da9f37f666 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -8,7 +8,7 @@ early enough in the process for this person to be known at that point in time. - [ ] Create a new issue to track the release process where you can copy-paste - the present checklist. + the present checklist from `dev/doc/release-process.md`. - [ ] Change the version name to the next major version and the magic numbers (see [#7008](https://github.com/coq/coq/pull/7008/files)). @@ -25,7 +25,10 @@ in time. the next branch point with the `--release` flag (see next section). - [ ] Put the corresponding alpha tag using `git tag -s`. The `VX.X+alpha` tag marks the first commit to be in `master` and not in the - branch of the previous version. + branch of the previous version. Note that this commit is the first commit + in the first PR merged in master, not the merge commit for that PR. + After tagging double check that `git describe` picks up + the tag you just made (if not, you tagged the wrong commit). - [ ] Create the `X.X+beta1` milestone if it did not already exist. - [ ] Decide the release calendar with the team (freeze date, beta date, final release date) and put this information in the milestone (using the diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index fb84155392..bfb25e72dd 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/807ca93fadd5197c2260490de0c76e500562dc05.tar.gz"; - sha256 = "10yq8bnls77fh3pk5chkkb1sv5lbdgyk1rr2v9xn71rr1k2x563p"; + url = "https://github.com/NixOS/nixpkgs/archive/17812e653d89c46d68b7b10e290b1c16758f4e47.tar.gz"; + sha256 = "1zcb70dyfqc8l2ywpbvxmpfshapdi0g365m3rhmwpagqg47pnyxs"; }) diff --git a/dev/tools/generate-release-changelog.sh b/dev/tools/generate-release-changelog.sh new file mode 100755 index 0000000000..5b2d749b66 --- /dev/null +++ b/dev/tools/generate-release-changelog.sh @@ -0,0 +1,92 @@ +#!/usr/bin/env bash + +set -e +set -o pipefail + +if [ $# != 1 ]; then + echo "Usage: $0 BRANCH" + exit +fi + +branch=$1 + +# Set SLOW_CONF to have the confirmation output wait for a newline +# Emacs doesn't send characters until the RET so we can't quick_conf +if [ -z ${SLOW_CONF+x} ] || [ -n "$INSIDE_EMACS" ]; then + quick_conf="-n 1" +else + quick_conf="" +fi + +ask_confirmation() { + read -p "Continue anyway? [y/N] " $quick_conf -r + echo + if [[ ! $REPLY =~ ^[Yy]$ ]]; then + exit 1 + fi +} + +if ! git diff --quiet; then + echo "Warning: current tree is dirty." + ask_confirmation +fi + +remote=$(git config --get "branch.${branch}.remote") + +if [ -z "$remote" ]; then + echo "Warning: branch $branch has no associated remote." + ask_confirmation +else + + if [ "$remote" != $(git config --get "branch.master.remote") ]; then + echo "Warning: branch master and branch $branch do not have the same remote." + ask_confirmation + fi + + official_remote_git_url="git@github.com:coq/coq" + official_remote_https_url="github.com/coq/coq" + remote_url=$(git remote get-url "$remote" --all) + + if [ "$remote_url" != "${official_remote_git_url}" ] && \ + [ "$remote_url" != "${official_remote_git_url}.git" ] && \ + [ "$remote_url" != "https://${official_remote_https_url}" ] && \ + [ "$remote_url" != "https://${official_remote_https_url}.git" ] && \ + [[ "$remote_url" != "https://"*"@${official_remote_https_url}" ]] && \ + [[ "$remote_url" != "https://"*"@${official_remote_https_url}.git" ]] ; then + echo "Warning: remote $remote does not point to the official Coq repo," + echo "that is $official_remote_git_url" + echo "It points to $remote_url instead." + ask_confirmation + fi + + git fetch "$remote" + + if [ $(git rev-parse master) != $(git rev-parse "${remote}/master") ]; then + echo "Warning: branch master is not up-to-date with ${remote}/master." + ask_confirmation + fi + + if [ $(git rev-parse "$branch") != $(git rev-parse "${remote}/${branch}") ]; then + echo "Warning: branch ${branch} is not up-to-date with ${remote}/${branch}." + ask_confirmation + fi + +fi + +git checkout $branch --detach +changelog_entries_with_title=$(ls doc/changelog/*/*.rst) +changelog_entries_no_title=$(echo "$changelog_entries_with_title" | grep -v "00000-title.rst") +git checkout master +for f in $changelog_entries_with_title; do + if [ -f "$f" ]; then + cat "$f" >> released.rst + else + echo "Warning: $f is missing in master branch." + fi +done +for f in $changelog_entries_no_title; do + if [ -f "$f" ]; then + git rm "$f" + fi +done +echo "Changelog written in released.rst. Move its content to a new section in doc/sphinx/changes.rst." diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index ce64aebdc7..82e4bd1e1e 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -49,10 +49,26 @@ ask_confirmation() { fi } +curl_paginate_array() { + # as per https://developer.github.com/v3/guides/traversing-with-pagination/#changing-the-number-of-items-received, GitHub will never give us more than 100 + url="$1?per_page=100" + # we keep fetching pages until the response is below the per-page limit (possibly 0 elements) + page=1 + while true; do + response="$(curl -s "${url}&page=${page}")" + echo "${response}" + if [ "$(jq 'length' <<< "$response")" -lt 100 ]; then # done + break + fi + page=$(($page + 1)) + done | jq '[.[]]' # we concatenate the arrays +} + check_util jq check_util curl check_util git check_util gpg +check_util grep # command line parsing @@ -70,6 +86,8 @@ fi # Fetching PR metadata +# The main API call returns a dict/object, not an array, so we don't +# bother paginating PRDATA=$(curl -s "$API/pulls/$PR") TITLE=$(echo "$PRDATA" | jq -r '.title') @@ -203,7 +221,7 @@ fi # Generate commit message info "Fetching review data" -reviews=$(curl -s "$API/pulls/$PR/reviews") +reviews=$(curl_paginate_array "$API/pulls/$PR/reviews") msg="Merge PR #$PR: $TITLE" has_state() { diff --git a/doc/README.md b/doc/README.md index e749bcf5d1..8e1bc85c49 100644 --- a/doc/README.md +++ b/doc/README.md @@ -30,12 +30,12 @@ To produce the complete documentation in HTML, you will need Coq dependencies listed in [`INSTALL.md`](../INSTALL.md). Additionally, the Sphinx-based reference manual requires Python 3, and the following Python packages: - - sphinx >= 1.8.0 - - sphinx_rtd_theme >= 0.2.5b2 + - sphinx >= 2.3.1 + - sphinx_rtd_theme >= 0.4.3 - beautifulsoup4 >= 4.0.6 - antlr4-python3-runtime >= 4.7.1 - pexpect >= 4.2.1 - - sphinxcontrib-bibtex >= 0.4.0 + - sphinxcontrib-bibtex >= 0.4.2 To install them, you should first install pip and setuptools (for instance, with `apt install python3-pip python3-setuptools` on Debian / Ubuntu) then run: @@ -68,7 +68,7 @@ install them with: Or if you want to use less disk space: apt install texlive-latex-extra texlive-fonts-recommended texlive-xetex \ - latexmk xindy + latexmk xindy fonts-freefont-otf Compilation ----------- diff --git a/doc/changelog/02-specification-language/12323-master+fix12322-anomaly-implicit-binder-factorization.rst b/doc/changelog/02-specification-language/12323-master+fix12322-anomaly-implicit-binder-factorization.rst new file mode 100644 index 0000000000..e5ec865b15 --- /dev/null +++ b/doc/changelog/02-specification-language/12323-master+fix12322-anomaly-implicit-binder-factorization.rst @@ -0,0 +1,4 @@ +- **Fixed:** + Anomaly possibly raised when printing binders with implicit types + (`#12323 <https://github.com/coq/coq/pull/12323>`_, + by Hugo Herbelin; fixes `#12322 <https://github.com/coq/coq/pull/12322>`_). diff --git a/doc/changelog/04-tactics/12326-fix11761-functional-induction-throws-unrecoverable-error.rst b/doc/changelog/04-tactics/12326-fix11761-functional-induction-throws-unrecoverable-error.rst new file mode 100644 index 0000000000..2402321fad --- /dev/null +++ b/doc/changelog/04-tactics/12326-fix11761-functional-induction-throws-unrecoverable-error.rst @@ -0,0 +1,13 @@ +- **Fixed:** + Wrong type error in tactic :tacn:`functional induction`. + (`#12326 <https://github.com/coq/coq/pull/12326>`_, + by Pierre Courtieu, + fixes `#11761 <https://github.com/coq/coq/issues/11761>`_, + reported by Lasse Blaauwbroek). +- **Changed** + When the tactic :tacn:`functional induction` :n:`c__1 c__2 ... c__n` is used + with no parenthesis around :n:`c__1 c__2 ... c__n`, :n:`c__1 c__2 ... c__n` is now + read as one sinlge applicative term. In particular implicit + arguments should be omitted. Rare source of incompatibility + (`#12326 <https://github.com/coq/coq/pull/12326>`_, + by Pierre Courtieu). diff --git a/doc/changelog/05-tactic-language/11981-ltac2-eval-notations.rst b/doc/changelog/05-tactic-language/11981-ltac2-eval-notations.rst new file mode 100644 index 0000000000..2f8d92fae5 --- /dev/null +++ b/doc/changelog/05-tactic-language/11981-ltac2-eval-notations.rst @@ -0,0 +1,4 @@ +- **Added:** + Ltac2 notations for reductions in terms: :n:`eval @red_expr in @ltac2_term` + (`#11981 <https://github.com/coq/coq/pull/11981>`_, + by Michael Soegtrop). diff --git a/doc/changelog/06-ssreflect/8855-master+more-search-options.rst b/doc/changelog/06-ssreflect/8855-master+more-search-options.rst new file mode 100644 index 0000000000..2fdacfd82a --- /dev/null +++ b/doc/changelog/06-ssreflect/8855-master+more-search-options.rst @@ -0,0 +1,11 @@ +- **Changed:** The :cmd:`Search (ssreflect)` command that used to be + available when loading the `ssreflect` plugin has been moved to a + separate plugin that needs to be loaded separately: `ssrsearch` + (part of `#8855 <https://github.com/coq/coq/pull/8855>`_, fixes + `#12253 <https://github.com/coq/coq/issues/12253>`_, by Théo + Zimmermann). + +- **Deprecated:** :cmd:`Search (ssreflect)` (available through + `Require ssrsearch.`) in favor of the `headconcl:` clause of + :cmd:`Search` (part of `#8855 + <https://github.com/coq/coq/pull/8855>`_, by Théo Zimmermann). diff --git a/doc/changelog/07-commands-and-options/12358-redirect_printing_params.rst b/doc/changelog/07-commands-and-options/12358-redirect_printing_params.rst new file mode 100644 index 0000000000..5b35090d7e --- /dev/null +++ b/doc/changelog/07-commands-and-options/12358-redirect_printing_params.rst @@ -0,0 +1,5 @@ +- **Changed:** + :cmd:Redirect now obeys the :opt:`Printing Width` and + :opt:`Printing Depth` flags. + (`#12358 <https://github.com/coq/coq/pull/12358>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/07-commands-and-options/8855-master+more-search-options.rst b/doc/changelog/07-commands-and-options/8855-master+more-search-options.rst new file mode 100644 index 0000000000..cd993bf356 --- /dev/null +++ b/doc/changelog/07-commands-and-options/8855-master+more-search-options.rst @@ -0,0 +1,9 @@ +- **Added:** Support for new clauses `hyp:`, `headhyp:`, `concl:`, + `headconcl:`, `head:` and `is:` in :cmd:`Search`. Support for + complex search queries combining disjunctions, conjunctions and + negations (`#8855 <https://github.com/coq/coq/pull/8855>`_, by Hugo + Herbelin, with ideas from Cyril Cohen and help from Théo + Zimmermann). +- **Deprecated:** :cmd:`SearchHead` in favor of the new `headconcl:` + clause of :cmd:`Search` (part of `#8855 + <https://github.com/coq/coq/pull/8855>`_, by Théo Zimmermann). diff --git a/doc/changelog/08-tools/12368-fix-missing-newline-time-file-maker.rst b/doc/changelog/08-tools/12368-fix-missing-newline-time-file-maker.rst new file mode 100644 index 0000000000..8a43f5af94 --- /dev/null +++ b/doc/changelog/08-tools/12368-fix-missing-newline-time-file-maker.rst @@ -0,0 +1,4 @@ +- **Changed:** + The pretty-timed scripts and targets now print a newline at the end of their + tables, rather than creating text with no trailing newline (`#12368 + <https://github.com/coq/coq/pull/12368>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12287-zero-of-Q.rst b/doc/changelog/10-standard-library/12287-zero-of-Q.rst new file mode 100644 index 0000000000..ba2c74379b --- /dev/null +++ b/doc/changelog/10-standard-library/12287-zero-of-Q.rst @@ -0,0 +1,4 @@ +- **Changed:** + Replace `CRzero` and `CRone` by `CR_of_Q 0` and `CR_of_Q 1` in `ConstructiveReals` + (`#12287 <https://github.com/coq/coq/pull/12287>`_, + by Vincent Semeria). diff --git a/doc/changelog/10-standard-library/12288-constructive-experimental.rst b/doc/changelog/10-standard-library/12288-constructive-experimental.rst new file mode 100644 index 0000000000..ec9b66bd7a --- /dev/null +++ b/doc/changelog/10-standard-library/12288-constructive-experimental.rst @@ -0,0 +1,7 @@ +- **Changed:** + Split files `ConstructiveMinMax` and `ConstructivePower`. + + .. warning:: The constructive reals modules are marked as experimental. + + (`#12288 <https://github.com/coq/coq/pull/12288>`_, + by Vincent Semeria). diff --git a/doc/changelog/11-infrastructure-and-dependencies/12224-gdef_alias.rst b/doc/changelog/11-infrastructure-and-dependencies/12224-gdef_alias.rst new file mode 100644 index 0000000000..35a618ea8d --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/12224-gdef_alias.rst @@ -0,0 +1,6 @@ +- **Changed:** + Minimal versions of dependencies for building the reference manual: + now requires Sphinx 2.3.1+, sphinx_rtd_theme 0.4.3+ and + sphinxcontrib-bibtex 0.4.2+ + (`#12224 <https://github.com/coq/coq/pull/12224>`_, + by Jim Fehrle and Théo Zimmermann). diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index e20469bb8b..f91874d74d 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -359,11 +359,14 @@ In addition to the objects and directives above, the ``coqrst`` Sphinx plugin de and reference its tokens using ``:token:`…```. ``:gdef:`` Marks the definition of a glossary term inline in the text. Matching :term:`XXX` - constructs will link to it. The term will also appear in the Glossary Index. + constructs will link to it. Use the form :gdef:`text <term>` to display "text" + for the definition of "term", such as when "term" must be capitalized or plural + for grammatical reasons. The term will also appear in the Glossary Index. - Example:: + Examples:: A :gdef:`prime` number is divisible only by itself and 1. + :gdef:`Composite <composite>` numbers are the non-prime numbers. Common mistakes =============== diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index b593b0cef1..5febfdc325 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -1,437 +1,5 @@ -.. _canonicalstructures: +:orphan: -Canonical Structures -====================== - -:Authors: Assia Mahboubi and Enrico Tassi - -This chapter explains the basics of canonical structures and how they can be used -to overload notations and build a hierarchy of algebraic structures. The -examples are taken from :cite:`CSwcu`. We invite the interested reader to refer -to this paper for all the details that are omitted here for brevity. The -interested reader shall also find in :cite:`CSlessadhoc` a detailed description -of another, complementary, use of canonical structures: advanced proof search. -This latter papers also presents many techniques one can employ to tune the -inference of canonical structures. - - -Notation overloading -------------------------- - -We build an infix notation == for a comparison predicate. Such -notation will be overloaded, and its meaning will depend on the types -of the terms that are compared. - -.. coqtop:: all - - Module EQ. - Record class (T : Type) := Class { cmp : T -> T -> Prop }. - Structure type := Pack { obj : Type; class_of : class obj }. - Definition op (e : type) : obj e -> obj e -> Prop := - let 'Pack _ (Class _ the_cmp) := e in the_cmp. - Check op. - Arguments op {e} x y : simpl never. - Arguments Class {T} cmp. - Module theory. - Notation "x == y" := (op x y) (at level 70). - End theory. - End EQ. - -We use Coq modules as namespaces. This allows us to follow the same -pattern and naming convention for the rest of the chapter. The base -namespace contains the definitions of the algebraic structure. To -keep the example small, the algebraic structure ``EQ.type`` we are -defining is very simplistic, and characterizes terms on which a binary -relation is defined, without requiring such relation to validate any -property. The inner theory module contains the overloaded notation ``==`` -and will eventually contain lemmas holding all the instances of the -algebraic structure (in this case there are no lemmas). - -Note that in practice the user may want to declare ``EQ.obj`` as a -coercion, but we will not do that here. - -The following line tests that, when we assume a type ``e`` that is in -theEQ class, we can relate two of its objects with ``==``. - -.. coqtop:: all - - Import EQ.theory. - Check forall (e : EQ.type) (a b : EQ.obj e), a == b. - -Still, no concrete type is in the ``EQ`` class. - -.. coqtop:: all - - Fail Check 3 == 3. - -We amend that by equipping ``nat`` with a comparison relation. - -.. coqtop:: all - - Definition nat_eq (x y : nat) := Nat.compare x y = Eq. - Definition nat_EQcl : EQ.class nat := EQ.Class nat_eq. - Canonical Structure nat_EQty : EQ.type := EQ.Pack nat nat_EQcl. - Check 3 == 3. - Eval compute in 3 == 4. - -This last test shows that |Coq| is now not only able to type check ``3 == 3``, -but also that the infix relation was bound to the ``nat_eq`` relation. -This relation is selected whenever ``==`` is used on terms of type nat. -This can be read in the line declaring the canonical structure -``nat_EQty``, where the first argument to ``Pack`` is the key and its second -argument a group of canonical values associated to the key. In this -case we associate to nat only one canonical value (since its class, -``nat_EQcl`` has just one member). The use of the projection ``op`` requires -its argument to be in the class ``EQ``, and uses such a member (function) -to actually compare its arguments. - -Similarly, we could equip any other type with a comparison relation, -and use the ``==`` notation on terms of this type. - - -Derived Canonical Structures -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We know how to use ``==`` on base types, like ``nat``, ``bool``, ``Z``. Here we show -how to deal with type constructors, i.e. how to make the following -example work: - - -.. coqtop:: all - - Fail Check forall (e : EQ.type) (a b : EQ.obj e), (a, b) == (a, b). - -The error message is telling that |Coq| has no idea on how to compare -pairs of objects. The following construction is telling Coq exactly -how to do that. - -.. coqtop:: all - - Definition pair_eq (e1 e2 : EQ.type) (x y : EQ.obj e1 * EQ.obj e2) := - fst x == fst y /\ snd x == snd y. - - Definition pair_EQcl e1 e2 := EQ.Class (pair_eq e1 e2). - - Canonical Structure pair_EQty (e1 e2 : EQ.type) : EQ.type := - EQ.Pack (EQ.obj e1 * EQ.obj e2) (pair_EQcl e1 e2). - - Check forall (e : EQ.type) (a b : EQ.obj e), (a, b) == (a, b). - - Check forall n m : nat, (3, 4) == (n, m). - -Thanks to the ``pair_EQty`` declaration, |Coq| is able to build a comparison -relation for pairs whenever it is able to build a comparison relation -for each component of the pair. The declaration associates to the key ``*`` -(the type constructor of pairs) the canonical comparison -relation ``pair_eq`` whenever the type constructor ``*`` is applied to two -types being themselves in the ``EQ`` class. - -Hierarchy of structures ----------------------------- - -To get to an interesting example we need another base class to be -available. We choose the class of types that are equipped with an -order relation, to which we associate the infix ``<=`` notation. - -.. coqtop:: all - - Module LE. - - Record class T := Class { cmp : T -> T -> Prop }. - - Structure type := Pack { obj : Type; class_of : class obj }. - - Definition op (e : type) : obj e -> obj e -> Prop := - let 'Pack _ (Class _ f) := e in f. - - Arguments op {_} x y : simpl never. - - Arguments Class {T} cmp. - - Module theory. - - Notation "x <= y" := (op x y) (at level 70). - - End theory. - - End LE. - -As before we register a canonical ``LE`` class for ``nat``. - -.. coqtop:: all - - Import LE.theory. - - Definition nat_le x y := Nat.compare x y <> Gt. - - Definition nat_LEcl : LE.class nat := LE.Class nat_le. - - Canonical Structure nat_LEty : LE.type := LE.Pack nat nat_LEcl. - -And we enable |Coq| to relate pair of terms with ``<=``. - -.. coqtop:: all - - Definition pair_le e1 e2 (x y : LE.obj e1 * LE.obj e2) := - fst x <= fst y /\ snd x <= snd y. - - Definition pair_LEcl e1 e2 := LE.Class (pair_le e1 e2). - - Canonical Structure pair_LEty (e1 e2 : LE.type) : LE.type := - LE.Pack (LE.obj e1 * LE.obj e2) (pair_LEcl e1 e2). - - Check (3,4,5) <= (3,4,5). - -At the current stage we can use ``==`` and ``<=`` on concrete types, like -tuples of natural numbers, but we can’t develop an algebraic theory -over the types that are equipped with both relations. - -.. coqtop:: all - - Check 2 <= 3 /\ 2 == 2. - - Fail Check forall (e : EQ.type) (x y : EQ.obj e), x <= y -> y <= x -> x == y. - - Fail Check forall (e : LE.type) (x y : LE.obj e), x <= y -> y <= x -> x == y. - -We need to define a new class that inherits from both ``EQ`` and ``LE``. - - -.. coqtop:: all - - Module LEQ. - - Record mixin (e : EQ.type) (le : EQ.obj e -> EQ.obj e -> Prop) := - Mixin { compat : forall x y : EQ.obj e, le x y /\ le y x <-> x == y }. - - Record class T := Class { - EQ_class : EQ.class T; - LE_class : LE.class T; - extra : mixin (EQ.Pack T EQ_class) (LE.cmp T LE_class) }. - - Structure type := _Pack { obj : Type; #[canonical(false)] class_of : class obj }. - - Arguments Mixin {e le} _. - - Arguments Class {T} _ _ _. - -The mixin component of the ``LEQ`` class contains all the extra content we -are adding to ``EQ`` and ``LE``. In particular it contains the requirement -that the two relations we are combining are compatible. - -The `class_of` projection of the `type` structure is annotated as *not canonical*; -it plays no role in the search for instances. - -Unfortunately there is still an obstacle to developing the algebraic -theory of this new class. - -.. coqtop:: all - - Module theory. - - Fail Check forall (le : type) (n m : obj le), n <= m -> n <= m -> n == m. - - -The problem is that the two classes ``LE`` and ``LEQ`` are not yet related by -a subclass relation. In other words |Coq| does not see that an object of -the ``LEQ`` class is also an object of the ``LE`` class. - -The following two constructions tell |Coq| how to canonically build the -``LE.type`` and ``EQ.type`` structure given an ``LEQ.type`` structure on the same -type. - -.. coqtop:: all - - Definition to_EQ (e : type) : EQ.type := - EQ.Pack (obj e) (EQ_class _ (class_of e)). - - Canonical Structure to_EQ. - - Definition to_LE (e : type) : LE.type := - LE.Pack (obj e) (LE_class _ (class_of e)). - - Canonical Structure to_LE. - -We can now formulate out first theorem on the objects of the ``LEQ`` -structure. - -.. coqtop:: all - - Lemma lele_eq (e : type) (x y : obj e) : x <= y -> y <= x -> x == y. - - now intros; apply (compat _ _ (extra _ (class_of e)) x y); split. - - Qed. - - Arguments lele_eq {e} x y _ _. - - End theory. - - End LEQ. - - Import LEQ.theory. - - Check lele_eq. - -Of course one would like to apply results proved in the algebraic -setting to any concrete instate of the algebraic structure. - -.. coqtop:: all - - Example test_algebraic (n m : nat) : n <= m -> m <= n -> n == m. - - Fail apply (lele_eq n m). - - Abort. - - Example test_algebraic2 (l1 l2 : LEQ.type) (n m : LEQ.obj l1 * LEQ.obj l2) : - n <= m -> m <= n -> n == m. - - Fail apply (lele_eq n m). - - Abort. - -Again one has to tell |Coq| that the type ``nat`` is in the ``LEQ`` class, and -how the type constructor ``*`` interacts with the ``LEQ`` class. In the -following proofs are omitted for brevity. - -.. coqtop:: all - - Lemma nat_LEQ_compat (n m : nat) : n <= m /\ m <= n <-> n == m. - - Admitted. - - Definition nat_LEQmx := LEQ.Mixin nat_LEQ_compat. - - Lemma pair_LEQ_compat (l1 l2 : LEQ.type) (n m : LEQ.obj l1 * LEQ.obj l2) : - n <= m /\ m <= n <-> n == m. - - Admitted. - - Definition pair_LEQmx l1 l2 := LEQ.Mixin (pair_LEQ_compat l1 l2). - -The following script registers an ``LEQ`` class for ``nat`` and for the type -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 - - Module Add_instance_attempt. - - Canonical Structure nat_LEQty : LEQ.type := - LEQ._Pack nat (LEQ.Class nat_EQcl nat_LEcl nat_LEQmx). - - Canonical Structure pair_LEQty (l1 l2 : LEQ.type) : LEQ.type := - LEQ._Pack (LEQ.obj l1 * LEQ.obj l2) - (LEQ.Class - (EQ.class_of (pair_EQty (to_EQ l1) (to_EQ l2))) - (LE.class_of (pair_LEty (to_LE l1) (to_LE l2))) - (pair_LEQmx l1 l2)). - - Example test_algebraic (n m : nat) : n <= m -> m <= n -> n == m. - - now apply (lele_eq n m). - - Qed. - - Example test_algebraic2 (n m : nat * nat) : n <= m -> m <= n -> n == m. - - now apply (lele_eq n m). Qed. - - End Add_instance_attempt. - -Note that no direct proof of ``n <= m -> m <= n -> n == m`` is provided by -the user for ``n`` and m of type ``nat * nat``. What the user provides is a -proof of this statement for ``n`` and ``m`` of type ``nat`` and a proof that the -pair constructor preserves this property. The combination of these two -facts is a simple form of proof search that |Coq| performs automatically -while inferring canonical structures. - -Compact declaration of Canonical Structures -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We need some infrastructure for that. - -.. coqtop:: all - - Require Import Strings.String. - - Module infrastructure. - - Inductive phantom {T : Type} (t : T) : Type := Phantom. - - Definition unify {T1 T2} (t1 : T1) (t2 : T2) (s : option string) := - phantom t1 -> phantom t2. - - Definition id {T} {t : T} (x : phantom t) := x. - - Notation "[find v | t1 ~ t2 ] p" := (fun v (_ : unify t1 t2 None) => p) - (at level 50, v ident, only parsing). - - Notation "[find v | t1 ~ t2 | s ] p" := (fun v (_ : unify t1 t2 (Some s)) => p) - (at level 50, v ident, only parsing). - - Notation "'Error : t : s" := (unify _ t (Some s)) - (at level 50, format "''Error' : t : s"). - - Open Scope string_scope. - - End infrastructure. - -To explain the notation ``[find v | t1 ~ t2]`` let us pick one of its -instances: ``[find e | EQ.obj e ~ T | "is not an EQ.type" ]``. It should be -read as: “find a class e such that its objects have type T or fail -with message "T is not an EQ.type"”. - -The other utilities are used to ask |Coq| to solve a specific unification -problem, that will in turn require the inference of some canonical structures. -They are explained in more details in :cite:`CSwcu`. - -We now have all we need to create a compact “packager” to declare -instances of the ``LEQ`` class. - -.. coqtop:: all - - Import infrastructure. - - Definition packager T e0 le0 (m0 : LEQ.mixin e0 le0) := - [find e | EQ.obj e ~ T | "is not an EQ.type" ] - [find o | LE.obj o ~ T | "is not an LE.type" ] - [find ce | EQ.class_of e ~ ce ] - [find co | LE.class_of o ~ co ] - [find m | m ~ m0 | "is not the right mixin" ] - LEQ._Pack T (LEQ.Class ce co m). - - Notation Pack T m := (packager T _ _ m _ id _ id _ id _ id _ id). - -The object ``Pack`` takes a type ``T`` (the key) and a mixin ``m``. It infers all -the other pieces of the class ``LEQ`` and declares them as canonical -values associated to the ``T`` key. All in all, the only new piece of -information we add in the ``LEQ`` class is the mixin, all the rest is -already canonical for ``T`` and hence can be inferred by |Coq|. - -``Pack`` is a notation, hence it is not type checked at the time of its -declaration. It will be type checked when it is used, an in that case ``T`` is -going to be a concrete type. The odd arguments ``_`` and ``id`` we pass to the -packager represent respectively the classes to be inferred (like ``e``, ``o``, -etc) and a token (``id``) to force their inference. Again, for all the details -the reader can refer to :cite:`CSwcu`. - -The declaration of canonical instances can now be way more compact: - -.. coqtop:: all - - Canonical Structure nat_LEQty := Eval hnf in Pack nat nat_LEQmx. - - Canonical Structure pair_LEQty (l1 l2 : LEQ.type) := - Eval hnf in Pack (LEQ.obj l1 * LEQ.obj l2) (pair_LEQmx l1 l2). - -Error messages are also quite intelligible (if one skips to the end of -the message). - -.. coqtop:: all - - Fail Canonical Structure err := Eval hnf in Pack bool nat_LEQmx. +.. raw:: html + <meta http-equiv="refresh" content="0;URL=../language/extensions/canonical.html"> diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index 8ec51e45ba..f17c4dce17 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -1,617 +1,5 @@ -.. _extendedpatternmatching: +:orphan: -Extended pattern matching -========================= +.. raw:: html -:Authors: Cristina Cornes and Hugo Herbelin - -This section describes the full form of pattern matching in |Coq| terms. - -.. |rhs| replace:: right hand sides - -Patterns --------- - -The full syntax of :g:`match` is presented in section :ref:`term`. -Identifiers in patterns are either constructor names or variables. Any -identifier that is not the constructor of an inductive or co-inductive -type is considered to be a variable. A variable name cannot occur more -than once in a given pattern. It is recommended to start variable -names by a lowercase letter. - -If a pattern has the form ``c x`` where ``c`` is a constructor symbol and x -is a linear vector of (distinct) variables, it is called *simple*: it -is the kind of pattern recognized by the basic version of match. On -the opposite, if it is a variable ``x`` or has the form ``c p`` with ``p`` not -only made of variables, the pattern is called *nested*. - -A variable pattern matches any value, and the identifier is bound to -that value. The pattern “``_``” (called “don't care” or “wildcard” symbol) -also matches any value, but does not bind anything. It may occur an -arbitrary number of times in a pattern. Alias patterns written -:n:`(@pattern as @ident)` are also accepted. This pattern matches the -same values as :token:`pattern` does and :token:`ident` is bound to the matched -value. A pattern of the form :n:`@pattern | @pattern` is called disjunctive. A -list of patterns separated with commas is also considered as a pattern -and is called *multiple pattern*. However multiple patterns can only -occur at the root of pattern matching equations. Disjunctions of -*multiple patterns* are allowed though. - -Since extended ``match`` expressions are compiled into the primitive ones, -the expressiveness of the theory remains the same. Once parsing has finished -only simple patterns remain. The original nesting of the ``match`` expressions -is recovered at printing time. An easy way to see the result -of the expansion is to toggle off the nesting performed at printing -(use here :flag:`Printing Matching`), then by printing the term with :cmd:`Print` -if the term is a constant, or using the command :cmd:`Check`. - -The extended ``match`` still accepts an optional *elimination predicate* -given after the keyword ``return``. Given a pattern matching expression, -if all the right-hand-sides of ``=>`` have the same -type, then this type can be sometimes synthesized, and so we can omit -the return part. Otherwise the predicate after return has to be -provided, like for the basicmatch. - -Let us illustrate through examples the different aspects of extended -pattern matching. Consider for example the function that computes the -maximum of two natural numbers. We can write it in primitive syntax -by: - -.. coqtop:: in - - Fixpoint max (n m:nat) {struct m} : nat := - match n with - | O => m - | S n' => match m with - | O => S n' - | S m' => S (max n' m') - end - end. - -Multiple patterns ------------------ - -Using multiple patterns in the definition of ``max`` lets us write: - -.. coqtop:: in reset - - Fixpoint max (n m:nat) {struct m} : nat := - match n, m with - | O, _ => m - | S n', O => S n' - | S n', S m' => S (max n' m') - end. - -which will be compiled into the previous form. - -The pattern matching compilation strategy examines patterns from left -to right. A match expression is generated **only** when there is at least -one constructor in the column of patterns. E.g. the following example -does not build a match expression. - -.. coqtop:: all - - Check (fun x:nat => match x return nat with - | y => y - end). - - -Aliasing subpatterns --------------------- - -We can also use :n:`as @ident` to associate a name to a sub-pattern: - -.. coqtop:: in reset - - Fixpoint max (n m:nat) {struct n} : nat := - match n, m with - | O, _ => m - | S n' as p, O => p - | S n', S m' => S (max n' m') - end. - -Nested patterns ---------------- - -Here is now an example of nested patterns: - -.. coqtop:: in - - Fixpoint even (n:nat) : bool := - match n with - | O => true - | S O => false - | S (S n') => even n' - end. - -This is compiled into: - -.. coqtop:: all - - Unset Printing Matching. - Print even. - -.. coqtop:: none - - Set Printing Matching. - -In the previous examples patterns do not conflict with, but sometimes -it is comfortable to write patterns that admit a non trivial -superposition. Consider the boolean function :g:`lef` that given two -natural numbers yields :g:`true` if the first one is less or equal than the -second one and :g:`false` otherwise. We can write it as follows: - -.. coqtop:: in - - Fixpoint lef (n m:nat) {struct m} : bool := - match n, m with - | O, x => true - | x, O => false - | S n, S m => lef n m - end. - -Note that the first and the second multiple pattern overlap because -the couple of values ``O O`` matches both. Thus, what is the result of the -function on those values? To eliminate ambiguity we use the *textual -priority rule:* we consider patterns to be ordered from top to bottom. A -value is matched by the pattern at the ith row if and only if it is -not matched by some pattern from a previous row. Thus in the example, ``O O`` -is matched by the first pattern, and so :g:`(lef O O)` yields true. - -Another way to write this function is: - -.. coqtop:: in reset - - Fixpoint lef (n m:nat) {struct m} : bool := - match n, m with - | O, x => true - | S n, S m => lef n m - | _, _ => false - end. - -Here the last pattern superposes with the first two. Because of the -priority rule, the last pattern will be used only for values that do -not match neither the first nor the second one. - -Terms with useless patterns are not accepted by the system. Here is an -example: - -.. coqtop:: all - - Fail Check (fun x:nat => - match x with - | O => true - | S _ => false - | x => true - end). - - -Disjunctive patterns --------------------- - -Multiple patterns that share the same right-hand-side can be -factorized using the notation :n:`{+| {+, @pattern } }`. For -instance, :g:`max` can be rewritten as follows: - -.. coqtop:: in reset - - Fixpoint max (n m:nat) {struct m} : nat := - match n, m with - | S n', S m' => S (max n' m') - | 0, p | p, 0 => p - end. - -Similarly, factorization of (not necessarily multiple) patterns that -share the same variables is possible by using the notation :n:`{+| @pattern}`. -Here is an example: - -.. coqtop:: in - - Definition filter_2_4 (n:nat) : nat := - match n with - | 2 as m | 4 as m => m - | _ => 0 - end. - - -Nested disjunctive patterns are allowed, inside parentheses, with the -notation :n:`({+| @pattern})`, as in: - -.. coqtop:: in - - Definition filter_some_square_corners (p:nat*nat) : nat*nat := - match p with - | ((2 as m | 4 as m), (3 as n | 5 as n)) => (m,n) - | _ => (0,0) - end. - -About patterns of parametric types ----------------------------------- - -Parameters in patterns -~~~~~~~~~~~~~~~~~~~~~~ - -When matching objects of a parametric type, parameters do not bind in -patterns. They must be substituted by “``_``”. Consider for example the -type of polymorphic lists: - -.. coqtop:: in - - Inductive List (A:Set) : Set := - | nil : List A - | cons : A -> List A -> List A. - -We can check the function *tail*: - -.. coqtop:: all - - Check - (fun l:List nat => - match l with - | nil _ => nil nat - | cons _ _ l' => l' - end). - -When we use parameters in patterns there is an error message: - -.. coqtop:: all - - Fail Check - (fun l:List nat => - match l with - | nil A => nil nat - | cons A _ l' => l' - end). - -.. flag:: Asymmetric Patterns - - This flag (off by default) removes parameters from constructors in patterns: - -.. coqtop:: all - - Set Asymmetric Patterns. - Check (fun l:List nat => - match l with - | nil => nil _ - | cons _ l' => l' - end). - Unset Asymmetric Patterns. - -Implicit arguments in patterns ------------------------------- - -By default, implicit arguments are omitted in patterns. So we write: - -.. coqtop:: all - - Arguments nil {A}. - Arguments cons [A] _ _. - Check - (fun l:List nat => - match l with - | nil => nil - | cons _ l' => l' - end). - -But the possibility to use all the arguments is given by “``@``” implicit -explicitations (as for terms, see :ref:`explicit-applications`). - -.. coqtop:: all - - Check - (fun l:List nat => - match l with - | @nil _ => @nil nat - | @cons _ _ l' => l' - end). - - -.. _matching-dependent: - -Matching objects of dependent types ------------------------------------ - -The previous examples illustrate pattern matching on objects of non- -dependent types, but we can also use the expansion strategy to -destructure objects of dependent types. Consider the type :g:`listn` of -lists of a certain length: - -.. coqtop:: in reset - - Inductive listn : nat -> Set := - | niln : listn 0 - | consn : forall n:nat, nat -> listn n -> listn (S n). - - -Understanding dependencies in patterns --------------------------------------- - -We can define the function length over :g:`listn` by: - -.. coqdoc:: - - Definition length (n:nat) (l:listn n) := n. - -Just for illustrating pattern matching, we can define it by case -analysis: - -.. coqtop:: in - - Definition length (n:nat) (l:listn n) := - match l with - | niln => 0 - | consn n _ _ => S n - end. - -We can understand the meaning of this definition using the same -notions of usual pattern matching. - - -When the elimination predicate must be provided ------------------------------------------------ - -Dependent pattern matching -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The examples given so far do not need an explicit elimination -predicate because all the |rhs| have the same type and Coq -succeeds to synthesize it. Unfortunately when dealing with dependent -patterns it often happens that we need to write cases where the types -of the |rhs| are different instances of the elimination predicate. The -function :g:`concat` for :g:`listn` is an example where the branches have -different types and we need to provide the elimination predicate: - -.. coqtop:: in - - Fixpoint concat (n:nat) (l:listn n) (m:nat) (l':listn m) {struct l} : - listn (n + m) := - match l in listn n return listn (n + m) with - | niln => l' - | consn n' a y => consn (n' + m) a (concat n' y m l') - end. - -.. coqtop:: none - - Reset concat. - -The elimination predicate is :g:`fun (n:nat) (l:listn n) => listn (n+m)`. -In general if :g:`m` has type :g:`(I q1 … qr t1 … ts)` where :g:`q1, …, qr` -are parameters, the elimination predicate should be of the form :g:`fun y1 … ys x : (I q1 … qr y1 … ys ) => Q`. - -In the concrete syntax, it should be written : -``match m as x in (I _ … _ y1 … ys) return Q with … end``. -The variables which appear in the ``in`` and ``as`` clause are new and bounded -in the property :g:`Q` in the return clause. The parameters of the -inductive definitions should not be mentioned and are replaced by ``_``. - -Multiple dependent pattern matching -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Recall that a list of patterns is also a pattern. So, when we -destructure several terms at the same time and the branches have -different types we need to provide the elimination predicate for this -multiple pattern. It is done using the same scheme: each term may be -associated to an ``as`` clause and an ``in`` clause in order to introduce -a dependent product. - -For example, an equivalent definition for :g:`concat` (even though the -matching on the second term is trivial) would have been: - -.. coqtop:: in - - Fixpoint concat (n:nat) (l:listn n) (m:nat) (l':listn m) {struct l} : - listn (n + m) := - match l in listn n, l' return listn (n + m) with - | niln, x => x - | consn n' a y, x => consn (n' + m) a (concat n' y m x) - end. - -Even without real matching over the second term, this construction can -be used to keep types linked. If :g:`a` and :g:`b` are two :g:`listn` of the same -length, by writing - -.. coqtop:: in - - Check (fun n (a b: listn n) => - match a, b with - | niln, b0 => tt - | consn n' a y, bS => tt - end). - -we have a copy of :g:`b` in type :g:`listn 0` resp. :g:`listn (S n')`. - -.. _match-in-patterns: - -Patterns in ``in`` -~~~~~~~~~~~~~~~~~~ - -If the type of the matched term is more precise than an inductive -applied to variables, arguments of the inductive in the ``in`` branch can -be more complicated patterns than a variable. - -Moreover, constructors whose types do not follow the same pattern will -become impossible branches. In an impossible branch, you can answer -anything but False_rect unit has the advantage to be subterm of -anything. - -To be concrete: the ``tail`` function can be written: - -.. coqtop:: in - - Definition tail n (v: listn (S n)) := - match v in listn (S m) return listn m with - | niln => False_rect unit - | consn n' a y => y - end. - -and :g:`tail n v` will be subterm of :g:`v`. - -Using pattern matching to write proofs --------------------------------------- - -In all the previous examples the elimination predicate does not depend -on the object(s) matched. But it may depend and the typical case is -when we write a proof by induction or a function that yields an object -of a dependent type. An example of a proof written using ``match`` is given -in the description of the tactic :tacn:`refine`. - -For example, we can write the function :g:`buildlist` that given a natural -number :g:`n` builds a list of length :g:`n` containing zeros as follows: - -.. coqtop:: in - - Fixpoint buildlist (n:nat) : listn n := - match n return listn n with - | O => niln - | S n => consn n 0 (buildlist n) - end. - -We can also use multiple patterns. Consider the following definition -of the predicate less-equal :g:`Le`: - -.. coqtop:: in - - Inductive LE : nat -> nat -> Prop := - | LEO : forall n:nat, LE 0 n - | LES : forall n m:nat, LE n m -> LE (S n) (S m). - -We can use multiple patterns to write the proof of the lemma -:g:`forall (n m:nat), (LE n m) \/ (LE m n)`: - -.. coqtop:: in - - Fixpoint dec (n m:nat) {struct n} : LE n m \/ LE m n := - match n, m return LE n m \/ LE m n with - | O, x => or_introl (LE x 0) (LEO x) - | x, O => or_intror (LE x 0) (LEO x) - | S n as n', S m as m' => - match dec n m with - | or_introl h => or_introl (LE m' n') (LES n m h) - | or_intror h => or_intror (LE n' m') (LES m n h) - end - end. - -In the example of :g:`dec`, the first match is dependent while the second -is not. - -The user can also use match in combination with the tactic :tacn:`refine` -to build incomplete proofs beginning with a :g:`match` construction. - - -Pattern-matching on inductive objects involving local definitions ------------------------------------------------------------------ - -If local definitions occur in the type of a constructor, then there -are two ways to match on this constructor. Either the local -definitions are skipped and matching is done only on the true -arguments of the constructors, or the bindings for local definitions -can also be caught in the matching. - -.. example:: - - .. coqtop:: in reset - - Inductive list : nat -> Set := - | nil : list 0 - | cons : forall n:nat, let m := (2 * n) in list m -> list (S (S m)). - - In the next example, the local definition is not caught. - - .. coqtop:: in - - Fixpoint length n (l:list n) {struct l} : nat := - match l with - | nil => 0 - | cons n l0 => S (length (2 * n) l0) - end. - - But in this example, it is. - - .. coqtop:: in - - Fixpoint length' n (l:list n) {struct l} : nat := - match l with - | nil => 0 - | @cons _ m l0 => S (length' m l0) - end. - -.. note:: For a given matching clause, either none of the local - definitions or all of them can be caught. - -.. note:: You can only catch let bindings in mode where you bind all - variables and so you have to use ``@`` syntax. - -.. note:: this feature is incoherent with the fact that parameters - cannot be caught and consequently is somehow hidden. For example, - there is no mention of it in error messages. - -Pattern-matching and coercions ------------------------------- - -If a mismatch occurs between the expected type of a pattern and its -actual type, a coercion made from constructors is sought. If such a -coercion can be found, it is automatically inserted around the -pattern. - -.. example:: - - .. coqtop:: in - - Inductive I : Set := - | C1 : nat -> I - | C2 : I -> I. - - Coercion C1 : nat >-> I. - - .. coqtop:: all - - Check (fun x => match x with - | C2 O => 0 - | _ => 0 - end). - - -When does the expansion strategy fail? --------------------------------------- - -The strategy works very like in ML languages when treating patterns of -non-dependent types. But there are new cases of failure that are due to -the presence of dependencies. - -The error messages of the current implementation may be sometimes -confusing. When the tactic fails because patterns are somehow -incorrect then error messages refer to the initial expression. But the -strategy may succeed to build an expression whose sub-expressions are -well typed when the whole expression is not. In this situation the -message makes reference to the expanded expression. We encourage -users, when they have patterns with the same outer constructor in -different equations, to name the variable patterns in the same -positions with the same name. E.g. to write ``(cons n O x) => e1`` and -``(cons n _ x) => e2`` instead of ``(cons n O x) => e1`` and -``(cons n' _ x') => e2``. This helps to maintain certain name correspondence between the -generated expression and the original. - -Here is a summary of the error messages corresponding to each -situation: - -.. exn:: The constructor @ident expects @num arguments. - - The variable ident is bound several times in pattern termFound a constructor - of inductive type term while a constructor of term is expectedPatterns are - incorrect (because constructors are not applied to the correct number of the - arguments, because they are not linear or they are wrongly typed). - -.. exn:: Non exhaustive pattern matching. - - The pattern matching is not exhaustive. - -.. exn:: The elimination predicate term should be of arity @num (for non \ - dependent case) or @num (for dependent case). - - The elimination predicate provided to match has not the expected arity. - -.. exn:: Unable to infer a match predicate - Either there is a type incompatibility or the problem involves dependencies. - - There is a type mismatch between the different branches. The user should - provide an elimination predicate. + <meta http-equiv="refresh" content="0;URL=../language/extensions/match.html"> diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index a6dc15da55..5d257c7370 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -1,4 +1,4 @@ -.. _implicitcoercions: +.. _coercions: Implicit Coercions ==================== diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 2958d866ac..12fd038fb6 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -365,6 +365,21 @@ it is an atomic universe (i.e. not an algebraic max() universe). Explicit Universes ------------------- +.. insertprodn universe_name univ_constraint + +.. prodn:: + universe_name ::= @qualid + | Set + | Prop + univ_annot ::= @%{ {* @universe_level } %} + universe_level ::= Set + | Prop + | Type + | _ + | @qualid + univ_decl ::= @%{ {* @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} + univ_constraint ::= @universe_name {| < | = | <= } @universe_name + The syntax has been extended to allow users to explicitly bind names to universes and explicitly instantiate polymorphic definitions. @@ -403,6 +418,37 @@ to universes and explicitly instantiate polymorphic definitions. .. exn:: Polymorphic universe constraints can only be declared inside sections, use Monomorphic Constraint instead :undocumented: +.. _printing-universes: + +Printing universes +------------------ + +.. flag:: Printing Universes + + Turn this flag on to activate the display of the actual level of each + occurrence of :g:`Type`. See :ref:`Sorts` for details. This wizard flag, in + combination with :flag:`Printing All` can help to diagnose failures to unify + terms apparently identical but internally different in the Calculus of Inductive + Constructions. + +.. cmd:: Print {? Sorted } Universes {? Subgraph ( {* @qualid } ) } {? @string } + :name: Print Universes + + This command can be used to print the constraints on the internal level + of the occurrences of :math:`\Type` (see :ref:`Sorts`). + + The :n:`Subgraph` clause limits the printed graph to the requested names (adjusting + constraints to preserve the implied transitive constraints between + kept universes). + + The :n:`Sorted` clause makes each universe + equivalent to a numbered label reflecting its level (with a linear + ordering) in the universe hierarchy. + + :n:`@string` is an optional output filename. + If :n:`@string` ends in ``.dot`` or ``.gv``, the constraints are printed in the DOT + language, and can be processed by Graphviz tools. The format is + unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. Polymorphic definitions ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 4136b406de..fabf7a519f 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -46,7 +46,7 @@ with open("refman-preamble.rst") as s: # -- General configuration ------------------------------------------------ # If your documentation needs a minimal Sphinx version, state it here. -needs_sphinx = '1.8.0' +needs_sphinx = '2.3.1' # Add any Sphinx extension module names here, as strings. They can be # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index b125d21a3c..768c83150e 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -1,7 +1,4 @@ -.. _calculusofinductiveconstructions: - - -Calculus of Inductive Constructions +Typing rules ==================================== The underlying formal language of |Coq| is a *Calculus of Inductive @@ -24,95 +21,6 @@ to a type and takes the form “*for all x of type* :math:`T`, :math:`P`”. The “:math:`x` *of type* :math:`T`” is written “:math:`x:T`”. Informally, “:math:`x:T`” can be thought as “:math:`x` *belongs to* :math:`T`”. -The types of types are called :gdef:`sort`\s. Types and sorts are themselves terms -so that terms, types and sorts are all components of a common -syntactic language of terms which is described in Section :ref:`terms`. But -first, we describe sorts. - - -.. _Sorts: - -Sorts -~~~~~~~~~~~ - -All sorts have a type and there is an infinite well-founded typing -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. -See :ref:`sprop` for information about using -:math:`\SProp`, and :cite:`Gilbert:POPL2019` for meta theoretical -considerations. - -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:`\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 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 -booleans, natural numbers, as well as products, subsets and function -types over small sets. But, unlike :math:`\Set`, they also contain large sets, -namely the sorts :math:`\Set` and :math:`\Type(j)` for :math:`j<i`, and all products, subsets -and function types over these sorts. - -Formally, we call :math:`\Sort` the set of sorts which is defined by: - -.. math:: - - \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`. - -The user does not have to mention explicitly the index :math:`i` when -referring to the universe :math:`\Type(i)`. One only writes :math:`\Type`. The system -itself generates for each instance of :math:`\Type` a new index for the -universe and checks that the constraints between these indexes can be -solved. From the user point of view we consequently have :math:`\Type:\Type`. We -shall make precise in the typing rules the constraints between the -indices. - - -.. _Implementation-issues: - -**Implementation issues** In practice, the Type hierarchy is -implemented using *algebraic -universes*. An algebraic universe :math:`u` is either a variable (a qualified -identifier with a number) or a successor of an algebraic universe (an -expression :math:`u+1`), or an upper bound of algebraic universes (an -expression :math:`\max(u_1 ,...,u_n )`), or the base universe (the expression -:math:`0`) which corresponds, in the arity of template polymorphic inductive -types (see Section -:ref:`well-formed-inductive-definitions`), -to the predicative sort :math:`\Set`. A graph of -constraints between the universe variables is maintained globally. To -ensure the existence of a mapping of the universes to the positive -integers, the graph of constraints must remain acyclic. Typing -expressions that violate the acyclicity of the graph of constraints -results in a Universe inconsistency error. - -.. seealso:: Section :ref:`printing-universes`. - - -.. _Terms: - -Terms -~~~~~ - - - Terms are built from sorts, variables, constants, abstractions, applications, local definitions, and products. From a syntactic point of view, types cannot be distinguished from terms, except that they @@ -411,221 +319,6 @@ following rules. :math:`x` may be used in a conversion rule (see Section :ref:`Conversion-rules`). - -.. _Conversion-rules: - -Conversion rules --------------------- - -In |Cic|, there is an internal reduction mechanism. In particular, it -can decide if two programs are *intentionally* equal (one says -*convertible*). Convertibility is described in this section. - - -.. _beta-reduction: - -β-reduction -~~~~~~~~~~~ - -We want to be able to identify some terms as we can identify the -application of a function to a given argument with its result. For -instance the identity function over a given type :math:`T` can be written -:math:`λx:T.~x`. In any global environment :math:`E` and local context -:math:`Γ`, we want to identify any object :math:`a` (of type -:math:`T`) with the application :math:`((λ x:T.~x)~a)`. We define for -this a *reduction* (or a *conversion*) rule we call :math:`β`: - -.. math:: - - E[Γ] ⊢ ((λx:T.~t)~u)~\triangleright_β~\subst{t}{x}{u} - -We say that :math:`\subst{t}{x}{u}` is the *β-contraction* of -:math:`((λx:T.~t)~u)` and, conversely, that :math:`((λ x:T.~t)~u)` is the -*β-expansion* of :math:`\subst{t}{x}{u}`. - -According to β-reduction, terms of the *Calculus of Inductive -Constructions* enjoy some fundamental properties such as confluence, -strong normalization, subject reduction. These results are -theoretically of great importance but we will not detail them here and -refer the interested reader to :cite:`Coq85`. - - -.. _iota-reduction: - -ι-reduction -~~~~~~~~~~~ - -A specific conversion rule is associated to the inductive objects in -the global environment. We shall give later on (see Section -:ref:`Well-formed-inductive-definitions`) the precise rules but it -just says that a destructor applied to an object built from a -constructor behaves as expected. This reduction is called ι-reduction -and is more precisely studied in :cite:`Moh93,Wer94`. - - -.. _delta-reduction: - -δ-reduction -~~~~~~~~~~~ - -We may have variables defined in local contexts or constants defined -in the global environment. It is legal to identify such a reference -with its value, that is to expand (or unfold) it into its value. This -reduction is called δ-reduction and shows as follows. - -.. inference:: Delta-Local - - \WFE{\Gamma} - (x:=t:T) ∈ Γ - -------------- - E[Γ] ⊢ x~\triangleright_Δ~t - -.. inference:: Delta-Global - - \WFE{\Gamma} - (c:=t:T) ∈ E - -------------- - E[Γ] ⊢ c~\triangleright_δ~t - - -.. _zeta-reduction: - -ζ-reduction -~~~~~~~~~~~ - -|Coq| allows also to remove local definitions occurring in terms by -replacing the defined variable by its value. The declaration being -destroyed, this reduction differs from δ-reduction. It is called -ζ-reduction and shows as follows. - -.. inference:: Zeta - - \WFE{\Gamma} - \WTEG{u}{U} - \WTE{\Gamma::(x:=u:U)}{t}{T} - -------------- - E[Γ] ⊢ \letin{x}{u:U}{t}~\triangleright_ζ~\subst{t}{x}{u} - - -.. _eta-expansion: - -η-expansion -~~~~~~~~~~~ - -Another important concept is η-expansion. It is legal to identify any -term :math:`t` of functional type :math:`∀ x:T,~U` with its so-called η-expansion - -.. math:: - λx:T.~(t~x) - -for :math:`x` an arbitrary variable name fresh in :math:`t`. - - -.. note:: - - We deliberately do not define η-reduction: - - .. math:: - λ x:T.~(t~x)~\not\triangleright_η~t - - This is because, in general, the type of :math:`t` need not to be convertible - to the type of :math:`λ x:T.~(t~x)`. E.g., if we take :math:`f` such that: - - .. math:: - f ~:~ ∀ x:\Type(2),~\Type(1) - - then - - .. math:: - λ x:\Type(1).~(f~x) ~:~ ∀ x:\Type(1),~\Type(1) - - We could not allow - - .. math:: - λ x:\Type(1).~(f~x) ~\triangleright_η~ f - - 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: - -Convertibility -~~~~~~~~~~~~~~ - -Let us write :math:`E[Γ] ⊢ t \triangleright u` for the contextual closure of the -relation :math:`t` reduces to :math:`u` in the global environment -:math:`E` and local context :math:`Γ` with one of the previous -reductions β, δ, ι or ζ. - -We say that two terms :math:`t_1` and :math:`t_2` are -*βδιζη-convertible*, or simply *convertible*, or *equivalent*, in the -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 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'` -and :math:`u_1 x` is recursively convertible to :math:`u_2'`. We then write -:math:`E[Γ] ⊢ t_1 =_{βδιζη} t_2`. - -Apart from this we consider two instances of polymorphic and -cumulative (see Chapter :ref:`polymorphicuniverses`) inductive types -(see below) convertible - -.. math:: - E[Γ] ⊢ t~w_1 … w_m =_{βδιζη} t~w_1' … w_m' - -if we have subtypings (see below) in both directions, i.e., - -.. math:: - E[Γ] ⊢ t~w_1 … w_m ≤_{βδιζη} t~w_1' … w_m' - -and - -.. math:: - E[Γ] ⊢ t~w_1' … w_m' ≤_{βδιζη} t~w_1 … w_m. - -Furthermore, we consider - -.. math:: - E[Γ] ⊢ c~v_1 … v_m =_{βδιζη} c'~v_1' … v_m' - -convertible if - -.. math:: - E[Γ] ⊢ v_i =_{βδιζη} v_i' - -and we have that :math:`c` and :math:`c'` -are the same constructors of different instances of the same inductive -types (differing only in universe levels) such that - -.. math:: - E[Γ] ⊢ c~v_1 … v_m : t~w_1 … w_m - -and - -.. math:: - E[Γ] ⊢ c'~v_1' … v_m' : t'~ w_1' … w_m ' - -and we have - -.. math:: - E[Γ] ⊢ t~w_1 … w_m =_{βδιζη} t~w_1' … w_m'. - -The convertibility relation allows introducing a new typing rule which -says that two convertible well-formed types have the same inhabitants. - - .. _subtyping-rules: Subtyping rules @@ -728,1219 +421,6 @@ normal form must not be confused with the normal form since some :math:`u_i` can be reducible. Similar notions of head-normal forms involving δ, ι and ζ reductions or any combination of those can also be defined. - -.. _inductive-definitions: - -Inductive Definitions -------------------------- - -Formally, we can represent any *inductive definition* as -:math:`\ind{p}{Γ_I}{Γ_C}` where: - -+ :math:`Γ_I` determines the names and types of inductive types; -+ :math:`Γ_C` determines the names and types of constructors of these - inductive types; -+ :math:`p` determines the number of parameters of these inductive types. - - -These inductive definitions, together with global assumptions and -global definitions, then form the global environment. Additionally, -for any :math:`p` there always exists :math:`Γ_P =[a_1 :A_1 ;~…;~a_p :A_p ]` such that -each :math:`T` in :math:`(t:T)∈Γ_I \cup Γ_C` can be written as: :math:`∀Γ_P , T'` where :math:`Γ_P` is -called the *context of parameters*. Furthermore, we must have that -each :math:`T` in :math:`(t:T)∈Γ_I` can be written as: :math:`∀Γ_P,∀Γ_{\mathit{Arr}(t)}, S` where -:math:`Γ_{\mathit{Arr}(t)}` is called the *Arity* of the inductive type :math:`t` and :math:`S` is called -the sort of the inductive type :math:`t` (not to be confused with :math:`\Sort` which is the set of sorts). - -.. example:: - - The declaration for parameterized lists is: - - .. math:: - \ind{1}{[\List:\Set→\Set]}{\left[\begin{array}{rcl} - \Nil & : & ∀ A:\Set,~\List~A \\ - \cons & : & ∀ A:\Set,~A→ \List~A→ \List~A - \end{array} - \right]} - - which corresponds to the result of the |Coq| declaration: - - .. coqtop:: in - - Inductive list (A:Set) : Set := - | nil : list A - | cons : A -> list A -> list A. - -.. example:: - - The declaration for a mutual inductive definition of tree and forest - is: - - .. math:: - \ind{0}{\left[\begin{array}{rcl}\tree&:&\Set\\\forest&:&\Set\end{array}\right]} - {\left[\begin{array}{rcl} - \node &:& \forest → \tree\\ - \emptyf &:& \forest\\ - \consf &:& \tree → \forest → \forest\\ - \end{array}\right]} - - which corresponds to the result of the |Coq| declaration: - - .. coqtop:: in - - Inductive tree : Set := - | node : forest -> tree - with forest : Set := - | emptyf : forest - | consf : tree -> forest -> forest. - -.. example:: - - The declaration for a mutual inductive definition of even and odd is: - - .. math:: - \ind{0}{\left[\begin{array}{rcl}\even&:&\nat → \Prop \\ - \odd&:&\nat → \Prop \end{array}\right]} - {\left[\begin{array}{rcl} - \evenO &:& \even~0\\ - \evenS &:& ∀ n,~\odd~n → \even~(\nS~n)\\ - \oddS &:& ∀ n,~\even~n → \odd~(\nS~n) - \end{array}\right]} - - which corresponds to the result of the |Coq| declaration: - - .. coqtop:: in - - Inductive even : nat -> Prop := - | even_O : even 0 - | even_S : forall n, odd n -> even (S n) - with odd : nat -> Prop := - | odd_S : forall n, even n -> odd (S n). - - - -.. _Types-of-inductive-objects: - -Types of inductive objects -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We have to give the type of constants in a global environment :math:`E` which -contains an inductive definition. - -.. inference:: Ind - - \WFE{Γ} - \ind{p}{Γ_I}{Γ_C} ∈ E - (a:A)∈Γ_I - --------------------- - E[Γ] ⊢ a : A - -.. inference:: Constr - - \WFE{Γ} - \ind{p}{Γ_I}{Γ_C} ∈ E - (c:C)∈Γ_C - --------------------- - E[Γ] ⊢ c : C - -.. example:: - - Provided that our environment :math:`E` contains inductive definitions we showed before, - these two inference rules above enable us to conclude that: - - .. math:: - \begin{array}{l} - E[Γ] ⊢ \even : \nat→\Prop\\ - E[Γ] ⊢ \odd : \nat→\Prop\\ - E[Γ] ⊢ \evenO : \even~\nO\\ - E[Γ] ⊢ \evenS : ∀ n:\nat,~\odd~n → \even~(\nS~n)\\ - E[Γ] ⊢ \oddS : ∀ n:\nat,~\even~n → \odd~(\nS~n) - \end{array} - - - - -.. _Well-formed-inductive-definitions: - -Well-formed inductive definitions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We cannot accept any inductive definition because some of them lead -to inconsistent systems. We restrict ourselves to definitions which -satisfy a syntactic criterion of positivity. Before giving the formal -rules, we need a few definitions: - -Arity of a given sort -+++++++++++++++++++++ - -A type :math:`T` is an *arity of sort* :math:`s` if it converts to the sort :math:`s` or to a -product :math:`∀ x:T,~U` with :math:`U` an arity of sort :math:`s`. - -.. example:: - - :math:`A→\Set` is an arity of sort :math:`\Set`. :math:`∀ A:\Prop,~A→ \Prop` is an arity of sort - :math:`\Prop`. - - -Arity -+++++ -A type :math:`T` is an *arity* if there is a :math:`s∈ \Sort` such that :math:`T` is an arity of -sort :math:`s`. - - -.. example:: - - :math:`A→ \Set` and :math:`∀ A:\Prop,~A→ \Prop` are arities. - - -Type of constructor -+++++++++++++++++++ -We say that :math:`T` is a *type of constructor of* :math:`I` in one of the following -two cases: - -+ :math:`T` is :math:`(I~t_1 … t_n )` -+ :math:`T` is :math:`∀ x:U,~T'` where :math:`T'` is also a type of constructor of :math:`I` - -.. example:: - - :math:`\nat` and :math:`\nat→\nat` are types of constructor of :math:`\nat`. - :math:`∀ A:\Type,~\List~A` and :math:`∀ A:\Type,~A→\List~A→\List~A` are types of constructor of :math:`\List`. - -.. _positivity: - -Positivity Condition -++++++++++++++++++++ - -The type of constructor :math:`T` will be said to *satisfy the positivity -condition* for a constant :math:`X` in the following cases: - -+ :math:`T=(X~t_1 … t_n )` and :math:`X` does not occur free in any :math:`t_i` -+ :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` - satisfies the positivity condition for :math:`X`. - -Strict positivity -+++++++++++++++++ - -The constant :math:`X` *occurs strictly positively* in :math:`T` in the following -cases: - - -+ :math:`X` does not occur in :math:`T` -+ :math:`T` converts to :math:`(X~t_1 … t_n )` and :math:`X` does not occur in any of :math:`t_i` -+ :math:`T` converts to :math:`∀ x:U,~V` and :math:`X` does not occur in type :math:`U` but occurs - strictly positively in type :math:`V` -+ :math:`T` converts to :math:`(I~a_1 … a_m~t_1 … t_p )` where :math:`I` is the name of an - inductive definition of the form - - .. math:: - \ind{m}{I:A}{c_1 :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_1 ;~…;~c_n :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_n} - - (in particular, it is - not mutually defined and it has :math:`m` parameters) and :math:`X` does not occur in - any of the :math:`t_i`, and the (instantiated) types of constructor - :math:`\subst{C_i}{p_j}{a_j}_{j=1… m}` of :math:`I` satisfy the nested positivity condition for :math:`X` - -Nested Positivity -+++++++++++++++++ - -The type of constructor :math:`T` of :math:`I` *satisfies the nested positivity -condition* for a constant :math:`X` in the following cases: - -+ :math:`T=(I~b_1 … b_m~u_1 … u_p)`, :math:`I` is an inductive type with :math:`m` - parameters and :math:`X` does not occur in any :math:`u_i` -+ :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` - satisfies the nested positivity condition for :math:`X` - - -.. example:: - - For instance, if one considers the following variant of a tree type - branching over the natural numbers: - - .. coqtop:: in - - Inductive nattree (A:Type) : Type := - | leaf : nattree A - | natnode : A -> (nat -> nattree A) -> nattree A. - - Then every instantiated constructor of ``nattree A`` satisfies the nested positivity - condition for ``nattree``: - - + Type ``nattree A`` of constructor ``leaf`` satisfies the positivity condition for - ``nattree`` because ``nattree`` does not appear in any (real) arguments of the - type of that constructor (primarily because ``nattree`` does not have any (real) - arguments) ... (bullet 1) - - + Type ``A → (nat → nattree A) → nattree A`` of constructor ``natnode`` satisfies the - positivity condition for ``nattree`` because: - - - ``nattree`` occurs only strictly positively in ``A`` ... (bullet 1) - - - ``nattree`` occurs only strictly positively in ``nat → nattree A`` ... (bullet 3 + 2) - - - ``nattree`` satisfies the positivity condition for ``nattree A`` ... (bullet 1) - -.. _Correctness-rules: - -Correctness rules -+++++++++++++++++ - -We shall now describe the rules allowing the introduction of a new -inductive definition. - -Let :math:`E` be a global environment and :math:`Γ_P`, :math:`Γ_I`, :math:`Γ_C` be contexts -such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k]`, and -:math:`Γ_C` is :math:`[c_1:∀ Γ_P ,C_1 ;~…;~c_n :∀ Γ_P ,C_n ]`. Then - -.. inference:: W-Ind - - \WFE{Γ_P} - (E[Γ_I ;Γ_P ] ⊢ C_i : s_{q_i} )_{i=1… n} - ------------------------------------------ - \WF{E;~\ind{p}{Γ_I}{Γ_C}}{} - - -provided that the following side conditions hold: - - + :math:`k>0` and all of :math:`I_j` and :math:`c_i` are distinct names for :math:`j=1… k` and :math:`i=1… n`, - + :math:`p` is the number of parameters of :math:`\ind{p}{Γ_I}{Γ_C}` and :math:`Γ_P` is the - context of parameters, - + for :math:`j=1… k` we have that :math:`A_j` is an arity of sort :math:`s_j` and :math:`I_j ∉ E`, - + for :math:`i=1… n` we have that :math:`C_i` is a type of constructor of :math:`I_{q_i}` which - satisfies the positivity condition for :math:`I_1 … I_k` and :math:`c_i ∉ E`. - -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 -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:: - - It is well known that the existential quantifier can be encoded as an - inductive definition. The following declaration introduces the - second-order existential quantifier :math:`∃ X.P(X)`. - - .. coqtop:: in - - Inductive exProp (P:Prop->Prop) : Prop := - | exP_intro : forall X:Prop, P X -> exProp P. - - The same definition on :math:`\Set` is not allowed and fails: - - .. coqtop:: all - - Fail Inductive exSet (P:Set->Prop) : Set := - exS_intro : forall X:Set, P X -> exSet P. - - It is possible to declare the same inductive definition in the - universe :math:`\Type`. The :g:`exType` inductive definition has type - :math:`(\Type(i)→\Prop)→\Type(j)` with the constraint that the parameter :math:`X` of :math:`\kw{exT}_{\kw{intro}}` - has type :math:`\Type(k)` with :math:`k<j` and :math:`k≤ i`. - - .. coqtop:: all - - Inductive exType (P:Type->Prop) : Type := - exT_intro : forall X:Type, P X -> exType P. - - -.. example:: Negative occurrence (first example) - - The following inductive definition is rejected because it does not - satisfy the positivity condition: - - .. coqtop:: all - - Fail Inductive I : Prop := not_I_I (not_I : I -> False) : I. - - If we were to accept such definition, we could derive a - contradiction from it (we can test this by disabling the - :flag:`Positivity Checking` flag): - - .. coqtop:: none - - Unset Positivity Checking. - Inductive I : Prop := not_I_I (not_I : I -> False) : I. - Set Positivity Checking. - - .. coqtop:: all - - Definition I_not_I : I -> ~ I := fun i => - match i with not_I_I not_I => not_I end. - - .. coqtop:: in - - Lemma contradiction : False. - Proof. - enough (I /\ ~ I) as [] by contradiction. - split. - - apply not_I_I. - intro. - now apply I_not_I. - - intro. - now apply I_not_I. - Qed. - -.. example:: Negative occurrence (second example) - - Here is another example of an inductive definition which is - rejected because it does not satify the positivity condition: - - .. coqtop:: all - - Fail Inductive Lam := lam (_ : Lam -> Lam). - - Again, if we were to accept it, we could derive a contradiction - (this time through a non-terminating recursive function): - - .. coqtop:: none - - Unset Positivity Checking. - Inductive Lam := lam (_ : Lam -> Lam). - Set Positivity Checking. - - .. coqtop:: all - - Fixpoint infinite_loop l : False := - match l with lam x => infinite_loop (x l) end. - - Check infinite_loop (lam (@id Lam)) : False. - -.. example:: Non strictly positive occurrence - - It is less obvious why inductive type definitions with occurences - that are positive but not strictly positive are harmful. - We will see that in presence of an impredicative type they - are unsound: - - .. coqtop:: all - - Fail Inductive A: Type := introA: ((A -> Prop) -> Prop) -> A. - - If we were to accept this definition we could derive a contradiction - by creating an injective function from :math:`A → \Prop` to :math:`A`. - - This function is defined by composing the injective constructor of - the type :math:`A` with the function :math:`λx. λz. z = x` injecting - any type :math:`T` into :math:`T → \Prop`. - - .. coqtop:: none - - Unset Positivity Checking. - Inductive A: Type := introA: ((A -> Prop) -> Prop) -> A. - Set Positivity Checking. - - .. coqtop:: all - - Definition f (x: A -> Prop): A := introA (fun z => z = x). - - .. coqtop:: in - - Lemma f_inj: forall x y, f x = f y -> x = y. - Proof. - unfold f; intros ? ? H; injection H. - set (F := fun z => z = y); intro HF. - symmetry; replace (y = x) with (F y). - + unfold F; reflexivity. - + rewrite <- HF; reflexivity. - Qed. - - The type :math:`A → \Prop` can be understood as the powerset - of the type :math:`A`. To derive a contradiction from the - injective function :math:`f` we use Cantor's classic diagonal - argument. - - .. coqtop:: all - - Definition d: A -> Prop := fun x => exists s, x = f s /\ ~s x. - Definition fd: A := f d. - - .. coqtop:: in - - Lemma cantor: (d fd) <-> ~(d fd). - Proof. - split. - + intros [s [H1 H2]]; unfold fd in H1. - replace d with s. - * assumption. - * apply f_inj; congruence. - + intro; exists d; tauto. - Qed. - - Lemma bad: False. - Proof. - pose cantor; tauto. - Qed. - - This derivation was first presented by Thierry Coquand and Christine - Paulin in :cite:`CP90`. - -.. _Template-polymorphism: - -Template polymorphism -+++++++++++++++++++++ - -Inductive types can be made polymorphic over the universes introduced by -their parameters in :math:`\Type`, if the minimal inferred sort of the -inductive declarations either mention some of those parameter universes -or is computed to be :math:`\Prop` or :math:`\Set`. - -If :math:`A` is an arity of some sort and :math:`s` is a sort, we write :math:`A_{/s}` -for the arity obtained from :math:`A` by replacing its sort with :math:`s`. -Especially, if :math:`A` is well-typed in some global environment and local -context, then :math:`A_{/s}` is typable by typability of all products in the -Calculus of Inductive Constructions. The following typing rule is -added to the theory. - -Let :math:`\ind{p}{Γ_I}{Γ_C}` be an inductive definition. Let -:math:`Γ_P = [p_1 :P_1 ;~…;~p_p :P_p ]` be its context of parameters, -:math:`Γ_I = [I_1:∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k ]` its context of definitions and -:math:`Γ_C = [c_1 :∀ Γ_P ,C_1 ;~…;~c_n :∀ Γ_P ,C_n]` its context of constructors, -with :math:`c_i` a constructor of :math:`I_{q_i}`. Let :math:`m ≤ p` be the length of the -longest prefix of parameters such that the :math:`m` first arguments of all -occurrences of all :math:`I_j` in all :math:`C_k` (even the occurrences in the -hypotheses of :math:`C_k`) are exactly applied to :math:`p_1 … p_m` (:math:`m` is the number -of *recursively uniform parameters* and the :math:`p−m` remaining parameters -are the *recursively non-uniform parameters*). Let :math:`q_1 , …, q_r`, with -:math:`0≤ r≤ m`, be a (possibly) partial instantiation of the recursively -uniform parameters of :math:`Γ_P`. We have: - -.. inference:: Ind-Family - - \left\{\begin{array}{l} - \ind{p}{Γ_I}{Γ_C} \in E\\ - (E[] ⊢ q_l : P'_l)_{l=1\ldots r}\\ - (E[] ⊢ P'_l ≤_{βδιζη} \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1})_{l=1\ldots r}\\ - 1 \leq j \leq k - \end{array} - \right. - ----------------------------- - E[] ⊢ I_j~q_1 … q_r :∀ [p_{r+1} :P_{r+1} ;~…;~p_p :P_p], (A_j)_{/s_j} - -provided that the following side conditions hold: - - + :math:`Γ_{P′}` is the context obtained from :math:`Γ_P` by replacing each :math:`P_l` that is - an arity with :math:`P_l'` for :math:`1≤ l ≤ r` (notice that :math:`P_l` arity implies :math:`P_l'` - arity since :math:`E[] ⊢ P_l' ≤_{βδιζη} \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}`); - + there are sorts :math:`s_i`, for :math:`1 ≤ i ≤ k` such that, for - :math:`Γ_{I'} = [I_1 :∀ Γ_{P'} ,(A_1)_{/s_1} ;~…;~I_k :∀ Γ_{P'} ,(A_k)_{/s_k}]` - we have :math:`(E[Γ_{I′} ;Γ_{P′}] ⊢ C_i : s_{q_i})_{i=1… n}` ; - + the sorts :math:`s_i` are all introduced by the inductive - declaration and have no universe constraints beside being greater - than or equal to :math:`\Prop`, and such that all - eliminations, to :math:`\Prop`, :math:`\Set` and :math:`\Type(j)`, - are allowed (see Section :ref:`Destructors`). - - -Notice that if :math:`I_j~q_1 … q_r` is typable using the rules **Ind-Const** and -**App**, then it is typable using the rule **Ind-Family**. Conversely, the -extended theory is not stronger than the theory without **Ind-Family**. We -get an equiconsistency result by mapping each :math:`\ind{p}{Γ_I}{Γ_C}` -occurring into a given derivation into as many different inductive -types and constructors as the number of different (partial) -replacements of sorts, needed for this derivation, in the parameters -that are arities (this is possible because :math:`\ind{p}{Γ_I}{Γ_C}` well-formed -implies that :math:`\ind{p}{Γ_{I'}}{Γ_{C'}}` is well-formed and has the -same allowed eliminations, where :math:`Γ_{I′}` is defined as above and -:math:`Γ_{C′} = [c_1 :∀ Γ_{P′} ,C_1 ;~…;~c_n :∀ Γ_{P′} ,C_n ]`). That is, the changes in the -types of each partial instance :math:`q_1 … q_r` can be characterized by the -ordered sets of arity sorts among the types of parameters, and to each -signature is associated a new inductive definition with fresh names. -Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or -:math:`C_i~q_1 … q_r` is mapped to the names chosen in the specific instance of -:math:`\ind{p}{Γ_I}{Γ_C}`. - -.. warning:: - - The restriction that sorts are introduced by the inductive - declaration prevents inductive types declared in sections to be - template-polymorphic on universes introduced previously in the - section: they cannot parameterize over the universes introduced with - section variables that become parameters at section closing time, as - these may be shared with other definitions from the same section - which can impose constraints on them. - -.. flag:: Auto Template Polymorphism - - This flag, enabled by default, makes every inductive type declared - at level :math:`\Type` (without annotations or hiding it behind a - definition) template polymorphic if possible. - - This can be prevented using the :attr:`universes(notemplate)` - attribute. - - Template polymorphism and full universe polymorphism (see Chapter - :ref:`polymorphicuniverses`) are incompatible, so if the latter is - enabled (through the :flag:`Universe Polymorphism` flag or the - :attr:`universes(polymorphic)` attribute) it will prevail over - automatic template polymorphism. - -.. warn:: Automatically declaring @ident as template polymorphic. - - Warning ``auto-template`` can be used (it is off by default) to - find which types are implicitly declared template polymorphic by - :flag:`Auto Template Polymorphism`. - - An inductive type can be forced to be template polymorphic using - the :attr:`universes(template)` attribute: in this case, the - warning is not emitted. - -.. attr:: universes(template) - - This attribute can be used to explicitly declare an inductive type - as template polymorphic, whether the :flag:`Auto Template - Polymorphism` flag is on or off. - - .. exn:: template and polymorphism not compatible - - This attribute cannot be used in a full universe polymorphic - context, i.e. if the :flag:`Universe Polymorphism` flag is on or - if the :attr:`universes(polymorphic)` attribute is used. - - .. exn:: Ill-formed template inductive declaration: not polymorphic on any universe. - - The attribute was used but the inductive definition does not - satisfy the criterion to be template polymorphic. - -.. attr:: universes(notemplate) - - This attribute can be used to prevent an inductive type to be - template polymorphic, even if the :flag:`Auto Template - Polymorphism` flag is on. - -In practice, the rule **Ind-Family** is used by |Coq| only when all the -inductive types of the inductive definition are declared with an arity -whose sort is in the Type hierarchy. Then, the polymorphism is over -the parameters whose type is an arity of sort in the Type hierarchy. -The sorts :math:`s_j` are chosen canonically so that each :math:`s_j` is minimal with -respect to the hierarchy :math:`\Prop ⊂ \Set_p ⊂ \Type` where :math:`\Set_p` is predicative -:math:`\Set`. More precisely, an empty or small singleton inductive definition -(i.e. an inductive definition of which all inductive types are -singleton – see Section :ref:`Destructors`) is set in :math:`\Prop`, a small non-singleton -inductive type is set in :math:`\Set` (even in case :math:`\Set` is impredicative – see -Section The-Calculus-of-Inductive-Construction-with-impredicative-Set_), -and otherwise in the Type hierarchy. - -Note that the side-condition about allowed elimination sorts in the rule -**Ind-Family** avoids to recompute the allowed elimination sorts at each -instance of a pattern matching (see Section :ref:`Destructors`). As an -example, let us consider the following definition: - -.. example:: - - .. coqtop:: in - - Inductive option (A:Type) : Type := - | None : option A - | Some : A -> option A. - -As the definition is set in the Type hierarchy, it is used -polymorphically over its parameters whose types are arities of a sort -in the Type hierarchy. Here, the parameter :math:`A` has this property, hence, -if :g:`option` is applied to a type in :math:`\Set`, the result is in :math:`\Set`. Note that -if :g:`option` is applied to a type in :math:`\Prop`, then, the result is not set in -:math:`\Prop` but in :math:`\Set` still. This is because :g:`option` is not a singleton type -(see Section :ref:`Destructors`) and it would lose the elimination to :math:`\Set` and :math:`\Type` -if set in :math:`\Prop`. - -.. example:: - - .. coqtop:: all - - Check (fun A:Set => option A). - Check (fun A:Prop => option A). - -Here is another example. - -.. example:: - - .. coqtop:: in - - Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. - -As :g:`prod` is a singleton type, it will be in :math:`\Prop` if applied twice to -propositions, in :math:`\Set` if applied twice to at least one type in :math:`\Set` and -none in :math:`\Type`, and in :math:`\Type` otherwise. In all cases, the three kind of -eliminations schemes are allowed. - -.. example:: - - .. coqtop:: all - - Check (fun A:Set => prod A). - Check (fun A:Prop => prod A A). - Check (fun (A:Prop) (B:Set) => prod A B). - Check (fun (A:Type) (B:Prop) => prod A B). - -.. note:: - Template polymorphism used to be called “sort-polymorphism of - inductive types” before universe polymorphism - (see Chapter :ref:`polymorphicuniverses`) was introduced. - - -.. _Destructors: - -Destructors -~~~~~~~~~~~~~~~~~ - -The specification of inductive definitions with arities and -constructors is quite natural. But we still have to say how to use an -object in an inductive type. - -This problem is rather delicate. There are actually several different -ways to do that. Some of them are logically equivalent but not always -equivalent from the computational point of view or from the user point -of view. - -From the computational point of view, we want to be able to define a -function whose domain is an inductively defined type by using a -combination of case analysis over the possible constructors of the -object and recursion. - -Because we need to keep a consistent theory and also we prefer to keep -a strongly normalizing reduction, we cannot accept any sort of -recursion (even terminating). So the basic idea is to restrict -ourselves to primitive recursive functions and functionals. - -For instance, assuming a parameter :math:`A:\Set` exists in the local context, -we want to build a function :math:`\length` of type :math:`\List~A → \nat` which computes -the length of the list, such that :math:`(\length~(\Nil~A)) = \nO` and -:math:`(\length~(\cons~A~a~l)) = (\nS~(\length~l))`. -We want these equalities to be -recognized implicitly and taken into account in the conversion rule. - -From the logical point of view, we have built a type family by giving -a set of constructors. We want to capture the fact that we do not have -any other way to build an object in this type. So when trying to prove -a property about an object :math:`m` in an inductive type it is enough -to enumerate all the cases where :math:`m` starts with a different -constructor. - -In case the inductive definition is effectively a recursive one, we -want to capture the extra property that we have built the smallest -fixed point of this recursive equation. This says that we are only -manipulating finite objects. This analysis provides induction -principles. For instance, in order to prove -:math:`∀ l:\List~A,~(\kw{has}\_\kw{length}~A~l~(\length~l))` it is enough to prove: - - -+ :math:`(\kw{has}\_\kw{length}~A~(\Nil~A)~(\length~(\Nil~A)))` -+ :math:`∀ a:A,~∀ l:\List~A,~(\kw{has}\_\kw{length}~A~l~(\length~l)) →` - :math:`(\kw{has}\_\kw{length}~A~(\cons~A~a~l)~(\length~(\cons~A~a~l)))` - - -which given the conversion equalities satisfied by :math:`\length` is the same -as proving: - - -+ :math:`(\kw{has}\_\kw{length}~A~(\Nil~A)~\nO)` -+ :math:`∀ a:A,~∀ l:\List~A,~(\kw{has}\_\kw{length}~A~l~(\length~l)) →` - :math:`(\kw{has}\_\kw{length}~A~(\cons~A~a~l)~(\nS~(\length~l)))` - - -One conceptually simple way to do that, following the basic scheme -proposed by Martin-Löf in his Intuitionistic Type Theory, is to -introduce for each inductive definition an elimination operator. At -the logical level it is a proof of the usual induction principle and -at the computational level it implements a generic operator for doing -primitive recursion over the structure. - -But this operator is rather tedious to implement and use. We choose in -this version of |Coq| to factorize the operator for primitive recursion -into two more primitive operations as was first suggested by Th. -Coquand in :cite:`Coq92`. One is the definition by pattern matching. The -second one is a definition by guarded fixpoints. - - -.. _match-construction: - -The match ... with ... end construction -+++++++++++++++++++++++++++++++++++++++ - -The basic idea of this operator is that we have an object :math:`m` in an -inductive type :math:`I` and we want to prove a property which possibly -depends on :math:`m`. For this, it is enough to prove the property for -:math:`m = (c_i~u_1 … u_{p_i} )` for each constructor of :math:`I`. -The |Coq| term for this proof -will be written: - -.. math:: - \Match~m~\with~(c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\kwend - -In this expression, if :math:`m` eventually happens to evaluate to -:math:`(c_i~u_1 … u_{p_i})` then the expression will behave as specified in its :math:`i`-th branch -and it will reduce to :math:`f_i` where the :math:`x_{i1} …x_{ip_i}` are replaced by the -:math:`u_1 … u_{p_i}` according to the ι-reduction. - -Actually, for type checking a :math:`\Match…\with…\kwend` expression we also need -to know the predicate :math:`P` to be proved by case analysis. In the general -case where :math:`I` is an inductively defined :math:`n`-ary relation, :math:`P` is a predicate -over :math:`n+1` arguments: the :math:`n` first ones correspond to the arguments of :math:`I` -(parameters excluded), and the last one corresponds to object :math:`m`. |Coq| -can sometimes infer this predicate but sometimes not. The concrete -syntax for describing this predicate uses the :math:`\as…\In…\return` -construction. For instance, let us assume that :math:`I` is an unary predicate -with one parameter and one argument. The predicate is made explicit -using the syntax: - -.. math:: - \Match~m~\as~x~\In~I~\_~a~\return~P~\with~ - (c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … - | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\kwend - -The :math:`\as` part can be omitted if either the result type does not depend -on :math:`m` (non-dependent elimination) or :math:`m` is a variable (in this case, :math:`m` -can occur in :math:`P` where it is considered a bound variable). The :math:`\In` part -can be omitted if the result type does not depend on the arguments -of :math:`I`. Note that the arguments of :math:`I` corresponding to parameters *must* -be :math:`\_`, because the result type is not generalized to all possible -values of the parameters. The other arguments of :math:`I` (sometimes called -indices in the literature) have to be variables (:math:`a` above) and these -variables can occur in :math:`P`. The expression after :math:`\In` must be seen as an -*inductive type pattern*. Notice that expansion of implicit arguments -and notations apply to this pattern. For the purpose of presenting the -inference rules, we use a more compact notation: - -.. math:: - \case(m,(λ a x . P), λ x_{11} ... x_{1p_1} . f_1~| … |~λ x_{n1} ...x_{np_n} . f_n ) - - -.. _Allowed-elimination-sorts: - -**Allowed elimination sorts.** An important question for building the typing rule for :math:`\Match` is what -can be the type of :math:`λ a x . P` with respect to the type of :math:`m`. If :math:`m:I` -and :math:`I:A` and :math:`λ a x . P : B` then by :math:`[I:A|B]` we mean that one can use -:math:`λ a x . P` with :math:`m` in the above match-construct. - - -.. _cic_notations: - -**Notations.** The :math:`[I:A|B]` is defined as the smallest relation satisfying the -following rules: We write :math:`[I|B]` for :math:`[I:A|B]` where :math:`A` is the type of :math:`I`. - -The case of inductive types in sorts :math:`\Set` or :math:`\Type` is simple. -There is no restriction on the sort of the predicate to be eliminated. - -.. inference:: Prod - - [(I~x):A′|B′] - ----------------------- - [I:∀ x:A,~A′|∀ x:A,~B′] - - -.. inference:: Set & Type - - s_1 ∈ \{\Set,\Type(j)\} - s_2 ∈ \Sort - ---------------- - [I:s_1 |I→ s_2 ] - - -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 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 - - s ∈ \{\SProp,\Prop\} - -------------------- - [I:\Prop|I→s] - - -:math:`\Prop` is the type of logical propositions, the proofs of properties :math:`P` in -:math:`\Prop` could not be used for computation and are consequently ignored by -the extraction mechanism. Assume :math:`A` and :math:`B` are two propositions, and the -logical disjunction :math:`A ∨ B` is defined inductively by: - -.. example:: - - .. coqtop:: in - - Inductive or (A B:Prop) : Prop := - or_introl : A -> or A B | or_intror : B -> or A B. - - -The following definition which computes a boolean value by case over -the proof of :g:`or A B` is not accepted: - -.. example:: - - .. coqtop:: all - - Fail Definition choice (A B: Prop) (x:or A B) := - match x with or_introl _ _ a => true | or_intror _ _ b => false end. - -From the computational point of view, the structure of the proof of -:g:`(or A B)` in this term is needed for computing the boolean value. - -In general, if :math:`I` has type :math:`\Prop` then :math:`P` cannot have type :math:`I→\Set`, because -it will mean to build an informative proof of type :math:`(P~m)` doing a case -analysis over a non-computational object that will disappear in the -extracted program. But the other way is safe with respect to our -interpretation we can have :math:`I` a computational object and :math:`P` a -non-computational one, it just corresponds to proving a logical property -of a computational object. - -In the same spirit, elimination on :math:`P` of type :math:`I→\Type` cannot be allowed -because it trivially implies the elimination on :math:`P` of type :math:`I→ \Set` by -cumulativity. It also implies that there are two proofs of the same -property which are provably different, contradicting the -proof-irrelevance property which is sometimes a useful axiom: - -.. example:: - - .. coqtop:: all - - Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. - -The elimination of an inductive type of sort :math:`\Prop` on a predicate -:math:`P` of type :math:`I→ \Type` leads to a paradox when applied to impredicative -inductive definition like the second-order existential quantifier -:g:`exProp` defined above, because it gives access to the two projections on -this type. - - -.. _Empty-and-singleton-elimination: - -**Empty and singleton elimination.** There are special inductive definitions in -:math:`\Prop` for which more eliminations are allowed. - -.. inference:: Prop-extended - - I~\kw{is an empty or singleton definition} - s ∈ \Sort - ------------------------------------- - [I:\Prop|I→ s] - -A *singleton definition* has only one constructor and all the -arguments of this constructor have type :math:`\Prop`. In that case, there is a -canonical way to interpret the informative extraction on an object in -that type, such that the elimination on any sort :math:`s` is legal. Typical -examples are the conjunction of non-informative propositions and the -equality. If there is a hypothesis :math:`h:a=b` in the local context, it can -be used for rewriting not only in logical propositions but also in any -type. - -.. example:: - - .. coqtop:: all - - Print eq_rec. - Require Extraction. - Extraction eq_rec. - -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: - -**Type of branches.** -Let :math:`c` be a term of type :math:`C`, we assume :math:`C` is a type of constructor for an -inductive type :math:`I`. Let :math:`P` be a term that represents the property to be -proved. We assume :math:`r` is the number of parameters and :math:`s` is the number of -arguments. - -We define a new type :math:`\{c:C\}^P` which represents the type of the branch -corresponding to the :math:`c:C` constructor. - -.. math:: - \begin{array}{ll} - \{c:(I~q_1\ldots q_r\ t_1 \ldots t_s)\}^P &\equiv (P~t_1\ldots ~t_s~c) \\ - \{c:∀ x:T,~C\}^P &\equiv ∀ x:T,~\{(c~x):C\}^P - \end{array} - -We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math:`c`. - - -.. example:: - - The following term in concrete syntax:: - - match t as l return P' with - | nil _ => t1 - | cons _ hd tl => t2 - end - - - can be represented in abstract syntax as - - .. math:: - \case(t,P,f_1 | f_2 ) - - where - - .. math:: - :nowrap: - - \begin{eqnarray*} - P & = & λ l.~P^\prime\\ - f_1 & = & t_1\\ - f_2 & = & λ (hd:\nat).~λ (tl:\List~\nat).~t_2 - \end{eqnarray*} - - According to the definition: - - .. math:: - \{(\Nil~\nat)\}^P ≡ \{(\Nil~\nat) : (\List~\nat)\}^P ≡ (P~(\Nil~\nat)) - - .. math:: - - \begin{array}{rl} - \{(\cons~\nat)\}^P & ≡\{(\cons~\nat) : (\nat→\List~\nat→\List~\nat)\}^P \\ - & ≡∀ n:\nat,~\{(\cons~\nat~n) : (\List~\nat→\List~\nat)\}^P \\ - & ≡∀ n:\nat,~∀ l:\List~\nat,~\{(\cons~\nat~n~l) : (\List~\nat)\}^P \\ - & ≡∀ n:\nat,~∀ l:\List~\nat,~(P~(\cons~\nat~n~l)). - \end{array} - - Given some :math:`P` then :math:`\{(\Nil~\nat)\}^P` represents the expected type of :math:`f_1`, - and :math:`\{(\cons~\nat)\}^P` represents the expected type of :math:`f_2`. - - -.. _Typing-rule: - -**Typing rule.** -Our very general destructor for inductive definition enjoys the -following typing rule - -.. inference:: match - - \begin{array}{l} - E[Γ] ⊢ c : (I~q_1 … q_r~t_1 … t_s ) \\ - E[Γ] ⊢ P : B \\ - [(I~q_1 … q_r)|B] \\ - (E[Γ] ⊢ f_i : \{(c_{p_i}~q_1 … q_r)\}^P)_{i=1… l} - \end{array} - ------------------------------------------------ - E[Γ] ⊢ \case(c,P,f_1 |… |f_l ) : (P~t_1 … t_s~c) - -provided :math:`I` is an inductive type in a -definition :math:`\ind{r}{Γ_I}{Γ_C}` with :math:`Γ_C = [c_1 :C_1 ;~…;~c_n :C_n ]` and -:math:`c_{p_1} … c_{p_l}` are the only constructors of :math:`I`. - - - -.. example:: - - Below is a typing rule for the term shown in the previous example: - - .. inference:: list example - - \begin{array}{l} - E[Γ] ⊢ t : (\List ~\nat) \\ - E[Γ] ⊢ P : B \\ - [(\List ~\nat)|B] \\ - E[Γ] ⊢ f_1 : \{(\Nil ~\nat)\}^P \\ - E[Γ] ⊢ f_2 : \{(\cons ~\nat)\}^P - \end{array} - ------------------------------------------------ - E[Γ] ⊢ \case(t,P,f_1 |f_2 ) : (P~t) - - -.. _Definition-of-ι-reduction: - -**Definition of ι-reduction.** -We still have to define the ι-reduction in the general case. - -An ι-redex is a term of the following form: - -.. math:: - \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_l ) - -with :math:`c_{p_i}` the :math:`i`-th constructor of the inductive type :math:`I` with :math:`r` -parameters. - -The ι-contraction of this term is :math:`(f_i~a_1 … a_m )` leading to the -general reduction rule: - -.. math:: - \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_l ) \triangleright_ι (f_i~a_1 … a_m ) - - -.. _Fixpoint-definitions: - -Fixpoint definitions -~~~~~~~~~~~~~~~~~~~~ - -The second operator for elimination is fixpoint definition. This -fixpoint may involve several mutually recursive definitions. The basic -concrete syntax for a recursive set of mutually recursive declarations -is (with :math:`Γ_i` contexts): - -.. math:: - \fix~f_1 (Γ_1 ) :A_1 :=t_1~\with … \with~f_n (Γ_n ) :A_n :=t_n - - -The terms are obtained by projections from this set of declarations -and are written - -.. math:: - \fix~f_1 (Γ_1 ) :A_1 :=t_1~\with … \with~f_n (Γ_n ) :A_n :=t_n~\for~f_i - -In the inference rules, we represent such a term by - -.. math:: - \Fix~f_i\{f_1 :A_1':=t_1' … f_n :A_n':=t_n'\} - -with :math:`t_i'` (resp. :math:`A_i'`) representing the term :math:`t_i` abstracted (resp. -generalized) with respect to the bindings in the context :math:`Γ_i`, namely -:math:`t_i'=λ Γ_i . t_i` and :math:`A_i'=∀ Γ_i , A_i`. - - -Typing rule -+++++++++++ - -The typing rule is the expected one for a fixpoint. - -.. inference:: Fix - - (E[Γ] ⊢ A_i : s_i )_{i=1… n} - (E[Γ;~f_1 :A_1 ;~…;~f_n :A_n ] ⊢ t_i : A_i )_{i=1… n} - ------------------------------------------------------- - E[Γ] ⊢ \Fix~f_i\{f_1 :A_1 :=t_1 … f_n :A_n :=t_n \} : A_i - - -Any fixpoint definition cannot be accepted because non-normalizing -terms allow proofs of absurdity. The basic scheme of recursion that -should be allowed is the one needed for defining primitive recursive -functionals. In that case the fixpoint enjoys a special syntactic -restriction, namely one of the arguments belongs to an inductive type, -the function starts with a case analysis and recursive calls are done -on variables coming from patterns and representing subterms. For -instance in the case of natural numbers, a proof of the induction -principle of type - -.. math:: - ∀ P:\nat→\Prop,~(P~\nO)→(∀ n:\nat,~(P~n)→(P~(\nS~n)))→ ∀ n:\nat,~(P~n) - -can be represented by the term: - -.. math:: - \begin{array}{l} - λ P:\nat→\Prop.~λ f:(P~\nO).~λ g:(∀ n:\nat,~(P~n)→(P~(\nS~n))).\\ - \Fix~h\{h:∀ n:\nat,~(P~n):=λ n:\nat.~\case(n,P,f | λp:\nat.~(g~p~(h~p)))\} - \end{array} - -Before accepting a fixpoint definition as being correctly typed, we -check that the definition is “guarded”. A precise analysis of this -notion can be found in :cite:`Gim94`. The first stage is to precise on which -argument the fixpoint will be decreasing. The type of this argument -should be an inductive type. For doing this, the syntax of -fixpoints is extended and becomes - -.. math:: - \Fix~f_i\{f_1/k_1 :A_1:=t_1 … f_n/k_n :A_n:=t_n\} - - -where :math:`k_i` are positive integers. Each :math:`k_i` represents the index of -parameter of :math:`f_i`, on which :math:`f_i` is decreasing. Each :math:`A_i` should be a -type (reducible to a term) starting with at least :math:`k_i` products -:math:`∀ y_1 :B_1 ,~… ∀ y_{k_i} :B_{k_i} ,~A_i'` and :math:`B_{k_i}` an inductive type. - -Now in the definition :math:`t_i`, if :math:`f_j` occurs then it should be applied to -at least :math:`k_j` arguments and the :math:`k_j`-th argument should be -syntactically recognized as structurally smaller than :math:`y_{k_i}`. - -The definition of being structurally smaller is a bit technical. One -needs first to define the notion of *recursive arguments of a -constructor*. For an inductive definition :math:`\ind{r}{Γ_I}{Γ_C}`, if the -type of a constructor :math:`c` has the form -:math:`∀ p_1 :P_1 ,~… ∀ p_r :P_r,~∀ x_1:T_1,~… ∀ x_m :T_m,~(I_j~p_1 … p_r~t_1 … t_s )`, -then the recursive -arguments will correspond to :math:`T_i` in which one of the :math:`I_l` occurs. - -The main rules for being structurally smaller are the following. -Given a variable :math:`y` of an inductively defined type in a declaration -:math:`\ind{r}{Γ_I}{Γ_C}` where :math:`Γ_I` is :math:`[I_1 :A_1 ;~…;~I_k :A_k]`, and :math:`Γ_C` is -:math:`[c_1 :C_1 ;~…;~c_n :C_n ]`, the terms structurally smaller than :math:`y` are: - - -+ :math:`(t~u)` and :math:`λ x:U .~t` when :math:`t` is structurally smaller than :math:`y`. -+ :math:`\case(c,P,f_1 … f_n)` when each :math:`f_i` is structurally smaller than :math:`y`. - If :math:`c` is :math:`y` or is structurally smaller than :math:`y`, its type is an inductive - type :math:`I_p` part of the inductive definition corresponding to :math:`y`. - Each :math:`f_i` corresponds to a type of constructor - :math:`C_q ≡ ∀ p_1 :P_1 ,~…,∀ p_r :P_r ,~∀ y_1 :B_1 ,~… ∀ y_m :B_m ,~(I_p~p_1 … p_r~t_1 … t_s )` - and can consequently be written :math:`λ y_1 :B_1' .~… λ y_m :B_m'.~g_i`. (:math:`B_i'` is - obtained from :math:`B_i` by substituting parameters for variables) the variables - :math:`y_j` occurring in :math:`g_i` corresponding to recursive arguments :math:`B_i` (the - ones in which one of the :math:`I_l` occurs) are structurally smaller than :math:`y`. - - -The following definitions are correct, we enter them using the :cmd:`Fixpoint` -command and show the internal representation. - -.. example:: - - .. coqtop:: all - - Fixpoint plus (n m:nat) {struct n} : nat := - match n with - | O => m - | S p => S (plus p m) - end. - - Print plus. - Fixpoint lgth (A:Set) (l:list A) {struct l} : nat := - match l with - | nil _ => O - | cons _ a l' => S (lgth A l') - end. - Print lgth. - Fixpoint sizet (t:tree) : nat := let (f) := t in S (sizef f) - with sizef (f:forest) : nat := - match f with - | emptyf => O - | consf t f => plus (sizet t) (sizef f) - end. - Print sizet. - -.. _Reduction-rule: - -Reduction rule -++++++++++++++ - -Let :math:`F` be the set of declarations: -:math:`f_1 /k_1 :A_1 :=t_1 …f_n /k_n :A_n:=t_n`. -The reduction for fixpoints is: - -.. math:: - (\Fix~f_i \{F\}~a_1 …a_{k_i}) ~\triangleright_ι~ \subst{t_i}{f_k}{\Fix~f_k \{F\}}_{k=1… n} ~a_1 … a_{k_i} - -when :math:`a_{k_i}` starts with a constructor. This last restriction is needed -in order to keep strong normalization and corresponds to the reduction -for primitive recursive operators. The following reductions are now -possible: - -.. math:: - :nowrap: - - \begin{eqnarray*} - \plus~(\nS~(\nS~\nO))~(\nS~\nO)~& \trii & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ - & \trii & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ - & \trii & \nS~(\nS~(\nS~\nO))\\ - \end{eqnarray*} - -.. _Mutual-induction: - -**Mutual induction** - -The principles of mutual induction can be automatically generated -using the Scheme command described in Section :ref:`proofschemes-induction-principles`. - - .. _Admissible-rules-for-global-environments: Admissible rules for global environments @@ -2039,16 +519,6 @@ One can consequently derive the following property. \WF{E;E′}{Γ} -.. _Co-inductive-types: - -Co-inductive types ----------------------- - -The implementation contains also co-inductive definitions, which are -types inhabited by infinite objects. More information on co-inductive -definitions can be found in :cite:`Gimenez95b,Gim98,GimCas05`. - - .. _The-Calculus-of-Inductive-Construction-with-impredicative-Set: The Calculus of Inductive Constructions with impredicative Set diff --git a/doc/sphinx/language/core/assumptions.rst b/doc/sphinx/language/core/assumptions.rst new file mode 100644 index 0000000000..9943e0aa76 --- /dev/null +++ b/doc/sphinx/language/core/assumptions.rst @@ -0,0 +1,186 @@ +Functions and assumptions +========================= + +.. _binders: + +Binders +------- + +.. insertprodn open_binders binder + +.. prodn:: + open_binders ::= {+ @name } : @term + | {+ @binder } + name ::= _ + | @ident + binder ::= @name + | ( {+ @name } : @type ) + | ( @name {? : @type } := @term ) + | @implicit_binders + | @generalizing_binder + | ( @name : @type %| @term ) + | ' @pattern0 + +Various constructions such as :g:`fun`, :g:`forall`, :g:`fix` and :g:`cofix` +*bind* variables. A binding is represented by an identifier. If the binding +variable is not used in the expression, the identifier can be replaced by the +symbol :g:`_`. When the type of a bound variable cannot be synthesized by the +system, it can be specified with the notation :n:`(@ident : @type)`. There is also +a notation for a sequence of binding variables sharing the same type: +:n:`({+ @ident} : @type)`. A +binder can also be any pattern prefixed by a quote, e.g. :g:`'(x,y)`. + +Some constructions allow the binding of a variable to value. This is +called a “let-binder”. The entry :n:`@binder` of the grammar accepts +either an assumption binder as defined above or a let-binder. The notation in +the latter case is :n:`(@ident := @term)`. In a let-binder, only one +variable can be introduced at the same time. It is also possible to give +the type of the variable as follows: +:n:`(@ident : @type := @term)`. + +Lists of :n:`@binder`\s are allowed. In the case of :g:`fun` and :g:`forall`, +it is intended that at least one binder of the list is an assumption otherwise +fun and forall gets identical. Moreover, parentheses can be omitted in +the case of a single sequence of bindings sharing the same type (e.g.: +:g:`fun (x y z : A) => t` can be shortened in :g:`fun x y z : A => t`). + +.. index:: fun ... => ... + +Abstractions: fun +----------------- + +.. insertprodn term_forall_or_fun term_forall_or_fun + +.. prodn:: + term_forall_or_fun ::= forall @open_binders , @term + | fun @open_binders => @term + +The expression :n:`fun @ident : @type => @term` defines the +*abstraction* of the variable :n:`@ident`, of type :n:`@type`, over the term +:n:`@term`. It denotes a function of the variable :n:`@ident` that evaluates to +the expression :n:`@term` (e.g. :g:`fun x : A => x` denotes the identity +function on type :g:`A`). The keyword :g:`fun` can be followed by several +binders as given in Section :ref:`binders`. Functions over +several variables are equivalent to an iteration of one-variable +functions. For instance the expression +:n:`fun {+ @ident__i } : @type => @term` +denotes the same function as :n:`{+ fun @ident__i : @type => } @term`. If +a let-binder occurs in +the list of binders, it is expanded to a let-in definition (see +Section :ref:`let-in`). + +.. index:: forall + +Products: forall +---------------- + +The expression :n:`forall @ident : @type, @term` denotes the +*product* of the variable :n:`@ident` of type :n:`@type`, over the term :n:`@term`. +As for abstractions, :g:`forall` is followed by a binder list, and products +over several variables are equivalent to an iteration of one-variable +products. Note that :n:`@term` is intended to be a type. + +If the variable :n:`@ident` occurs in :n:`@term`, the product is called +*dependent product*. The intention behind a dependent product +:g:`forall x : A, B` is twofold. It denotes either +the universal quantification of the variable :g:`x` of type :g:`A` +in the proposition :g:`B` or the functional dependent product from +:g:`A` to :g:`B` (a construction usually written +:math:`\Pi_{x:A}.B` in set theory). + +Non dependent product types have a special notation: :g:`A -> B` stands for +:g:`forall _ : A, B`. The *non dependent product* is used both to denote +the propositional implication and function types. + +Applications +------------ + +.. insertprodn term_application arg + +.. prodn:: + term_application ::= @term1 {+ @arg } + | @ @qualid_annotated {+ @term1 } + arg ::= ( @ident := @term ) + | @term1 + +:n:`@term__fun @term` denotes applying the function :n:`@term__fun` to :token:`term`. + +:n:`@term__fun {+ @term__i }` denotes applying +:n:`@term__fun` to the arguments :n:`@term__i`. It is +equivalent to :n:`( … ( @term__fun @term__1 ) … ) @term__n`: +associativity is to the left. + +The notation :n:`(@ident := @term)` for arguments is used for making +explicit the value of implicit arguments (see +Section :ref:`explicit-applications`). + +.. _gallina-assumptions: + +Assumptions +----------- + +Assumptions extend the environment with axioms, parameters, hypotheses +or variables. An assumption binds an :n:`@ident` to a :n:`@type`. It is accepted +by Coq if and only if this :n:`@type` is a correct type in the environment +preexisting the declaration and if :n:`@ident` was not previously defined in +the same module. This :n:`@type` is considered to be the type (or +specification, or statement) assumed by :n:`@ident` and we say that :n:`@ident` +has type :n:`@type`. + +.. _Axiom: + +.. cmd:: @assumption_token {? Inline {? ( @num ) } } {| {+ ( @assumpt ) } | @assumpt } + :name: Axiom; Axioms; Conjecture; Conjectures; Hypothesis; Hypotheses; Parameter; Parameters; Variable; Variables + + .. insertprodn assumption_token of_type + + .. prodn:: + assumption_token ::= {| Axiom | Axioms } + | {| Conjecture | Conjectures } + | {| Parameter | Parameters } + | {| Hypothesis | Hypotheses } + | {| Variable | Variables } + assumpt ::= {+ @ident_decl } @of_type + ident_decl ::= @ident {? @univ_decl } + of_type ::= {| : | :> | :>> } @type + + These commands bind one or more :n:`@ident`\(s) to specified :n:`@type`\(s) as their specifications in + the global context. The fact asserted by the :n:`@type` (or, equivalently, the existence + of an object of this type) is accepted as a postulate. + + :cmd:`Axiom`, :cmd:`Conjecture`, :cmd:`Parameter` and their plural forms + are equivalent. They can take the :attr:`local` :term:`attribute`, + which makes the defined :n:`@ident`\s accessible by :cmd:`Import` and its variants + only through their fully qualified names. + + Similarly, :cmd:`Hypothesis`, :cmd:`Variable` and their plural forms are equivalent. Outside + of a section, these are equivalent to :n:`Local Parameter`. Inside a section, the + :n:`@ident`\s defined are only accessible within the section. When the current section + is closed, the :n:`@ident`\(s) become undefined and every object depending on them will be explicitly + parameterized (i.e., the variables are *discharged*). See Section :ref:`section-mechanism`. + + The :n:`Inline` clause is only relevant inside functors. See :cmd:`Module`. + +.. example:: Simple assumptions + + .. coqtop:: reset in + + Parameter X Y : Set. + Parameter (R : X -> Y -> Prop) (S : Y -> X -> Prop). + Axiom R_S_inv : forall x y, R x y <-> S y x. + +.. exn:: @ident already exists. + :name: @ident already exists. (Axiom) + :undocumented: + +.. warn:: @ident is declared as a local axiom + + Warning generated when using :cmd:`Variable` or its equivalent + instead of :n:`Local Parameter` or its equivalent. + +.. note:: + We advise using the commands :cmd:`Axiom`, :cmd:`Conjecture` and + :cmd:`Hypothesis` (and their plural forms) for logical postulates (i.e. when + the assertion :n:`@type` is of sort :g:`Prop`), and to use the commands + :cmd:`Parameter` and :cmd:`Variable` (and their plural forms) in other cases + (corresponding to the declaration of an abstract object of the given type). diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 250a0f0326..68900aa0be 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -267,7 +267,7 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types Intuitively, types may be viewed as sets containing terms. We say that a type is :gdef:`inhabited` if it contains at least one term (i.e. if we can find a term which is associated with this - type). We call such terms :gdef:`witness`\es. Note that deciding + type). We call such terms :gdef:`witnesses <witness>`. Note that deciding whether a type is inhabited is `undecidable <https://en.wikipedia.org/wiki/Undecidable_problem>`_. diff --git a/doc/sphinx/language/core/coinductive.rst b/doc/sphinx/language/core/coinductive.rst new file mode 100644 index 0000000000..c034b7f302 --- /dev/null +++ b/doc/sphinx/language/core/coinductive.rst @@ -0,0 +1,201 @@ +Co-inductive types and co-recursive functions +============================================= + +.. _coinductive-types: + +Co-inductive types +------------------ + +The objects of an inductive type are well-founded with respect to the +constructors of the type. In other words, such objects contain only a +*finite* number of constructors. Co-inductive types arise from relaxing +this condition, and admitting types whose objects contain an infinity of +constructors. Infinite objects are introduced by a non-ending (but +effective) process of construction, defined in terms of the constructors +of the type. + +More information on co-inductive definitions can be found in +:cite:`Gimenez95b,Gim98,GimCas05`. + +.. cmd:: CoInductive @inductive_definition {* with @inductive_definition } + + This command introduces a co-inductive type. + The syntax of the command is the same as the command :cmd:`Inductive`. + No principle of induction is derived from the definition of a co-inductive + type, since such principles only make sense for inductive types. + For co-inductive types, the only elimination principle is case analysis. + + This command supports the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`universes(template)`, + :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, + :attr:`universes(noncumulative)` and :attr:`private(matching)` + attributes. + +.. example:: + + The type of infinite sequences of natural numbers, usually called streams, + is an example of a co-inductive type. + + .. coqtop:: in + + CoInductive Stream : Set := Seq : nat -> Stream -> Stream. + + The usual destructors on streams :g:`hd:Stream->nat` and :g:`tl:Str->Str` + can be defined as follows: + + .. coqtop:: in + + Definition hd (x:Stream) := let (a,s) := x in a. + Definition tl (x:Stream) := let (a,s) := x in s. + +Definitions of co-inductive predicates and blocks of mutually +co-inductive definitions are also allowed. + +.. example:: + + The extensional equality on streams is an example of a co-inductive type: + + .. coqtop:: in + + CoInductive EqSt : Stream -> Stream -> Prop := + eqst : forall s1 s2:Stream, + hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2. + + In order to prove the extensional equality of two streams :g:`s1` and :g:`s2` + we have to construct an infinite proof of equality, that is, an infinite + object of type :g:`(EqSt s1 s2)`. We will see how to introduce infinite + objects in Section :ref:`cofixpoint`. + +Caveat +~~~~~~ + +The ability to define co-inductive types by constructors, hereafter called +*positive co-inductive types*, is known to break subject reduction. The story is +a bit long: this is due to dependent pattern-matching which implies +propositional η-equality, which itself would require full η-conversion for +subject reduction to hold, but full η-conversion is not acceptable as it would +make type checking undecidable. + +Since the introduction of primitive records in Coq 8.5, an alternative +presentation is available, called *negative co-inductive types*. This consists +in defining a co-inductive type as a primitive record type through its +projections. Such a technique is akin to the *co-pattern* style that can be +found in e.g. Agda, and preserves subject reduction. + +The above example can be rewritten in the following way. + +.. coqtop:: none + + Reset Stream. + +.. coqtop:: all + + Set Primitive Projections. + CoInductive Stream : Set := Seq { hd : nat; tl : Stream }. + CoInductive EqSt (s1 s2: Stream) : Prop := eqst { + eqst_hd : hd s1 = hd s2; + eqst_tl : EqSt (tl s1) (tl s2); + }. + +Some properties that hold over positive streams are lost when going to the +negative presentation, typically when they imply equality over streams. +For instance, propositional η-equality is lost when going to the negative +presentation. It is nonetheless logically consistent to recover it through an +axiom. + +.. coqtop:: all + + Axiom Stream_eta : forall s: Stream, s = Seq (hd s) (tl s). + +More generally, as in the case of positive coinductive types, it is consistent +to further identify extensional equality of coinductive types with propositional +equality: + +.. coqtop:: all + + Axiom Stream_ext : forall (s1 s2: Stream), EqSt s1 s2 -> s1 = s2. + +As of Coq 8.9, it is now advised to use negative co-inductive types rather than +their positive counterparts. + +.. seealso:: + :ref:`primitive_projections` for more information about negative + records and primitive projections. + +.. index:: + single: cofix + +Co-recursive functions: cofix +----------------------------- + +.. insertprodn term_cofix cofix_body + +.. prodn:: + term_cofix ::= let cofix @cofix_body in @term + | cofix @cofix_body {? {+ with @cofix_body } for @ident } + cofix_body ::= @ident {* @binder } {? : @type } := @term + +The expression +":n:`cofix @ident__1 @binder__1 : @type__1 with … with @ident__n @binder__n : @type__n for @ident__i`" +denotes the :math:`i`-th component of a block of terms defined by a mutual guarded +co-recursion. It is the local counterpart of the :cmd:`CoFixpoint` command. When +:math:`n=1`, the ":n:`for @ident__i`" clause is omitted. + +.. _cofixpoint: + +Top-level definitions of co-recursive functions +----------------------------------------------- + +.. cmd:: CoFixpoint @cofix_definition {* with @cofix_definition } + + .. insertprodn cofix_definition cofix_definition + + .. prodn:: + cofix_definition ::= @ident_decl {* @binder } {? : @type } {? := @term } {? @decl_notations } + + This command introduces a method for constructing an infinite object of a + coinductive type. For example, the stream containing all natural numbers can + be introduced applying the following method to the number :g:`O` (see + Section :ref:`coinductive-types` for the definition of :g:`Stream`, :g:`hd` + and :g:`tl`): + + .. coqtop:: all + + CoFixpoint from (n:nat) : Stream := Seq n (from (S n)). + + Unlike recursive definitions, there is no decreasing argument in a + co-recursive definition. To be admissible, a method of construction must + provide at least one extra constructor of the infinite object for each + iteration. A syntactical guard condition is imposed on co-recursive + definitions in order to ensure this: each recursive call in the + definition must be protected by at least one constructor, and only by + constructors. That is the case in the former definition, where the single + recursive call of :g:`from` is guarded by an application of :g:`Seq`. + On the contrary, the following recursive function does not satisfy the + guard condition: + + .. coqtop:: all + + Fail CoFixpoint filter (p:nat -> bool) (s:Stream) : Stream := + if p (hd s) then Seq (hd s) (filter p (tl s)) else filter p (tl s). + + The elimination of co-recursive definition is done lazily, i.e. the + definition is expanded only when it occurs at the head of an application + which is the argument of a case analysis expression. In any other + context, it is considered as a canonical expression which is completely + evaluated. We can test this using the command :cmd:`Eval`, which computes + the normal forms of a term: + + .. coqtop:: all + + Eval compute in (from 0). + Eval compute in (hd (from 0)). + Eval compute in (tl (from 0)). + + As in the :cmd:`Fixpoint` command, the :n:`with` clause allows simultaneously + defining several mutual cofixpoints. + + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. + In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant + for which the computational behavior is relevant. See :ref:`proof-editing-mode`. diff --git a/doc/sphinx/language/core/conversion.rst b/doc/sphinx/language/core/conversion.rst new file mode 100644 index 0000000000..0f27b65107 --- /dev/null +++ b/doc/sphinx/language/core/conversion.rst @@ -0,0 +1,212 @@ +.. _Conversion-rules: + +Conversion rules +-------------------- + +In |Cic|, there is an internal reduction mechanism. In particular, it +can decide if two programs are *intentionally* equal (one says +*convertible*). Convertibility is described in this section. + + +.. _beta-reduction: + +β-reduction +~~~~~~~~~~~ + +We want to be able to identify some terms as we can identify the +application of a function to a given argument with its result. For +instance the identity function over a given type :math:`T` can be written +:math:`λx:T.~x`. In any global environment :math:`E` and local context +:math:`Γ`, we want to identify any object :math:`a` (of type +:math:`T`) with the application :math:`((λ x:T.~x)~a)`. We define for +this a *reduction* (or a *conversion*) rule we call :math:`β`: + +.. math:: + + E[Γ] ⊢ ((λx:T.~t)~u)~\triangleright_β~\subst{t}{x}{u} + +We say that :math:`\subst{t}{x}{u}` is the *β-contraction* of +:math:`((λx:T.~t)~u)` and, conversely, that :math:`((λ x:T.~t)~u)` is the +*β-expansion* of :math:`\subst{t}{x}{u}`. + +According to β-reduction, terms of the *Calculus of Inductive +Constructions* enjoy some fundamental properties such as confluence, +strong normalization, subject reduction. These results are +theoretically of great importance but we will not detail them here and +refer the interested reader to :cite:`Coq85`. + + +.. _iota-reduction: + +ι-reduction +~~~~~~~~~~~ + +A specific conversion rule is associated to the inductive objects in +the global environment. We shall give later on (see Section +:ref:`Well-formed-inductive-definitions`) the precise rules but it +just says that a destructor applied to an object built from a +constructor behaves as expected. This reduction is called ι-reduction +and is more precisely studied in :cite:`Moh93,Wer94`. + + +.. _delta-reduction: + +δ-reduction +~~~~~~~~~~~ + +We may have variables defined in local contexts or constants defined +in the global environment. It is legal to identify such a reference +with its value, that is to expand (or unfold) it into its value. This +reduction is called δ-reduction and shows as follows. + +.. inference:: Delta-Local + + \WFE{\Gamma} + (x:=t:T) ∈ Γ + -------------- + E[Γ] ⊢ x~\triangleright_Δ~t + +.. inference:: Delta-Global + + \WFE{\Gamma} + (c:=t:T) ∈ E + -------------- + E[Γ] ⊢ c~\triangleright_δ~t + + +.. _zeta-reduction: + +ζ-reduction +~~~~~~~~~~~ + +|Coq| allows also to remove local definitions occurring in terms by +replacing the defined variable by its value. The declaration being +destroyed, this reduction differs from δ-reduction. It is called +ζ-reduction and shows as follows. + +.. inference:: Zeta + + \WFE{\Gamma} + \WTEG{u}{U} + \WTE{\Gamma::(x:=u:U)}{t}{T} + -------------- + E[Γ] ⊢ \letin{x}{u:U}{t}~\triangleright_ζ~\subst{t}{x}{u} + + +.. _eta-expansion: + +η-expansion +~~~~~~~~~~~ + +Another important concept is η-expansion. It is legal to identify any +term :math:`t` of functional type :math:`∀ x:T,~U` with its so-called η-expansion + +.. math:: + λx:T.~(t~x) + +for :math:`x` an arbitrary variable name fresh in :math:`t`. + + +.. note:: + + We deliberately do not define η-reduction: + + .. math:: + λ x:T.~(t~x)~\not\triangleright_η~t + + This is because, in general, the type of :math:`t` need not to be convertible + to the type of :math:`λ x:T.~(t~x)`. E.g., if we take :math:`f` such that: + + .. math:: + f ~:~ ∀ x:\Type(2),~\Type(1) + + then + + .. math:: + λ x:\Type(1).~(f~x) ~:~ ∀ x:\Type(1),~\Type(1) + + We could not allow + + .. math:: + λ x:\Type(1).~(f~x) ~\triangleright_η~ f + + 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: + +Convertibility +~~~~~~~~~~~~~~ + +Let us write :math:`E[Γ] ⊢ t \triangleright u` for the contextual closure of the +relation :math:`t` reduces to :math:`u` in the global environment +:math:`E` and local context :math:`Γ` with one of the previous +reductions β, δ, ι or ζ. + +We say that two terms :math:`t_1` and :math:`t_2` are +*βδιζη-convertible*, or simply *convertible*, or *equivalent*, in the +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 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'` +and :math:`u_1 x` is recursively convertible to :math:`u_2'`. We then write +:math:`E[Γ] ⊢ t_1 =_{βδιζη} t_2`. + +Apart from this we consider two instances of polymorphic and +cumulative (see Chapter :ref:`polymorphicuniverses`) inductive types +(see below) convertible + +.. math:: + E[Γ] ⊢ t~w_1 … w_m =_{βδιζη} t~w_1' … w_m' + +if we have subtypings (see below) in both directions, i.e., + +.. math:: + E[Γ] ⊢ t~w_1 … w_m ≤_{βδιζη} t~w_1' … w_m' + +and + +.. math:: + E[Γ] ⊢ t~w_1' … w_m' ≤_{βδιζη} t~w_1 … w_m. + +Furthermore, we consider + +.. math:: + E[Γ] ⊢ c~v_1 … v_m =_{βδιζη} c'~v_1' … v_m' + +convertible if + +.. math:: + E[Γ] ⊢ v_i =_{βδιζη} v_i' + +and we have that :math:`c` and :math:`c'` +are the same constructors of different instances of the same inductive +types (differing only in universe levels) such that + +.. math:: + E[Γ] ⊢ c~v_1 … v_m : t~w_1 … w_m + +and + +.. math:: + E[Γ] ⊢ c'~v_1' … v_m' : t'~ w_1' … w_m ' + +and we have + +.. math:: + E[Γ] ⊢ t~w_1 … w_m =_{βδιζη} t~w_1' … w_m'. + +The convertibility relation allows introducing a new typing rule which +says that two convertible well-formed types have the same inhabitants. diff --git a/doc/sphinx/language/core/definitions.rst b/doc/sphinx/language/core/definitions.rst new file mode 100644 index 0000000000..0e637e5aa3 --- /dev/null +++ b/doc/sphinx/language/core/definitions.rst @@ -0,0 +1,204 @@ +Definitions +=========== + +.. index:: let ... := ... (term) + +.. _let-in: + +Let-in definitions +------------------ + +.. insertprodn term_let term_let + +.. prodn:: + term_let ::= let @name {? : @type } := @term in @term + | let @name {+ @binder } {? : @type } := @term in @term + | let ( {*, @name } ) {? {? as @name } return @term100 } := @term in @term + | let ' @pattern := @term {? return @term100 } in @term + | let ' @pattern in @pattern := @term return @term100 in @term + +:n:`let @ident := @term in @term’` +denotes the local binding of :n:`@term` to the variable +:n:`@ident` in :n:`@term`’. There is a syntactic sugar for let-in +definition of functions: :n:`let @ident {+ @binder} := @term in @term’` +stands for :n:`let @ident := fun {+ @binder} => @term in @term’`. + +.. index:: + single: ... : ... (type cast) + single: ... <: ... + single: ... <<: ... + +Type cast +--------- + +.. insertprodn term_cast term_cast + +.. prodn:: + term_cast ::= @term10 <: @term + | @term10 <<: @term + | @term10 : @term + | @term10 :> + +The expression :n:`@term : @type` is a type cast expression. It enforces +the type of :n:`@term` to be :n:`@type`. + +:n:`@term <: @type` locally sets up the virtual machine for checking that +:n:`@term` has type :n:`@type`. + +:n:`@term <<: @type` uses native compilation for checking that :n:`@term` +has type :n:`@type`. + +.. _gallina-definitions: + +Top-level definitions +--------------------- + +Definitions extend the environment with associations of names to terms. +A definition can be seen as a way to give a meaning to a name or as a +way to abbreviate a term. In any case, the name can later be replaced at +any time by its definition. + +The operation of unfolding a name into its definition is called +:math:`\delta`-conversion (see Section :ref:`delta-reduction`). A +definition is accepted by the system if and only if the defined term is +well-typed in the current context of the definition and if the name is +not already used. The name defined by the definition is called a +*constant* and the term it refers to is its *body*. A definition has a +type which is the type of its body. + +A formal presentation of constants and environments is given in +Section :ref:`typing-rules`. + +.. cmd:: {| Definition | Example } @ident_decl @def_body + :name: Definition; Example + + .. insertprodn def_body reduce + + .. prodn:: + def_body ::= {* @binder } {? : @type } := {? @reduce } @term + | {* @binder } : @type + reduce ::= Eval @red_expr in + + These commands bind :n:`@term` to the name :n:`@ident` in the environment, + provided that :n:`@term` is well-typed. They can take the :attr:`local` :term:`attribute`, + which makes the defined :n:`@ident` accessible by :cmd:`Import` and its variants + only through their fully qualified names. + If :n:`@reduce` is present then :n:`@ident` is bound to the result of the specified + computation on :n:`@term`. + + These commands also support the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`program` and + :attr:`canonical` attributes. + + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. + In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant + for which the computational behavior is relevant. See :ref:`proof-editing-mode`. + + The form :n:`Definition @ident : @type := @term` checks that the type of :n:`@term` + is definitionally equal to :n:`@type`, and registers :n:`@ident` as being of type + :n:`@type`, and bound to value :n:`@term`. + + The form :n:`Definition @ident {* @binder } : @type := @term` is equivalent to + :n:`Definition @ident : forall {* @binder }, @type := fun {* @binder } => @term`. + + .. seealso:: :cmd:`Opaque`, :cmd:`Transparent`, :tacn:`unfold`. + + .. exn:: @ident already exists. + :name: @ident already exists. (Definition) + :undocumented: + + .. exn:: The term @term has type @type while it is expected to have type @type'. + :undocumented: + +.. _Assertions: + +Assertions and proofs +--------------------- + +An assertion states a proposition (or a type) of which the proof (or an +inhabitant of the type) is interactively built using tactics. The interactive +proof mode is described in Chapter :ref:`proofhandling` and the tactics in +Chapter :ref:`Tactics`. The basic assertion command is: + +.. cmd:: @thm_token @ident_decl {* @binder } : @type {* with @ident_decl {* @binder } : @type } + :name: Theorem; Lemma; Fact; Remark; Corollary; Proposition; Property + + .. insertprodn thm_token thm_token + + .. prodn:: + thm_token ::= Theorem + | Lemma + | Fact + | Remark + | Corollary + | Proposition + | Property + + After the statement is asserted, Coq needs a proof. Once a proof of + :n:`@type` under the assumptions represented by :n:`@binder`\s is given and + validated, the proof is generalized into a proof of :n:`forall {* @binder }, @type` and + the theorem is bound to the name :n:`@ident` in the environment. + + Forms using the :n:`with` clause are useful for theorems that are proved by simultaneous induction + over a mutually inductive assumption, or that assert mutually dependent + statements in some mutual co-inductive type. It is equivalent to + :cmd:`Fixpoint` or :cmd:`CoFixpoint` but using tactics to build the proof of + the statements (or the body of the specification, depending on the point of + view). The inductive or co-inductive types on which the induction or + coinduction has to be done is assumed to be non ambiguous and is guessed by + the system. + + Like in a :cmd:`Fixpoint` or :cmd:`CoFixpoint` definition, the induction hypotheses + have to be used on *structurally smaller* arguments (for a :cmd:`Fixpoint`) or + be *guarded by a constructor* (for a :cmd:`CoFixpoint`). The verification that + recursive proof arguments are correct is done only at the time of registering + the lemma in the environment. To know if the use of induction hypotheses is + correct at some time of the interactive development of a proof, use the + command :cmd:`Guarded`. + + .. exn:: The term @term has type @type which should be Set, Prop or Type. + :undocumented: + + .. exn:: @ident already exists. + :name: @ident already exists. (Theorem) + + The name you provided is already defined. You have then to choose + another name. + + .. exn:: Nested proofs are not allowed unless you turn the Nested Proofs Allowed flag on. + + You are asserting a new statement while already being in proof editing mode. + This feature, called nested proofs, is disabled by default. + To activate it, turn the :flag:`Nested Proofs Allowed` flag on. + +Proofs start with the keyword :cmd:`Proof`. Then Coq enters the proof editing mode +until the proof is completed. In proof editing mode, the user primarily enters +tactics, which are described in chapter :ref:`Tactics`. The user may also enter +commands to manage the proof editing mode. They are described in Chapter +:ref:`proofhandling`. + +When the proof is complete, use the :cmd:`Qed` command so the kernel verifies +the proof and adds it to the environment. + +.. note:: + + #. Several statements can be simultaneously asserted provided the + :flag:`Nested Proofs Allowed` flag was turned on. + + #. Not only other assertions but any vernacular command can be given + while in the process of proving a given assertion. In this case, the + command is understood as if it would have been given before the + statements still to be proved. Nonetheless, this practice is discouraged + and may stop working in future versions. + + #. Proofs ended by :cmd:`Qed` are declared opaque. Their content cannot be + unfolded (see :ref:`performingcomputations`), thus + realizing some form of *proof-irrelevance*. To be able to unfold a + proof, the proof should be ended by :cmd:`Defined`. + + #. :cmd:`Proof` is recommended but can currently be omitted. On the opposite + side, :cmd:`Qed` (or :cmd:`Defined`) is mandatory to validate a proof. + + #. One can also use :cmd:`Admitted` in place of :cmd:`Qed` to turn the + current asserted statement into an axiom and exit the proof editing mode. diff --git a/doc/sphinx/language/core/index.rst b/doc/sphinx/language/core/index.rst index 5e83672463..de780db267 100644 --- a/doc/sphinx/language/core/index.rst +++ b/doc/sphinx/language/core/index.rst @@ -34,10 +34,17 @@ will have to check their output. :maxdepth: 1 basic - ../gallina-specification-language + sorts + assumptions + definitions + conversion ../cic + variants records + inductive + coinductive + sections + modules + primitive ../../addendum/universe-polymorphism ../../addendum/sprop - sections - ../module-system diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst new file mode 100644 index 0000000000..4cdfba146a --- /dev/null +++ b/doc/sphinx/language/core/inductive.rst @@ -0,0 +1,1722 @@ +Inductive types and recursive functions +======================================= + +.. _gallina-inductive-definitions: + +Inductive types +--------------- + +.. cmd:: Inductive @inductive_definition {* with @inductive_definition } + + .. insertprodn inductive_definition constructor + + .. prodn:: + inductive_definition ::= {? > } @ident_decl {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } + constructors_or_record ::= {? %| } {+| @constructor } + | {? @ident } %{ {*; @record_field } %} + constructor ::= @ident {* @binder } {? @of_type } + + This command defines one or more + inductive types and its constructors. Coq generates destructors + depending on the universe that the inductive type belongs to. + + The destructors are named :n:`@ident`\ ``_rect``, :n:`@ident`\ ``_ind``, + :n:`@ident`\ ``_rec`` and :n:`@ident`\ ``_sind``, which + respectively correspond to elimination principles on :g:`Type`, :g:`Prop`, + :g:`Set` and :g:`SProp`. The type of the destructors + expresses structural induction/recursion principles over objects of + type :n:`@ident`. The constant :n:`@ident`\ ``_ind`` is always + generated, whereas :n:`@ident`\ ``_rec`` and :n:`@ident`\ ``_rect`` + may be impossible to derive (for example, when :n:`@ident` is a + proposition). + + This command supports the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`universes(template)`, + :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, + :attr:`universes(noncumulative)` and :attr:`private(matching)` + attributes. + + Mutually inductive types can be defined by including multiple :n:`@inductive_definition`\s. + The :n:`@ident`\s are simultaneously added to the environment before the types of constructors are checked. + Each :n:`@ident` can be used independently thereafter. + See :ref:`mutually_inductive_types`. + + If the entire inductive definition is parameterized with :n:`@binder`\s, the parameters correspond + to a local context in which the entire set of inductive declarations is interpreted. + For this reason, the parameters must be strictly the same for each inductive type. + See :ref:`parametrized-inductive-types`. + + Constructor :n:`@ident`\s can come with :n:`@binder`\s, in which case + the actual type of the constructor is :n:`forall {* @binder }, @type`. + + .. exn:: Non strictly positive occurrence of @ident in @type. + + The types of the constructors have to satisfy a *positivity condition* + (see Section :ref:`positivity`). This condition ensures the soundness of + the inductive definition. The positivity checking can be disabled using + the :flag:`Positivity Checking` flag (see :ref:`controlling-typing-flags`). + + .. exn:: The conclusion of @type is not valid; it must be built from @ident. + + The conclusion of the type of the constructors must be the inductive type + :n:`@ident` being defined (or :n:`@ident` applied to arguments in + the case of annotated inductive types — cf. next section). + +The following subsections show examples of simple inductive types, +simple annotated inductive types, simple parametric inductive types, +mutually inductive types and private (matching) inductive types. + +.. _simple-inductive-types: + +Simple inductive types +~~~~~~~~~~~~~~~~~~~~~~ + +A simple inductive type belongs to a universe that is a simple :n:`@sort`. + +.. example:: + + The set of natural numbers is defined as: + + .. coqtop:: reset all + + Inductive nat : Set := + | O : nat + | S : nat -> nat. + + The type nat is defined as the least :g:`Set` containing :g:`O` and closed by + the :g:`S` constructor. The names :g:`nat`, :g:`O` and :g:`S` are added to the + environment. + + This definition generates four elimination principles: + :g:`nat_rect`, :g:`nat_ind`, :g:`nat_rec` and :g:`nat_sind`. The type of :g:`nat_ind` is: + + .. coqtop:: all + + Check nat_ind. + + This is the well known structural induction principle over natural + numbers, i.e. the second-order form of Peano’s induction principle. It + allows proving universal properties of natural numbers (:g:`forall + n:nat, P n`) by induction on :g:`n`. + + The types of :g:`nat_rect`, :g:`nat_rec` and :g:`nat_sind` are similar, except that they + apply to, respectively, :g:`(P:nat->Type)`, :g:`(P:nat->Set)` and :g:`(P:nat->SProp)`. They correspond to + primitive induction principles (allowing dependent types) respectively + over sorts ```Type``, ``Set`` and ``SProp``. + +In the case where inductive types don't have annotations (the next section +gives an example of annotations), a constructor can be defined +by giving the type of its arguments alone. + +.. example:: + + .. coqtop:: reset none + + Reset nat. + + .. coqtop:: in + + Inductive nat : Set := O | S (_:nat). + +Simple annotated inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In annotated inductive types, the universe where the inductive type +is defined is no longer a simple :n:`@sort`, but what is called an arity, +which is a type whose conclusion is a :n:`@sort`. + +.. example:: + + As an example of annotated inductive types, let us define the + :g:`even` predicate: + + .. coqtop:: all + + Inductive even : nat -> Prop := + | even_0 : even O + | even_SS : forall n:nat, even n -> even (S (S n)). + + The type :g:`nat->Prop` means that :g:`even` is a unary predicate (inductively + defined) over natural numbers. The type of its two constructors are the + defining clauses of the predicate :g:`even`. The type of :g:`even_ind` is: + + .. coqtop:: all + + Check even_ind. + + From a mathematical point of view, this asserts that the natural numbers satisfying + the predicate :g:`even` are exactly in the smallest set of naturals satisfying the + clauses :g:`even_0` or :g:`even_SS`. This is why, when we want to prove any + predicate :g:`P` over elements of :g:`even`, it is enough to prove it for :g:`O` + and to prove that if any natural number :g:`n` satisfies :g:`P` its double + successor :g:`(S (S n))` satisfies also :g:`P`. This is analogous to the + structural induction principle we got for :g:`nat`. + +.. _parametrized-inductive-types: + +Parameterized inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In the previous example, each constructor introduces a different +instance of the predicate :g:`even`. In some cases, all the constructors +introduce the same generic instance of the inductive definition, in +which case, instead of an annotation, we use a context of parameters +which are :n:`@binder`\s shared by all the constructors of the definition. + +Parameters differ from inductive type annotations in that the +conclusion of each type of constructor invokes the inductive type with +the same parameter values of its specification. + +.. example:: + + A typical example is the definition of polymorphic lists: + + .. coqtop:: all + + Inductive list (A:Set) : Set := + | nil : list A + | cons : A -> list A -> list A. + + In the type of :g:`nil` and :g:`cons`, we write ":g:`list A`" and not + just ":g:`list`". The constructors :g:`nil` and :g:`cons` have these types: + + .. coqtop:: all + + Check nil. + Check cons. + + Observe that the destructors are also quantified with :g:`(A:Set)`, for example: + + .. coqtop:: all + + Check list_ind. + + Once again, the types of the constructor arguments and of the conclusion can be omitted: + + .. coqtop:: none + + Reset list. + + .. coqtop:: in + + Inductive list (A:Set) : Set := nil | cons (_:A) (_:list A). + +.. note:: + + The constructor type can + recursively invoke the inductive definition on an argument which is not + the parameter itself. + + One can define : + + .. coqtop:: all + + Inductive list2 (A:Set) : Set := + | nil2 : list2 A + | cons2 : A -> list2 (A*A) -> list2 A. + + that can also be written by specifying only the type of the arguments: + + .. coqtop:: all reset + + Inductive list2 (A:Set) : Set := + | nil2 + | cons2 (_:A) (_:list2 (A*A)). + + But the following definition will give an error: + + .. coqtop:: all + + Fail Inductive listw (A:Set) : Set := + | nilw : listw (A*A) + | consw : A -> listw (A*A) -> listw (A*A). + + because the conclusion of the type of constructors should be :g:`listw A` + in both cases. + + + A parameterized inductive definition can be defined using annotations + instead of parameters but it will sometimes give a different (bigger) + sort for the inductive definition and will produce a less convenient + rule for case elimination. + +.. flag:: Uniform Inductive Parameters + + When this flag is set (it is off by default), + inductive definitions are abstracted over their parameters + before type checking constructors, allowing to write: + + .. coqtop:: all + + Set Uniform Inductive Parameters. + Inductive list3 (A:Set) : Set := + | nil3 : list3 + | cons3 : A -> list3 -> list3. + + This behavior is essentially equivalent to starting a new section + and using :cmd:`Context` to give the uniform parameters, like so + (cf. :ref:`section-mechanism`): + + .. coqtop:: all reset + + Section list3. + Context (A:Set). + Inductive list3 : Set := + | nil3 : list3 + | cons3 : A -> list3 -> list3. + End list3. + + For finer control, you can use a ``|`` between the uniform and + the non-uniform parameters: + + .. coqtop:: in reset + + Inductive Acc {A:Type} (R:A->A->Prop) | (x:A) : Prop + := Acc_in : (forall y, R y x -> Acc y) -> Acc x. + + The flag can then be seen as deciding whether the ``|`` is at the + beginning (when the flag is unset) or at the end (when it is set) + of the parameters when not explicitly given. + +.. seealso:: + Section :ref:`inductive-definitions` and the :tacn:`induction` tactic. + +.. _mutually_inductive_types: + +Mutually defined inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. example:: Mutually defined inductive types + + A typical example of mutually inductive data types is trees and + forests. We assume two types :g:`A` and :g:`B` that are given as variables. The types can + be declared like this: + + .. coqtop:: in + + Parameters A B : Set. + + Inductive tree : Set := node : A -> forest -> tree + + with forest : Set := + | leaf : B -> forest + | cons : tree -> forest -> forest. + + This declaration automatically generates eight induction principles. They are not the most + general principles, but they correspond to each inductive part seen as a single inductive definition. + + To illustrate this point on our example, here are the types of :g:`tree_rec` + and :g:`forest_rec`. + + .. coqtop:: all + + Check tree_rec. + + Check forest_rec. + + Assume we want to parameterize our mutual inductive definitions with the + two type variables :g:`A` and :g:`B`, the declaration should be + done as follows: + + .. coqdoc:: + + Inductive tree (A B:Set) : Set := node : A -> forest A B -> tree A B + + with forest (A B:Set) : Set := + | leaf : B -> forest A B + | cons : tree A B -> forest A B -> forest A B. + + Assume we define an inductive definition inside a section + (cf. :ref:`section-mechanism`). When the section is closed, the variables + declared in the section and occurring free in the declaration are added as + parameters to the inductive definition. + +.. seealso:: + A generic command :cmd:`Scheme` is useful to build automatically various + mutual induction principles. + +.. index:: + single: fix + +Recursive functions: fix +------------------------ + +.. insertprodn term_fix fixannot + +.. prodn:: + term_fix ::= let fix @fix_body in @term + | fix @fix_body {? {+ with @fix_body } for @ident } + fix_body ::= @ident {* @binder } {? @fixannot } {? : @type } := @term + fixannot ::= %{ struct @ident %} + | %{ wf @one_term @ident %} + | %{ measure @one_term {? @ident } {? @one_term } %} + + +The expression ":n:`fix @ident__1 @binder__1 : @type__1 := @term__1 with … with @ident__n @binder__n : @type__n := @term__n for @ident__i`" denotes the +:math:`i`-th component of a block of functions defined by mutual structural +recursion. It is the local counterpart of the :cmd:`Fixpoint` command. When +:math:`n=1`, the ":n:`for @ident__i`" clause is omitted. + +The association of a single fixpoint and a local definition have a special +syntax: :n:`let fix @ident {* @binder } := @term in` stands for +:n:`let @ident := fix @ident {* @binder } := @term in`. The same applies for co-fixpoints. + +Some options of :n:`@fixannot` are only supported in specific constructs. :n:`fix` and :n:`let fix` +only support the :n:`struct` option, while :n:`wf` and :n:`measure` are only supported in +commands such as :cmd:`Function` and :cmd:`Program Fixpoint`. + +.. _Fixpoint: + +Top-level recursive functions +----------------------------- + +This section describes the primitive form of definition by recursion over +inductive objects. See the :cmd:`Function` command for more advanced +constructions. + +.. cmd:: Fixpoint @fix_definition {* with @fix_definition } + + .. insertprodn fix_definition fix_definition + + .. prodn:: + fix_definition ::= @ident_decl {* @binder } {? @fixannot } {? : @type } {? := @term } {? @decl_notations } + + This command allows defining functions by pattern matching over inductive + objects using a fixed point construction. The meaning of this declaration is + to define :n:`@ident` as a recursive function with arguments specified by + the :n:`@binder`\s such that :n:`@ident` applied to arguments + corresponding to these :n:`@binder`\s has type :n:`@type`, and is + equivalent to the expression :n:`@term`. The type of :n:`@ident` is + consequently :n:`forall {* @binder }, @type` and its value is equivalent + to :n:`fun {* @binder } => @term`. + + To be accepted, a :cmd:`Fixpoint` definition has to satisfy syntactical + constraints on a special argument called the decreasing argument. They + are needed to ensure that the :cmd:`Fixpoint` definition always terminates. + The point of the :n:`{struct @ident}` annotation (see :n:`@fixannot`) is to + let the user tell the system which argument decreases along the recursive calls. + + The :n:`{struct @ident}` annotation may be left implicit, in which case the + system successively tries arguments from left to right until it finds one + that satisfies the decreasing condition. + + :cmd:`Fixpoint` without the :attr:`program` attribute does not support the + :n:`wf` or :n:`measure` clauses of :n:`@fixannot`. + + The :n:`with` clause allows simultaneously defining several mutual fixpoints. + It is especially useful when defining functions over mutually defined + inductive types. Example: :ref:`Mutual Fixpoints<example_mutual_fixpoints>`. + + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. + In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant + for which the computational behavior is relevant. See :ref:`proof-editing-mode`. + + .. note:: + + + Some fixpoints may have several arguments that fit as decreasing + arguments, and this choice influences the reduction of the fixpoint. + Hence an explicit annotation must be used if the leftmost decreasing + argument is not the desired one. Writing explicit annotations can also + speed up type checking of large mutual fixpoints. + + + In order to keep the strong normalization property, the fixed point + reduction will only be performed when the argument in position of the + decreasing argument (which type should be in an inductive definition) + starts with a constructor. + + + .. example:: + + One can define the addition function as : + + .. coqtop:: all + + Fixpoint add (n m:nat) {struct n} : nat := + match n with + | O => m + | S p => S (add p m) + end. + + The match operator matches a value (here :g:`n`) with the various + constructors of its (inductive) type. The remaining arguments give the + respective values to be returned, as functions of the parameters of the + corresponding constructor. Thus here when :g:`n` equals :g:`O` we return + :g:`m`, and when :g:`n` equals :g:`(S p)` we return :g:`(S (add p m))`. + + The match operator is formally described in + Section :ref:`match-construction`. + The system recognizes that in the inductive call :g:`(add p m)` the first + argument actually decreases because it is a *pattern variable* coming + from :g:`match n with`. + + .. example:: + + The following definition is not correct and generates an error message: + + .. coqtop:: all + + Fail Fixpoint wrongplus (n m:nat) {struct n} : nat := + match m with + | O => n + | S p => S (wrongplus n p) + end. + + because the declared decreasing argument :g:`n` does not actually + decrease in the recursive call. The function computing the addition over + the second argument should rather be written: + + .. coqtop:: all + + Fixpoint plus (n m:nat) {struct m} : nat := + match m with + | O => n + | S p => S (plus n p) + end. + + .. example:: + + The recursive call may not only be on direct subterms of the recursive + variable :g:`n` but also on a deeper subterm and we can directly write + the function :g:`mod2` which gives the remainder modulo 2 of a natural + number. + + .. coqtop:: all + + Fixpoint mod2 (n:nat) : nat := + match n with + | O => O + | S p => match p with + | O => S O + | S q => mod2 q + end + end. + +.. _example_mutual_fixpoints: + + .. example:: Mutual fixpoints + + The size of trees and forests can be defined the following way: + + .. coqtop:: all + + Fixpoint tree_size (t:tree) : nat := + match t with + | node a f => S (forest_size f) + end + with forest_size (f:forest) : nat := + match f with + | leaf b => 1 + | cons t f' => (tree_size t + forest_size f') + end. + +.. extracted from CIC chapter + +.. _inductive-definitions: + +Theory of inductive definitions +------------------------------- + +Formally, we can represent any *inductive definition* as +:math:`\ind{p}{Γ_I}{Γ_C}` where: + ++ :math:`Γ_I` determines the names and types of inductive types; ++ :math:`Γ_C` determines the names and types of constructors of these + inductive types; ++ :math:`p` determines the number of parameters of these inductive types. + + +These inductive definitions, together with global assumptions and +global definitions, then form the global environment. Additionally, +for any :math:`p` there always exists :math:`Γ_P =[a_1 :A_1 ;~…;~a_p :A_p ]` such that +each :math:`T` in :math:`(t:T)∈Γ_I \cup Γ_C` can be written as: :math:`∀Γ_P , T'` where :math:`Γ_P` is +called the *context of parameters*. Furthermore, we must have that +each :math:`T` in :math:`(t:T)∈Γ_I` can be written as: :math:`∀Γ_P,∀Γ_{\mathit{Arr}(t)}, S` where +:math:`Γ_{\mathit{Arr}(t)}` is called the *Arity* of the inductive type :math:`t` and :math:`S` is called +the sort of the inductive type :math:`t` (not to be confused with :math:`\Sort` which is the set of sorts). + +.. example:: + + The declaration for parameterized lists is: + + .. math:: + \ind{1}{[\List:\Set→\Set]}{\left[\begin{array}{rcl} + \Nil & : & ∀ A:\Set,~\List~A \\ + \cons & : & ∀ A:\Set,~A→ \List~A→ \List~A + \end{array} + \right]} + + which corresponds to the result of the |Coq| declaration: + + .. coqtop:: in reset + + Inductive list (A:Set) : Set := + | nil : list A + | cons : A -> list A -> list A. + +.. example:: + + The declaration for a mutual inductive definition of tree and forest + is: + + .. math:: + \ind{0}{\left[\begin{array}{rcl}\tree&:&\Set\\\forest&:&\Set\end{array}\right]} + {\left[\begin{array}{rcl} + \node &:& \forest → \tree\\ + \emptyf &:& \forest\\ + \consf &:& \tree → \forest → \forest\\ + \end{array}\right]} + + which corresponds to the result of the |Coq| declaration: + + .. coqtop:: in + + Inductive tree : Set := + | node : forest -> tree + with forest : Set := + | emptyf : forest + | consf : tree -> forest -> forest. + +.. example:: + + The declaration for a mutual inductive definition of even and odd is: + + .. math:: + \ind{0}{\left[\begin{array}{rcl}\even&:&\nat → \Prop \\ + \odd&:&\nat → \Prop \end{array}\right]} + {\left[\begin{array}{rcl} + \evenO &:& \even~0\\ + \evenS &:& ∀ n,~\odd~n → \even~(\nS~n)\\ + \oddS &:& ∀ n,~\even~n → \odd~(\nS~n) + \end{array}\right]} + + which corresponds to the result of the |Coq| declaration: + + .. coqtop:: in + + Inductive even : nat -> Prop := + | even_O : even 0 + | even_S : forall n, odd n -> even (S n) + with odd : nat -> Prop := + | odd_S : forall n, even n -> odd (S n). + + + +.. _Types-of-inductive-objects: + +Types of inductive objects +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We have to give the type of constants in a global environment :math:`E` which +contains an inductive definition. + +.. inference:: Ind + + \WFE{Γ} + \ind{p}{Γ_I}{Γ_C} ∈ E + (a:A)∈Γ_I + --------------------- + E[Γ] ⊢ a : A + +.. inference:: Constr + + \WFE{Γ} + \ind{p}{Γ_I}{Γ_C} ∈ E + (c:C)∈Γ_C + --------------------- + E[Γ] ⊢ c : C + +.. example:: + + Provided that our environment :math:`E` contains inductive definitions we showed before, + these two inference rules above enable us to conclude that: + + .. math:: + \begin{array}{l} + E[Γ] ⊢ \even : \nat→\Prop\\ + E[Γ] ⊢ \odd : \nat→\Prop\\ + E[Γ] ⊢ \evenO : \even~\nO\\ + E[Γ] ⊢ \evenS : ∀ n:\nat,~\odd~n → \even~(\nS~n)\\ + E[Γ] ⊢ \oddS : ∀ n:\nat,~\even~n → \odd~(\nS~n) + \end{array} + + + + +.. _Well-formed-inductive-definitions: + +Well-formed inductive definitions +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We cannot accept any inductive definition because some of them lead +to inconsistent systems. We restrict ourselves to definitions which +satisfy a syntactic criterion of positivity. Before giving the formal +rules, we need a few definitions: + +Arity of a given sort ++++++++++++++++++++++ + +A type :math:`T` is an *arity of sort* :math:`s` if it converts to the sort :math:`s` or to a +product :math:`∀ x:T,~U` with :math:`U` an arity of sort :math:`s`. + +.. example:: + + :math:`A→\Set` is an arity of sort :math:`\Set`. :math:`∀ A:\Prop,~A→ \Prop` is an arity of sort + :math:`\Prop`. + + +Arity ++++++ +A type :math:`T` is an *arity* if there is a :math:`s∈ \Sort` such that :math:`T` is an arity of +sort :math:`s`. + + +.. example:: + + :math:`A→ \Set` and :math:`∀ A:\Prop,~A→ \Prop` are arities. + + +Type of constructor ++++++++++++++++++++ +We say that :math:`T` is a *type of constructor of* :math:`I` in one of the following +two cases: + ++ :math:`T` is :math:`(I~t_1 … t_n )` ++ :math:`T` is :math:`∀ x:U,~T'` where :math:`T'` is also a type of constructor of :math:`I` + +.. example:: + + :math:`\nat` and :math:`\nat→\nat` are types of constructor of :math:`\nat`. + :math:`∀ A:\Type,~\List~A` and :math:`∀ A:\Type,~A→\List~A→\List~A` are types of constructor of :math:`\List`. + +.. _positivity: + +Positivity Condition +++++++++++++++++++++ + +The type of constructor :math:`T` will be said to *satisfy the positivity +condition* for a constant :math:`X` in the following cases: + ++ :math:`T=(X~t_1 … t_n )` and :math:`X` does not occur free in any :math:`t_i` ++ :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` + satisfies the positivity condition for :math:`X`. + +Strict positivity ++++++++++++++++++ + +The constant :math:`X` *occurs strictly positively* in :math:`T` in the following +cases: + + ++ :math:`X` does not occur in :math:`T` ++ :math:`T` converts to :math:`(X~t_1 … t_n )` and :math:`X` does not occur in any of :math:`t_i` ++ :math:`T` converts to :math:`∀ x:U,~V` and :math:`X` does not occur in type :math:`U` but occurs + strictly positively in type :math:`V` ++ :math:`T` converts to :math:`(I~a_1 … a_m~t_1 … t_p )` where :math:`I` is the name of an + inductive definition of the form + + .. math:: + \ind{m}{I:A}{c_1 :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_1 ;~…;~c_n :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_n} + + (in particular, it is + not mutually defined and it has :math:`m` parameters) and :math:`X` does not occur in + any of the :math:`t_i`, and the (instantiated) types of constructor + :math:`\subst{C_i}{p_j}{a_j}_{j=1… m}` of :math:`I` satisfy the nested positivity condition for :math:`X` + +Nested Positivity ++++++++++++++++++ + +The type of constructor :math:`T` of :math:`I` *satisfies the nested positivity +condition* for a constant :math:`X` in the following cases: + ++ :math:`T=(I~b_1 … b_m~u_1 … u_p)`, :math:`I` is an inductive type with :math:`m` + parameters and :math:`X` does not occur in any :math:`u_i` ++ :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` + satisfies the nested positivity condition for :math:`X` + + +.. example:: + + For instance, if one considers the following variant of a tree type + branching over the natural numbers: + + .. coqtop:: in + + Inductive nattree (A:Type) : Type := + | leaf : nattree A + | natnode : A -> (nat -> nattree A) -> nattree A. + + Then every instantiated constructor of ``nattree A`` satisfies the nested positivity + condition for ``nattree``: + + + Type ``nattree A`` of constructor ``leaf`` satisfies the positivity condition for + ``nattree`` because ``nattree`` does not appear in any (real) arguments of the + type of that constructor (primarily because ``nattree`` does not have any (real) + arguments) ... (bullet 1) + + + Type ``A → (nat → nattree A) → nattree A`` of constructor ``natnode`` satisfies the + positivity condition for ``nattree`` because: + + - ``nattree`` occurs only strictly positively in ``A`` ... (bullet 1) + + - ``nattree`` occurs only strictly positively in ``nat → nattree A`` ... (bullet 3 + 2) + + - ``nattree`` satisfies the positivity condition for ``nattree A`` ... (bullet 1) + +.. _Correctness-rules: + +Correctness rules ++++++++++++++++++ + +We shall now describe the rules allowing the introduction of a new +inductive definition. + +Let :math:`E` be a global environment and :math:`Γ_P`, :math:`Γ_I`, :math:`Γ_C` be contexts +such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k]`, and +:math:`Γ_C` is :math:`[c_1:∀ Γ_P ,C_1 ;~…;~c_n :∀ Γ_P ,C_n ]`. Then + +.. inference:: W-Ind + + \WFE{Γ_P} + (E[Γ_I ;Γ_P ] ⊢ C_i : s_{q_i} )_{i=1… n} + ------------------------------------------ + \WF{E;~\ind{p}{Γ_I}{Γ_C}}{} + + +provided that the following side conditions hold: + + + :math:`k>0` and all of :math:`I_j` and :math:`c_i` are distinct names for :math:`j=1… k` and :math:`i=1… n`, + + :math:`p` is the number of parameters of :math:`\ind{p}{Γ_I}{Γ_C}` and :math:`Γ_P` is the + context of parameters, + + for :math:`j=1… k` we have that :math:`A_j` is an arity of sort :math:`s_j` and :math:`I_j ∉ E`, + + for :math:`i=1… n` we have that :math:`C_i` is a type of constructor of :math:`I_{q_i}` which + satisfies the positivity condition for :math:`I_1 … I_k` and :math:`c_i ∉ E`. + +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 +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:: + + It is well known that the existential quantifier can be encoded as an + inductive definition. The following declaration introduces the + second-order existential quantifier :math:`∃ X.P(X)`. + + .. coqtop:: in + + Inductive exProp (P:Prop->Prop) : Prop := + | exP_intro : forall X:Prop, P X -> exProp P. + + The same definition on :math:`\Set` is not allowed and fails: + + .. coqtop:: all + + Fail Inductive exSet (P:Set->Prop) : Set := + exS_intro : forall X:Set, P X -> exSet P. + + It is possible to declare the same inductive definition in the + universe :math:`\Type`. The :g:`exType` inductive definition has type + :math:`(\Type(i)→\Prop)→\Type(j)` with the constraint that the parameter :math:`X` of :math:`\kw{exT}_{\kw{intro}}` + has type :math:`\Type(k)` with :math:`k<j` and :math:`k≤ i`. + + .. coqtop:: all + + Inductive exType (P:Type->Prop) : Type := + exT_intro : forall X:Type, P X -> exType P. + + +.. example:: Negative occurrence (first example) + + The following inductive definition is rejected because it does not + satisfy the positivity condition: + + .. coqtop:: all + + Fail Inductive I : Prop := not_I_I (not_I : I -> False) : I. + + If we were to accept such definition, we could derive a + contradiction from it (we can test this by disabling the + :flag:`Positivity Checking` flag): + + .. coqtop:: none + + Unset Positivity Checking. + Inductive I : Prop := not_I_I (not_I : I -> False) : I. + Set Positivity Checking. + + .. coqtop:: all + + Definition I_not_I : I -> ~ I := fun i => + match i with not_I_I not_I => not_I end. + + .. coqtop:: in + + Lemma contradiction : False. + Proof. + enough (I /\ ~ I) as [] by contradiction. + split. + - apply not_I_I. + intro. + now apply I_not_I. + - intro. + now apply I_not_I. + Qed. + +.. example:: Negative occurrence (second example) + + Here is another example of an inductive definition which is + rejected because it does not satify the positivity condition: + + .. coqtop:: all + + Fail Inductive Lam := lam (_ : Lam -> Lam). + + Again, if we were to accept it, we could derive a contradiction + (this time through a non-terminating recursive function): + + .. coqtop:: none + + Unset Positivity Checking. + Inductive Lam := lam (_ : Lam -> Lam). + Set Positivity Checking. + + .. coqtop:: all + + Fixpoint infinite_loop l : False := + match l with lam x => infinite_loop (x l) end. + + Check infinite_loop (lam (@id Lam)) : False. + +.. example:: Non strictly positive occurrence + + It is less obvious why inductive type definitions with occurences + that are positive but not strictly positive are harmful. + We will see that in presence of an impredicative type they + are unsound: + + .. coqtop:: all + + Fail Inductive A: Type := introA: ((A -> Prop) -> Prop) -> A. + + If we were to accept this definition we could derive a contradiction + by creating an injective function from :math:`A → \Prop` to :math:`A`. + + This function is defined by composing the injective constructor of + the type :math:`A` with the function :math:`λx. λz. z = x` injecting + any type :math:`T` into :math:`T → \Prop`. + + .. coqtop:: none + + Unset Positivity Checking. + Inductive A: Type := introA: ((A -> Prop) -> Prop) -> A. + Set Positivity Checking. + + .. coqtop:: all + + Definition f (x: A -> Prop): A := introA (fun z => z = x). + + .. coqtop:: in + + Lemma f_inj: forall x y, f x = f y -> x = y. + Proof. + unfold f; intros ? ? H; injection H. + set (F := fun z => z = y); intro HF. + symmetry; replace (y = x) with (F y). + + unfold F; reflexivity. + + rewrite <- HF; reflexivity. + Qed. + + The type :math:`A → \Prop` can be understood as the powerset + of the type :math:`A`. To derive a contradiction from the + injective function :math:`f` we use Cantor's classic diagonal + argument. + + .. coqtop:: all + + Definition d: A -> Prop := fun x => exists s, x = f s /\ ~s x. + Definition fd: A := f d. + + .. coqtop:: in + + Lemma cantor: (d fd) <-> ~(d fd). + Proof. + split. + + intros [s [H1 H2]]; unfold fd in H1. + replace d with s. + * assumption. + * apply f_inj; congruence. + + intro; exists d; tauto. + Qed. + + Lemma bad: False. + Proof. + pose cantor; tauto. + Qed. + + This derivation was first presented by Thierry Coquand and Christine + Paulin in :cite:`CP90`. + +.. _Template-polymorphism: + +Template polymorphism ++++++++++++++++++++++ + +Inductive types can be made polymorphic over the universes introduced by +their parameters in :math:`\Type`, if the minimal inferred sort of the +inductive declarations either mention some of those parameter universes +or is computed to be :math:`\Prop` or :math:`\Set`. + +If :math:`A` is an arity of some sort and :math:`s` is a sort, we write :math:`A_{/s}` +for the arity obtained from :math:`A` by replacing its sort with :math:`s`. +Especially, if :math:`A` is well-typed in some global environment and local +context, then :math:`A_{/s}` is typable by typability of all products in the +Calculus of Inductive Constructions. The following typing rule is +added to the theory. + +Let :math:`\ind{p}{Γ_I}{Γ_C}` be an inductive definition. Let +:math:`Γ_P = [p_1 :P_1 ;~…;~p_p :P_p ]` be its context of parameters, +:math:`Γ_I = [I_1:∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k ]` its context of definitions and +:math:`Γ_C = [c_1 :∀ Γ_P ,C_1 ;~…;~c_n :∀ Γ_P ,C_n]` its context of constructors, +with :math:`c_i` a constructor of :math:`I_{q_i}`. Let :math:`m ≤ p` be the length of the +longest prefix of parameters such that the :math:`m` first arguments of all +occurrences of all :math:`I_j` in all :math:`C_k` (even the occurrences in the +hypotheses of :math:`C_k`) are exactly applied to :math:`p_1 … p_m` (:math:`m` is the number +of *recursively uniform parameters* and the :math:`p−m` remaining parameters +are the *recursively non-uniform parameters*). Let :math:`q_1 , …, q_r`, with +:math:`0≤ r≤ m`, be a (possibly) partial instantiation of the recursively +uniform parameters of :math:`Γ_P`. We have: + +.. inference:: Ind-Family + + \left\{\begin{array}{l} + \ind{p}{Γ_I}{Γ_C} \in E\\ + (E[] ⊢ q_l : P'_l)_{l=1\ldots r}\\ + (E[] ⊢ P'_l ≤_{βδιζη} \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1})_{l=1\ldots r}\\ + 1 \leq j \leq k + \end{array} + \right. + ----------------------------- + E[] ⊢ I_j~q_1 … q_r :∀ [p_{r+1} :P_{r+1} ;~…;~p_p :P_p], (A_j)_{/s_j} + +provided that the following side conditions hold: + + + :math:`Γ_{P′}` is the context obtained from :math:`Γ_P` by replacing each :math:`P_l` that is + an arity with :math:`P_l'` for :math:`1≤ l ≤ r` (notice that :math:`P_l` arity implies :math:`P_l'` + arity since :math:`E[] ⊢ P_l' ≤_{βδιζη} \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}`); + + there are sorts :math:`s_i`, for :math:`1 ≤ i ≤ k` such that, for + :math:`Γ_{I'} = [I_1 :∀ Γ_{P'} ,(A_1)_{/s_1} ;~…;~I_k :∀ Γ_{P'} ,(A_k)_{/s_k}]` + we have :math:`(E[Γ_{I′} ;Γ_{P′}] ⊢ C_i : s_{q_i})_{i=1… n}` ; + + the sorts :math:`s_i` are all introduced by the inductive + declaration and have no universe constraints beside being greater + than or equal to :math:`\Prop`, and such that all + eliminations, to :math:`\Prop`, :math:`\Set` and :math:`\Type(j)`, + are allowed (see Section :ref:`Destructors`). + + +Notice that if :math:`I_j~q_1 … q_r` is typable using the rules **Ind-Const** and +**App**, then it is typable using the rule **Ind-Family**. Conversely, the +extended theory is not stronger than the theory without **Ind-Family**. We +get an equiconsistency result by mapping each :math:`\ind{p}{Γ_I}{Γ_C}` +occurring into a given derivation into as many different inductive +types and constructors as the number of different (partial) +replacements of sorts, needed for this derivation, in the parameters +that are arities (this is possible because :math:`\ind{p}{Γ_I}{Γ_C}` well-formed +implies that :math:`\ind{p}{Γ_{I'}}{Γ_{C'}}` is well-formed and has the +same allowed eliminations, where :math:`Γ_{I′}` is defined as above and +:math:`Γ_{C′} = [c_1 :∀ Γ_{P′} ,C_1 ;~…;~c_n :∀ Γ_{P′} ,C_n ]`). That is, the changes in the +types of each partial instance :math:`q_1 … q_r` can be characterized by the +ordered sets of arity sorts among the types of parameters, and to each +signature is associated a new inductive definition with fresh names. +Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or +:math:`C_i~q_1 … q_r` is mapped to the names chosen in the specific instance of +:math:`\ind{p}{Γ_I}{Γ_C}`. + +.. warning:: + + The restriction that sorts are introduced by the inductive + declaration prevents inductive types declared in sections to be + template-polymorphic on universes introduced previously in the + section: they cannot parameterize over the universes introduced with + section variables that become parameters at section closing time, as + these may be shared with other definitions from the same section + which can impose constraints on them. + +.. flag:: Auto Template Polymorphism + + This flag, enabled by default, makes every inductive type declared + at level :math:`\Type` (without annotations or hiding it behind a + definition) template polymorphic if possible. + + This can be prevented using the :attr:`universes(notemplate)` + attribute. + + Template polymorphism and full universe polymorphism (see Chapter + :ref:`polymorphicuniverses`) are incompatible, so if the latter is + enabled (through the :flag:`Universe Polymorphism` flag or the + :attr:`universes(polymorphic)` attribute) it will prevail over + automatic template polymorphism. + +.. warn:: Automatically declaring @ident as template polymorphic. + + Warning ``auto-template`` can be used (it is off by default) to + find which types are implicitly declared template polymorphic by + :flag:`Auto Template Polymorphism`. + + An inductive type can be forced to be template polymorphic using + the :attr:`universes(template)` attribute: in this case, the + warning is not emitted. + +.. attr:: universes(template) + + This attribute can be used to explicitly declare an inductive type + as template polymorphic, whether the :flag:`Auto Template + Polymorphism` flag is on or off. + + .. exn:: template and polymorphism not compatible + + This attribute cannot be used in a full universe polymorphic + context, i.e. if the :flag:`Universe Polymorphism` flag is on or + if the :attr:`universes(polymorphic)` attribute is used. + + .. exn:: Ill-formed template inductive declaration: not polymorphic on any universe. + + The attribute was used but the inductive definition does not + satisfy the criterion to be template polymorphic. + +.. attr:: universes(notemplate) + + This attribute can be used to prevent an inductive type to be + template polymorphic, even if the :flag:`Auto Template + Polymorphism` flag is on. + +In practice, the rule **Ind-Family** is used by |Coq| only when all the +inductive types of the inductive definition are declared with an arity +whose sort is in the Type hierarchy. Then, the polymorphism is over +the parameters whose type is an arity of sort in the Type hierarchy. +The sorts :math:`s_j` are chosen canonically so that each :math:`s_j` is minimal with +respect to the hierarchy :math:`\Prop ⊂ \Set_p ⊂ \Type` where :math:`\Set_p` is predicative +:math:`\Set`. More precisely, an empty or small singleton inductive definition +(i.e. an inductive definition of which all inductive types are +singleton – see Section :ref:`Destructors`) is set in :math:`\Prop`, a small non-singleton +inductive type is set in :math:`\Set` (even in case :math:`\Set` is impredicative – see +:ref:`The-Calculus-of-Inductive-Construction-with-impredicative-Set`), +and otherwise in the Type hierarchy. + +Note that the side-condition about allowed elimination sorts in the rule +**Ind-Family** avoids to recompute the allowed elimination sorts at each +instance of a pattern matching (see Section :ref:`Destructors`). As an +example, let us consider the following definition: + +.. example:: + + .. coqtop:: in + + Inductive option (A:Type) : Type := + | None : option A + | Some : A -> option A. + +As the definition is set in the Type hierarchy, it is used +polymorphically over its parameters whose types are arities of a sort +in the Type hierarchy. Here, the parameter :math:`A` has this property, hence, +if :g:`option` is applied to a type in :math:`\Set`, the result is in :math:`\Set`. Note that +if :g:`option` is applied to a type in :math:`\Prop`, then, the result is not set in +:math:`\Prop` but in :math:`\Set` still. This is because :g:`option` is not a singleton type +(see Section :ref:`Destructors`) and it would lose the elimination to :math:`\Set` and :math:`\Type` +if set in :math:`\Prop`. + +.. example:: + + .. coqtop:: all + + Check (fun A:Set => option A). + Check (fun A:Prop => option A). + +Here is another example. + +.. example:: + + .. coqtop:: in + + Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. + +As :g:`prod` is a singleton type, it will be in :math:`\Prop` if applied twice to +propositions, in :math:`\Set` if applied twice to at least one type in :math:`\Set` and +none in :math:`\Type`, and in :math:`\Type` otherwise. In all cases, the three kind of +eliminations schemes are allowed. + +.. example:: + + .. coqtop:: all + + Check (fun A:Set => prod A). + Check (fun A:Prop => prod A A). + Check (fun (A:Prop) (B:Set) => prod A B). + Check (fun (A:Type) (B:Prop) => prod A B). + +.. note:: + Template polymorphism used to be called “sort-polymorphism of + inductive types” before universe polymorphism + (see Chapter :ref:`polymorphicuniverses`) was introduced. + + +.. _Destructors: + +Destructors +~~~~~~~~~~~~~~~~~ + +The specification of inductive definitions with arities and +constructors is quite natural. But we still have to say how to use an +object in an inductive type. + +This problem is rather delicate. There are actually several different +ways to do that. Some of them are logically equivalent but not always +equivalent from the computational point of view or from the user point +of view. + +From the computational point of view, we want to be able to define a +function whose domain is an inductively defined type by using a +combination of case analysis over the possible constructors of the +object and recursion. + +Because we need to keep a consistent theory and also we prefer to keep +a strongly normalizing reduction, we cannot accept any sort of +recursion (even terminating). So the basic idea is to restrict +ourselves to primitive recursive functions and functionals. + +For instance, assuming a parameter :math:`A:\Set` exists in the local context, +we want to build a function :math:`\length` of type :math:`\List~A → \nat` which computes +the length of the list, such that :math:`(\length~(\Nil~A)) = \nO` and +:math:`(\length~(\cons~A~a~l)) = (\nS~(\length~l))`. +We want these equalities to be +recognized implicitly and taken into account in the conversion rule. + +From the logical point of view, we have built a type family by giving +a set of constructors. We want to capture the fact that we do not have +any other way to build an object in this type. So when trying to prove +a property about an object :math:`m` in an inductive type it is enough +to enumerate all the cases where :math:`m` starts with a different +constructor. + +In case the inductive definition is effectively a recursive one, we +want to capture the extra property that we have built the smallest +fixed point of this recursive equation. This says that we are only +manipulating finite objects. This analysis provides induction +principles. For instance, in order to prove +:math:`∀ l:\List~A,~(\kw{has}\_\kw{length}~A~l~(\length~l))` it is enough to prove: + + ++ :math:`(\kw{has}\_\kw{length}~A~(\Nil~A)~(\length~(\Nil~A)))` ++ :math:`∀ a:A,~∀ l:\List~A,~(\kw{has}\_\kw{length}~A~l~(\length~l)) →` + :math:`(\kw{has}\_\kw{length}~A~(\cons~A~a~l)~(\length~(\cons~A~a~l)))` + + +which given the conversion equalities satisfied by :math:`\length` is the same +as proving: + + ++ :math:`(\kw{has}\_\kw{length}~A~(\Nil~A)~\nO)` ++ :math:`∀ a:A,~∀ l:\List~A,~(\kw{has}\_\kw{length}~A~l~(\length~l)) →` + :math:`(\kw{has}\_\kw{length}~A~(\cons~A~a~l)~(\nS~(\length~l)))` + + +One conceptually simple way to do that, following the basic scheme +proposed by Martin-Löf in his Intuitionistic Type Theory, is to +introduce for each inductive definition an elimination operator. At +the logical level it is a proof of the usual induction principle and +at the computational level it implements a generic operator for doing +primitive recursion over the structure. + +But this operator is rather tedious to implement and use. We choose in +this version of |Coq| to factorize the operator for primitive recursion +into two more primitive operations as was first suggested by Th. +Coquand in :cite:`Coq92`. One is the definition by pattern matching. The +second one is a definition by guarded fixpoints. + + +.. _match-construction: + +The match ... with ... end construction ++++++++++++++++++++++++++++++++++++++++ + +The basic idea of this operator is that we have an object :math:`m` in an +inductive type :math:`I` and we want to prove a property which possibly +depends on :math:`m`. For this, it is enough to prove the property for +:math:`m = (c_i~u_1 … u_{p_i} )` for each constructor of :math:`I`. +The |Coq| term for this proof +will be written: + +.. math:: + \Match~m~\with~(c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\kwend + +In this expression, if :math:`m` eventually happens to evaluate to +:math:`(c_i~u_1 … u_{p_i})` then the expression will behave as specified in its :math:`i`-th branch +and it will reduce to :math:`f_i` where the :math:`x_{i1} …x_{ip_i}` are replaced by the +:math:`u_1 … u_{p_i}` according to the ι-reduction. + +Actually, for type checking a :math:`\Match…\with…\kwend` expression we also need +to know the predicate :math:`P` to be proved by case analysis. In the general +case where :math:`I` is an inductively defined :math:`n`-ary relation, :math:`P` is a predicate +over :math:`n+1` arguments: the :math:`n` first ones correspond to the arguments of :math:`I` +(parameters excluded), and the last one corresponds to object :math:`m`. |Coq| +can sometimes infer this predicate but sometimes not. The concrete +syntax for describing this predicate uses the :math:`\as…\In…\return` +construction. For instance, let us assume that :math:`I` is an unary predicate +with one parameter and one argument. The predicate is made explicit +using the syntax: + +.. math:: + \Match~m~\as~x~\In~I~\_~a~\return~P~\with~ + (c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … + | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\kwend + +The :math:`\as` part can be omitted if either the result type does not depend +on :math:`m` (non-dependent elimination) or :math:`m` is a variable (in this case, :math:`m` +can occur in :math:`P` where it is considered a bound variable). The :math:`\In` part +can be omitted if the result type does not depend on the arguments +of :math:`I`. Note that the arguments of :math:`I` corresponding to parameters *must* +be :math:`\_`, because the result type is not generalized to all possible +values of the parameters. The other arguments of :math:`I` (sometimes called +indices in the literature) have to be variables (:math:`a` above) and these +variables can occur in :math:`P`. The expression after :math:`\In` must be seen as an +*inductive type pattern*. Notice that expansion of implicit arguments +and notations apply to this pattern. For the purpose of presenting the +inference rules, we use a more compact notation: + +.. math:: + \case(m,(λ a x . P), λ x_{11} ... x_{1p_1} . f_1~| … |~λ x_{n1} ...x_{np_n} . f_n ) + + +.. _Allowed-elimination-sorts: + +**Allowed elimination sorts.** An important question for building the typing rule for :math:`\Match` is what +can be the type of :math:`λ a x . P` with respect to the type of :math:`m`. If :math:`m:I` +and :math:`I:A` and :math:`λ a x . P : B` then by :math:`[I:A|B]` we mean that one can use +:math:`λ a x . P` with :math:`m` in the above match-construct. + + +.. _cic_notations: + +**Notations.** The :math:`[I:A|B]` is defined as the smallest relation satisfying the +following rules: We write :math:`[I|B]` for :math:`[I:A|B]` where :math:`A` is the type of :math:`I`. + +The case of inductive types in sorts :math:`\Set` or :math:`\Type` is simple. +There is no restriction on the sort of the predicate to be eliminated. + +.. inference:: Prod + + [(I~x):A′|B′] + ----------------------- + [I:∀ x:A,~A′|∀ x:A,~B′] + + +.. inference:: Set & Type + + s_1 ∈ \{\Set,\Type(j)\} + s_2 ∈ \Sort + ---------------- + [I:s_1 |I→ s_2 ] + + +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 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 + + s ∈ \{\SProp,\Prop\} + -------------------- + [I:\Prop|I→s] + + +:math:`\Prop` is the type of logical propositions, the proofs of properties :math:`P` in +:math:`\Prop` could not be used for computation and are consequently ignored by +the extraction mechanism. Assume :math:`A` and :math:`B` are two propositions, and the +logical disjunction :math:`A ∨ B` is defined inductively by: + +.. example:: + + .. coqtop:: in + + Inductive or (A B:Prop) : Prop := + or_introl : A -> or A B | or_intror : B -> or A B. + + +The following definition which computes a boolean value by case over +the proof of :g:`or A B` is not accepted: + +.. example:: + + .. coqtop:: all + + Fail Definition choice (A B: Prop) (x:or A B) := + match x with or_introl _ _ a => true | or_intror _ _ b => false end. + +From the computational point of view, the structure of the proof of +:g:`(or A B)` in this term is needed for computing the boolean value. + +In general, if :math:`I` has type :math:`\Prop` then :math:`P` cannot have type :math:`I→\Set`, because +it will mean to build an informative proof of type :math:`(P~m)` doing a case +analysis over a non-computational object that will disappear in the +extracted program. But the other way is safe with respect to our +interpretation we can have :math:`I` a computational object and :math:`P` a +non-computational one, it just corresponds to proving a logical property +of a computational object. + +In the same spirit, elimination on :math:`P` of type :math:`I→\Type` cannot be allowed +because it trivially implies the elimination on :math:`P` of type :math:`I→ \Set` by +cumulativity. It also implies that there are two proofs of the same +property which are provably different, contradicting the +proof-irrelevance property which is sometimes a useful axiom: + +.. example:: + + .. coqtop:: all + + Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. + +The elimination of an inductive type of sort :math:`\Prop` on a predicate +:math:`P` of type :math:`I→ \Type` leads to a paradox when applied to impredicative +inductive definition like the second-order existential quantifier +:g:`exProp` defined above, because it gives access to the two projections on +this type. + + +.. _Empty-and-singleton-elimination: + +**Empty and singleton elimination.** There are special inductive definitions in +:math:`\Prop` for which more eliminations are allowed. + +.. inference:: Prop-extended + + I~\kw{is an empty or singleton definition} + s ∈ \Sort + ------------------------------------- + [I:\Prop|I→ s] + +A *singleton definition* has only one constructor and all the +arguments of this constructor have type :math:`\Prop`. In that case, there is a +canonical way to interpret the informative extraction on an object in +that type, such that the elimination on any sort :math:`s` is legal. Typical +examples are the conjunction of non-informative propositions and the +equality. If there is a hypothesis :math:`h:a=b` in the local context, it can +be used for rewriting not only in logical propositions but also in any +type. + +.. example:: + + .. coqtop:: all + + Print eq_rec. + Require Extraction. + Extraction eq_rec. + +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: + +**Type of branches.** +Let :math:`c` be a term of type :math:`C`, we assume :math:`C` is a type of constructor for an +inductive type :math:`I`. Let :math:`P` be a term that represents the property to be +proved. We assume :math:`r` is the number of parameters and :math:`s` is the number of +arguments. + +We define a new type :math:`\{c:C\}^P` which represents the type of the branch +corresponding to the :math:`c:C` constructor. + +.. math:: + \begin{array}{ll} + \{c:(I~q_1\ldots q_r\ t_1 \ldots t_s)\}^P &\equiv (P~t_1\ldots ~t_s~c) \\ + \{c:∀ x:T,~C\}^P &\equiv ∀ x:T,~\{(c~x):C\}^P + \end{array} + +We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math:`c`. + + +.. example:: + + The following term in concrete syntax:: + + match t as l return P' with + | nil _ => t1 + | cons _ hd tl => t2 + end + + + can be represented in abstract syntax as + + .. math:: + \case(t,P,f_1 | f_2 ) + + where + + .. math:: + :nowrap: + + \begin{eqnarray*} + P & = & λ l.~P^\prime\\ + f_1 & = & t_1\\ + f_2 & = & λ (hd:\nat).~λ (tl:\List~\nat).~t_2 + \end{eqnarray*} + + According to the definition: + + .. math:: + \{(\Nil~\nat)\}^P ≡ \{(\Nil~\nat) : (\List~\nat)\}^P ≡ (P~(\Nil~\nat)) + + .. math:: + + \begin{array}{rl} + \{(\cons~\nat)\}^P & ≡\{(\cons~\nat) : (\nat→\List~\nat→\List~\nat)\}^P \\ + & ≡∀ n:\nat,~\{(\cons~\nat~n) : (\List~\nat→\List~\nat)\}^P \\ + & ≡∀ n:\nat,~∀ l:\List~\nat,~\{(\cons~\nat~n~l) : (\List~\nat)\}^P \\ + & ≡∀ n:\nat,~∀ l:\List~\nat,~(P~(\cons~\nat~n~l)). + \end{array} + + Given some :math:`P` then :math:`\{(\Nil~\nat)\}^P` represents the expected type of :math:`f_1`, + and :math:`\{(\cons~\nat)\}^P` represents the expected type of :math:`f_2`. + + +.. _Typing-rule: + +**Typing rule.** +Our very general destructor for inductive definition enjoys the +following typing rule + +.. inference:: match + + \begin{array}{l} + E[Γ] ⊢ c : (I~q_1 … q_r~t_1 … t_s ) \\ + E[Γ] ⊢ P : B \\ + [(I~q_1 … q_r)|B] \\ + (E[Γ] ⊢ f_i : \{(c_{p_i}~q_1 … q_r)\}^P)_{i=1… l} + \end{array} + ------------------------------------------------ + E[Γ] ⊢ \case(c,P,f_1 |… |f_l ) : (P~t_1 … t_s~c) + +provided :math:`I` is an inductive type in a +definition :math:`\ind{r}{Γ_I}{Γ_C}` with :math:`Γ_C = [c_1 :C_1 ;~…;~c_n :C_n ]` and +:math:`c_{p_1} … c_{p_l}` are the only constructors of :math:`I`. + + + +.. example:: + + Below is a typing rule for the term shown in the previous example: + + .. inference:: list example + + \begin{array}{l} + E[Γ] ⊢ t : (\List ~\nat) \\ + E[Γ] ⊢ P : B \\ + [(\List ~\nat)|B] \\ + E[Γ] ⊢ f_1 : \{(\Nil ~\nat)\}^P \\ + E[Γ] ⊢ f_2 : \{(\cons ~\nat)\}^P + \end{array} + ------------------------------------------------ + E[Γ] ⊢ \case(t,P,f_1 |f_2 ) : (P~t) + + +.. _Definition-of-ι-reduction: + +**Definition of ι-reduction.** +We still have to define the ι-reduction in the general case. + +An ι-redex is a term of the following form: + +.. math:: + \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_l ) + +with :math:`c_{p_i}` the :math:`i`-th constructor of the inductive type :math:`I` with :math:`r` +parameters. + +The ι-contraction of this term is :math:`(f_i~a_1 … a_m )` leading to the +general reduction rule: + +.. math:: + \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_l ) \triangleright_ι (f_i~a_1 … a_m ) + + +.. _Fixpoint-definitions: + +Fixpoint definitions +~~~~~~~~~~~~~~~~~~~~ + +The second operator for elimination is fixpoint definition. This +fixpoint may involve several mutually recursive definitions. The basic +concrete syntax for a recursive set of mutually recursive declarations +is (with :math:`Γ_i` contexts): + +.. math:: + \fix~f_1 (Γ_1 ) :A_1 :=t_1~\with … \with~f_n (Γ_n ) :A_n :=t_n + + +The terms are obtained by projections from this set of declarations +and are written + +.. math:: + \fix~f_1 (Γ_1 ) :A_1 :=t_1~\with … \with~f_n (Γ_n ) :A_n :=t_n~\for~f_i + +In the inference rules, we represent such a term by + +.. math:: + \Fix~f_i\{f_1 :A_1':=t_1' … f_n :A_n':=t_n'\} + +with :math:`t_i'` (resp. :math:`A_i'`) representing the term :math:`t_i` abstracted (resp. +generalized) with respect to the bindings in the context :math:`Γ_i`, namely +:math:`t_i'=λ Γ_i . t_i` and :math:`A_i'=∀ Γ_i , A_i`. + + +Typing rule ++++++++++++ + +The typing rule is the expected one for a fixpoint. + +.. inference:: Fix + + (E[Γ] ⊢ A_i : s_i )_{i=1… n} + (E[Γ;~f_1 :A_1 ;~…;~f_n :A_n ] ⊢ t_i : A_i )_{i=1… n} + ------------------------------------------------------- + E[Γ] ⊢ \Fix~f_i\{f_1 :A_1 :=t_1 … f_n :A_n :=t_n \} : A_i + + +Any fixpoint definition cannot be accepted because non-normalizing +terms allow proofs of absurdity. The basic scheme of recursion that +should be allowed is the one needed for defining primitive recursive +functionals. In that case the fixpoint enjoys a special syntactic +restriction, namely one of the arguments belongs to an inductive type, +the function starts with a case analysis and recursive calls are done +on variables coming from patterns and representing subterms. For +instance in the case of natural numbers, a proof of the induction +principle of type + +.. math:: + ∀ P:\nat→\Prop,~(P~\nO)→(∀ n:\nat,~(P~n)→(P~(\nS~n)))→ ∀ n:\nat,~(P~n) + +can be represented by the term: + +.. math:: + \begin{array}{l} + λ P:\nat→\Prop.~λ f:(P~\nO).~λ g:(∀ n:\nat,~(P~n)→(P~(\nS~n))).\\ + \Fix~h\{h:∀ n:\nat,~(P~n):=λ n:\nat.~\case(n,P,f | λp:\nat.~(g~p~(h~p)))\} + \end{array} + +Before accepting a fixpoint definition as being correctly typed, we +check that the definition is “guarded”. A precise analysis of this +notion can be found in :cite:`Gim94`. The first stage is to precise on which +argument the fixpoint will be decreasing. The type of this argument +should be an inductive type. For doing this, the syntax of +fixpoints is extended and becomes + +.. math:: + \Fix~f_i\{f_1/k_1 :A_1:=t_1 … f_n/k_n :A_n:=t_n\} + + +where :math:`k_i` are positive integers. Each :math:`k_i` represents the index of +parameter of :math:`f_i`, on which :math:`f_i` is decreasing. Each :math:`A_i` should be a +type (reducible to a term) starting with at least :math:`k_i` products +:math:`∀ y_1 :B_1 ,~… ∀ y_{k_i} :B_{k_i} ,~A_i'` and :math:`B_{k_i}` an inductive type. + +Now in the definition :math:`t_i`, if :math:`f_j` occurs then it should be applied to +at least :math:`k_j` arguments and the :math:`k_j`-th argument should be +syntactically recognized as structurally smaller than :math:`y_{k_i}`. + +The definition of being structurally smaller is a bit technical. One +needs first to define the notion of *recursive arguments of a +constructor*. For an inductive definition :math:`\ind{r}{Γ_I}{Γ_C}`, if the +type of a constructor :math:`c` has the form +:math:`∀ p_1 :P_1 ,~… ∀ p_r :P_r,~∀ x_1:T_1,~… ∀ x_m :T_m,~(I_j~p_1 … p_r~t_1 … t_s )`, +then the recursive +arguments will correspond to :math:`T_i` in which one of the :math:`I_l` occurs. + +The main rules for being structurally smaller are the following. +Given a variable :math:`y` of an inductively defined type in a declaration +:math:`\ind{r}{Γ_I}{Γ_C}` where :math:`Γ_I` is :math:`[I_1 :A_1 ;~…;~I_k :A_k]`, and :math:`Γ_C` is +:math:`[c_1 :C_1 ;~…;~c_n :C_n ]`, the terms structurally smaller than :math:`y` are: + + ++ :math:`(t~u)` and :math:`λ x:U .~t` when :math:`t` is structurally smaller than :math:`y`. ++ :math:`\case(c,P,f_1 … f_n)` when each :math:`f_i` is structurally smaller than :math:`y`. + If :math:`c` is :math:`y` or is structurally smaller than :math:`y`, its type is an inductive + type :math:`I_p` part of the inductive definition corresponding to :math:`y`. + Each :math:`f_i` corresponds to a type of constructor + :math:`C_q ≡ ∀ p_1 :P_1 ,~…,∀ p_r :P_r ,~∀ y_1 :B_1 ,~… ∀ y_m :B_m ,~(I_p~p_1 … p_r~t_1 … t_s )` + and can consequently be written :math:`λ y_1 :B_1' .~… λ y_m :B_m'.~g_i`. (:math:`B_i'` is + obtained from :math:`B_i` by substituting parameters for variables) the variables + :math:`y_j` occurring in :math:`g_i` corresponding to recursive arguments :math:`B_i` (the + ones in which one of the :math:`I_l` occurs) are structurally smaller than :math:`y`. + + +The following definitions are correct, we enter them using the :cmd:`Fixpoint` +command and show the internal representation. + +.. example:: + + .. coqtop:: all + + Fixpoint plus (n m:nat) {struct n} : nat := + match n with + | O => m + | S p => S (plus p m) + end. + + Print plus. + Fixpoint lgth (A:Set) (l:list A) {struct l} : nat := + match l with + | nil _ => O + | cons _ a l' => S (lgth A l') + end. + Print lgth. + Fixpoint sizet (t:tree) : nat := let (f) := t in S (sizef f) + with sizef (f:forest) : nat := + match f with + | emptyf => O + | consf t f => plus (sizet t) (sizef f) + end. + Print sizet. + +.. _Reduction-rule: + +Reduction rule +++++++++++++++ + +Let :math:`F` be the set of declarations: +:math:`f_1 /k_1 :A_1 :=t_1 …f_n /k_n :A_n:=t_n`. +The reduction for fixpoints is: + +.. math:: + (\Fix~f_i \{F\}~a_1 …a_{k_i}) ~\triangleright_ι~ \subst{t_i}{f_k}{\Fix~f_k \{F\}}_{k=1… n} ~a_1 … a_{k_i} + +when :math:`a_{k_i}` starts with a constructor. This last restriction is needed +in order to keep strong normalization and corresponds to the reduction +for primitive recursive operators. The following reductions are now +possible: + +.. math:: + :nowrap: + + \begin{eqnarray*} + \plus~(\nS~(\nS~\nO))~(\nS~\nO)~& \trii & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ + & \trii & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ + & \trii & \nS~(\nS~(\nS~\nO))\\ + \end{eqnarray*} + +.. _Mutual-induction: + +**Mutual induction** + +The principles of mutual induction can be automatically generated +using the Scheme command described in Section :ref:`proofschemes-induction-principles`. diff --git a/doc/sphinx/language/core/modules.rst b/doc/sphinx/language/core/modules.rst new file mode 100644 index 0000000000..29e703c223 --- /dev/null +++ b/doc/sphinx/language/core/modules.rst @@ -0,0 +1,1012 @@ +.. _themodulesystem: + +The Module System +================= + +The module system extends the Calculus of Inductive Constructions +providing a convenient way to structure large developments as well as +a means of massive abstraction. + + +Modules and module types +---------------------------- + +**Access path.** An access path is denoted by :math:`p` and can be +either a module variable :math:`X` or, if :math:`p′` is an access path +and :math:`id` an identifier, then :math:`p′.id` is an access path. + + +**Structure element.** A structure element is denoted by :math:`e` and +is either a definition of a constant, an assumption, a definition of +an inductive, a definition of a module, an alias of a module or a module +type abbreviation. + + +**Structure expression.** A structure expression is denoted by :math:`S` and can be: + ++ an access path :math:`p` ++ a plain structure :math:`\Struct~e ; … ; e~\End` ++ a functor :math:`\Functor(X:S)~S′`, where :math:`X` is a module variable, :math:`S` and :math:`S′` are + structure expressions ++ an application :math:`S~p`, where :math:`S` is a structure expression and :math:`p` an + access path ++ a refined structure :math:`S~\with~p := p`′ or :math:`S~\with~p := t:T` where :math:`S` is a + structure expression, :math:`p` and :math:`p′` are access paths, :math:`t` is a term and :math:`T` is + the type of :math:`t`. + +**Module definition.** A module definition is written :math:`\Mod{X}{S}{S'}` +and consists of a module variable :math:`X`, a module type +:math:`S` which can be any structure expression and optionally a +module implementation :math:`S′` which can be any structure expression +except a refined structure. + + +**Module alias.** A module alias is written :math:`\ModA{X}{p}` +and consists of a module variable :math:`X` and a module path +:math:`p`. + +**Module type abbreviation.** +A module type abbreviation is written :math:`\ModType{Y}{S}`, +where :math:`Y` is an identifier and :math:`S` is any structure +expression . + +.. extracted from Gallina extensions chapter + +Using modules +------------- + +The module system provides a way of packaging related elements +together, as well as a means of massive abstraction. + + +.. cmd:: Module {? {| Import | Export } } @ident {* @module_binder } {? @of_module_type } {? := {+<+ @module_expr_inl } } + + .. insertprodn module_binder module_expr_inl + + .. prodn:: + module_binder ::= ( {? {| Import | Export } } {+ @ident } : @module_type_inl ) + module_type_inl ::= ! @module_type + | @module_type {? @functor_app_annot } + functor_app_annot ::= [ inline at level @num ] + | [ no inline ] + module_type ::= @qualid + | ( @module_type ) + | @module_type @module_expr_atom + | @module_type with @with_declaration + with_declaration ::= Definition @qualid {? @univ_decl } := @term + | Module @qualid := @qualid + module_expr_atom ::= @qualid + | ( {+ @module_expr_atom } ) + of_module_type ::= : @module_type_inl + | {* <: @module_type_inl } + module_expr_inl ::= ! {+ @module_expr_atom } + | {+ @module_expr_atom } {? @functor_app_annot } + + Defines a module named :token:`ident`. See the examples :ref:`here<module_examples>`. + + The :n:`Import` and :n:`Export` flags specify whether the module should be automatically + imported or exported. + + Specifying :n:`{* @module_binder }` starts a functor with + parameters given by the :n:`@module_binder`\s. (A *functor* is a function + from modules to modules.) + + :n:`@of_module_type` specifies the module type. :n:`{+ <: @module_type_inl }` + starts a module that satisfies each :n:`@module_type_inl`. + + .. todo: would like to find a better term than "interactive", not very descriptive + + :n:`:= {+<+ @module_expr_inl }` specifies the body of a module or functor + definition. If it's not specified, then the module is defined *interactively*, + meaning that the module is defined as a series of commands terminated with :cmd:`End` + instead of in a single :cmd:`Module` command. + Interactively defining the :n:`@module_expr_inl`\s in a series of + :cmd:`Include` commands is equivalent to giving them all in a single + non-interactive :cmd:`Module` command. + + The ! prefix indicates that any assumption command (such as :cmd:`Axiom`) with an :n:`Inline` clause + in the type of the functor arguments will be ignored. + + .. todo: What is an Inline directive? sb command but still unclear. Maybe referring to the + "inline" in functor_app_annot? or assumption_token Inline assum_list? + +.. cmd:: Module Type @ident {* @module_binder } {* <: @module_type_inl } {? := {+<+ @module_type_inl } } + + Defines a module type named :n:`@ident`. See the example :ref:`here<example_def_simple_module_type>`. + + Specifying :n:`{* @module_binder }` starts a functor type with + parameters given by the :n:`@module_binder`\s. + + :n:`:= {+<+ @module_type_inl }` specifies the body of a module or functor type + definition. If it's not specified, then the module type is defined *interactively*, + meaning that the module type is defined as a series of commands terminated with :cmd:`End` + instead of in a single :cmd:`Module Type` command. + Interactively defining the :n:`@module_type_inl`\s in a series of + :cmd:`Include` commands is equivalent to giving them all in a single + non-interactive :cmd:`Module Type` command. + +.. _terminating_module: + +**Terminating an interactive module or module type definition** + +Interactive modules are terminated with the :cmd:`End` command, which +is also used to terminate :ref:`Sections<section-mechanism>`. +:n:`End @ident` closes the interactive module or module type :token:`ident`. +If the module type was given, the command verifies that the content of the module +matches the module type. If the module is not a +functor, its components (constants, inductive types, submodules etc.) +are now available through the dot notation. + +.. exn:: No such label @ident. + :undocumented: + +.. exn:: Signature components for label @ident do not match. + :undocumented: + +.. exn:: The field @ident is missing in @qualid. + :undocumented: + +.. |br| raw:: html + + <br> + +.. note:: + + #. Interactive modules and module types can be nested. + #. Interactive modules and module types can't be defined inside of :ref:`sections<section-mechanism>`. + Sections can be defined inside of interactive modules and module types. + #. Hints and notations (:cmd:`Hint` and :cmd:`Notation` commands) can also appear inside interactive + modules and module types. Note that with module definitions like: + + :n:`Module @ident__1 : @module_type := @ident__2.` + + or + + :n:`Module @ident__1 : @module_type.` |br| + :n:`Include @ident__2.` |br| + :n:`End @ident__1.` + + hints and the like valid for :n:`@ident__1` are the ones defined in :n:`@module_type` + rather then those defined in :n:`@ident__2` (or the module body). + #. Within an interactive module type definition, the :cmd:`Parameter` command declares a + constant instead of definining a new axiom (which it does when not in a module type definition). + #. Assumptions such as :cmd:`Axiom` that include the :n:`Inline` clause will be automatically + expanded when the functor is applied, except when the function application is prefixed by ``!``. + +.. cmd:: Include @module_type_inl {* <+ @module_expr_inl } + + Includes the content of module(s) in the current + interactive module. Here :n:`@module_type_inl` can be a module expression or a module + type expression. If it is a high-order module or module type + expression then the system tries to instantiate :n:`@module_type_inl` with the current + interactive module. + + Including multiple modules is a single :cmd:`Include` is equivalent to including each module + in a separate :cmd:`Include` command. + +.. cmd:: Include Type {+<+ @module_type_inl } + + .. deprecated:: 8.3 + + Use :cmd:`Include` instead. + +.. cmd:: Declare Module {? {| Import | Export } } @ident {* @module_binder } : @module_type_inl + + Declares a module :token:`ident` of type :token:`module_type_inl`. + + If :n:`@module_binder`\s are specified, declares a functor with parameters given by the list of + :token:`module_binder`\s. + +.. cmd:: Import {+ @filtered_import } + + .. insertprodn filtered_import filtered_import + + .. prodn:: + filtered_import ::= @qualid {? ( {+, @qualid {? ( .. ) } } ) } + + If :token:`qualid` denotes a valid basic module (i.e. its module type is a + signature), makes its components available by their short names. + + .. example:: + + .. coqtop:: reset in + + Module Mod. + Definition T:=nat. + Check T. + End Mod. + Check Mod.T. + + .. coqtop:: all + + Fail Check T. + Import Mod. + Check T. + + Some features defined in modules are activated only when a module is + imported. This is for instance the case of notations (see :ref:`Notations`). + + Declarations made with the :attr:`local` attribute are never imported by the :cmd:`Import` + command. Such declarations are only accessible through their fully + qualified name. + + .. example:: + + .. coqtop:: in + + Module A. + Module B. + Local Definition T := nat. + End B. + End A. + Import A. + + .. coqtop:: all fail + + Check B.T. + + Appending a module name with a parenthesized list of names will + make only those names available with short names, not other names + defined in the module nor will it activate other features. + + The names to import may be constants, inductive types and + constructors, and notation aliases (for instance, Ltac definitions + cannot be selectively imported). If they are from an inner module + to the one being imported, they must be prefixed by the inner path. + + The name of an inductive type may also be followed by ``(..)`` to + import it, its constructors and its eliminators if they exist. For + this purpose "eliminator" means a constant in the same module whose + name is the inductive type's name suffixed by one of ``_sind``, + ``_ind``, ``_rec`` or ``_rect``. + + .. example:: + + .. coqtop:: reset in + + Module A. + Module B. + Inductive T := C. + Definition U := nat. + End B. + Definition Z := Prop. + End A. + Import A(B.T(..), Z). + + .. coqtop:: all + + Check B.T. + Check B.C. + Check Z. + Fail Check B.U. + Check A.B.U. + +.. cmd:: Export {+ @filtered_import } + :name: Export + + Similar to :cmd:`Import`, except that when the module containing this command + is imported, the :n:`{+ @qualid }` are imported as well. + + The selective import syntax also works with Export. + + .. exn:: @qualid is not a module. + :undocumented: + + .. warn:: Trying to mask the absolute name @qualid! + :undocumented: + +.. cmd:: Print Module @qualid + + Prints the module type and (optionally) the body of the module :n:`@qualid`. + +.. cmd:: Print Module Type @qualid + + Prints the module type corresponding to :n:`@qualid`. + +.. flag:: Short Module Printing + + This flag (off by default) disables the printing of the types of fields, + leaving only their names, for the commands :cmd:`Print Module` and + :cmd:`Print Module Type`. + +.. _module_examples: + +Examples +~~~~~~~~ + +.. example:: Defining a simple module interactively + + .. coqtop:: in + + Module M. + Definition T := nat. + Definition x := 0. + + .. coqtop:: all + + Definition y : bool. + exact true. + + .. coqtop:: in + + Defined. + End M. + +Inside a module one can define constants, prove theorems and do anything +else that can be done in the toplevel. Components of a closed +module can be accessed using the dot notation: + +.. coqtop:: all + + Print M.x. + +.. _example_def_simple_module_type: + +.. example:: Defining a simple module type interactively + + .. coqtop:: in + + Module Type SIG. + Parameter T : Set. + Parameter x : T. + End SIG. + +.. _example_filter_module: + +.. example:: Creating a new module that omits some items from an existing module + + Since :n:`SIG`, the type of the new module :n:`N`, doesn't define :n:`y` or + give the body of :n:`x`, which are not included in :n:`N`. + + .. coqtop:: all + + Module N : SIG with Definition T := nat := M. + Print N.T. + Print N.x. + Fail Print N.y. + + .. reset to remove N (undo in last coqtop block doesn't seem to do that), invisibly redefine M, SIG + .. coqtop:: none reset + + Module M. + Definition T := nat. + Definition x := 0. + Definition y : bool. + exact true. + Defined. + End M. + + Module Type SIG. + Parameter T : Set. + Parameter x : T. + End SIG. + +The definition of :g:`N` using the module type expression :g:`SIG` with +:g:`Definition T := nat` is equivalent to the following one: + +.. coqtop:: in + + Module Type SIG'. + Definition T : Set := nat. + Parameter x : T. + End SIG'. + + Module N : SIG' := M. + +If we just want to be sure that our implementation satisfies a +given module type without restricting the interface, we can use a +transparent constraint + +.. coqtop:: in + + Module P <: SIG := M. + +.. coqtop:: all + + Print P.y. + +.. example:: Creating a functor (a module with parameters) + + .. coqtop:: in + + Module Two (X Y: SIG). + Definition T := (X.T * Y.T)%type. + Definition x := (X.x, Y.x). + End Two. + + and apply it to our modules and do some computations: + + .. coqtop:: in + + + Module Q := Two M N. + + .. coqtop:: all + + Eval compute in (fst Q.x + snd Q.x). + +.. example:: A module type with two sub-modules, sharing some fields + + .. coqtop:: in + + Module Type SIG2. + Declare Module M1 : SIG. + Module M2 <: SIG. + Definition T := M1.T. + Parameter x : T. + End M2. + End SIG2. + + .. coqtop:: in + + Module Mod <: SIG2. + Module M1. + Definition T := nat. + Definition x := 1. + End M1. + Module M2 := M. + End Mod. + +Notice that ``M`` is a correct body for the component ``M2`` since its ``T`` +component is ``nat`` as specified for ``M1.T``. + +Typing Modules +------------------ + +In order to introduce the typing system we first slightly extend the syntactic +class of terms and environments given in section :ref:`The-terms`. The +environments, apart from definitions of constants and inductive types now also +hold any other structure elements. Terms, apart from variables, constants and +complex terms, include also access paths. + +We also need additional typing judgments: + + ++ :math:`\WFT{E}{S}`, denoting that a structure :math:`S` is well-formed, ++ :math:`\WTM{E}{p}{S}`, denoting that the module pointed by :math:`p` has type :math:`S` in + environment :math:`E`. ++ :math:`\WEV{E}{S}{\ovl{S}}`, denoting that a structure :math:`S` is evaluated to a + structure :math:`S` in weak head normal form. ++ :math:`\WS{E}{S_1}{S_2}` , denoting that a structure :math:`S_1` is a subtype of a + structure :math:`S_2`. ++ :math:`\WS{E}{e_1}{e_2}` , denoting that a structure element e_1 is more + precise than a structure element e_2. + +The rules for forming structures are the following: + +.. inference:: WF-STR + + \WF{E;E′}{} + ------------------------ + \WFT{E}{ \Struct~E′ ~\End} + +.. inference:: WF-FUN + + \WFT{E; \ModS{X}{S}}{ \ovl{S′} } + -------------------------- + \WFT{E}{ \Functor(X:S)~S′} + + +Evaluation of structures to weak head normal form: + +.. inference:: WEVAL-APP + + \begin{array}{c} + \WEV{E}{S}{\Functor(X:S_1 )~S_2}~~~~~\WEV{E}{S_1}{\ovl{S_1}} \\ + \WTM{E}{p}{S_3}~~~~~ \WS{E}{S_3}{\ovl{S_1}} + \end{array} + -------------------------- + \WEV{E}{S~p}{S_2 \{p/X,t_1 /p_1 .c_1 ,…,t_n /p_n.c_n \}} + + +In the last rule, :math:`\{t_1 /p_1 .c_1 ,…,t_n /p_n .c_n \}` is the resulting +substitution from the inlining mechanism. We substitute in :math:`S` the +inlined fields :math:`p_i .c_i` from :math:`\ModS{X}{S_1 }` by the corresponding delta- +reduced term :math:`t_i` in :math:`p`. + +.. inference:: WEVAL-WITH-MOD + + \begin{array}{c} + E[] ⊢ S \lra \Struct~e_1 ;…;e_i ; \ModS{X}{S_1 };e_{i+2} ;… ;e_n ~\End \\ + E;e_1 ;…;e_i [] ⊢ S_1 \lra \ovl{S_1} ~~~~~~ + E[] ⊢ p : S_2 \\ + E;e_1 ;…;e_i [] ⊢ S_2 <: \ovl{S_1} + \end{array} + ---------------------------------- + \begin{array}{c} + \WEV{E}{S~\with~x := p}{}\\ + \Struct~e_1 ;…;e_i ; \ModA{X}{p};e_{i+2} \{p/X\} ;…;e_n \{p/X\} ~\End + \end{array} + +.. inference:: WEVAL-WITH-MOD-REC + + \begin{array}{c} + \WEV{E}{S}{\Struct~e_1 ;…;e_i ; \ModS{X_1}{S_1 };e_{i+2} ;… ;e_n ~\End} \\ + \WEV{E;e_1 ;…;e_i }{S_1~\with~p := p_1}{\ovl{S_2}} + \end{array} + -------------------------- + \begin{array}{c} + \WEV{E}{S~\with~X_1.p := p_1}{} \\ + \Struct~e_1 ;…;e_i ; \ModS{X}{\ovl{S_2}};e_{i+2} \{p_1 /X_1.p\} ;…;e_n \{p_1 /X_1.p\} ~\End + \end{array} + +.. inference:: WEVAL-WITH-DEF + + \begin{array}{c} + \WEV{E}{S}{\Struct~e_1 ;…;e_i ;\Assum{}{c}{T_1};e_{i+2} ;… ;e_n ~\End} \\ + \WS{E;e_1 ;…;e_i }{Def()(c:=t:T)}{\Assum{}{c}{T_1}} + \end{array} + -------------------------- + \begin{array}{c} + \WEV{E}{S~\with~c := t:T}{} \\ + \Struct~e_1 ;…;e_i ;Def()(c:=t:T);e_{i+2} ;… ;e_n ~\End + \end{array} + +.. inference:: WEVAL-WITH-DEF-REC + + \begin{array}{c} + \WEV{E}{S}{\Struct~e_1 ;…;e_i ; \ModS{X_1 }{S_1 };e_{i+2} ;… ;e_n ~\End} \\ + \WEV{E;e_1 ;…;e_i }{S_1~\with~p := p_1}{\ovl{S_2}} + \end{array} + -------------------------- + \begin{array}{c} + \WEV{E}{S~\with~X_1.p := t:T}{} \\ + \Struct~e_1 ;…;e_i ; \ModS{X}{\ovl{S_2} };e_{i+2} ;… ;e_n ~\End + \end{array} + +.. inference:: WEVAL-PATH-MOD1 + + \begin{array}{c} + \WEV{E}{p}{\Struct~e_1 ;…;e_i ; \Mod{X}{S}{S_1};e_{i+2} ;… ;e_n End} \\ + \WEV{E;e_1 ;…;e_i }{S}{\ovl{S}} + \end{array} + -------------------------- + E[] ⊢ p.X \lra \ovl{S} + +.. inference:: WEVAL-PATH-MOD2 + + \WF{E}{} + \Mod{X}{S}{S_1}∈ E + \WEV{E}{S}{\ovl{S}} + -------------------------- + \WEV{E}{X}{\ovl{S}} + +.. inference:: WEVAL-PATH-ALIAS1 + + \begin{array}{c} + \WEV{E}{p}{~\Struct~e_1 ;…;e_i ; \ModA{X}{p_1};e_{i+2} ;… ;e_n End} \\ + \WEV{E;e_1 ;…;e_i }{p_1}{\ovl{S}} + \end{array} + -------------------------- + \WEV{E}{p.X}{\ovl{S}} + +.. inference:: WEVAL-PATH-ALIAS2 + + \WF{E}{} + \ModA{X}{p_1 }∈ E + \WEV{E}{p_1}{\ovl{S}} + -------------------------- + \WEV{E}{X}{\ovl{S}} + +.. inference:: WEVAL-PATH-TYPE1 + + \begin{array}{c} + \WEV{E}{p}{~\Struct~e_1 ;…;e_i ; \ModType{Y}{S};e_{i+2} ;… ;e_n End} \\ + \WEV{E;e_1 ;…;e_i }{S}{\ovl{S}} + \end{array} + -------------------------- + \WEV{E}{p.Y}{\ovl{S}} + +.. inference:: WEVAL-PATH-TYPE2 + + \WF{E}{} + \ModType{Y}{S}∈ E + \WEV{E}{S}{\ovl{S}} + -------------------------- + \WEV{E}{Y}{\ovl{S}} + + +Rules for typing module: + +.. inference:: MT-EVAL + + \WEV{E}{p}{\ovl{S}} + -------------------------- + E[] ⊢ p : \ovl{S} + +.. inference:: MT-STR + + E[] ⊢ p : S + -------------------------- + E[] ⊢ p : S/p + + +The last rule, called strengthening is used to make all module fields +manifestly equal to themselves. The notation :math:`S/p` has the following +meaning: + + ++ if :math:`S\lra~\Struct~e_1 ;…;e_n ~\End` then :math:`S/p=~\Struct~e_1 /p;…;e_n /p ~\End` + where :math:`e/p` is defined as follows (note that opaque definitions are processed + as assumptions): + + + :math:`\Def{}{c}{t}{T}/p = \Def{}{c}{t}{T}` + + :math:`\Assum{}{c}{U}/p = \Def{}{c}{p.c}{U}` + + :math:`\ModS{X}{S}/p = \ModA{X}{p.X}` + + :math:`\ModA{X}{p′}/p = \ModA{X}{p′}` + + :math:`\Ind{}{Γ_P}{Γ_C}{Γ_I}/p = \Indp{}{Γ_P}{Γ_C}{Γ_I}{p}` + + :math:`\Indpstr{}{Γ_P}{Γ_C}{Γ_I}{p'}{p} = \Indp{}{Γ_P}{Γ_C}{Γ_I}{p'}` + ++ if :math:`S \lra \Functor(X:S′)~S″` then :math:`S/p=S` + + +The notation :math:`\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}` +denotes an inductive definition that is definitionally equal to the +inductive definition in the module denoted by the path :math:`p`. All rules +which have :math:`\Ind{}{Γ_P}{Γ_C}{Γ_I}` as premises are also valid for +:math:`\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}`. We give the formation rule for +:math:`\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}` +below as well as the equality rules on inductive types and +constructors. + +The module subtyping rules: + +.. inference:: MSUB-STR + + \begin{array}{c} + \WS{E;e_1 ;…;e_n }{e_{σ(i)}}{e'_i ~\for~ i=1..m} \\ + σ : \{1… m\} → \{1… n\} ~\injective + \end{array} + -------------------------- + \WS{E}{\Struct~e_1 ;…;e_n ~\End}{~\Struct~e'_1 ;…;e'_m ~\End} + +.. inference:: MSUB-FUN + + \WS{E}{\ovl{S_1'}}{\ovl{S_1}} + \WS{E; \ModS{X}{S_1'}}{\ovl{S_2}}{\ovl{S_2'}} + -------------------------- + E[] ⊢ \Functor(X:S_1 ) S_2 <: \Functor(X:S_1') S_2' + + +Structure element subtyping rules: + +.. inference:: ASSUM-ASSUM + + E[] ⊢ T_1 ≤_{βδιζη} T_2 + -------------------------- + \WS{E}{\Assum{}{c}{T_1 }}{\Assum{}{c}{T_2 }} + +.. inference:: DEF-ASSUM + + E[] ⊢ T_1 ≤_{βδιζη} T_2 + -------------------------- + \WS{E}{\Def{}{c}{t}{T_1 }}{\Assum{}{c}{T_2 }} + +.. inference:: ASSUM-DEF + + E[] ⊢ T_1 ≤_{βδιζη} T_2 + E[] ⊢ c =_{βδιζη} t_2 + -------------------------- + \WS{E}{\Assum{}{c}{T_1 }}{\Def{}{c}{t_2 }{T_2 }} + +.. inference:: DEF-DEF + + E[] ⊢ T_1 ≤_{βδιζη} T_2 + E[] ⊢ t_1 =_{βδιζη} t_2 + -------------------------- + \WS{E}{\Def{}{c}{t_1 }{T_1 }}{\Def{}{c}{t_2 }{T_2 }} + +.. inference:: IND-IND + + E[] ⊢ Γ_P =_{βδιζη} Γ_P' + E[Γ_P ] ⊢ Γ_C =_{βδιζη} Γ_C' + E[Γ_P ;Γ_C ] ⊢ Γ_I =_{βδιζη} Γ_I' + -------------------------- + \WS{E}{\ind{Γ_P}{Γ_C}{Γ_I}}{\ind{Γ_P'}{Γ_C'}{Γ_I'}} + +.. inference:: INDP-IND + + E[] ⊢ Γ_P =_{βδιζη} Γ_P' + E[Γ_P ] ⊢ Γ_C =_{βδιζη} Γ_C' + E[Γ_P ;Γ_C ] ⊢ Γ_I =_{βδιζη} Γ_I' + -------------------------- + \WS{E}{\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}}{\ind{Γ_P'}{Γ_C'}{Γ_I'}} + +.. inference:: INDP-INDP + + \begin{array}{c} + E[] ⊢ Γ_P =_{βδιζη} Γ_P' + E[Γ_P ] ⊢ Γ_C =_{βδιζη} Γ_C' \\ + E[Γ_P ;Γ_C ] ⊢ Γ_I =_{βδιζη} Γ_I' + E[] ⊢ p =_{βδιζη} p' + \end{array} + -------------------------- + \WS{E}{\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}}{\Indp{}{Γ_P'}{Γ_C'}{Γ_I'}{p'}} + +.. inference:: MOD-MOD + + \WS{E}{S_1}{S_2} + -------------------------- + \WS{E}{\ModS{X}{S_1 }}{\ModS{X}{S_2 }} + +.. inference:: ALIAS-MOD + + E[] ⊢ p : S_1 + \WS{E}{S_1}{S_2} + -------------------------- + \WS{E}{\ModA{X}{p}}{\ModS{X}{S_2 }} + +.. inference:: MOD-ALIAS + + E[] ⊢ p : S_2 + \WS{E}{S_1}{S_2} + E[] ⊢ X =_{βδιζη} p + -------------------------- + \WS{E}{\ModS{X}{S_1 }}{\ModA{X}{p}} + +.. inference:: ALIAS-ALIAS + + E[] ⊢ p_1 =_{βδιζη} p_2 + -------------------------- + \WS{E}{\ModA{X}{p_1 }}{\ModA{X}{p_2 }} + +.. inference:: MODTYPE-MODTYPE + + \WS{E}{S_1}{S_2} + \WS{E}{S_2}{S_1} + -------------------------- + \WS{E}{\ModType{Y}{S_1 }}{\ModType{Y}{S_2 }} + + +New environment formation rules + + +.. inference:: WF-MOD1 + + \WF{E}{} + \WFT{E}{S} + -------------------------- + WF(E; \ModS{X}{S})[] + +.. inference:: WF-MOD2 + + \WS{E}{S_2}{S_1} + \WF{E}{} + \WFT{E}{S_1} + \WFT{E}{S_2} + -------------------------- + \WF{E; \Mod{X}{S_1}{S_2}}{} + +.. inference:: WF-ALIAS + + \WF{E}{} + E[] ⊢ p : S + -------------------------- + \WF{E, \ModA{X}{p}}{} + +.. inference:: WF-MODTYPE + + \WF{E}{} + \WFT{E}{S} + -------------------------- + \WF{E, \ModType{Y}{S}}{} + +.. inference:: WF-IND + + \begin{array}{c} + \WF{E;\ind{Γ_P}{Γ_C}{Γ_I}}{} \\ + E[] ⊢ p:~\Struct~e_1 ;…;e_n ;\ind{Γ_P'}{Γ_C'}{Γ_I'};… ~\End : \\ + E[] ⊢ \ind{Γ_P'}{Γ_C'}{Γ_I'} <: \ind{Γ_P}{Γ_C}{Γ_I} + \end{array} + -------------------------- + \WF{E; \Indp{}{Γ_P}{Γ_C}{Γ_I}{p} }{} + + +Component access rules + + +.. inference:: ACC-TYPE1 + + E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\Assum{}{c}{T};… ~\End + -------------------------- + E[Γ] ⊢ p.c : T + +.. inference:: ACC-TYPE2 + + E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\Def{}{c}{t}{T};… ~\End + -------------------------- + E[Γ] ⊢ p.c : T + +Notice that the following rule extends the delta rule defined in section :ref:`Conversion-rules` + +.. inference:: ACC-DELTA + + E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\Def{}{c}{t}{U};… ~\End + -------------------------- + E[Γ] ⊢ p.c \triangleright_δ t + +In the rules below we assume +:math:`Γ_P` is :math:`[p_1 :P_1 ;…;p_r :P_r ]`, +:math:`Γ_I` is :math:`[I_1 :A_1 ;…;I_k :A_k ]`, +and :math:`Γ_C` is :math:`[c_1 :C_1 ;…;c_n :C_n ]`. + +.. inference:: ACC-IND1 + + E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\ind{Γ_P}{Γ_C}{Γ_I};… ~\End + -------------------------- + E[Γ] ⊢ p.I_j : (p_1 :P_1 )…(p_r :P_r )A_j + +.. inference:: ACC-IND2 + + E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\ind{Γ_P}{Γ_C}{Γ_I};… ~\End + -------------------------- + E[Γ] ⊢ p.c_m : (p_1 :P_1 )…(p_r :P_r )C_m I_j (I_j~p_1 …p_r )_{j=1… k} + +.. inference:: ACC-INDP1 + + E[] ⊢ p :~\Struct~e_1 ;…;e_i ; \Indp{}{Γ_P}{Γ_C}{Γ_I}{p'} ;… ~\End + -------------------------- + E[] ⊢ p.I_i \triangleright_δ p'.I_i + +.. inference:: ACC-INDP2 + + E[] ⊢ p :~\Struct~e_1 ;…;e_i ; \Indp{}{Γ_P}{Γ_C}{Γ_I}{p'} ;… ~\End + -------------------------- + E[] ⊢ p.c_i \triangleright_δ p'.c_i + +.. extracted from Gallina extensions chapter + +Libraries and qualified names +--------------------------------- + +.. _names-of-libraries: + +Names of libraries +~~~~~~~~~~~~~~~~~~ + +The theories developed in |Coq| are stored in *library files* which are +hierarchically classified into *libraries* and *sublibraries*. To +express this hierarchy, library names are represented by qualified +identifiers qualid, i.e. as list of identifiers separated by dots (see +:ref:`qualified-names`). For instance, the library file ``Mult`` of the standard +|Coq| library ``Arith`` is named ``Coq.Arith.Mult``. The identifier that starts +the name of a library is called a *library root*. All library files of +the standard library of |Coq| have the reserved root |Coq| but library +filenames based on other roots can be obtained by using |Coq| commands +(coqc, coqtop, coqdep, …) options ``-Q`` or ``-R`` (see :ref:`command-line-options`). +Also, when an interactive |Coq| session starts, a library of root ``Top`` is +started, unless option ``-top`` or ``-notop`` is set (see :ref:`command-line-options`). + +.. _qualified-names: + +Qualified identifiers +--------------------- + +.. insertprodn qualid field_ident + +.. prodn:: + qualid ::= @ident {* @field_ident } + field_ident ::= .@ident + +Library files are modules which possibly contain submodules which +eventually contain constructions (axioms, parameters, definitions, +lemmas, theorems, remarks or facts). The *absolute name*, or *full +name*, of a construction in some library file is a qualified +identifier starting with the logical name of the library file, +followed by the sequence of submodules names encapsulating the +construction and ended by the proper name of the construction. +Typically, the absolute name ``Coq.Init.Logic.eq`` denotes Leibniz’ +equality defined in the module Logic in the sublibrary ``Init`` of the +standard library of |Coq|. + +The proper name that ends the name of a construction is the short name +(or sometimes base name) of the construction (for instance, the short +name of ``Coq.Init.Logic.eq`` is ``eq``). Any partial suffix of the absolute +name is a *partially qualified name* (e.g. ``Logic.eq`` is a partially +qualified name for ``Coq.Init.Logic.eq``). Especially, the short name of a +construction is its shortest partially qualified name. + +|Coq| does not accept two constructions (definition, theorem, …) with +the same absolute name but different constructions can have the same +short name (or even same partially qualified names as soon as the full +names are different). + +Notice that the notion of absolute, partially qualified and short +names also applies to library filenames. + +**Visibility** + +|Coq| maintains a table called the name table which maps partially qualified +names of constructions to absolute names. This table is updated by the +commands :cmd:`Require`, :cmd:`Import` and :cmd:`Export` and +also each time a new declaration is added to the context. An absolute +name is called visible from a given short or partially qualified name +when this latter name is enough to denote it. This means that the +short or partially qualified name is mapped to the absolute name in +|Coq| name table. Definitions with the :attr:`local` attribute are only accessible with +their fully qualified name (see :ref:`gallina-definitions`). + +It may happen that a visible name is hidden by the short name or a +qualified name of another construction. In this case, the name that +has been hidden must be referred to using one more level of +qualification. To ensure that a construction always remains +accessible, absolute names can never be hidden. + +.. example:: + + .. coqtop:: all + + Check 0. + + Definition nat := bool. + + Check 0. + + Check Datatypes.nat. + + Locate nat. + +.. seealso:: Commands :cmd:`Locate`. + +.. _libraries-and-filesystem: + +Libraries and filesystem +~~~~~~~~~~~~~~~~~~~~~~~~ + +.. note:: The questions described here have been subject to redesign in |Coq| 8.5. + Former versions of |Coq| use the same terminology to describe slightly different things. + +Compiled files (``.vo`` and ``.vio``) store sub-libraries. In order to refer +to them inside |Coq|, a translation from file-system names to |Coq| names +is needed. In this translation, names in the file system are called +*physical* paths while |Coq| names are contrastingly called *logical* +names. + +A logical prefix Lib can be associated with a physical path using +the command line option ``-Q`` `path` ``Lib``. All subfolders of path are +recursively associated to the logical path ``Lib`` extended with the +corresponding suffix coming from the physical path. For instance, the +folder ``path/fOO/Bar`` maps to ``Lib.fOO.Bar``. Subdirectories corresponding +to invalid |Coq| identifiers are skipped, and, by convention, +subdirectories named ``CVS`` or ``_darcs`` are skipped too. + +Thanks to this mechanism, ``.vo`` files are made available through the +logical name of the folder they are in, extended with their own +basename. For example, the name associated to the file +``path/fOO/Bar/File.vo`` is ``Lib.fOO.Bar.File``. The same caveat applies for +invalid identifiers. When compiling a source file, the ``.vo`` file stores +its logical name, so that an error is issued if it is loaded with the +wrong loadpath afterwards. + +Some folders have a special status and are automatically put in the +path. |Coq| commands associate automatically a logical path to files in +the repository trees rooted at the directory from where the command is +launched, ``coqlib/user-contrib/``, the directories listed in the +``$COQPATH``, ``${XDG_DATA_HOME}/coq/`` and ``${XDG_DATA_DIRS}/coq/`` +environment variables (see `XDG base directory specification +<http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>`_) +with the same physical-to-logical translation and with an empty logical prefix. + +The command line option ``-R`` is a variant of ``-Q`` which has the strictly +same behavior regarding loadpaths, but which also makes the +corresponding ``.vo`` files available through their short names in a way +similar to the :cmd:`Import` command. For instance, ``-R path Lib`` +associates to the file ``/path/fOO/Bar/File.vo`` the logical name +``Lib.fOO.Bar.File``, but allows this file to be accessed through the +short names ``fOO.Bar.File,Bar.File`` and ``File``. If several files with +identical base name are present in different subdirectories of a +recursive loadpath, which of these files is found first may be system- +dependent and explicit qualification is recommended. The ``From`` argument +of the ``Require`` command can be used to bypass the implicit shortening +by providing an absolute root to the required file (see :ref:`compiled-files`). + +There also exists another independent loadpath mechanism attached to +OCaml object files (``.cmo`` or ``.cmxs``) rather than |Coq| object +files as described above. The OCaml loadpath is managed using +the option ``-I`` `path` (in the OCaml world, there is neither a +notion of logical name prefix nor a way to access files in +subdirectories of path). See the command :cmd:`Declare ML Module` in +:ref:`compiled-files` to understand the need of the OCaml loadpath. + +See :ref:`command-line-options` for a more general view over the |Coq| command +line options. diff --git a/doc/sphinx/language/core/primitive.rst b/doc/sphinx/language/core/primitive.rst new file mode 100644 index 0000000000..dc8f131209 --- /dev/null +++ b/doc/sphinx/language/core/primitive.rst @@ -0,0 +1,107 @@ +Primitive objects +================= + +.. _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. + +The extraction of these primitives can be customized similarly to the extraction +of regular axioms (see :ref:`extraction`). Nonetheless, the :g:`ExtrOCamlInt63` +module can be used when extracting to OCaml: it maps the Coq primitives to types +and functions of a :g:`Uint63` module. Said OCaml 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. + +Literal values (at type :g:`Int63.int`) are extracted to literal OCaml values +wrapped into the :g:`Uint63.of_int` (resp. :g:`Uint63.of_int64`) constructor on +64-bit (resp. 32-bit) platforms. Currently, this cannot be customized (see the +function :g:`Uint63.compile` from the kernel). + +.. _primitive-floats: + +Primitive Floats +---------------- + +The language of terms features Binary64 floating-point numbers as values. +The type of such a value is *axiomatized*; it is declared through the +following sentence (excerpt from the :g:`PrimFloat` module): + +.. coqdoc:: + + Primitive float := #float64_type. + +This type is equipped with a few operators, that must be similarly declared. +For instance, the product of two primitive floats can be computed using the +:g:`PrimFloat.mul` function, declared and specified as follows: + +.. coqdoc:: + + Primitive mul := #float64_mul. + Notation "x * y" := (mul x y) : float_scope. + + Axiom mul_spec : forall x y, Prim2SF (x * y)%float = SF64mul (Prim2SF x) (Prim2SF y). + +where :g:`Prim2SF` is defined in the :g:`FloatOps` module. + +The set of such operators is described in section :ref:`floats_library`. + +These primitive declarations are regular axioms. As such, they must be trusted, and are listed by the +:g:`Print Assumptions` command. + +The reduction machines (:tacn:`vm_compute`, :tacn:`native_compute`) implement +dedicated, efficient rules to reduce the applications of these primitive +operations, using the floating-point processor operators that are assumed +to comply with the IEEE 754 standard for floating-point arithmetic. + +The extraction of these primitives can be customized similarly to the extraction +of regular axioms (see :ref:`extraction`). Nonetheless, the :g:`ExtrOCamlFloats` +module can be used when extracting to OCaml: it maps the Coq primitives to types +and functions of a :g:`Float64` module. Said OCaml 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. + +Literal values (of type :g:`Float64.t`) are extracted to literal OCaml +values (of type :g:`float`) written in hexadecimal notation and +wrapped into the :g:`Float64.of_float` constructor, e.g.: +:g:`Float64.of_float (0x1p+0)`. diff --git a/doc/sphinx/language/core/sorts.rst b/doc/sphinx/language/core/sorts.rst new file mode 100644 index 0000000000..03581b95dd --- /dev/null +++ b/doc/sphinx/language/core/sorts.rst @@ -0,0 +1,99 @@ +.. index:: + single: Set (sort) + single: SProp + single: Prop + single: Type + +.. _sorts: + +Sorts +~~~~~~~~~~~ + +.. insertprodn sort universe_expr + +.. prodn:: + sort ::= Set + | Prop + | SProp + | Type + | Type @%{ _ %} + | Type @%{ @universe %} + universe ::= max ( {+, @universe_expr } ) + | @universe_expr + universe_expr ::= @universe_name {? + @num } + +The types of types are called :gdef:`sorts <sort>`. + +All sorts have a type and there is an infinite well-founded typing +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. +We denote propositions by :n:`@form`. +This constitutes a semantic subclass of the syntactic class :n:`@term`. + +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. +See :ref:`sprop` for information about using +:math:`\SProp`, and :cite:`Gilbert:POPL2019` for meta theoretical +considerations. + +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. +We denote specifications (program types) by :n:`@specif`. +This constitutes a semantic subclass of the syntactic class :n:`@term`. + +: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 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 +booleans, natural numbers, as well as products, subsets and function +types over small sets. But, unlike :math:`\Set`, they also contain large sets, +namely the sorts :math:`\Set` and :math:`\Type(j)` for :math:`j<i`, and all products, subsets +and function types over these sorts. + +Formally, we call :math:`\Sort` the set of sorts which is defined by: + +.. math:: + + \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`. + +The user does not have to mention explicitly the index :math:`i` when +referring to the universe :math:`\Type(i)`. One only writes :math:`\Type`. The system +itself generates for each instance of :math:`\Type` a new index for the +universe and checks that the constraints between these indexes can be +solved. From the user point of view we consequently have :math:`\Type:\Type`. We +shall make precise in the typing rules the constraints between the +indices. + + +.. _Implementation-issues: + +**Implementation issues** In practice, the Type hierarchy is +implemented using *algebraic +universes*. An algebraic universe :math:`u` is either a variable (a qualified +identifier with a number) or a successor of an algebraic universe (an +expression :math:`u+1`), or an upper bound of algebraic universes (an +expression :math:`\max(u_1 ,...,u_n )`), or the base universe (the expression +:math:`0`) which corresponds, in the arity of template polymorphic inductive +types (see Section +:ref:`well-formed-inductive-definitions`), +to the predicative sort :math:`\Set`. A graph of +constraints between the universe variables is maintained globally. To +ensure the existence of a mapping of the universes to the positive +integers, the graph of constraints must remain acyclic. Typing +expressions that violate the acyclicity of the graph of constraints +results in a Universe inconsistency error. + +.. seealso:: :ref:`printing-universes`. diff --git a/doc/sphinx/language/core/variants.rst b/doc/sphinx/language/core/variants.rst new file mode 100644 index 0000000000..6d4676b3c4 --- /dev/null +++ b/doc/sphinx/language/core/variants.rst @@ -0,0 +1,202 @@ +Variants and the `match` construct +================================== + +Variants +-------- + +.. cmd:: Variant @variant_definition {* with @variant_definition } + + .. insertprodn variant_definition variant_definition + + .. prodn:: + variant_definition ::= @ident_decl {* @binder } {? %| {* @binder } } {? : @type } := {? %| } {+| @constructor } {? @decl_notations } + + The :cmd:`Variant` command is similar to the :cmd:`Inductive` command, except + that it disallows recursive definition of types (for instance, lists cannot + be defined using :cmd:`Variant`). No induction scheme is generated for + this variant, unless the :flag:`Nonrecursive Elimination Schemes` flag is on. + + This command supports the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`universes(template)`, + :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, + :attr:`universes(noncumulative)` and :attr:`private(matching)` + attributes. + + .. exn:: The @num th argument of @ident must be @ident in @type. + :undocumented: + +Private (matching) inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. attr:: private(matching) + + This attribute can be used to forbid the use of the :g:`match` + construct on objects of this inductive type outside of the module + where it is defined. There is also a legacy syntax using the + ``Private`` prefix (cf. :n:`@legacy_attr`). + + The main use case of private (matching) inductive types is to emulate + quotient types / higher-order inductive types in projects such as + the `HoTT library <https://github.com/HoTT/HoTT>`_. + +.. example:: + + .. coqtop:: all + + Module Foo. + #[ private(matching) ] Inductive my_nat := my_O : my_nat | my_S : my_nat -> my_nat. + Check (fun x : my_nat => match x with my_O => true | my_S _ => false end). + End Foo. + Import Foo. + Fail Check (fun x : my_nat => match x with my_O => true | my_S _ => false end). + +.. index:: match ... with ... + +.. _match: + +Definition by cases: match +-------------------------- + +.. insertprodn term_match pattern0 + +.. prodn:: + term_match ::= match {+, @case_item } {? return @term100 } with {? %| } {*| @eqn } end + case_item ::= @term100 {? as @name } {? in @pattern } + eqn ::= {+| {+, @pattern } } => @term + pattern ::= @pattern10 : @term + | @pattern10 + pattern10 ::= @pattern1 as @name + | @pattern1 {* @pattern1 } + | @ @qualid {* @pattern1 } + pattern1 ::= @pattern0 % @scope_key + | @pattern0 + pattern0 ::= @qualid + | %{%| {* @qualid := @pattern } %|%} + | _ + | ( {+| @pattern } ) + | @numeral + | @string + +Objects of inductive types can be destructured by a case-analysis +construction called *pattern matching* expression. A pattern matching +expression is used to analyze the structure of an inductive object and +to apply specific treatments accordingly. + +This paragraph describes the basic form of pattern matching. See +Section :ref:`Mult-match` and Chapter :ref:`extendedpatternmatching` for the description +of the general form. The basic form of pattern matching is characterized +by a single :n:`@case_item` expression, an :n:`@eqn` restricted to a +single :n:`@pattern` and :n:`@pattern` restricted to the form +:n:`@qualid {* @ident}`. + +The expression +:n:`match @term {? return @term100 } with {+| @pattern__i => @term__i } end` denotes a +*pattern matching* over the term :n:`@term` (expected to be +of an inductive type :math:`I`). The :n:`@term__i` +are the *branches* of the pattern matching +expression. Each :n:`@pattern__i` has the form :n:`@qualid @ident` +where :n:`@qualid` must denote a constructor. There should be +exactly one branch for every constructor of :math:`I`. + +The :n:`return @term100` clause gives the type returned by the whole match +expression. There are several cases. In the *non dependent* case, all +branches have the same type, and the :n:`return @term100` specifies that type. +In this case, :n:`return @term100` can usually be omitted as it can be +inferred from the type of the branches [1]_. + +In the *dependent* case, there are three subcases. In the first subcase, +the type in each branch may depend on the exact value being matched in +the branch. In this case, the whole pattern matching itself depends on +the term being matched. This dependency of the term being matched in the +return type is expressed with an :n:`@ident` clause where :n:`@ident` +is dependent in the return type. For instance, in the following example: + +.. coqtop:: in + + Inductive bool : Type := true : bool | false : bool. + Inductive eq (A:Type) (x:A) : A -> Prop := eq_refl : eq A x x. + Inductive or (A:Prop) (B:Prop) : Prop := + | or_introl : A -> or A B + | or_intror : B -> or A B. + + Definition bool_case (b:bool) : or (eq bool b true) (eq bool b false) := + match b as x return or (eq bool x true) (eq bool x false) with + | true => or_introl (eq bool true true) (eq bool true false) (eq_refl bool true) + | false => or_intror (eq bool false true) (eq bool false false) (eq_refl bool false) + end. + +the branches have respective types ":g:`or (eq bool true true) (eq bool true false)`" +and ":g:`or (eq bool false true) (eq bool false false)`" while the whole +pattern matching expression has type ":g:`or (eq bool b true) (eq bool b false)`", +the identifier :g:`b` being used to represent the dependency. + +.. note:: + + When the term being matched is a variable, the ``as`` clause can be + omitted and the term being matched can serve itself as binding name in + the return type. For instance, the following alternative definition is + accepted and has the same meaning as the previous one. + + .. coqtop:: none + + Reset bool_case. + + .. coqtop:: in + + Definition bool_case (b:bool) : or (eq bool b true) (eq bool b false) := + match b return or (eq bool b true) (eq bool b false) with + | true => or_introl (eq bool true true) (eq bool true false) (eq_refl bool true) + | false => or_intror (eq bool false true) (eq bool false false) (eq_refl bool false) + end. + +The second subcase is only relevant for annotated inductive types such +as the equality predicate (see Section :ref:`coq-equality`), +the order predicate on natural numbers or the type of lists of a given +length (see Section :ref:`matching-dependent`). In this configuration, the +type of each branch can depend on the type dependencies specific to the +branch and the whole pattern matching expression has a type determined +by the specific dependencies in the type of the term being matched. This +dependency of the return type in the annotations of the inductive type +is expressed with a clause in the form +:n:`in @qualid {+ _ } {+ @pattern }`, where + +- :n:`@qualid` is the inductive type of the term being matched; + +- the holes :n:`_` match the parameters of the inductive type: the + return type is not dependent on them. + +- each :n:`@pattern` matches the annotations of the + inductive type: the return type is dependent on them + +- in the basic case which we describe below, each :n:`@pattern` + is a name :n:`@ident`; see :ref:`match-in-patterns` for the + general case + +For instance, in the following example: + +.. coqtop:: in + + Definition eq_sym (A:Type) (x y:A) (H:eq A x y) : eq A y x := + match H in eq _ _ z return eq A z x with + | eq_refl _ _ => eq_refl A x + end. + +the type of the branch is :g:`eq A x x` because the third argument of +:g:`eq` is :g:`x` in the type of the pattern :g:`eq_refl`. On the contrary, the +type of the whole pattern matching expression has type :g:`eq A y x` because the +third argument of eq is y in the type of H. This dependency of the case analysis +in the third argument of :g:`eq` is expressed by the identifier :g:`z` in the +return type. + +Finally, the third subcase is a combination of the first and second +subcase. In particular, it only applies to pattern matching on terms in +a type with annotations. For this third subcase, both the clauses ``as`` and +``in`` are available. + +There are specific notations for case analysis on types with one or two +constructors: ``if … then … else …`` and ``let (…,…) := … in …`` (see +Sections :ref:`if-then-else` and :ref:`irrefutable-patterns`). + +.. [1] + Except if the inductive type is empty in which case there is no + equation that can be used to infer the return type. diff --git a/doc/sphinx/language/extensions/arguments-command.rst b/doc/sphinx/language/extensions/arguments-command.rst index 34a48b368b..613669c34b 100644 --- a/doc/sphinx/language/extensions/arguments-command.rst +++ b/doc/sphinx/language/extensions/arguments-command.rst @@ -6,12 +6,9 @@ Setting properties of a function's arguments .. cmd:: Arguments @smart_qualid {* @arg_specs } {* , {* @implicits_alt } } {? : {+, @args_modifier } } :name: Arguments - .. insertprodn smart_qualid args_modifier + .. insertprodn argument_spec args_modifier .. prodn:: - smart_qualid ::= @qualid - | @by_notation - by_notation ::= @string {? % @scope_key } argument_spec ::= {? ! } @name {? % @scope_key } arg_specs ::= @argument_spec | / @@ -109,7 +106,7 @@ Setting properties of a function's arguments clears argument scopes of :n:`@smart_qualid` `extra scopes` defines extra argument scopes, to be used in case of coercion to ``Funclass`` - (see the :ref:`implicitcoercions` chapter) or with a computed type. + (see :ref:`coercions`) or with a computed type. `simpl nomatch` prevents performing a simplification step for :n:`@smart_qualid` that would expose a match construct in the head position. See :ref:`Args_effect_on_unfolding`. diff --git a/doc/sphinx/language/extensions/canonical.rst b/doc/sphinx/language/extensions/canonical.rst new file mode 100644 index 0000000000..f55f3c5495 --- /dev/null +++ b/doc/sphinx/language/extensions/canonical.rst @@ -0,0 +1,558 @@ +.. _canonicalstructures: + +Canonical Structures +====================== + +:Authors: Assia Mahboubi and Enrico Tassi + +This chapter explains the basics of canonical structures and how they can be used +to overload notations and build a hierarchy of algebraic structures. The +examples are taken from :cite:`CSwcu`. We invite the interested reader to refer +to this paper for all the details that are omitted here for brevity. The +interested reader shall also find in :cite:`CSlessadhoc` a detailed description +of another, complementary, use of canonical structures: advanced proof search. +This latter papers also presents many techniques one can employ to tune the +inference of canonical structures. + + .. extracted from implicit arguments section + +.. _canonical-structure-declaration: + +Declaration of canonical structures +----------------------------------- + +A canonical structure is an instance of a record/structure type that +can be used to solve unification problems involving a projection +applied to an unknown structure instance (an implicit argument) and a +value. The complete documentation of canonical structures can be found +in :ref:`canonicalstructures`; here only a simple example is given. + +.. cmd:: Canonical {? Structure } @smart_qualid + Canonical {? Structure } @ident_decl @def_body + :name: Canonical Structure; _ + + The first form of this command declares an existing :n:`@smart_qualid` as a + canonical instance of a structure (a record). + + The second form defines a new constant as if the :cmd:`Definition` command + had been used, then declares it as a canonical instance as if the first + form had been used on the defined object. + + This command supports the :attr:`local` attribute. When used, the + structure is canonical only within the :cmd:`Section` containing it. + + Assume that :token:`qualid` denotes an object ``(Build_struct`` |c_1| … |c_n| ``)`` in the + structure :g:`struct` of which the fields are |x_1|, …, |x_n|. + Then, each time an equation of the form ``(``\ |x_i| ``_)`` |eq_beta_delta_iota_zeta| |c_i| has to be + solved during the type checking process, :token:`qualid` is used as a solution. + Otherwise said, :token:`qualid` is canonically used to extend the field |c_i| + into a complete structure built on |c_i|. + + Canonical structures are particularly useful when mixed with coercions + and strict implicit arguments. + + .. example:: + + Here is an example. + + .. coqtop:: all reset + + Require Import Relations. + + Require Import EqNat. + + Set Implicit Arguments. + + Unset Strict Implicit. + + Structure Setoid : Type := {Carrier :> Set; Equal : relation Carrier; + Prf_equiv : equivalence Carrier Equal}. + + Definition is_law (A B:Setoid) (f:A -> B) := forall x y:A, Equal x y -> Equal (f x) (f y). + + Axiom eq_nat_equiv : equivalence nat eq_nat. + + Definition nat_setoid : Setoid := Build_Setoid eq_nat_equiv. + + Canonical nat_setoid. + + Thanks to :g:`nat_setoid` declared as canonical, the implicit arguments :g:`A` + and :g:`B` can be synthesized in the next statement. + + .. coqtop:: all abort + + Lemma is_law_S : is_law S. + + .. note:: + If a same field occurs in several canonical structures, then + only the structure declared first as canonical is considered. + + .. attr:: canonical(false) + + To prevent a field from being involved in the inference of + canonical instances, its declaration can be annotated with the + :attr:`canonical(false)` attribute (cf. the syntax of + :n:`@record_field`). + + .. example:: + + For instance, when declaring the :g:`Setoid` structure above, the + :g:`Prf_equiv` field declaration could be written as follows. + + .. coqdoc:: + + #[canonical(false)] Prf_equiv : equivalence Carrier Equal + + See :ref:`canonicalstructures` for a more realistic example. + +.. attr:: canonical + + This attribute can decorate a :cmd:`Definition` or :cmd:`Let` command. + It is equivalent to having a :cmd:`Canonical Structure` declaration just + after the command. + +.. cmd:: Print Canonical Projections {* @smart_qualid } + + This displays the list of global names that are components of some + canonical structure. For each of them, the canonical structure of + which it is a projection is indicated. If constants are given as + its arguments, only the unification rules that involve or are + synthesized from simultaneously all given constants will be shown. + + .. example:: + + For instance, the above example gives the following output: + + .. coqtop:: all + + Print Canonical Projections. + + .. coqtop:: all + + Print Canonical Projections nat. + + .. note:: + + The last line in the first example would not show up if the + corresponding projection (namely :g:`Prf_equiv`) were annotated as not + canonical, as described above. + +Notation overloading +------------------------- + +We build an infix notation == for a comparison predicate. Such +notation will be overloaded, and its meaning will depend on the types +of the terms that are compared. + +.. coqtop:: all reset + + Module EQ. + Record class (T : Type) := Class { cmp : T -> T -> Prop }. + Structure type := Pack { obj : Type; class_of : class obj }. + Definition op (e : type) : obj e -> obj e -> Prop := + let 'Pack _ (Class _ the_cmp) := e in the_cmp. + Check op. + Arguments op {e} x y : simpl never. + Arguments Class {T} cmp. + Module theory. + Notation "x == y" := (op x y) (at level 70). + End theory. + End EQ. + +We use Coq modules as namespaces. This allows us to follow the same +pattern and naming convention for the rest of the chapter. The base +namespace contains the definitions of the algebraic structure. To +keep the example small, the algebraic structure ``EQ.type`` we are +defining is very simplistic, and characterizes terms on which a binary +relation is defined, without requiring such relation to validate any +property. The inner theory module contains the overloaded notation ``==`` +and will eventually contain lemmas holding all the instances of the +algebraic structure (in this case there are no lemmas). + +Note that in practice the user may want to declare ``EQ.obj`` as a +coercion, but we will not do that here. + +The following line tests that, when we assume a type ``e`` that is in +theEQ class, we can relate two of its objects with ``==``. + +.. coqtop:: all + + Import EQ.theory. + Check forall (e : EQ.type) (a b : EQ.obj e), a == b. + +Still, no concrete type is in the ``EQ`` class. + +.. coqtop:: all + + Fail Check 3 == 3. + +We amend that by equipping ``nat`` with a comparison relation. + +.. coqtop:: all + + Definition nat_eq (x y : nat) := Nat.compare x y = Eq. + Definition nat_EQcl : EQ.class nat := EQ.Class nat_eq. + Canonical Structure nat_EQty : EQ.type := EQ.Pack nat nat_EQcl. + Check 3 == 3. + Eval compute in 3 == 4. + +This last test shows that |Coq| is now not only able to type check ``3 == 3``, +but also that the infix relation was bound to the ``nat_eq`` relation. +This relation is selected whenever ``==`` is used on terms of type nat. +This can be read in the line declaring the canonical structure +``nat_EQty``, where the first argument to ``Pack`` is the key and its second +argument a group of canonical values associated to the key. In this +case we associate to nat only one canonical value (since its class, +``nat_EQcl`` has just one member). The use of the projection ``op`` requires +its argument to be in the class ``EQ``, and uses such a member (function) +to actually compare its arguments. + +Similarly, we could equip any other type with a comparison relation, +and use the ``==`` notation on terms of this type. + + +Derived Canonical Structures +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We know how to use ``==`` on base types, like ``nat``, ``bool``, ``Z``. Here we show +how to deal with type constructors, i.e. how to make the following +example work: + + +.. coqtop:: all + + Fail Check forall (e : EQ.type) (a b : EQ.obj e), (a, b) == (a, b). + +The error message is telling that |Coq| has no idea on how to compare +pairs of objects. The following construction is telling Coq exactly +how to do that. + +.. coqtop:: all + + Definition pair_eq (e1 e2 : EQ.type) (x y : EQ.obj e1 * EQ.obj e2) := + fst x == fst y /\ snd x == snd y. + + Definition pair_EQcl e1 e2 := EQ.Class (pair_eq e1 e2). + + Canonical Structure pair_EQty (e1 e2 : EQ.type) : EQ.type := + EQ.Pack (EQ.obj e1 * EQ.obj e2) (pair_EQcl e1 e2). + + Check forall (e : EQ.type) (a b : EQ.obj e), (a, b) == (a, b). + + Check forall n m : nat, (3, 4) == (n, m). + +Thanks to the ``pair_EQty`` declaration, |Coq| is able to build a comparison +relation for pairs whenever it is able to build a comparison relation +for each component of the pair. The declaration associates to the key ``*`` +(the type constructor of pairs) the canonical comparison +relation ``pair_eq`` whenever the type constructor ``*`` is applied to two +types being themselves in the ``EQ`` class. + +Hierarchy of structures +---------------------------- + +To get to an interesting example we need another base class to be +available. We choose the class of types that are equipped with an +order relation, to which we associate the infix ``<=`` notation. + +.. coqtop:: all + + Module LE. + + Record class T := Class { cmp : T -> T -> Prop }. + + Structure type := Pack { obj : Type; class_of : class obj }. + + Definition op (e : type) : obj e -> obj e -> Prop := + let 'Pack _ (Class _ f) := e in f. + + Arguments op {_} x y : simpl never. + + Arguments Class {T} cmp. + + Module theory. + + Notation "x <= y" := (op x y) (at level 70). + + End theory. + + End LE. + +As before we register a canonical ``LE`` class for ``nat``. + +.. coqtop:: all + + Import LE.theory. + + Definition nat_le x y := Nat.compare x y <> Gt. + + Definition nat_LEcl : LE.class nat := LE.Class nat_le. + + Canonical Structure nat_LEty : LE.type := LE.Pack nat nat_LEcl. + +And we enable |Coq| to relate pair of terms with ``<=``. + +.. coqtop:: all + + Definition pair_le e1 e2 (x y : LE.obj e1 * LE.obj e2) := + fst x <= fst y /\ snd x <= snd y. + + Definition pair_LEcl e1 e2 := LE.Class (pair_le e1 e2). + + Canonical Structure pair_LEty (e1 e2 : LE.type) : LE.type := + LE.Pack (LE.obj e1 * LE.obj e2) (pair_LEcl e1 e2). + + Check (3,4,5) <= (3,4,5). + +At the current stage we can use ``==`` and ``<=`` on concrete types, like +tuples of natural numbers, but we can’t develop an algebraic theory +over the types that are equipped with both relations. + +.. coqtop:: all + + Check 2 <= 3 /\ 2 == 2. + + Fail Check forall (e : EQ.type) (x y : EQ.obj e), x <= y -> y <= x -> x == y. + + Fail Check forall (e : LE.type) (x y : LE.obj e), x <= y -> y <= x -> x == y. + +We need to define a new class that inherits from both ``EQ`` and ``LE``. + + +.. coqtop:: all + + Module LEQ. + + Record mixin (e : EQ.type) (le : EQ.obj e -> EQ.obj e -> Prop) := + Mixin { compat : forall x y : EQ.obj e, le x y /\ le y x <-> x == y }. + + Record class T := Class { + EQ_class : EQ.class T; + LE_class : LE.class T; + extra : mixin (EQ.Pack T EQ_class) (LE.cmp T LE_class) }. + + Structure type := _Pack { obj : Type; #[canonical(false)] class_of : class obj }. + + Arguments Mixin {e le} _. + + Arguments Class {T} _ _ _. + +The mixin component of the ``LEQ`` class contains all the extra content we +are adding to ``EQ`` and ``LE``. In particular it contains the requirement +that the two relations we are combining are compatible. + +The `class_of` projection of the `type` structure is annotated as *not canonical*; +it plays no role in the search for instances. + +Unfortunately there is still an obstacle to developing the algebraic +theory of this new class. + +.. coqtop:: all + + Module theory. + + Fail Check forall (le : type) (n m : obj le), n <= m -> n <= m -> n == m. + + +The problem is that the two classes ``LE`` and ``LEQ`` are not yet related by +a subclass relation. In other words |Coq| does not see that an object of +the ``LEQ`` class is also an object of the ``LE`` class. + +The following two constructions tell |Coq| how to canonically build the +``LE.type`` and ``EQ.type`` structure given an ``LEQ.type`` structure on the same +type. + +.. coqtop:: all + + Definition to_EQ (e : type) : EQ.type := + EQ.Pack (obj e) (EQ_class _ (class_of e)). + + Canonical Structure to_EQ. + + Definition to_LE (e : type) : LE.type := + LE.Pack (obj e) (LE_class _ (class_of e)). + + Canonical Structure to_LE. + +We can now formulate out first theorem on the objects of the ``LEQ`` +structure. + +.. coqtop:: all + + Lemma lele_eq (e : type) (x y : obj e) : x <= y -> y <= x -> x == y. + + now intros; apply (compat _ _ (extra _ (class_of e)) x y); split. + + Qed. + + Arguments lele_eq {e} x y _ _. + + End theory. + + End LEQ. + + Import LEQ.theory. + + Check lele_eq. + +Of course one would like to apply results proved in the algebraic +setting to any concrete instate of the algebraic structure. + +.. coqtop:: all + + Example test_algebraic (n m : nat) : n <= m -> m <= n -> n == m. + + Fail apply (lele_eq n m). + + Abort. + + Example test_algebraic2 (l1 l2 : LEQ.type) (n m : LEQ.obj l1 * LEQ.obj l2) : + n <= m -> m <= n -> n == m. + + Fail apply (lele_eq n m). + + Abort. + +Again one has to tell |Coq| that the type ``nat`` is in the ``LEQ`` class, and +how the type constructor ``*`` interacts with the ``LEQ`` class. In the +following proofs are omitted for brevity. + +.. coqtop:: all + + Lemma nat_LEQ_compat (n m : nat) : n <= m /\ m <= n <-> n == m. + + Admitted. + + Definition nat_LEQmx := LEQ.Mixin nat_LEQ_compat. + + Lemma pair_LEQ_compat (l1 l2 : LEQ.type) (n m : LEQ.obj l1 * LEQ.obj l2) : + n <= m /\ m <= n <-> n == m. + + Admitted. + + Definition pair_LEQmx l1 l2 := LEQ.Mixin (pair_LEQ_compat l1 l2). + +The following script registers an ``LEQ`` class for ``nat`` and for the type +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 + + Module Add_instance_attempt. + + Canonical Structure nat_LEQty : LEQ.type := + LEQ._Pack nat (LEQ.Class nat_EQcl nat_LEcl nat_LEQmx). + + Canonical Structure pair_LEQty (l1 l2 : LEQ.type) : LEQ.type := + LEQ._Pack (LEQ.obj l1 * LEQ.obj l2) + (LEQ.Class + (EQ.class_of (pair_EQty (to_EQ l1) (to_EQ l2))) + (LE.class_of (pair_LEty (to_LE l1) (to_LE l2))) + (pair_LEQmx l1 l2)). + + Example test_algebraic (n m : nat) : n <= m -> m <= n -> n == m. + + now apply (lele_eq n m). + + Qed. + + Example test_algebraic2 (n m : nat * nat) : n <= m -> m <= n -> n == m. + + now apply (lele_eq n m). Qed. + + End Add_instance_attempt. + +Note that no direct proof of ``n <= m -> m <= n -> n == m`` is provided by +the user for ``n`` and m of type ``nat * nat``. What the user provides is a +proof of this statement for ``n`` and ``m`` of type ``nat`` and a proof that the +pair constructor preserves this property. The combination of these two +facts is a simple form of proof search that |Coq| performs automatically +while inferring canonical structures. + +Compact declaration of Canonical Structures +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We need some infrastructure for that. + +.. coqtop:: all + + Require Import Strings.String. + + Module infrastructure. + + Inductive phantom {T : Type} (t : T) : Type := Phantom. + + Definition unify {T1 T2} (t1 : T1) (t2 : T2) (s : option string) := + phantom t1 -> phantom t2. + + Definition id {T} {t : T} (x : phantom t) := x. + + Notation "[find v | t1 ~ t2 ] p" := (fun v (_ : unify t1 t2 None) => p) + (at level 50, v ident, only parsing). + + Notation "[find v | t1 ~ t2 | s ] p" := (fun v (_ : unify t1 t2 (Some s)) => p) + (at level 50, v ident, only parsing). + + Notation "'Error : t : s" := (unify _ t (Some s)) + (at level 50, format "''Error' : t : s"). + + Open Scope string_scope. + + End infrastructure. + +To explain the notation ``[find v | t1 ~ t2]`` let us pick one of its +instances: ``[find e | EQ.obj e ~ T | "is not an EQ.type" ]``. It should be +read as: “find a class e such that its objects have type T or fail +with message "T is not an EQ.type"”. + +The other utilities are used to ask |Coq| to solve a specific unification +problem, that will in turn require the inference of some canonical structures. +They are explained in more details in :cite:`CSwcu`. + +We now have all we need to create a compact “packager” to declare +instances of the ``LEQ`` class. + +.. coqtop:: all + + Import infrastructure. + + Definition packager T e0 le0 (m0 : LEQ.mixin e0 le0) := + [find e | EQ.obj e ~ T | "is not an EQ.type" ] + [find o | LE.obj o ~ T | "is not an LE.type" ] + [find ce | EQ.class_of e ~ ce ] + [find co | LE.class_of o ~ co ] + [find m | m ~ m0 | "is not the right mixin" ] + LEQ._Pack T (LEQ.Class ce co m). + + Notation Pack T m := (packager T _ _ m _ id _ id _ id _ id _ id). + +The object ``Pack`` takes a type ``T`` (the key) and a mixin ``m``. It infers all +the other pieces of the class ``LEQ`` and declares them as canonical +values associated to the ``T`` key. All in all, the only new piece of +information we add in the ``LEQ`` class is the mixin, all the rest is +already canonical for ``T`` and hence can be inferred by |Coq|. + +``Pack`` is a notation, hence it is not type checked at the time of its +declaration. It will be type checked when it is used, an in that case ``T`` is +going to be a concrete type. The odd arguments ``_`` and ``id`` we pass to the +packager represent respectively the classes to be inferred (like ``e``, ``o``, +etc) and a token (``id``) to force their inference. Again, for all the details +the reader can refer to :cite:`CSwcu`. + +The declaration of canonical instances can now be way more compact: + +.. coqtop:: all + + Canonical Structure nat_LEQty := Eval hnf in Pack nat nat_LEQmx. + + Canonical Structure pair_LEQty (l1 l2 : LEQ.type) := + Eval hnf in Pack (LEQ.obj l1 * LEQ.obj l2) (pair_LEQmx l1 l2). + +Error messages are also quite intelligible (if one skips to the end of +the message). + +.. coqtop:: all + + Fail Canonical Structure err := Eval hnf in Pack bool nat_LEQmx. diff --git a/doc/sphinx/language/extensions/evars.rst b/doc/sphinx/language/extensions/evars.rst new file mode 100644 index 0000000000..40e0898871 --- /dev/null +++ b/doc/sphinx/language/extensions/evars.rst @@ -0,0 +1,112 @@ +.. extracted from Gallina extensions chapter + +.. _existential-variables: + +Existential variables +--------------------- + +.. insertprodn term_evar term_evar + +.. prodn:: + term_evar ::= _ + | ?[ @ident ] + | ?[ ?@ident ] + | ?@ident {? @%{ {+; @ident := @term } %} } + +|Coq| terms can include existential variables which represents unknown +subterms to eventually be replaced by actual subterms. + +Existential variables are generated in place of unsolvable implicit +arguments or “_” placeholders when using commands such as ``Check`` (see +Section :ref:`requests-to-the-environment`) or when using tactics such as +:tacn:`refine`, as well as in place of unsolvable instances when using +tactics such that :tacn:`eapply`. An existential +variable is defined in a context, which is the context of variables of +the placeholder which generated the existential variable, and a type, +which is the expected type of the placeholder. + +As a consequence of typing constraints, existential variables can be +duplicated in such a way that they possibly appear in different +contexts than their defining context. Thus, any occurrence of a given +existential variable comes with an instance of its original context. +In the simple case, when an existential variable denotes the +placeholder which generated it, or is used in the same context as the +one in which it was generated, the context is not displayed and the +existential variable is represented by “?” followed by an identifier. + +.. coqtop:: all + + Parameter identity : forall (X:Set), X -> X. + + Check identity _ _. + + Check identity _ (fun x => _). + +In the general case, when an existential variable :n:`?@ident` appears +outside of its context of definition, its instance, written under the +form :n:`{ {*; @ident := @term} }` is appending to its name, indicating +how the variables of its defining context are instantiated. +The variables of the context of the existential variables which are +instantiated by themselves are not written, unless the :flag:`Printing Existential Instances` flag +is on (see Section :ref:`explicit-display-existentials`), and this is why an +existential variable used in the same context as its context of definition is written with no instance. + +.. coqtop:: all + + Check (fun x y => _) 0 1. + + Set Printing Existential Instances. + + Check (fun x y => _) 0 1. + +Existential variables can be named by the user upon creation using +the syntax :n:`?[@ident]`. This is useful when the existential +variable needs to be explicitly handled later in the script (e.g. +with a named-goal selector, see :ref:`goal-selectors`). + +.. extracted from Gallina chapter + +.. index:: _ + +Inferable subterms +~~~~~~~~~~~~~~~~~~ + +Expressions often contain redundant pieces of information. Subterms that can be +automatically inferred by Coq can be replaced by the symbol ``_`` and Coq will +guess the missing piece of information. + +.. extracted from Gallina extensions chapter + +.. _explicit-display-existentials: + +Explicit displaying of existential instances for pretty-printing +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. flag:: Printing Existential Instances + + This flag (off by default) activates the full display of how the + context of an existential variable is instantiated at each of the + occurrences of the existential variable. + +.. _tactics-in-terms: + +Solving existential variables using tactics +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Instead of letting the unification engine try to solve an existential +variable by itself, one can also provide an explicit hole together +with a tactic to solve it. Using the syntax ``ltac:(``\ `tacexpr`\ ``)``, the user +can put a tactic anywhere a term is expected. The order of resolution +is not specified and is implementation-dependent. The inner tactic may +use any variable defined in its scope, including repeated alternations +between variables introduced by term binding as well as those +introduced by tactic binding. The expression `tacexpr` can be any tactic +expression as described in :ref:`ltac`. + +.. coqtop:: all + + Definition foo (x : nat) : nat := ltac:(exact x). + +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. diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index 73b1b65097..b4f7fe0846 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -466,127 +466,6 @@ function. Check (id 1). Check (id' nat 1). -.. _canonical-structure-declaration: - -Canonical structures -~~~~~~~~~~~~~~~~~~~~ - -A canonical structure is an instance of a record/structure type that -can be used to solve unification problems involving a projection -applied to an unknown structure instance (an implicit argument) and a -value. The complete documentation of canonical structures can be found -in :ref:`canonicalstructures`; here only a simple example is given. - -.. cmd:: Canonical {? Structure } @smart_qualid - Canonical {? Structure } @ident_decl @def_body - :name: Canonical Structure; _ - - The first form of this command declares an existing :n:`@smart_qualid` as a - canonical instance of a structure (a record). - - The second form defines a new constant as if the :cmd:`Definition` command - had been used, then declares it as a canonical instance as if the first - form had been used on the defined object. - - This command supports the :attr:`local` attribute. When used, the - structure is canonical only within the :cmd:`Section` containing it. - - Assume that :token:`qualid` denotes an object ``(Build_struct`` |c_1| … |c_n| ``)`` in the - structure :g:`struct` of which the fields are |x_1|, …, |x_n|. - Then, each time an equation of the form ``(``\ |x_i| ``_)`` |eq_beta_delta_iota_zeta| |c_i| has to be - solved during the type checking process, :token:`qualid` is used as a solution. - Otherwise said, :token:`qualid` is canonically used to extend the field |c_i| - into a complete structure built on |c_i|. - - Canonical structures are particularly useful when mixed with coercions - and strict implicit arguments. - - .. example:: - - Here is an example. - - .. coqtop:: all reset - - Require Import Relations. - - Require Import EqNat. - - Set Implicit Arguments. - - Unset Strict Implicit. - - Structure Setoid : Type := {Carrier :> Set; Equal : relation Carrier; - Prf_equiv : equivalence Carrier Equal}. - - Definition is_law (A B:Setoid) (f:A -> B) := forall x y:A, Equal x y -> Equal (f x) (f y). - - Axiom eq_nat_equiv : equivalence nat eq_nat. - - Definition nat_setoid : Setoid := Build_Setoid eq_nat_equiv. - - Canonical nat_setoid. - - Thanks to :g:`nat_setoid` declared as canonical, the implicit arguments :g:`A` - and :g:`B` can be synthesized in the next statement. - - .. coqtop:: all abort - - Lemma is_law_S : is_law S. - - .. note:: - If a same field occurs in several canonical structures, then - only the structure declared first as canonical is considered. - - .. attr:: canonical(false) - - To prevent a field from being involved in the inference of - canonical instances, its declaration can be annotated with the - :attr:`canonical(false)` attribute (cf. the syntax of - :n:`@record_field`). - - .. example:: - - For instance, when declaring the :g:`Setoid` structure above, the - :g:`Prf_equiv` field declaration could be written as follows. - - .. coqdoc:: - - #[canonical(false)] Prf_equiv : equivalence Carrier Equal - - See :ref:`canonicalstructures` for a more realistic example. - -.. attr:: canonical - - This attribute can decorate a :cmd:`Definition` or :cmd:`Let` command. - It is equivalent to having a :cmd:`Canonical Structure` declaration just - after the command. - -.. cmd:: Print Canonical Projections {* @smart_qualid } - - This displays the list of global names that are components of some - canonical structure. For each of them, the canonical structure of - which it is a projection is indicated. If constants are given as - its arguments, only the unification rules that involve or are - synthesized from simultaneously all given constants will be shown. - - .. example:: - - For instance, the above example gives the following output: - - .. coqtop:: all - - Print Canonical Projections. - - .. coqtop:: all - - Print Canonical Projections nat. - - .. note:: - - The last line in the first example would not show up if the - corresponding projection (namely :g:`Prf_equiv`) were annotated as not - canonical, as described above. - Implicit types of variables ~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/language/extensions/index.rst b/doc/sphinx/language/extensions/index.rst index fc2ce03093..ed207ca743 100644 --- a/doc/sphinx/language/extensions/index.rst +++ b/doc/sphinx/language/extensions/index.rst @@ -16,13 +16,13 @@ language presented in the :ref:`previous chapter <core-language>`. .. toctree:: :maxdepth: 1 - ../gallina-extensions + evars implicit-arguments - ../../addendum/extended-pattern-matching + match ../../user-extensions/syntax-extensions arguments-command ../../addendum/implicit-coercions ../../addendum/type-classes - ../../addendum/canonical-structures + canonical ../../addendum/program ../../proof-engine/vernacular-commands diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst new file mode 100644 index 0000000000..028d0aaf57 --- /dev/null +++ b/doc/sphinx/language/extensions/match.rst @@ -0,0 +1,898 @@ +.. _extendedpatternmatching: + +Extended pattern matching +========================= + +:Authors: Cristina Cornes and Hugo Herbelin + +This section describes the full form of pattern matching in |Coq| terms. + +.. |rhs| replace:: right hand sides + +.. extracted from Gallina extensions chapter + +Variants and extensions of :g:`match` +------------------------------------- + +.. _mult-match: + +Multiple and nested pattern matching +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The basic version of :g:`match` allows pattern matching on simple +patterns. As an extension, multiple nested patterns or disjunction of +patterns are allowed, as in ML-like languages +(cf. :ref:`multiple-patterns` and :ref:`nested-patterns`). + +The extension just acts as a macro that is expanded during parsing +into a sequence of match on simple patterns. Especially, a +construction defined using the extended match is generally printed +under its expanded form (see :flag:`Printing Matching`). + +.. _if-then-else: + +Pattern-matching on boolean values: the if expression +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. insertprodn term_if term_if + +.. prodn:: + term_if ::= if @term {? {? as @name } return @term100 } then @term else @term + +For inductive types with exactly two constructors and for pattern matching +expressions that do not depend on the arguments of the constructors, it is possible +to use a ``if … then … else`` notation. For instance, the definition + +.. coqtop:: all + + Definition not (b:bool) := + match b with + | true => false + | false => true + end. + +can be alternatively written + +.. coqtop:: reset all + + Definition not (b:bool) := if b then false else true. + +More generally, for an inductive type with constructors :n:`@ident__1` +and :n:`@ident__2`, the following terms are equal: + +:n:`if @term__0 {? {? as @name } return @term } then @term__1 else @term__2` + +:n:`match @term__0 {? {? as @name } return @term } with | @ident__1 {* _ } => @term__1 | @ident__2 {* _ } => @term__2 end` + +.. example:: + + .. coqtop:: all + + Check (fun x (H:{x=0}+{x<>0}) => + match H with + | left _ => true + | right _ => false + end). + +Notice that the printing uses the :g:`if` syntax because :g:`sumbool` is +declared as such (see :ref:`controlling-match-pp`). + +.. _irrefutable-patterns: + +Irrefutable patterns: the destructuring let variants +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Pattern-matching on terms inhabiting inductive type having only one +constructor can be alternatively written using :g:`let … in …` +constructions. There are two variants of them. + + +First destructuring let syntax +++++++++++++++++++++++++++++++ + +The expression :n:`let ( {*, @ident__i } ) := @term__0 in @term__1` +performs case analysis on :n:`@term__0` whose type must be an +inductive type with exactly one constructor. The number of variables +:n:`@ident__i` must correspond to the number of arguments of this +contrustor. Then, in :n:`@term__1`, these variables are bound to the +arguments of the constructor in :n:`@term__0`. For instance, the +definition + +.. coqtop:: reset all + + Definition fst (A B:Set) (H:A * B) := match H with + | pair x y => x + end. + +can be alternatively written + +.. coqtop:: reset all + + Definition fst (A B:Set) (p:A * B) := let (x, _) := p in x. + +Notice that reduction is different from regular :g:`let … in …` +construction since it happens only if :n:`@term__0` is in constructor form. +Otherwise, the reduction is blocked. + +The pretty-printing of a definition by matching on a irrefutable +pattern can either be done using :g:`match` or the :g:`let` construction +(see Section :ref:`controlling-match-pp`). + +If term inhabits an inductive type with one constructor `C`, we have an +equivalence between + +:: + + let (ident₁, …, identₙ) [dep_ret_type] := term in term' + +and + +:: + + match term [dep_ret_type] with + C ident₁ … identₙ => term' + end + + +Second destructuring let syntax ++++++++++++++++++++++++++++++++ + +Another destructuring let syntax is available for inductive types with +one constructor by giving an arbitrary pattern instead of just a tuple +for all the arguments. For example, the preceding example can be +written: + +.. coqtop:: reset all + + Definition fst (A B:Set) (p:A*B) := let 'pair x _ := p in x. + +This is useful to match deeper inside tuples and also to use notations +for the pattern, as the syntax :g:`let ’p := t in b` allows arbitrary +patterns to do the deconstruction. For example: + +.. coqtop:: all + + Definition deep_tuple (A:Set) (x:(A*A)*(A*A)) : A*A*A*A := + let '((a,b), (c, d)) := x in (a,b,c,d). + + Notation " x 'With' p " := (exist _ x p) (at level 20). + + Definition proj1_sig' (A:Set) (P:A->Prop) (t:{ x:A | P x }) : A := + let 'x With p := t in x. + +When printing definitions which are written using this construct it +takes precedence over let printing directives for the datatype under +consideration (see Section :ref:`controlling-match-pp`). + + +.. _controlling-match-pp: + +Controlling pretty-printing of match expressions +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The following commands give some control over the pretty-printing +of :g:`match` expressions. + +Printing nested patterns ++++++++++++++++++++++++++ + +.. flag:: Printing Matching + + The Calculus of Inductive Constructions knows pattern matching only + over simple patterns. It is however convenient to re-factorize nested + pattern matching into a single pattern matching over a nested + pattern. + + When this flag is on (default), |Coq|’s printer tries to do such + limited re-factorization. + Turning it off tells |Coq| to print only simple pattern matching problems + in the same way as the |Coq| kernel handles them. + + +Factorization of clauses with same right-hand side +++++++++++++++++++++++++++++++++++++++++++++++++++ + +.. flag:: Printing Factorizable Match Patterns + + When several patterns share the same right-hand side, it is additionally + possible to share the clauses using disjunctive patterns. Assuming that the + printing matching mode is on, this flag (on by default) tells |Coq|'s + printer to try to do this kind of factorization. + +Use of a default clause ++++++++++++++++++++++++ + +.. flag:: Printing Allow Match Default Clause + + When several patterns share the same right-hand side which do not depend on the + arguments of the patterns, yet an extra factorization is possible: the + disjunction of patterns can be replaced with a `_` default clause. Assuming that + the printing matching mode and the factorization mode are on, this flag (on by + default) tells |Coq|'s printer to use a default clause when relevant. + +Printing of wildcard patterns +++++++++++++++++++++++++++++++ + +.. flag:: Printing Wildcard + + Some variables in a pattern may not occur in the right-hand side of + the pattern matching clause. When this flag is on (default), the + variables having no occurrences in the right-hand side of the + pattern matching clause are just printed using the wildcard symbol + “_”. + + +Printing of the elimination predicate ++++++++++++++++++++++++++++++++++++++ + +.. flag:: Printing Synth + + In most of the cases, the type of the result of a matched term is + mechanically synthesizable. Especially, if the result type does not + depend of the matched term. When this flag is on (default), + the result type is not printed when |Coq| knows that it can re- + synthesize it. + + +Printing matching on irrefutable patterns +++++++++++++++++++++++++++++++++++++++++++ + +If an inductive type has just one constructor, pattern matching can be +written using the first destructuring let syntax. + +.. table:: Printing Let @qualid + :name: Printing Let + + Specifies a set of qualids for which pattern matching is displayed using a let expression. + Note that this only applies to pattern matching instances entered with :g:`match`. + It doesn't affect pattern matching explicitly entered with a destructuring + :g:`let`. + Use the :cmd:`Add` and :cmd:`Remove` commands to update this set. + + +Printing matching on booleans ++++++++++++++++++++++++++++++ + +If an inductive type is isomorphic to the boolean type, pattern matching +can be written using ``if`` … ``then`` … ``else`` …. This table controls +which types are written this way: + +.. table:: Printing If @qualid + :name: Printing If + + Specifies a set of qualids for which pattern matching is displayed using + ``if`` … ``then`` … ``else`` …. Use the :cmd:`Add` and :cmd:`Remove` + commands to update this set. + +This example emphasizes what the printing settings offer. + +.. example:: + + .. coqtop:: all + + Definition snd (A B:Set) (H:A * B) := match H with + | pair x y => y + end. + + Test Printing Let for prod. + + Print snd. + + Remove Printing Let prod. + + Unset Printing Synth. + + Unset Printing Wildcard. + + Print snd. + +Patterns +-------- + +The full syntax of `match` is presented in :ref:`match`. +Identifiers in patterns are either constructor names or variables. Any +identifier that is not the constructor of an inductive or co-inductive +type is considered to be a variable. A variable name cannot occur more +than once in a given pattern. It is recommended to start variable +names by a lowercase letter. + +If a pattern has the form ``c x`` where ``c`` is a constructor symbol and x +is a linear vector of (distinct) variables, it is called *simple*: it +is the kind of pattern recognized by the basic version of match. On +the opposite, if it is a variable ``x`` or has the form ``c p`` with ``p`` not +only made of variables, the pattern is called *nested*. + +A variable pattern matches any value, and the identifier is bound to +that value. The pattern “``_``” (called “don't care” or “wildcard” symbol) +also matches any value, but does not bind anything. It may occur an +arbitrary number of times in a pattern. Alias patterns written +:n:`(@pattern as @ident)` are also accepted. This pattern matches the +same values as :token:`pattern` does and :token:`ident` is bound to the matched +value. A pattern of the form :n:`@pattern | @pattern` is called disjunctive. A +list of patterns separated with commas is also considered as a pattern +and is called *multiple pattern*. However multiple patterns can only +occur at the root of pattern matching equations. Disjunctions of +*multiple patterns* are allowed though. + +Since extended ``match`` expressions are compiled into the primitive ones, +the expressiveness of the theory remains the same. Once parsing has finished +only simple patterns remain. The original nesting of the ``match`` expressions +is recovered at printing time. An easy way to see the result +of the expansion is to toggle off the nesting performed at printing +(use here :flag:`Printing Matching`), then by printing the term with :cmd:`Print` +if the term is a constant, or using the command :cmd:`Check`. + +The extended ``match`` still accepts an optional *elimination predicate* +given after the keyword ``return``. Given a pattern matching expression, +if all the right-hand-sides of ``=>`` have the same +type, then this type can be sometimes synthesized, and so we can omit +the return part. Otherwise the predicate after return has to be +provided, like for the basicmatch. + +Let us illustrate through examples the different aspects of extended +pattern matching. Consider for example the function that computes the +maximum of two natural numbers. We can write it in primitive syntax +by: + +.. coqtop:: in + + Fixpoint max (n m:nat) {struct m} : nat := + match n with + | O => m + | S n' => match m with + | O => S n' + | S m' => S (max n' m') + end + end. + +.. _multiple-patterns: + +Multiple patterns +----------------- + +Using multiple patterns in the definition of ``max`` lets us write: + +.. coqtop:: in reset + + Fixpoint max (n m:nat) {struct m} : nat := + match n, m with + | O, _ => m + | S n', O => S n' + | S n', S m' => S (max n' m') + end. + +which will be compiled into the previous form. + +The pattern matching compilation strategy examines patterns from left +to right. A match expression is generated **only** when there is at least +one constructor in the column of patterns. E.g. the following example +does not build a match expression. + +.. coqtop:: all + + Check (fun x:nat => match x return nat with + | y => y + end). + + +Aliasing subpatterns +-------------------- + +We can also use :n:`as @ident` to associate a name to a sub-pattern: + +.. coqtop:: in reset + + Fixpoint max (n m:nat) {struct n} : nat := + match n, m with + | O, _ => m + | S n' as p, O => p + | S n', S m' => S (max n' m') + end. + +.. _nested-patterns: + +Nested patterns +--------------- + +Here is now an example of nested patterns: + +.. coqtop:: in + + Fixpoint even (n:nat) : bool := + match n with + | O => true + | S O => false + | S (S n') => even n' + end. + +This is compiled into: + +.. coqtop:: all + + Unset Printing Matching. + Print even. + +.. coqtop:: none + + Set Printing Matching. + +In the previous examples patterns do not conflict with, but sometimes +it is comfortable to write patterns that admit a non trivial +superposition. Consider the boolean function :g:`lef` that given two +natural numbers yields :g:`true` if the first one is less or equal than the +second one and :g:`false` otherwise. We can write it as follows: + +.. coqtop:: in + + Fixpoint lef (n m:nat) {struct m} : bool := + match n, m with + | O, x => true + | x, O => false + | S n, S m => lef n m + end. + +Note that the first and the second multiple pattern overlap because +the couple of values ``O O`` matches both. Thus, what is the result of the +function on those values? To eliminate ambiguity we use the *textual +priority rule:* we consider patterns to be ordered from top to bottom. A +value is matched by the pattern at the ith row if and only if it is +not matched by some pattern from a previous row. Thus in the example, ``O O`` +is matched by the first pattern, and so :g:`(lef O O)` yields true. + +Another way to write this function is: + +.. coqtop:: in reset + + Fixpoint lef (n m:nat) {struct m} : bool := + match n, m with + | O, x => true + | S n, S m => lef n m + | _, _ => false + end. + +Here the last pattern superposes with the first two. Because of the +priority rule, the last pattern will be used only for values that do +not match neither the first nor the second one. + +Terms with useless patterns are not accepted by the system. Here is an +example: + +.. coqtop:: all + + Fail Check (fun x:nat => + match x with + | O => true + | S _ => false + | x => true + end). + + +Disjunctive patterns +-------------------- + +Multiple patterns that share the same right-hand-side can be +factorized using the notation :n:`{+| {+, @pattern } }`. For +instance, :g:`max` can be rewritten as follows: + +.. coqtop:: in reset + + Fixpoint max (n m:nat) {struct m} : nat := + match n, m with + | S n', S m' => S (max n' m') + | 0, p | p, 0 => p + end. + +Similarly, factorization of (not necessarily multiple) patterns that +share the same variables is possible by using the notation :n:`{+| @pattern}`. +Here is an example: + +.. coqtop:: in + + Definition filter_2_4 (n:nat) : nat := + match n with + | 2 as m | 4 as m => m + | _ => 0 + end. + + +Nested disjunctive patterns are allowed, inside parentheses, with the +notation :n:`({+| @pattern})`, as in: + +.. coqtop:: in + + Definition filter_some_square_corners (p:nat*nat) : nat*nat := + match p with + | ((2 as m | 4 as m), (3 as n | 5 as n)) => (m,n) + | _ => (0,0) + end. + +About patterns of parametric types +---------------------------------- + +Parameters in patterns +~~~~~~~~~~~~~~~~~~~~~~ + +When matching objects of a parametric type, parameters do not bind in +patterns. They must be substituted by “``_``”. Consider for example the +type of polymorphic lists: + +.. coqtop:: in + + Inductive List (A:Set) : Set := + | nil : List A + | cons : A -> List A -> List A. + +We can check the function *tail*: + +.. coqtop:: all + + Check + (fun l:List nat => + match l with + | nil _ => nil nat + | cons _ _ l' => l' + end). + +When we use parameters in patterns there is an error message: + +.. coqtop:: all + + Fail Check + (fun l:List nat => + match l with + | nil A => nil nat + | cons A _ l' => l' + end). + +.. flag:: Asymmetric Patterns + + This flag (off by default) removes parameters from constructors in patterns: + +.. coqtop:: all + + Set Asymmetric Patterns. + Check (fun l:List nat => + match l with + | nil => nil _ + | cons _ l' => l' + end). + Unset Asymmetric Patterns. + +Implicit arguments in patterns +------------------------------ + +By default, implicit arguments are omitted in patterns. So we write: + +.. coqtop:: all + + Arguments nil {A}. + Arguments cons [A] _ _. + Check + (fun l:List nat => + match l with + | nil => nil + | cons _ l' => l' + end). + +But the possibility to use all the arguments is given by “``@``” implicit +explicitations (as for terms, see :ref:`explicit-applications`). + +.. coqtop:: all + + Check + (fun l:List nat => + match l with + | @nil _ => @nil nat + | @cons _ _ l' => l' + end). + + +.. _matching-dependent: + +Matching objects of dependent types +----------------------------------- + +The previous examples illustrate pattern matching on objects of non- +dependent types, but we can also use the expansion strategy to +destructure objects of dependent types. Consider the type :g:`listn` of +lists of a certain length: + +.. coqtop:: in reset + + Inductive listn : nat -> Set := + | niln : listn 0 + | consn : forall n:nat, nat -> listn n -> listn (S n). + + +Understanding dependencies in patterns +-------------------------------------- + +We can define the function length over :g:`listn` by: + +.. coqdoc:: + + Definition length (n:nat) (l:listn n) := n. + +Just for illustrating pattern matching, we can define it by case +analysis: + +.. coqtop:: in + + Definition length (n:nat) (l:listn n) := + match l with + | niln => 0 + | consn n _ _ => S n + end. + +We can understand the meaning of this definition using the same +notions of usual pattern matching. + + +When the elimination predicate must be provided +----------------------------------------------- + +Dependent pattern matching +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The examples given so far do not need an explicit elimination +predicate because all the |rhs| have the same type and Coq +succeeds to synthesize it. Unfortunately when dealing with dependent +patterns it often happens that we need to write cases where the types +of the |rhs| are different instances of the elimination predicate. The +function :g:`concat` for :g:`listn` is an example where the branches have +different types and we need to provide the elimination predicate: + +.. coqtop:: in + + Fixpoint concat (n:nat) (l:listn n) (m:nat) (l':listn m) {struct l} : + listn (n + m) := + match l in listn n return listn (n + m) with + | niln => l' + | consn n' a y => consn (n' + m) a (concat n' y m l') + end. + +.. coqtop:: none + + Reset concat. + +The elimination predicate is :g:`fun (n:nat) (l:listn n) => listn (n+m)`. +In general if :g:`m` has type :g:`(I q1 … qr t1 … ts)` where :g:`q1, …, qr` +are parameters, the elimination predicate should be of the form :g:`fun y1 … ys x : (I q1 … qr y1 … ys ) => Q`. + +In the concrete syntax, it should be written : +``match m as x in (I _ … _ y1 … ys) return Q with … end``. +The variables which appear in the ``in`` and ``as`` clause are new and bounded +in the property :g:`Q` in the return clause. The parameters of the +inductive definitions should not be mentioned and are replaced by ``_``. + +Multiple dependent pattern matching +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Recall that a list of patterns is also a pattern. So, when we +destructure several terms at the same time and the branches have +different types we need to provide the elimination predicate for this +multiple pattern. It is done using the same scheme: each term may be +associated to an ``as`` clause and an ``in`` clause in order to introduce +a dependent product. + +For example, an equivalent definition for :g:`concat` (even though the +matching on the second term is trivial) would have been: + +.. coqtop:: in + + Fixpoint concat (n:nat) (l:listn n) (m:nat) (l':listn m) {struct l} : + listn (n + m) := + match l in listn n, l' return listn (n + m) with + | niln, x => x + | consn n' a y, x => consn (n' + m) a (concat n' y m x) + end. + +Even without real matching over the second term, this construction can +be used to keep types linked. If :g:`a` and :g:`b` are two :g:`listn` of the same +length, by writing + +.. coqtop:: in + + Check (fun n (a b: listn n) => + match a, b with + | niln, b0 => tt + | consn n' a y, bS => tt + end). + +we have a copy of :g:`b` in type :g:`listn 0` resp. :g:`listn (S n')`. + +.. _match-in-patterns: + +Patterns in ``in`` +~~~~~~~~~~~~~~~~~~ + +If the type of the matched term is more precise than an inductive +applied to variables, arguments of the inductive in the ``in`` branch can +be more complicated patterns than a variable. + +Moreover, constructors whose types do not follow the same pattern will +become impossible branches. In an impossible branch, you can answer +anything but False_rect unit has the advantage to be subterm of +anything. + +To be concrete: the ``tail`` function can be written: + +.. coqtop:: in + + Definition tail n (v: listn (S n)) := + match v in listn (S m) return listn m with + | niln => False_rect unit + | consn n' a y => y + end. + +and :g:`tail n v` will be subterm of :g:`v`. + +Using pattern matching to write proofs +-------------------------------------- + +In all the previous examples the elimination predicate does not depend +on the object(s) matched. But it may depend and the typical case is +when we write a proof by induction or a function that yields an object +of a dependent type. An example of a proof written using ``match`` is given +in the description of the tactic :tacn:`refine`. + +For example, we can write the function :g:`buildlist` that given a natural +number :g:`n` builds a list of length :g:`n` containing zeros as follows: + +.. coqtop:: in + + Fixpoint buildlist (n:nat) : listn n := + match n return listn n with + | O => niln + | S n => consn n 0 (buildlist n) + end. + +We can also use multiple patterns. Consider the following definition +of the predicate less-equal :g:`Le`: + +.. coqtop:: in + + Inductive LE : nat -> nat -> Prop := + | LEO : forall n:nat, LE 0 n + | LES : forall n m:nat, LE n m -> LE (S n) (S m). + +We can use multiple patterns to write the proof of the lemma +:g:`forall (n m:nat), (LE n m) \/ (LE m n)`: + +.. coqtop:: in + + Fixpoint dec (n m:nat) {struct n} : LE n m \/ LE m n := + match n, m return LE n m \/ LE m n with + | O, x => or_introl (LE x 0) (LEO x) + | x, O => or_intror (LE x 0) (LEO x) + | S n as n', S m as m' => + match dec n m with + | or_introl h => or_introl (LE m' n') (LES n m h) + | or_intror h => or_intror (LE n' m') (LES m n h) + end + end. + +In the example of :g:`dec`, the first match is dependent while the second +is not. + +The user can also use match in combination with the tactic :tacn:`refine` +to build incomplete proofs beginning with a :g:`match` construction. + + +Pattern-matching on inductive objects involving local definitions +----------------------------------------------------------------- + +If local definitions occur in the type of a constructor, then there +are two ways to match on this constructor. Either the local +definitions are skipped and matching is done only on the true +arguments of the constructors, or the bindings for local definitions +can also be caught in the matching. + +.. example:: + + .. coqtop:: in reset + + Inductive list : nat -> Set := + | nil : list 0 + | cons : forall n:nat, let m := (2 * n) in list m -> list (S (S m)). + + In the next example, the local definition is not caught. + + .. coqtop:: in + + Fixpoint length n (l:list n) {struct l} : nat := + match l with + | nil => 0 + | cons n l0 => S (length (2 * n) l0) + end. + + But in this example, it is. + + .. coqtop:: in + + Fixpoint length' n (l:list n) {struct l} : nat := + match l with + | nil => 0 + | @cons _ m l0 => S (length' m l0) + end. + +.. note:: For a given matching clause, either none of the local + definitions or all of them can be caught. + +.. note:: You can only catch let bindings in mode where you bind all + variables and so you have to use ``@`` syntax. + +.. note:: this feature is incoherent with the fact that parameters + cannot be caught and consequently is somehow hidden. For example, + there is no mention of it in error messages. + +Pattern-matching and coercions +------------------------------ + +If a mismatch occurs between the expected type of a pattern and its +actual type, a coercion made from constructors is sought. If such a +coercion can be found, it is automatically inserted around the +pattern. + +.. example:: + + .. coqtop:: in + + Inductive I : Set := + | C1 : nat -> I + | C2 : I -> I. + + Coercion C1 : nat >-> I. + + .. coqtop:: all + + Check (fun x => match x with + | C2 O => 0 + | _ => 0 + end). + + +When does the expansion strategy fail? +-------------------------------------- + +The strategy works very like in ML languages when treating patterns of +non-dependent types. But there are new cases of failure that are due to +the presence of dependencies. + +The error messages of the current implementation may be sometimes +confusing. When the tactic fails because patterns are somehow +incorrect then error messages refer to the initial expression. But the +strategy may succeed to build an expression whose sub-expressions are +well typed when the whole expression is not. In this situation the +message makes reference to the expanded expression. We encourage +users, when they have patterns with the same outer constructor in +different equations, to name the variable patterns in the same +positions with the same name. E.g. to write ``(cons n O x) => e1`` and +``(cons n _ x) => e2`` instead of ``(cons n O x) => e1`` and +``(cons n' _ x') => e2``. This helps to maintain certain name correspondence between the +generated expression and the original. + +Here is a summary of the error messages corresponding to each +situation: + +.. exn:: The constructor @ident expects @num arguments. + + The variable ident is bound several times in pattern termFound a constructor + of inductive type term while a constructor of term is expectedPatterns are + incorrect (because constructors are not applied to the correct number of the + arguments, because they are not linear or they are wrongly typed). + +.. exn:: Non exhaustive pattern matching. + + The pattern matching is not exhaustive. + +.. exn:: The elimination predicate term should be of arity @num (for non \ + dependent case) or @num (for dependent case). + + The elimination predicate provided to match has not the expected arity. + +.. exn:: Unable to infer a match predicate + Either there is a type incompatibility or the problem involves dependencies. + + There is a type mismatch between the different branches. The user should + provide an elimination predicate. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 5b78280edc..29929618d4 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -1,1114 +1,5 @@ -.. _extensionsofgallina: +:orphan: -Extensions of |Gallina| -======================= +.. raw:: html -|Gallina| is the kernel language of |Coq|. We describe here extensions of -|Gallina|’s syntax. - -Variants and extensions of :g:`match` -------------------------------------- - -.. _mult-match: - -Multiple and nested pattern matching -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The basic version of :g:`match` allows pattern matching on simple -patterns. As an extension, multiple nested patterns or disjunction of -patterns are allowed, as in ML-like languages. - -The extension just acts as a macro that is expanded during parsing -into a sequence of match on simple patterns. Especially, a -construction defined using the extended match is generally printed -under its expanded form (see :flag:`Printing Matching`). - -.. seealso:: :ref:`extendedpatternmatching`. - -.. _if-then-else: - -Pattern-matching on boolean values: the if expression -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. insertprodn term_if term_if - -.. prodn:: - term_if ::= if @term {? {? as @name } return @term100 } then @term else @term - -For inductive types with exactly two constructors and for pattern matching -expressions that do not depend on the arguments of the constructors, it is possible -to use a ``if … then … else`` notation. For instance, the definition - -.. coqtop:: all - - Definition not (b:bool) := - match b with - | true => false - | false => true - end. - -can be alternatively written - -.. coqtop:: reset all - - Definition not (b:bool) := if b then false else true. - -More generally, for an inductive type with constructors :n:`@ident__1` -and :n:`@ident__2`, the following terms are equal: - -:n:`if @term__0 {? {? as @name } return @term } then @term__1 else @term__2` - -:n:`match @term__0 {? {? as @name } return @term } with | @ident__1 {* _ } => @term__1 | @ident__2 {* _ } => @term__2 end` - -.. example:: - - .. coqtop:: all - - Check (fun x (H:{x=0}+{x<>0}) => - match H with - | left _ => true - | right _ => false - end). - -Notice that the printing uses the :g:`if` syntax because :g:`sumbool` is -declared as such (see :ref:`controlling-match-pp`). - -.. _irrefutable-patterns: - -Irrefutable patterns: the destructuring let variants -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Pattern-matching on terms inhabiting inductive type having only one -constructor can be alternatively written using :g:`let … in …` -constructions. There are two variants of them. - - -First destructuring let syntax -++++++++++++++++++++++++++++++ - -The expression :n:`let ( {*, @ident__i } ) := @term__0 in @term__1` -performs case analysis on :n:`@term__0` whose type must be an -inductive type with exactly one constructor. The number of variables -:n:`@ident__i` must correspond to the number of arguments of this -contrustor. Then, in :n:`@term__1`, these variables are bound to the -arguments of the constructor in :n:`@term__0`. For instance, the -definition - -.. coqtop:: reset all - - Definition fst (A B:Set) (H:A * B) := match H with - | pair x y => x - end. - -can be alternatively written - -.. coqtop:: reset all - - Definition fst (A B:Set) (p:A * B) := let (x, _) := p in x. - -Notice that reduction is different from regular :g:`let … in …` -construction since it happens only if :n:`@term__0` is in constructor form. -Otherwise, the reduction is blocked. - -The pretty-printing of a definition by matching on a irrefutable -pattern can either be done using :g:`match` or the :g:`let` construction -(see Section :ref:`controlling-match-pp`). - -If term inhabits an inductive type with one constructor `C`, we have an -equivalence between - -:: - - let (ident₁, …, identₙ) [dep_ret_type] := term in term' - -and - -:: - - match term [dep_ret_type] with - C ident₁ … identₙ => term' - end - - -Second destructuring let syntax -+++++++++++++++++++++++++++++++ - -Another destructuring let syntax is available for inductive types with -one constructor by giving an arbitrary pattern instead of just a tuple -for all the arguments. For example, the preceding example can be -written: - -.. coqtop:: reset all - - Definition fst (A B:Set) (p:A*B) := let 'pair x _ := p in x. - -This is useful to match deeper inside tuples and also to use notations -for the pattern, as the syntax :g:`let ’p := t in b` allows arbitrary -patterns to do the deconstruction. For example: - -.. coqtop:: all - - Definition deep_tuple (A:Set) (x:(A*A)*(A*A)) : A*A*A*A := - let '((a,b), (c, d)) := x in (a,b,c,d). - - Notation " x 'With' p " := (exist _ x p) (at level 20). - - Definition proj1_sig' (A:Set) (P:A->Prop) (t:{ x:A | P x }) : A := - let 'x With p := t in x. - -When printing definitions which are written using this construct it -takes precedence over let printing directives for the datatype under -consideration (see Section :ref:`controlling-match-pp`). - - -.. _controlling-match-pp: - -Controlling pretty-printing of match expressions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The following commands give some control over the pretty-printing -of :g:`match` expressions. - -Printing nested patterns -+++++++++++++++++++++++++ - -.. flag:: Printing Matching - - The Calculus of Inductive Constructions knows pattern matching only - over simple patterns. It is however convenient to re-factorize nested - pattern matching into a single pattern matching over a nested - pattern. - - When this flag is on (default), |Coq|’s printer tries to do such - limited re-factorization. - Turning it off tells |Coq| to print only simple pattern matching problems - in the same way as the |Coq| kernel handles them. - - -Factorization of clauses with same right-hand side -++++++++++++++++++++++++++++++++++++++++++++++++++ - -.. flag:: Printing Factorizable Match Patterns - - When several patterns share the same right-hand side, it is additionally - possible to share the clauses using disjunctive patterns. Assuming that the - printing matching mode is on, this flag (on by default) tells |Coq|'s - printer to try to do this kind of factorization. - -Use of a default clause -+++++++++++++++++++++++ - -.. flag:: Printing Allow Match Default Clause - - When several patterns share the same right-hand side which do not depend on the - arguments of the patterns, yet an extra factorization is possible: the - disjunction of patterns can be replaced with a `_` default clause. Assuming that - the printing matching mode and the factorization mode are on, this flag (on by - default) tells |Coq|'s printer to use a default clause when relevant. - -Printing of wildcard patterns -++++++++++++++++++++++++++++++ - -.. flag:: Printing Wildcard - - Some variables in a pattern may not occur in the right-hand side of - the pattern matching clause. When this flag is on (default), the - variables having no occurrences in the right-hand side of the - pattern matching clause are just printed using the wildcard symbol - “_”. - - -Printing of the elimination predicate -+++++++++++++++++++++++++++++++++++++ - -.. flag:: Printing Synth - - In most of the cases, the type of the result of a matched term is - mechanically synthesizable. Especially, if the result type does not - depend of the matched term. When this flag is on (default), - the result type is not printed when |Coq| knows that it can re- - synthesize it. - - -Printing matching on irrefutable patterns -++++++++++++++++++++++++++++++++++++++++++ - -If an inductive type has just one constructor, pattern matching can be -written using the first destructuring let syntax. - -.. table:: Printing Let @qualid - :name: Printing Let - - Specifies a set of qualids for which pattern matching is displayed using a let expression. - Note that this only applies to pattern matching instances entered with :g:`match`. - It doesn't affect pattern matching explicitly entered with a destructuring - :g:`let`. - Use the :cmd:`Add` and :cmd:`Remove` commands to update this set. - - -Printing matching on booleans -+++++++++++++++++++++++++++++ - -If an inductive type is isomorphic to the boolean type, pattern matching -can be written using ``if`` … ``then`` … ``else`` …. This table controls -which types are written this way: - -.. table:: Printing If @qualid - :name: Printing If - - Specifies a set of qualids for which pattern matching is displayed using - ``if`` … ``then`` … ``else`` …. Use the :cmd:`Add` and :cmd:`Remove` - commands to update this set. - -This example emphasizes what the printing settings offer. - -.. example:: - - .. coqtop:: all - - Definition snd (A B:Set) (H:A * B) := match H with - | pair x y => y - end. - - Test Printing Let for prod. - - Print snd. - - Remove Printing Let prod. - - Unset Printing Synth. - - Unset Printing Wildcard. - - Print snd. - -Module system -------------- - -The module system provides a way of packaging related elements -together, as well as a means of massive abstraction. - - -.. cmd:: Module {? {| Import | Export } } @ident {* @module_binder } {? @of_module_type } {? := {+<+ @module_expr_inl } } - - .. insertprodn module_binder module_expr_inl - - .. prodn:: - module_binder ::= ( {? {| Import | Export } } {+ @ident } : @module_type_inl ) - module_type_inl ::= ! @module_type - | @module_type {? @functor_app_annot } - functor_app_annot ::= [ inline at level @num ] - | [ no inline ] - module_type ::= @qualid - | ( @module_type ) - | @module_type @module_expr_atom - | @module_type with @with_declaration - with_declaration ::= Definition @qualid {? @univ_decl } := @term - | Module @qualid := @qualid - module_expr_atom ::= @qualid - | ( {+ @module_expr_atom } ) - of_module_type ::= : @module_type_inl - | {* <: @module_type_inl } - module_expr_inl ::= ! {+ @module_expr_atom } - | {+ @module_expr_atom } {? @functor_app_annot } - - Defines a module named :token:`ident`. See the examples :ref:`here<module_examples>`. - - The :n:`Import` and :n:`Export` flags specify whether the module should be automatically - imported or exported. - - Specifying :n:`{* @module_binder }` starts a functor with - parameters given by the :n:`@module_binder`\s. (A *functor* is a function - from modules to modules.) - - :n:`@of_module_type` specifies the module type. :n:`{+ <: @module_type_inl }` - starts a module that satisfies each :n:`@module_type_inl`. - - .. todo: would like to find a better term than "interactive", not very descriptive - - :n:`:= {+<+ @module_expr_inl }` specifies the body of a module or functor - definition. If it's not specified, then the module is defined *interactively*, - meaning that the module is defined as a series of commands terminated with :cmd:`End` - instead of in a single :cmd:`Module` command. - Interactively defining the :n:`@module_expr_inl`\s in a series of - :cmd:`Include` commands is equivalent to giving them all in a single - non-interactive :cmd:`Module` command. - - The ! prefix indicates that any assumption command (such as :cmd:`Axiom`) with an :n:`Inline` clause - in the type of the functor arguments will be ignored. - - .. todo: What is an Inline directive? sb command but still unclear. Maybe referring to the - "inline" in functor_app_annot? or assumption_token Inline assum_list? - -.. cmd:: Module Type @ident {* @module_binder } {* <: @module_type_inl } {? := {+<+ @module_type_inl } } - - Defines a module type named :n:`@ident`. See the example :ref:`here<example_def_simple_module_type>`. - - Specifying :n:`{* @module_binder }` starts a functor type with - parameters given by the :n:`@module_binder`\s. - - :n:`:= {+<+ @module_type_inl }` specifies the body of a module or functor type - definition. If it's not specified, then the module type is defined *interactively*, - meaning that the module type is defined as a series of commands terminated with :cmd:`End` - instead of in a single :cmd:`Module Type` command. - Interactively defining the :n:`@module_type_inl`\s in a series of - :cmd:`Include` commands is equivalent to giving them all in a single - non-interactive :cmd:`Module Type` command. - -.. _terminating_module: - -**Terminating an interactive module or module type definition** - -Interactive modules are terminated with the :cmd:`End` command, which -is also used to terminate :ref:`Sections<section-mechanism>`. -:n:`End @ident` closes the interactive module or module type :token:`ident`. -If the module type was given, the command verifies that the content of the module -matches the module type. If the module is not a -functor, its components (constants, inductive types, submodules etc.) -are now available through the dot notation. - -.. exn:: No such label @ident. - :undocumented: - -.. exn:: Signature components for label @ident do not match. - :undocumented: - -.. exn:: The field @ident is missing in @qualid. - :undocumented: - -.. |br| raw:: html - - <br> - -.. note:: - - #. Interactive modules and module types can be nested. - #. Interactive modules and module types can't be defined inside of :ref:`sections<section-mechanism>`. - Sections can be defined inside of interactive modules and module types. - #. Hints and notations (:cmd:`Hint` and :cmd:`Notation` commands) can also appear inside interactive - modules and module types. Note that with module definitions like: - - :n:`Module @ident__1 : @module_type := @ident__2.` - - or - - :n:`Module @ident__1 : @module_type.` |br| - :n:`Include @ident__2.` |br| - :n:`End @ident__1.` - - hints and the like valid for :n:`@ident__1` are the ones defined in :n:`@module_type` - rather then those defined in :n:`@ident__2` (or the module body). - #. Within an interactive module type definition, the :cmd:`Parameter` command declares a - constant instead of definining a new axiom (which it does when not in a module type definition). - #. Assumptions such as :cmd:`Axiom` that include the :n:`Inline` clause will be automatically - expanded when the functor is applied, except when the function application is prefixed by ``!``. - -.. cmd:: Include @module_type_inl {* <+ @module_expr_inl } - - Includes the content of module(s) in the current - interactive module. Here :n:`@module_type_inl` can be a module expression or a module - type expression. If it is a high-order module or module type - expression then the system tries to instantiate :n:`@module_type_inl` with the current - interactive module. - - Including multiple modules is a single :cmd:`Include` is equivalent to including each module - in a separate :cmd:`Include` command. - -.. cmd:: Include Type {+<+ @module_type_inl } - - .. deprecated:: 8.3 - - Use :cmd:`Include` instead. - -.. cmd:: Declare Module {? {| Import | Export } } @ident {* @module_binder } : @module_type_inl - - Declares a module :token:`ident` of type :token:`module_type_inl`. - - If :n:`@module_binder`\s are specified, declares a functor with parameters given by the list of - :token:`module_binder`\s. - -.. cmd:: Import {+ @filtered_import } - - .. insertprodn filtered_import filtered_import - - .. prodn:: - filtered_import ::= @qualid {? ( {+, @qualid {? ( .. ) } } ) } - - If :token:`qualid` denotes a valid basic module (i.e. its module type is a - signature), makes its components available by their short names. - - .. example:: - - .. coqtop:: reset in - - Module Mod. - Definition T:=nat. - Check T. - End Mod. - Check Mod.T. - - .. coqtop:: all - - Fail Check T. - Import Mod. - Check T. - - Some features defined in modules are activated only when a module is - imported. This is for instance the case of notations (see :ref:`Notations`). - - Declarations made with the :attr:`local` attribute are never imported by the :cmd:`Import` - command. Such declarations are only accessible through their fully - qualified name. - - .. example:: - - .. coqtop:: in - - Module A. - Module B. - Local Definition T := nat. - End B. - End A. - Import A. - - .. coqtop:: all fail - - Check B.T. - - Appending a module name with a parenthesized list of names will - make only those names available with short names, not other names - defined in the module nor will it activate other features. - - The names to import may be constants, inductive types and - constructors, and notation aliases (for instance, Ltac definitions - cannot be selectively imported). If they are from an inner module - to the one being imported, they must be prefixed by the inner path. - - The name of an inductive type may also be followed by ``(..)`` to - import it, its constructors and its eliminators if they exist. For - this purpose "eliminator" means a constant in the same module whose - name is the inductive type's name suffixed by one of ``_sind``, - ``_ind``, ``_rec`` or ``_rect``. - - .. example:: - - .. coqtop:: reset in - - Module A. - Module B. - Inductive T := C. - Definition U := nat. - End B. - Definition Z := Prop. - End A. - Import A(B.T(..), Z). - - .. coqtop:: all - - Check B.T. - Check B.C. - Check Z. - Fail Check B.U. - Check A.B.U. - -.. cmd:: Export {+ @filtered_import } - :name: Export - - Similar to :cmd:`Import`, except that when the module containing this command - is imported, the :n:`{+ @qualid }` are imported as well. - - The selective import syntax also works with Export. - - .. exn:: @qualid is not a module. - :undocumented: - - .. warn:: Trying to mask the absolute name @qualid! - :undocumented: - -.. cmd:: Print Module @qualid - - Prints the module type and (optionally) the body of the module :n:`@qualid`. - -.. cmd:: Print Module Type @qualid - - Prints the module type corresponding to :n:`@qualid`. - -.. flag:: Short Module Printing - - This flag (off by default) disables the printing of the types of fields, - leaving only their names, for the commands :cmd:`Print Module` and - :cmd:`Print Module Type`. - -.. _module_examples: - -Examples -~~~~~~~~ - -.. example:: Defining a simple module interactively - - .. coqtop:: in - - Module M. - Definition T := nat. - Definition x := 0. - - .. coqtop:: all - - Definition y : bool. - exact true. - - .. coqtop:: in - - Defined. - End M. - -Inside a module one can define constants, prove theorems and do anything -else that can be done in the toplevel. Components of a closed -module can be accessed using the dot notation: - -.. coqtop:: all - - Print M.x. - -.. _example_def_simple_module_type: - -.. example:: Defining a simple module type interactively - - .. coqtop:: in - - Module Type SIG. - Parameter T : Set. - Parameter x : T. - End SIG. - -.. _example_filter_module: - -.. example:: Creating a new module that omits some items from an existing module - - Since :n:`SIG`, the type of the new module :n:`N`, doesn't define :n:`y` or - give the body of :n:`x`, which are not included in :n:`N`. - - .. coqtop:: all - - Module N : SIG with Definition T := nat := M. - Print N.T. - Print N.x. - Fail Print N.y. - - .. reset to remove N (undo in last coqtop block doesn't seem to do that), invisibly redefine M, SIG - .. coqtop:: none reset - - Module M. - Definition T := nat. - Definition x := 0. - Definition y : bool. - exact true. - Defined. - End M. - - Module Type SIG. - Parameter T : Set. - Parameter x : T. - End SIG. - -The definition of :g:`N` using the module type expression :g:`SIG` with -:g:`Definition T := nat` is equivalent to the following one: - -.. coqtop:: in - - Module Type SIG'. - Definition T : Set := nat. - Parameter x : T. - End SIG'. - - Module N : SIG' := M. - -If we just want to be sure that our implementation satisfies a -given module type without restricting the interface, we can use a -transparent constraint - -.. coqtop:: in - - Module P <: SIG := M. - -.. coqtop:: all - - Print P.y. - -.. example:: Creating a functor (a module with parameters) - - .. coqtop:: in - - Module Two (X Y: SIG). - Definition T := (X.T * Y.T)%type. - Definition x := (X.x, Y.x). - End Two. - - and apply it to our modules and do some computations: - - .. coqtop:: in - - - Module Q := Two M N. - - .. coqtop:: all - - Eval compute in (fst Q.x + snd Q.x). - -.. example:: A module type with two sub-modules, sharing some fields - - .. coqtop:: in - - Module Type SIG2. - Declare Module M1 : SIG. - Module M2 <: SIG. - Definition T := M1.T. - Parameter x : T. - End M2. - End SIG2. - - .. coqtop:: in - - Module Mod <: SIG2. - Module M1. - Definition T := nat. - Definition x := 1. - End M1. - Module M2 := M. - End Mod. - -Notice that ``M`` is a correct body for the component ``M2`` since its ``T`` -component is ``nat`` as specified for ``M1.T``. - -Libraries and qualified names ---------------------------------- - -.. _names-of-libraries: - -Names of libraries -~~~~~~~~~~~~~~~~~~ - -The theories developed in |Coq| are stored in *library files* which are -hierarchically classified into *libraries* and *sublibraries*. To -express this hierarchy, library names are represented by qualified -identifiers qualid, i.e. as list of identifiers separated by dots (see -:ref:`gallina-identifiers`). For instance, the library file ``Mult`` of the standard -|Coq| library ``Arith`` is named ``Coq.Arith.Mult``. The identifier that starts -the name of a library is called a *library root*. All library files of -the standard library of |Coq| have the reserved root |Coq| but library -filenames based on other roots can be obtained by using |Coq| commands -(coqc, coqtop, coqdep, …) options ``-Q`` or ``-R`` (see :ref:`command-line-options`). -Also, when an interactive |Coq| session starts, a library of root ``Top`` is -started, unless option ``-top`` or ``-notop`` is set (see :ref:`command-line-options`). - -.. _qualified-names: - -Qualified names -~~~~~~~~~~~~~~~ - -Library files are modules which possibly contain submodules which -eventually contain constructions (axioms, parameters, definitions, -lemmas, theorems, remarks or facts). The *absolute name*, or *full -name*, of a construction in some library file is a qualified -identifier starting with the logical name of the library file, -followed by the sequence of submodules names encapsulating the -construction and ended by the proper name of the construction. -Typically, the absolute name ``Coq.Init.Logic.eq`` denotes Leibniz’ -equality defined in the module Logic in the sublibrary ``Init`` of the -standard library of |Coq|. - -The proper name that ends the name of a construction is the short name -(or sometimes base name) of the construction (for instance, the short -name of ``Coq.Init.Logic.eq`` is ``eq``). Any partial suffix of the absolute -name is a *partially qualified name* (e.g. ``Logic.eq`` is a partially -qualified name for ``Coq.Init.Logic.eq``). Especially, the short name of a -construction is its shortest partially qualified name. - -|Coq| does not accept two constructions (definition, theorem, …) with -the same absolute name but different constructions can have the same -short name (or even same partially qualified names as soon as the full -names are different). - -Notice that the notion of absolute, partially qualified and short -names also applies to library filenames. - -**Visibility** - -|Coq| maintains a table called the name table which maps partially qualified -names of constructions to absolute names. This table is updated by the -commands :cmd:`Require`, :cmd:`Import` and :cmd:`Export` and -also each time a new declaration is added to the context. An absolute -name is called visible from a given short or partially qualified name -when this latter name is enough to denote it. This means that the -short or partially qualified name is mapped to the absolute name in -|Coq| name table. Definitions with the :attr:`local` attribute are only accessible with -their fully qualified name (see :ref:`gallina-definitions`). - -It may happen that a visible name is hidden by the short name or a -qualified name of another construction. In this case, the name that -has been hidden must be referred to using one more level of -qualification. To ensure that a construction always remains -accessible, absolute names can never be hidden. - -.. example:: - - .. coqtop:: all - - Check 0. - - Definition nat := bool. - - Check 0. - - Check Datatypes.nat. - - Locate nat. - -.. seealso:: Commands :cmd:`Locate`. - -.. _libraries-and-filesystem: - -Libraries and filesystem -~~~~~~~~~~~~~~~~~~~~~~~~ - -.. note:: The questions described here have been subject to redesign in |Coq| 8.5. - Former versions of |Coq| use the same terminology to describe slightly different things. - -Compiled files (``.vo`` and ``.vio``) store sub-libraries. In order to refer -to them inside |Coq|, a translation from file-system names to |Coq| names -is needed. In this translation, names in the file system are called -*physical* paths while |Coq| names are contrastingly called *logical* -names. - -A logical prefix Lib can be associated with a physical path using -the command line option ``-Q`` `path` ``Lib``. All subfolders of path are -recursively associated to the logical path ``Lib`` extended with the -corresponding suffix coming from the physical path. For instance, the -folder ``path/fOO/Bar`` maps to ``Lib.fOO.Bar``. Subdirectories corresponding -to invalid |Coq| identifiers are skipped, and, by convention, -subdirectories named ``CVS`` or ``_darcs`` are skipped too. - -Thanks to this mechanism, ``.vo`` files are made available through the -logical name of the folder they are in, extended with their own -basename. For example, the name associated to the file -``path/fOO/Bar/File.vo`` is ``Lib.fOO.Bar.File``. The same caveat applies for -invalid identifiers. When compiling a source file, the ``.vo`` file stores -its logical name, so that an error is issued if it is loaded with the -wrong loadpath afterwards. - -Some folders have a special status and are automatically put in the -path. |Coq| commands associate automatically a logical path to files in -the repository trees rooted at the directory from where the command is -launched, ``coqlib/user-contrib/``, the directories listed in the -``$COQPATH``, ``${XDG_DATA_HOME}/coq/`` and ``${XDG_DATA_DIRS}/coq/`` -environment variables (see `XDG base directory specification -<http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>`_) -with the same physical-to-logical translation and with an empty logical prefix. - -The command line option ``-R`` is a variant of ``-Q`` which has the strictly -same behavior regarding loadpaths, but which also makes the -corresponding ``.vo`` files available through their short names in a way -similar to the :cmd:`Import` command. For instance, ``-R path Lib`` -associates to the file ``/path/fOO/Bar/File.vo`` the logical name -``Lib.fOO.Bar.File``, but allows this file to be accessed through the -short names ``fOO.Bar.File,Bar.File`` and ``File``. If several files with -identical base name are present in different subdirectories of a -recursive loadpath, which of these files is found first may be system- -dependent and explicit qualification is recommended. The ``From`` argument -of the ``Require`` command can be used to bypass the implicit shortening -by providing an absolute root to the required file (see :ref:`compiled-files`). - -There also exists another independent loadpath mechanism attached to -OCaml object files (``.cmo`` or ``.cmxs``) rather than |Coq| object -files as described above. The OCaml loadpath is managed using -the option ``-I`` `path` (in the OCaml world, there is neither a -notion of logical name prefix nor a way to access files in -subdirectories of path). See the command :cmd:`Declare ML Module` in -:ref:`compiled-files` to understand the need of the OCaml loadpath. - -See :ref:`command-line-options` for a more general view over the |Coq| command -line options. - -.. _Coercions: - -Coercions ---------- - -Coercions can be used to implicitly inject terms from one *class* in -which they reside into another one. A *class* is either a sort -(denoted by the keyword ``Sortclass``), a product type (denoted by the -keyword ``Funclass``), or a type constructor (denoted by its name), e.g. -an inductive type or any constant with a type of the form -:n:`forall {+ @binder }, @sort`. - -Then the user is able to apply an object that is not a function, but -can be coerced to a function, and more generally to consider that a -term of type ``A`` is of type ``B`` provided that there is a declared coercion -between ``A`` and ``B``. - -More details and examples, and a description of the commands related -to coercions are provided in :ref:`implicitcoercions`. - -.. _printing_constructions_full: - -Printing constructions in full ------------------------------- - -.. flag:: Printing All - - Coercions, implicit arguments, the type of pattern matching, but also - notations (see :ref:`syntax-extensions-and-notation-scopes`) can obfuscate the behavior of some - tactics (typically the tactics applying to occurrences of subterms are - sensitive to the implicit arguments). Turning this flag on - deactivates all high-level printing features such as coercions, - implicit arguments, returned type of pattern matching, notations and - various syntactic sugar for pattern matching or record projections. - Otherwise said, :flag:`Printing All` includes the effects of the flags - :flag:`Printing Implicit`, :flag:`Printing Coercions`, :flag:`Printing Synth`, - :flag:`Printing Projections`, and :flag:`Printing Notations`. To reactivate - the high-level printing features, use the command ``Unset Printing All``. - - .. note:: In some cases, setting :flag:`Printing All` may display terms - that are so big they become very hard to read. One technique to work around - this is use :cmd:`Undelimit Scope` and/or :cmd:`Close Scope` to turn off the - printing of notations bound to particular scope(s). This can be useful when - notations in a given scope are getting in the way of understanding - a goal, but turning off all notations with :flag:`Printing All` would make - the goal unreadable. - - .. see a contrived example here: https://github.com/coq/coq/pull/11718#discussion_r415481854 - -.. _printing-universes: - -Printing universes ------------------- - -.. flag:: Printing Universes - - Turn this flag on to activate the display of the actual level of each - occurrence of :g:`Type`. See :ref:`Sorts` for details. This wizard flag, in - combination with :flag:`Printing All` can help to diagnose failures to unify - terms apparently identical but internally different in the Calculus of Inductive - Constructions. - -.. cmd:: Print {? Sorted } Universes {? Subgraph ( {* @qualid } ) } {? @string } - :name: Print Universes - - This command can be used to print the constraints on the internal level - of the occurrences of :math:`\Type` (see :ref:`Sorts`). - - The :n:`Subgraph` clause limits the printed graph to the requested names (adjusting - constraints to preserve the implied transitive constraints between - kept universes). - - The :n:`Sorted` clause makes each universe - equivalent to a numbered label reflecting its level (with a linear - ordering) in the universe hierarchy. - - :n:`@string` is an optional output filename. - If :n:`@string` ends in ``.dot`` or ``.gv``, the constraints are printed in the DOT - language, and can be processed by Graphviz tools. The format is - unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. - -.. _existential-variables: - -Existential variables ---------------------- - -.. insertprodn term_evar term_evar - -.. prodn:: - term_evar ::= _ - | ?[ @ident ] - | ?[ ?@ident ] - | ?@ident {? @%{ {+; @ident := @term } %} } - -|Coq| terms can include existential variables which represents unknown -subterms to eventually be replaced by actual subterms. - -Existential variables are generated in place of unsolvable implicit -arguments or “_” placeholders when using commands such as ``Check`` (see -Section :ref:`requests-to-the-environment`) or when using tactics such as -:tacn:`refine`, as well as in place of unsolvable instances when using -tactics such that :tacn:`eapply`. An existential -variable is defined in a context, which is the context of variables of -the placeholder which generated the existential variable, and a type, -which is the expected type of the placeholder. - -As a consequence of typing constraints, existential variables can be -duplicated in such a way that they possibly appear in different -contexts than their defining context. Thus, any occurrence of a given -existential variable comes with an instance of its original context. -In the simple case, when an existential variable denotes the -placeholder which generated it, or is used in the same context as the -one in which it was generated, the context is not displayed and the -existential variable is represented by “?” followed by an identifier. - -.. coqtop:: all - - Parameter identity : forall (X:Set), X -> X. - - Check identity _ _. - - Check identity _ (fun x => _). - -In the general case, when an existential variable :n:`?@ident` appears -outside of its context of definition, its instance, written under the -form :n:`{ {*; @ident := @term} }` is appending to its name, indicating -how the variables of its defining context are instantiated. -The variables of the context of the existential variables which are -instantiated by themselves are not written, unless the :flag:`Printing Existential Instances` flag -is on (see Section :ref:`explicit-display-existentials`), and this is why an -existential variable used in the same context as its context of definition is written with no instance. - -.. coqtop:: all - - Check (fun x y => _) 0 1. - - Set Printing Existential Instances. - - Check (fun x y => _) 0 1. - -Existential variables can be named by the user upon creation using -the syntax :n:`?[@ident]`. This is useful when the existential -variable needs to be explicitly handled later in the script (e.g. -with a named-goal selector, see :ref:`goal-selectors`). - -.. _explicit-display-existentials: - -Explicit displaying of existential instances for pretty-printing -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. flag:: Printing Existential Instances - - This flag (off by default) activates the full display of how the - context of an existential variable is instantiated at each of the - occurrences of the existential variable. - -.. _tactics-in-terms: - -Solving existential variables using tactics -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Instead of letting the unification engine try to solve an existential -variable by itself, one can also provide an explicit hole together -with a tactic to solve it. Using the syntax ``ltac:(``\ `tacexpr`\ ``)``, the user -can put a tactic anywhere a term is expected. The order of resolution -is not specified and is implementation-dependent. The inner tactic may -use any variable defined in its scope, including repeated alternations -between variables introduced by term binding as well as those -introduced by tactic binding. The expression `tacexpr` can be any tactic -expression as described in :ref:`ltac`. - -.. coqtop:: all - - Definition foo (x : nat) : nat := ltac:(exact x). - -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. - -The extraction of these primitives can be customized similarly to the extraction -of regular axioms (see :ref:`extraction`). Nonetheless, the :g:`ExtrOCamlInt63` -module can be used when extracting to OCaml: it maps the Coq primitives to types -and functions of a :g:`Uint63` module. Said OCaml 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. - -Literal values (at type :g:`Int63.int`) are extracted to literal OCaml values -wrapped into the :g:`Uint63.of_int` (resp. :g:`Uint63.of_int64`) constructor on -64-bit (resp. 32-bit) platforms. Currently, this cannot be customized (see the -function :g:`Uint63.compile` from the kernel). - -.. _primitive-floats: - -Primitive Floats ----------------- - -The language of terms features Binary64 floating-point numbers as values. -The type of such a value is *axiomatized*; it is declared through the -following sentence (excerpt from the :g:`PrimFloat` module): - -.. coqdoc:: - - Primitive float := #float64_type. - -This type is equipped with a few operators, that must be similarly declared. -For instance, the product of two primitive floats can be computed using the -:g:`PrimFloat.mul` function, declared and specified as follows: - -.. coqdoc:: - - Primitive mul := #float64_mul. - Notation "x * y" := (mul x y) : float_scope. - - Axiom mul_spec : forall x y, Prim2SF (x * y)%float = SF64mul (Prim2SF x) (Prim2SF y). - -where :g:`Prim2SF` is defined in the :g:`FloatOps` module. - -The set of such operators is described in section :ref:`floats_library`. - -These primitive declarations are regular axioms. As such, they must be trusted, and are listed by the -:g:`Print Assumptions` command. - -The reduction machines (:tacn:`vm_compute`, :tacn:`native_compute`) implement -dedicated, efficient rules to reduce the applications of these primitive -operations, using the floating-point processor operators that are assumed -to comply with the IEEE 754 standard for floating-point arithmetic. - -The extraction of these primitives can be customized similarly to the extraction -of regular axioms (see :ref:`extraction`). Nonetheless, the :g:`ExtrOCamlFloats` -module can be used when extracting to OCaml: it maps the Coq primitives to types -and functions of a :g:`Float64` module. Said OCaml 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. - -Literal values (of type :g:`Float64.t`) are extracted to literal OCaml -values (of type :g:`float`) written in hexadecimal notation and -wrapped into the :g:`Float64.of_float` constructor, e.g.: -:g:`Float64.of_float (0x1p+0)`. + <meta http-equiv="refresh" content="0;URL=extensions/index.html"> diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 353bed1b3d..25812e5257 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -1,1452 +1,5 @@ -.. _gallinaspecificationlanguage: +:orphan: ------------------------------------- - The Gallina specification language ------------------------------------- +.. raw:: html -This chapter describes Gallina, the specification language of Coq. It allows -developing mathematical theories and to prove specifications of programs. The -theories are built from axioms, hypotheses, parameters, lemmas, theorems and -definitions of constants, functions, predicates and sets. - -.. _term: - -Terms -===== - -.. _gallina-identifiers: - -Qualified identifiers and simple identifiers --------------------------------------------- - -.. insertprodn qualid field_ident - -.. prodn:: - qualid ::= @ident {* @field_ident } - field_ident ::= .@ident - -*Qualified identifiers* (:n:`@qualid`) denote *global constants* -(definitions, lemmas, theorems, remarks or facts), *global variables* -(parameters or axioms), *inductive types* or *constructors of inductive -types*. *Simple identifiers* (or shortly :n:`@ident`) are a syntactic subset -of qualified identifiers. Identifiers may also denote *local variables*, -while qualified identifiers do not. - -Field identifiers, written :n:`@field_ident`, are identifiers prefixed by -`.` (dot) with no blank between the dot and the identifier. - - -Numerals and strings --------------------- - -.. insertprodn primitive_notations primitive_notations - -.. prodn:: - primitive_notations ::= @numeral - | @string - -Numerals and strings have no predefined semantics in the calculus. They are -merely notations that can be bound to objects through the notation mechanism -(see Chapter :ref:`syntax-extensions-and-notation-scopes` for details). -Initially, numerals are bound to Peano’s representation of natural -numbers (see :ref:`datatypes`). - -.. note:: - - Negative integers are not at the same level as :n:`@num`, for this - would make precedence unnatural. - -.. index:: - single: Set (sort) - single: SProp - single: Prop - single: Type - -Sorts ------ - -.. insertprodn sort univ_constraint - -.. prodn:: - sort ::= Set - | Prop - | SProp - | Type - | Type @%{ _ %} - | Type @%{ @universe %} - universe ::= max ( {+, @universe_expr } ) - | @universe_expr - universe_expr ::= @universe_name {? + @num } - universe_name ::= @qualid - | Set - | Prop - univ_annot ::= @%{ {* @universe_level } %} - universe_level ::= Set - | Prop - | Type - | _ - | @qualid - univ_decl ::= @%{ {* @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} - univ_constraint ::= @universe_name {| < | = | <= } @universe_name - -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 :n:`@form`. - This constitutes a semantic subclass of the syntactic class :n:`@term`. - -- :g:`Set` is the universe of *program types* or *specifications*. The - specifications themselves are typing the programs. We denote - specifications by :n:`@specif`. This constitutes a semantic subclass of - the syntactic class :n:`@term`. - -- :g:`Type` is the type of sorts. - -More on sorts can be found in Section :ref:`sorts`. - -.. _binders: - -Binders -------- - -.. insertprodn open_binders binder - -.. prodn:: - open_binders ::= {+ @name } : @term - | {+ @binder } - name ::= _ - | @ident - binder ::= @name - | ( {+ @name } : @type ) - | ( @name {? : @type } := @term ) - | @implicit_binders - | @generalizing_binder - | ( @name : @type %| @term ) - | ' @pattern0 - -Various constructions such as :g:`fun`, :g:`forall`, :g:`fix` and :g:`cofix` -*bind* variables. A binding is represented by an identifier. If the binding -variable is not used in the expression, the identifier can be replaced by the -symbol :g:`_`. When the type of a bound variable cannot be synthesized by the -system, it can be specified with the notation :n:`(@ident : @type)`. There is also -a notation for a sequence of binding variables sharing the same type: -:n:`({+ @ident} : @type)`. A -binder can also be any pattern prefixed by a quote, e.g. :g:`'(x,y)`. - -Some constructions allow the binding of a variable to value. This is -called a “let-binder”. The entry :n:`@binder` of the grammar accepts -either an assumption binder as defined above or a let-binder. The notation in -the latter case is :n:`(@ident := @term)`. In a let-binder, only one -variable can be introduced at the same time. It is also possible to give -the type of the variable as follows: -:n:`(@ident : @type := @term)`. - -Lists of :n:`@binder`\s are allowed. In the case of :g:`fun` and :g:`forall`, -it is intended that at least one binder of the list is an assumption otherwise -fun and forall gets identical. Moreover, parentheses can be omitted in -the case of a single sequence of bindings sharing the same type (e.g.: -:g:`fun (x y z : A) => t` can be shortened in :g:`fun x y z : A => t`). - -.. index:: fun ... => ... - -Abstractions: fun ------------------ - -The expression :n:`fun @ident : @type => @term` defines the -*abstraction* of the variable :n:`@ident`, of type :n:`@type`, over the term -:n:`@term`. It denotes a function of the variable :n:`@ident` that evaluates to -the expression :n:`@term` (e.g. :g:`fun x : A => x` denotes the identity -function on type :g:`A`). The keyword :g:`fun` can be followed by several -binders as given in Section :ref:`binders`. Functions over -several variables are equivalent to an iteration of one-variable -functions. For instance the expression -:n:`fun {+ @ident__i } : @type => @term` -denotes the same function as :n:`{+ fun @ident__i : @type => } @term`. If -a let-binder occurs in -the list of binders, it is expanded to a let-in definition (see -Section :ref:`let-in`). - -.. index:: forall - -Products: forall ----------------- - -.. insertprodn term_forall_or_fun term_forall_or_fun - -.. prodn:: - term_forall_or_fun ::= forall @open_binders , @term - | fun @open_binders => @term - -The expression :n:`forall @ident : @type, @term` denotes the -*product* of the variable :n:`@ident` of type :n:`@type`, over the term :n:`@term`. -As for abstractions, :g:`forall` is followed by a binder list, and products -over several variables are equivalent to an iteration of one-variable -products. Note that :n:`@term` is intended to be a type. - -If the variable :n:`@ident` occurs in :n:`@term`, the product is called -*dependent product*. The intention behind a dependent product -:g:`forall x : A, B` is twofold. It denotes either -the universal quantification of the variable :g:`x` of type :g:`A` -in the proposition :g:`B` or the functional dependent product from -:g:`A` to :g:`B` (a construction usually written -:math:`\Pi_{x:A}.B` in set theory). - -Non dependent product types have a special notation: :g:`A -> B` stands for -:g:`forall _ : A, B`. The *non dependent product* is used both to denote -the propositional implication and function types. - -Applications ------------- - -.. insertprodn term_application arg - -.. prodn:: - term_application ::= @term1 {+ @arg } - | @ @qualid_annotated {+ @term1 } - arg ::= ( @ident := @term ) - | @term1 - -:n:`@term__fun @term` denotes applying the function :n:`@term__fun` to :token:`term`. - -:n:`@term__fun {+ @term__i }` denotes applying -:n:`@term__fun` to the arguments :n:`@term__i`. It is -equivalent to :n:`( … ( @term__fun @term__1 ) … ) @term__n`: -associativity is to the left. - -The notation :n:`(@ident := @term)` for arguments is used for making -explicit the value of implicit arguments (see -Section :ref:`explicit-applications`). - -.. index:: - single: ... : ... (type cast) - single: ... <: ... - single: ... <<: ... - -Type cast ---------- - -.. insertprodn term_cast term_cast - -.. prodn:: - term_cast ::= @term10 <: @term - | @term10 <<: @term - | @term10 : @term - | @term10 :> - -The expression :n:`@term : @type` is a type cast expression. It enforces -the type of :n:`@term` to be :n:`@type`. - -:n:`@term <: @type` locally sets up the virtual machine for checking that -:n:`@term` has type :n:`@type`. - -:n:`@term <<: @type` uses native compilation for checking that :n:`@term` -has type :n:`@type`. - -.. index:: _ - -Inferable subterms ------------------- - -Expressions often contain redundant pieces of information. Subterms that can be -automatically inferred by Coq can be replaced by the symbol ``_`` and Coq will -guess the missing piece of information. - -.. index:: let ... := ... (term) - -.. _let-in: - -Let-in definitions ------------------- - -.. insertprodn term_let term_let - -.. prodn:: - term_let ::= let @name {? : @type } := @term in @term - | let @name {+ @binder } {? : @type } := @term in @term - | let ( {*, @name } ) {? {? as @name } return @term100 } := @term in @term - | let ' @pattern := @term {? return @term100 } in @term - | let ' @pattern in @pattern := @term return @term100 in @term - -:n:`let @ident := @term in @term’` -denotes the local binding of :n:`@term` to the variable -:n:`@ident` in :n:`@term`’. There is a syntactic sugar for let-in -definition of functions: :n:`let @ident {+ @binder} := @term in @term’` -stands for :n:`let @ident := fun {+ @binder} => @term in @term’`. - -.. index:: match ... with ... - -Definition by cases: match --------------------------- - -.. insertprodn term_match pattern0 - -.. prodn:: - term_match ::= match {+, @case_item } {? return @term100 } with {? %| } {*| @eqn } end - case_item ::= @term100 {? as @name } {? in @pattern } - eqn ::= {+| {+, @pattern } } => @term - pattern ::= @pattern10 : @term - | @pattern10 - pattern10 ::= @pattern1 as @name - | @pattern1 {* @pattern1 } - | @ @qualid {* @pattern1 } - pattern1 ::= @pattern0 % @scope_key - | @pattern0 - pattern0 ::= @qualid - | %{%| {* @qualid := @pattern } %|%} - | _ - | ( {+| @pattern } ) - | @numeral - | @string - -Objects of inductive types can be destructured by a case-analysis -construction called *pattern matching* expression. A pattern matching -expression is used to analyze the structure of an inductive object and -to apply specific treatments accordingly. - -This paragraph describes the basic form of pattern matching. See -Section :ref:`Mult-match` and Chapter :ref:`extendedpatternmatching` for the description -of the general form. The basic form of pattern matching is characterized -by a single :n:`@case_item` expression, an :n:`@eqn` restricted to a -single :n:`@pattern` and :n:`@pattern` restricted to the form -:n:`@qualid {* @ident}`. - -The expression -:n:`match @term {? return @term100 } with {+| @pattern__i => @term__i } end` denotes a -*pattern matching* over the term :n:`@term` (expected to be -of an inductive type :math:`I`). The :n:`@term__i` -are the *branches* of the pattern matching -expression. Each :n:`@pattern__i` has the form :n:`@qualid @ident` -where :n:`@qualid` must denote a constructor. There should be -exactly one branch for every constructor of :math:`I`. - -The :n:`return @term100` clause gives the type returned by the whole match -expression. There are several cases. In the *non dependent* case, all -branches have the same type, and the :n:`return @term100` specifies that type. -In this case, :n:`return @term100` can usually be omitted as it can be -inferred from the type of the branches [1]_. - -In the *dependent* case, there are three subcases. In the first subcase, -the type in each branch may depend on the exact value being matched in -the branch. In this case, the whole pattern matching itself depends on -the term being matched. This dependency of the term being matched in the -return type is expressed with an :n:`@ident` clause where :n:`@ident` -is dependent in the return type. For instance, in the following example: - -.. coqtop:: in - - Inductive bool : Type := true : bool | false : bool. - Inductive eq (A:Type) (x:A) : A -> Prop := eq_refl : eq A x x. - Inductive or (A:Prop) (B:Prop) : Prop := - | or_introl : A -> or A B - | or_intror : B -> or A B. - - Definition bool_case (b:bool) : or (eq bool b true) (eq bool b false) := - match b as x return or (eq bool x true) (eq bool x false) with - | true => or_introl (eq bool true true) (eq bool true false) (eq_refl bool true) - | false => or_intror (eq bool false true) (eq bool false false) (eq_refl bool false) - end. - -the branches have respective types ":g:`or (eq bool true true) (eq bool true false)`" -and ":g:`or (eq bool false true) (eq bool false false)`" while the whole -pattern matching expression has type ":g:`or (eq bool b true) (eq bool b false)`", -the identifier :g:`b` being used to represent the dependency. - -.. note:: - - When the term being matched is a variable, the ``as`` clause can be - omitted and the term being matched can serve itself as binding name in - the return type. For instance, the following alternative definition is - accepted and has the same meaning as the previous one. - - .. coqtop:: none - - Reset bool_case. - - .. coqtop:: in - - Definition bool_case (b:bool) : or (eq bool b true) (eq bool b false) := - match b return or (eq bool b true) (eq bool b false) with - | true => or_introl (eq bool true true) (eq bool true false) (eq_refl bool true) - | false => or_intror (eq bool false true) (eq bool false false) (eq_refl bool false) - end. - -The second subcase is only relevant for annotated inductive types such -as the equality predicate (see Section :ref:`coq-equality`), -the order predicate on natural numbers or the type of lists of a given -length (see Section :ref:`matching-dependent`). In this configuration, the -type of each branch can depend on the type dependencies specific to the -branch and the whole pattern matching expression has a type determined -by the specific dependencies in the type of the term being matched. This -dependency of the return type in the annotations of the inductive type -is expressed with a clause in the form -:n:`in @qualid {+ _ } {+ @pattern }`, where - -- :n:`@qualid` is the inductive type of the term being matched; - -- the holes :n:`_` match the parameters of the inductive type: the - return type is not dependent on them. - -- each :n:`@pattern` matches the annotations of the - inductive type: the return type is dependent on them - -- in the basic case which we describe below, each :n:`@pattern` - is a name :n:`@ident`; see :ref:`match-in-patterns` for the - general case - -For instance, in the following example: - -.. coqtop:: in - - Definition eq_sym (A:Type) (x y:A) (H:eq A x y) : eq A y x := - match H in eq _ _ z return eq A z x with - | eq_refl _ _ => eq_refl A x - end. - -the type of the branch is :g:`eq A x x` because the third argument of -:g:`eq` is :g:`x` in the type of the pattern :g:`eq_refl`. On the contrary, the -type of the whole pattern matching expression has type :g:`eq A y x` because the -third argument of eq is y in the type of H. This dependency of the case analysis -in the third argument of :g:`eq` is expressed by the identifier :g:`z` in the -return type. - -Finally, the third subcase is a combination of the first and second -subcase. In particular, it only applies to pattern matching on terms in -a type with annotations. For this third subcase, both the clauses ``as`` and -``in`` are available. - -There are specific notations for case analysis on types with one or two -constructors: ``if … then … else …`` and ``let (…,…) := … in …`` (see -Sections :ref:`if-then-else` and :ref:`irrefutable-patterns`). - -.. index:: - single: fix - single: cofix - -Recursive and co-recursive functions: fix and cofix ---------------------------------------------------- - -.. insertprodn term_fix fixannot - -.. prodn:: - term_fix ::= let fix @fix_body in @term - | fix @fix_body {? {+ with @fix_body } for @ident } - fix_body ::= @ident {* @binder } {? @fixannot } {? : @type } := @term - fixannot ::= %{ struct @ident %} - | %{ wf @one_term @ident %} - | %{ measure @one_term {? @ident } {? @one_term } %} - - -The expression ":n:`fix @ident__1 @binder__1 : @type__1 := @term__1 with … with @ident__n @binder__n : @type__n := @term__n for @ident__i`" denotes the -:math:`i`-th component of a block of functions defined by mutual structural -recursion. It is the local counterpart of the :cmd:`Fixpoint` command. When -:math:`n=1`, the ":n:`for @ident__i`" clause is omitted. - -The association of a single fixpoint and a local definition have a special -syntax: :n:`let fix @ident {* @binder } := @term in` stands for -:n:`let @ident := fix @ident {* @binder } := @term in`. The same applies for co-fixpoints. - -Some options of :n:`@fixannot` are only supported in specific constructs. :n:`fix` and :n:`let fix` -only support the :n:`struct` option, while :n:`wf` and :n:`measure` are only supported in -commands such as :cmd:`Function` and :cmd:`Program Fixpoint`. - -.. insertprodn term_cofix cofix_body - -.. prodn:: - term_cofix ::= let cofix @cofix_body in @term - | cofix @cofix_body {? {+ with @cofix_body } for @ident } - cofix_body ::= @ident {* @binder } {? : @type } := @term - -The expression -":n:`cofix @ident__1 @binder__1 : @type__1 with … with @ident__n @binder__n : @type__n for @ident__i`" -denotes the :math:`i`-th component of a block of terms defined by a mutual guarded -co-recursion. It is the local counterpart of the :cmd:`CoFixpoint` command. When -:math:`n=1`, the ":n:`for @ident__i`" clause is omitted. - -.. _vernacular: - -The Vernacular -============== - -.. _gallina-assumptions: - -Assumptions ------------ - -Assumptions extend the environment with axioms, parameters, hypotheses -or variables. An assumption binds an :n:`@ident` to a :n:`@type`. It is accepted -by Coq if and only if this :n:`@type` is a correct type in the environment -preexisting the declaration and if :n:`@ident` was not previously defined in -the same module. This :n:`@type` is considered to be the type (or -specification, or statement) assumed by :n:`@ident` and we say that :n:`@ident` -has type :n:`@type`. - -.. _Axiom: - -.. cmd:: @assumption_token {? Inline {? ( @num ) } } {| {+ ( @assumpt ) } | @assumpt } - :name: Axiom; Axioms; Conjecture; Conjectures; Hypothesis; Hypotheses; Parameter; Parameters; Variable; Variables - - .. insertprodn assumption_token of_type - - .. prodn:: - assumption_token ::= {| Axiom | Axioms } - | {| Conjecture | Conjectures } - | {| Parameter | Parameters } - | {| Hypothesis | Hypotheses } - | {| Variable | Variables } - assumpt ::= {+ @ident_decl } @of_type - ident_decl ::= @ident {? @univ_decl } - of_type ::= {| : | :> | :>> } @type - - These commands bind one or more :n:`@ident`\(s) to specified :n:`@type`\(s) as their specifications in - the global context. The fact asserted by the :n:`@type` (or, equivalently, the existence - of an object of this type) is accepted as a postulate. - - :cmd:`Axiom`, :cmd:`Conjecture`, :cmd:`Parameter` and their plural forms - are equivalent. They can take the :attr:`local` :term:`attribute`, - which makes the defined :n:`@ident`\s accessible by :cmd:`Import` and its variants - only through their fully qualified names. - - Similarly, :cmd:`Hypothesis`, :cmd:`Variable` and their plural forms are equivalent. Outside - of a section, these are equivalent to :n:`Local Parameter`. Inside a section, the - :n:`@ident`\s defined are only accessible within the section. When the current section - is closed, the :n:`@ident`\(s) become undefined and every object depending on them will be explicitly - parameterized (i.e., the variables are *discharged*). See Section :ref:`section-mechanism`. - - The :n:`Inline` clause is only relevant inside functors. See :cmd:`Module`. - -.. example:: Simple assumptions - - .. coqtop:: reset in - - Parameter X Y : Set. - Parameter (R : X -> Y -> Prop) (S : Y -> X -> Prop). - Axiom R_S_inv : forall x y, R x y <-> S y x. - -.. exn:: @ident already exists. - :name: @ident already exists. (Axiom) - :undocumented: - -.. warn:: @ident is declared as a local axiom - - Warning generated when using :cmd:`Variable` or its equivalent - instead of :n:`Local Parameter` or its equivalent. - -.. note:: - We advise using the commands :cmd:`Axiom`, :cmd:`Conjecture` and - :cmd:`Hypothesis` (and their plural forms) for logical postulates (i.e. when - the assertion :n:`@type` is of sort :g:`Prop`), and to use the commands - :cmd:`Parameter` and :cmd:`Variable` (and their plural forms) in other cases - (corresponding to the declaration of an abstract object of the given type). - -.. _gallina-definitions: - -Definitions ------------ - -Definitions extend the environment with associations of names to terms. -A definition can be seen as a way to give a meaning to a name or as a -way to abbreviate a term. In any case, the name can later be replaced at -any time by its definition. - -The operation of unfolding a name into its definition is called -:math:`\delta`-conversion (see Section :ref:`delta-reduction`). A -definition is accepted by the system if and only if the defined term is -well-typed in the current context of the definition and if the name is -not already used. The name defined by the definition is called a -*constant* and the term it refers to is its *body*. A definition has a -type which is the type of its body. - -A formal presentation of constants and environments is given in -Section :ref:`typing-rules`. - -.. cmd:: {| Definition | Example } @ident_decl @def_body - :name: Definition; Example - - .. insertprodn def_body def_body - - .. prodn:: - def_body ::= {* @binder } {? : @type } := {? @reduce } @term - | {* @binder } : @type - - These commands bind :n:`@term` to the name :n:`@ident` in the environment, - provided that :n:`@term` is well-typed. They can take the :attr:`local` :term:`attribute`, - which makes the defined :n:`@ident` accessible by :cmd:`Import` and its variants - only through their fully qualified names. - If :n:`@reduce` is present then :n:`@ident` is bound to the result of the specified - computation on :n:`@term`. - - These commands also support the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`program` and - :attr:`canonical` attributes. - - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. - This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. - In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant - for which the computational behavior is relevant. See :ref:`proof-editing-mode`. - - The form :n:`Definition @ident : @type := @term` checks that the type of :n:`@term` - is definitionally equal to :n:`@type`, and registers :n:`@ident` as being of type - :n:`@type`, and bound to value :n:`@term`. - - The form :n:`Definition @ident {* @binder } : @type := @term` is equivalent to - :n:`Definition @ident : forall {* @binder }, @type := fun {* @binder } => @term`. - - .. seealso:: :cmd:`Opaque`, :cmd:`Transparent`, :tacn:`unfold`. - - .. exn:: @ident already exists. - :name: @ident already exists. (Definition) - :undocumented: - - .. exn:: The term @term has type @type while it is expected to have type @type'. - :undocumented: - -.. _gallina-inductive-definitions: - -Inductive types ---------------- - -.. cmd:: Inductive @inductive_definition {* with @inductive_definition } - - .. insertprodn inductive_definition constructor - - .. prodn:: - inductive_definition ::= {? > } @ident_decl {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } - constructors_or_record ::= {? %| } {+| @constructor } - | {? @ident } %{ {*; @record_field } %} - constructor ::= @ident {* @binder } {? @of_type } - - This command defines one or more - inductive types and its constructors. Coq generates destructors - depending on the universe that the inductive type belongs to. - - The destructors are named :n:`@ident`\ ``_rect``, :n:`@ident`\ ``_ind``, - :n:`@ident`\ ``_rec`` and :n:`@ident`\ ``_sind``, which - respectively correspond to elimination principles on :g:`Type`, :g:`Prop`, - :g:`Set` and :g:`SProp`. The type of the destructors - expresses structural induction/recursion principles over objects of - type :n:`@ident`. The constant :n:`@ident`\ ``_ind`` is always - generated, whereas :n:`@ident`\ ``_rec`` and :n:`@ident`\ ``_rect`` - may be impossible to derive (for example, when :n:`@ident` is a - proposition). - - This command supports the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`universes(template)`, - :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, - :attr:`universes(noncumulative)` and :attr:`private(matching)` - attributes. - - Mutually inductive types can be defined by including multiple :n:`@inductive_definition`\s. - The :n:`@ident`\s are simultaneously added to the environment before the types of constructors are checked. - Each :n:`@ident` can be used independently thereafter. - See :ref:`mutually_inductive_types`. - - If the entire inductive definition is parameterized with :n:`@binder`\s, the parameters correspond - to a local context in which the entire set of inductive declarations is interpreted. - For this reason, the parameters must be strictly the same for each inductive type. - See :ref:`parametrized-inductive-types`. - - Constructor :n:`@ident`\s can come with :n:`@binder`\s, in which case - the actual type of the constructor is :n:`forall {* @binder }, @type`. - - .. exn:: Non strictly positive occurrence of @ident in @type. - - The types of the constructors have to satisfy a *positivity condition* - (see Section :ref:`positivity`). This condition ensures the soundness of - the inductive definition. The positivity checking can be disabled using - the :flag:`Positivity Checking` flag (see :ref:`controlling-typing-flags`). - - .. exn:: The conclusion of @type is not valid; it must be built from @ident. - - The conclusion of the type of the constructors must be the inductive type - :n:`@ident` being defined (or :n:`@ident` applied to arguments in - the case of annotated inductive types — cf. next section). - -The following subsections show examples of simple inductive types, -simple annotated inductive types, simple parametric inductive types, -mutually inductive types and private (matching) inductive types. - -.. _simple-inductive-types: - -Simple inductive types -~~~~~~~~~~~~~~~~~~~~~~ - -A simple inductive type belongs to a universe that is a simple :n:`@sort`. - -.. example:: - - The set of natural numbers is defined as: - - .. coqtop:: reset all - - Inductive nat : Set := - | O : nat - | S : nat -> nat. - - The type nat is defined as the least :g:`Set` containing :g:`O` and closed by - the :g:`S` constructor. The names :g:`nat`, :g:`O` and :g:`S` are added to the - environment. - - This definition generates four elimination principles: - :g:`nat_rect`, :g:`nat_ind`, :g:`nat_rec` and :g:`nat_sind`. The type of :g:`nat_ind` is: - - .. coqtop:: all - - Check nat_ind. - - This is the well known structural induction principle over natural - numbers, i.e. the second-order form of Peano’s induction principle. It - allows proving universal properties of natural numbers (:g:`forall - n:nat, P n`) by induction on :g:`n`. - - The types of :g:`nat_rect`, :g:`nat_rec` and :g:`nat_sind` are similar, except that they - apply to, respectively, :g:`(P:nat->Type)`, :g:`(P:nat->Set)` and :g:`(P:nat->SProp)`. They correspond to - primitive induction principles (allowing dependent types) respectively - over sorts ```Type``, ``Set`` and ``SProp``. - -In the case where inductive types don't have annotations (the next section -gives an example of annotations), a constructor can be defined -by giving the type of its arguments alone. - -.. example:: - - .. coqtop:: reset none - - Reset nat. - - .. coqtop:: in - - Inductive nat : Set := O | S (_:nat). - -Simple annotated inductive types -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In annotated inductive types, the universe where the inductive type -is defined is no longer a simple :n:`@sort`, but what is called an arity, -which is a type whose conclusion is a :n:`@sort`. - -.. example:: - - As an example of annotated inductive types, let us define the - :g:`even` predicate: - - .. coqtop:: all - - Inductive even : nat -> Prop := - | even_0 : even O - | even_SS : forall n:nat, even n -> even (S (S n)). - - The type :g:`nat->Prop` means that :g:`even` is a unary predicate (inductively - defined) over natural numbers. The type of its two constructors are the - defining clauses of the predicate :g:`even`. The type of :g:`even_ind` is: - - .. coqtop:: all - - Check even_ind. - - From a mathematical point of view, this asserts that the natural numbers satisfying - the predicate :g:`even` are exactly in the smallest set of naturals satisfying the - clauses :g:`even_0` or :g:`even_SS`. This is why, when we want to prove any - predicate :g:`P` over elements of :g:`even`, it is enough to prove it for :g:`O` - and to prove that if any natural number :g:`n` satisfies :g:`P` its double - successor :g:`(S (S n))` satisfies also :g:`P`. This is analogous to the - structural induction principle we got for :g:`nat`. - -.. _parametrized-inductive-types: - -Parameterized inductive types -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In the previous example, each constructor introduces a different -instance of the predicate :g:`even`. In some cases, all the constructors -introduce the same generic instance of the inductive definition, in -which case, instead of an annotation, we use a context of parameters -which are :n:`@binder`\s shared by all the constructors of the definition. - -Parameters differ from inductive type annotations in that the -conclusion of each type of constructor invokes the inductive type with -the same parameter values of its specification. - -.. example:: - - A typical example is the definition of polymorphic lists: - - .. coqtop:: all - - Inductive list (A:Set) : Set := - | nil : list A - | cons : A -> list A -> list A. - - In the type of :g:`nil` and :g:`cons`, we write ":g:`list A`" and not - just ":g:`list`". The constructors :g:`nil` and :g:`cons` have these types: - - .. coqtop:: all - - Check nil. - Check cons. - - Observe that the destructors are also quantified with :g:`(A:Set)`, for example: - - .. coqtop:: all - - Check list_ind. - - Once again, the types of the constructor arguments and of the conclusion can be omitted: - - .. coqtop:: none - - Reset list. - - .. coqtop:: in - - Inductive list (A:Set) : Set := nil | cons (_:A) (_:list A). - -.. note:: - + The constructor type can - recursively invoke the inductive definition on an argument which is not - the parameter itself. - - One can define : - - .. coqtop:: all - - Inductive list2 (A:Set) : Set := - | nil2 : list2 A - | cons2 : A -> list2 (A*A) -> list2 A. - - that can also be written by specifying only the type of the arguments: - - .. coqtop:: all reset - - Inductive list2 (A:Set) : Set := - | nil2 - | cons2 (_:A) (_:list2 (A*A)). - - But the following definition will give an error: - - .. coqtop:: all - - Fail Inductive listw (A:Set) : Set := - | nilw : listw (A*A) - | consw : A -> listw (A*A) -> listw (A*A). - - because the conclusion of the type of constructors should be :g:`listw A` - in both cases. - - + A parameterized inductive definition can be defined using annotations - instead of parameters but it will sometimes give a different (bigger) - sort for the inductive definition and will produce a less convenient - rule for case elimination. - -.. flag:: Uniform Inductive Parameters - - When this flag is set (it is off by default), - inductive definitions are abstracted over their parameters - before type checking constructors, allowing to write: - - .. coqtop:: all - - Set Uniform Inductive Parameters. - Inductive list3 (A:Set) : Set := - | nil3 : list3 - | cons3 : A -> list3 -> list3. - - This behavior is essentially equivalent to starting a new section - and using :cmd:`Context` to give the uniform parameters, like so - (cf. :ref:`section-mechanism`): - - .. coqtop:: all reset - - Section list3. - Context (A:Set). - Inductive list3 : Set := - | nil3 : list3 - | cons3 : A -> list3 -> list3. - End list3. - - For finer control, you can use a ``|`` between the uniform and - the non-uniform parameters: - - .. coqtop:: in reset - - Inductive Acc {A:Type} (R:A->A->Prop) | (x:A) : Prop - := Acc_in : (forall y, R y x -> Acc y) -> Acc x. - - The flag can then be seen as deciding whether the ``|`` is at the - beginning (when the flag is unset) or at the end (when it is set) - of the parameters when not explicitly given. - -.. seealso:: - Section :ref:`inductive-definitions` and the :tacn:`induction` tactic. - -.. _mutually_inductive_types: - -Mutually defined inductive types -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. example:: Mutually defined inductive types - - A typical example of mutually inductive data types is trees and - forests. We assume two types :g:`A` and :g:`B` that are given as variables. The types can - be declared like this: - - .. coqtop:: in - - Parameters A B : Set. - - Inductive tree : Set := node : A -> forest -> tree - - with forest : Set := - | leaf : B -> forest - | cons : tree -> forest -> forest. - - This declaration automatically generates eight induction principles. They are not the most - general principles, but they correspond to each inductive part seen as a single inductive definition. - - To illustrate this point on our example, here are the types of :g:`tree_rec` - and :g:`forest_rec`. - - .. coqtop:: all - - Check tree_rec. - - Check forest_rec. - - Assume we want to parameterize our mutual inductive definitions with the - two type variables :g:`A` and :g:`B`, the declaration should be - done as follows: - - .. coqdoc:: - - Inductive tree (A B:Set) : Set := node : A -> forest A B -> tree A B - - with forest (A B:Set) : Set := - | leaf : B -> forest A B - | cons : tree A B -> forest A B -> forest A B. - - Assume we define an inductive definition inside a section - (cf. :ref:`section-mechanism`). When the section is closed, the variables - declared in the section and occurring free in the declaration are added as - parameters to the inductive definition. - -.. seealso:: - A generic command :cmd:`Scheme` is useful to build automatically various - mutual induction principles. - -Private (matching) inductive types -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. attr:: private(matching) - - This attribute can be used to forbid the use of the :g:`match` - construct on objects of this inductive type outside of the module - where it is defined. There is also a legacy syntax using the - ``Private`` prefix (cf. :n:`@legacy_attr`). - - The main use case of private (matching) inductive types is to emulate - quotient types / higher-order inductive types in projects such as - the `HoTT library <https://github.com/HoTT/HoTT>`_. - -.. example:: - - .. coqtop:: all - - Module Foo. - #[ private(matching) ] Inductive my_nat := my_O : my_nat | my_S : my_nat -> my_nat. - Check (fun x : my_nat => match x with my_O => true | my_S _ => false end). - End Foo. - Import Foo. - Fail Check (fun x : my_nat => match x with my_O => true | my_S _ => false end). - -Variants -~~~~~~~~ - -.. cmd:: Variant @variant_definition {* with @variant_definition } - - .. insertprodn variant_definition variant_definition - - .. prodn:: - variant_definition ::= @ident_decl {* @binder } {? %| {* @binder } } {? : @type } := {? %| } {+| @constructor } {? @decl_notations } - - The :cmd:`Variant` command is similar to the :cmd:`Inductive` command, except - that it disallows recursive definition of types (for instance, lists cannot - be defined using :cmd:`Variant`). No induction scheme is generated for - this variant, unless the :flag:`Nonrecursive Elimination Schemes` flag is on. - - This command supports the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`universes(template)`, - :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, - :attr:`universes(noncumulative)` and :attr:`private(matching)` - attributes. - - .. exn:: The @num th argument of @ident must be @ident in @type. - :undocumented: - -.. _coinductive-types: - -Co-inductive types ------------------- - -The objects of an inductive type are well-founded with respect to the -constructors of the type. In other words, such objects contain only a -*finite* number of constructors. Co-inductive types arise from relaxing -this condition, and admitting types whose objects contain an infinity of -constructors. Infinite objects are introduced by a non-ending (but -effective) process of construction, defined in terms of the constructors -of the type. - -.. cmd:: CoInductive @inductive_definition {* with @inductive_definition } - - This command introduces a co-inductive type. - The syntax of the command is the same as the command :cmd:`Inductive`. - No principle of induction is derived from the definition of a co-inductive - type, since such principles only make sense for inductive types. - For co-inductive types, the only elimination principle is case analysis. - - This command supports the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`universes(template)`, - :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, - :attr:`universes(noncumulative)` and :attr:`private(matching)` - attributes. - -.. example:: - - The type of infinite sequences of natural numbers, usually called streams, - is an example of a co-inductive type. - - .. coqtop:: in - - CoInductive Stream : Set := Seq : nat -> Stream -> Stream. - - The usual destructors on streams :g:`hd:Stream->nat` and :g:`tl:Str->Str` - can be defined as follows: - - .. coqtop:: in - - Definition hd (x:Stream) := let (a,s) := x in a. - Definition tl (x:Stream) := let (a,s) := x in s. - -Definitions of co-inductive predicates and blocks of mutually -co-inductive definitions are also allowed. - -.. example:: - - The extensional equality on streams is an example of a co-inductive type: - - .. coqtop:: in - - CoInductive EqSt : Stream -> Stream -> Prop := - eqst : forall s1 s2:Stream, - hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2. - - In order to prove the extensional equality of two streams :g:`s1` and :g:`s2` - we have to construct an infinite proof of equality, that is, an infinite - object of type :g:`(EqSt s1 s2)`. We will see how to introduce infinite - objects in Section :ref:`cofixpoint`. - -Caveat -~~~~~~ - -The ability to define co-inductive types by constructors, hereafter called -*positive co-inductive types*, is known to break subject reduction. The story is -a bit long: this is due to dependent pattern-matching which implies -propositional η-equality, which itself would require full η-conversion for -subject reduction to hold, but full η-conversion is not acceptable as it would -make type checking undecidable. - -Since the introduction of primitive records in Coq 8.5, an alternative -presentation is available, called *negative co-inductive types*. This consists -in defining a co-inductive type as a primitive record type through its -projections. Such a technique is akin to the *co-pattern* style that can be -found in e.g. Agda, and preserves subject reduction. - -The above example can be rewritten in the following way. - -.. coqtop:: none - - Reset Stream. - -.. coqtop:: all - - Set Primitive Projections. - CoInductive Stream : Set := Seq { hd : nat; tl : Stream }. - CoInductive EqSt (s1 s2: Stream) : Prop := eqst { - eqst_hd : hd s1 = hd s2; - eqst_tl : EqSt (tl s1) (tl s2); - }. - -Some properties that hold over positive streams are lost when going to the -negative presentation, typically when they imply equality over streams. -For instance, propositional η-equality is lost when going to the negative -presentation. It is nonetheless logically consistent to recover it through an -axiom. - -.. coqtop:: all - - Axiom Stream_eta : forall s: Stream, s = Seq (hd s) (tl s). - -More generally, as in the case of positive coinductive types, it is consistent -to further identify extensional equality of coinductive types with propositional -equality: - -.. coqtop:: all - - Axiom Stream_ext : forall (s1 s2: Stream), EqSt s1 s2 -> s1 = s2. - -As of Coq 8.9, it is now advised to use negative co-inductive types rather than -their positive counterparts. - -.. seealso:: - :ref:`primitive_projections` for more information about negative - records and primitive projections. - - -Definition of recursive functions ---------------------------------- - -Definition of functions by recursion over inductive objects -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -This section describes the primitive form of definition by recursion over -inductive objects. See the :cmd:`Function` command for more advanced -constructions. - -.. _Fixpoint: - -.. cmd:: Fixpoint @fix_definition {* with @fix_definition } - - .. insertprodn fix_definition fix_definition - - .. prodn:: - fix_definition ::= @ident_decl {* @binder } {? @fixannot } {? : @type } {? := @term } {? @decl_notations } - - This command allows defining functions by pattern matching over inductive - objects using a fixed point construction. The meaning of this declaration is - to define :n:`@ident` as a recursive function with arguments specified by - the :n:`@binder`\s such that :n:`@ident` applied to arguments - corresponding to these :n:`@binder`\s has type :n:`@type`, and is - equivalent to the expression :n:`@term`. The type of :n:`@ident` is - consequently :n:`forall {* @binder }, @type` and its value is equivalent - to :n:`fun {* @binder } => @term`. - - To be accepted, a :cmd:`Fixpoint` definition has to satisfy syntactical - constraints on a special argument called the decreasing argument. They - are needed to ensure that the :cmd:`Fixpoint` definition always terminates. - The point of the :n:`{struct @ident}` annotation (see :n:`@fixannot`) is to - let the user tell the system which argument decreases along the recursive calls. - - The :n:`{struct @ident}` annotation may be left implicit, in which case the - system successively tries arguments from left to right until it finds one - that satisfies the decreasing condition. - - :cmd:`Fixpoint` without the :attr:`program` attribute does not support the - :n:`wf` or :n:`measure` clauses of :n:`@fixannot`. - - The :n:`with` clause allows simultaneously defining several mutual fixpoints. - It is especially useful when defining functions over mutually defined - inductive types. Example: :ref:`Mutual Fixpoints<example_mutual_fixpoints>`. - - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. - This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. - In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant - for which the computational behavior is relevant. See :ref:`proof-editing-mode`. - - .. note:: - - + Some fixpoints may have several arguments that fit as decreasing - arguments, and this choice influences the reduction of the fixpoint. - Hence an explicit annotation must be used if the leftmost decreasing - argument is not the desired one. Writing explicit annotations can also - speed up type checking of large mutual fixpoints. - - + In order to keep the strong normalization property, the fixed point - reduction will only be performed when the argument in position of the - decreasing argument (which type should be in an inductive definition) - starts with a constructor. - - - .. example:: - - One can define the addition function as : - - .. coqtop:: all - - Fixpoint add (n m:nat) {struct n} : nat := - match n with - | O => m - | S p => S (add p m) - end. - - The match operator matches a value (here :g:`n`) with the various - constructors of its (inductive) type. The remaining arguments give the - respective values to be returned, as functions of the parameters of the - corresponding constructor. Thus here when :g:`n` equals :g:`O` we return - :g:`m`, and when :g:`n` equals :g:`(S p)` we return :g:`(S (add p m))`. - - The match operator is formally described in - Section :ref:`match-construction`. - The system recognizes that in the inductive call :g:`(add p m)` the first - argument actually decreases because it is a *pattern variable* coming - from :g:`match n with`. - - .. example:: - - The following definition is not correct and generates an error message: - - .. coqtop:: all - - Fail Fixpoint wrongplus (n m:nat) {struct n} : nat := - match m with - | O => n - | S p => S (wrongplus n p) - end. - - because the declared decreasing argument :g:`n` does not actually - decrease in the recursive call. The function computing the addition over - the second argument should rather be written: - - .. coqtop:: all - - Fixpoint plus (n m:nat) {struct m} : nat := - match m with - | O => n - | S p => S (plus n p) - end. - - .. example:: - - The recursive call may not only be on direct subterms of the recursive - variable :g:`n` but also on a deeper subterm and we can directly write - the function :g:`mod2` which gives the remainder modulo 2 of a natural - number. - - .. coqtop:: all - - Fixpoint mod2 (n:nat) : nat := - match n with - | O => O - | S p => match p with - | O => S O - | S q => mod2 q - end - end. - -.. _example_mutual_fixpoints: - - .. example:: Mutual fixpoints - - The size of trees and forests can be defined the following way: - - .. coqtop:: all - - Fixpoint tree_size (t:tree) : nat := - match t with - | node a f => S (forest_size f) - end - with forest_size (f:forest) : nat := - match f with - | leaf b => 1 - | cons t f' => (tree_size t + forest_size f') - end. - -.. _cofixpoint: - -Definitions of recursive objects in co-inductive types -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. cmd:: CoFixpoint @cofix_definition {* with @cofix_definition } - - .. insertprodn cofix_definition cofix_definition - - .. prodn:: - cofix_definition ::= @ident_decl {* @binder } {? : @type } {? := @term } {? @decl_notations } - - This command introduces a method for constructing an infinite object of a - coinductive type. For example, the stream containing all natural numbers can - be introduced applying the following method to the number :g:`O` (see - Section :ref:`coinductive-types` for the definition of :g:`Stream`, :g:`hd` - and :g:`tl`): - - .. coqtop:: all - - CoFixpoint from (n:nat) : Stream := Seq n (from (S n)). - - Unlike recursive definitions, there is no decreasing argument in a - co-recursive definition. To be admissible, a method of construction must - provide at least one extra constructor of the infinite object for each - iteration. A syntactical guard condition is imposed on co-recursive - definitions in order to ensure this: each recursive call in the - definition must be protected by at least one constructor, and only by - constructors. That is the case in the former definition, where the single - recursive call of :g:`from` is guarded by an application of :g:`Seq`. - On the contrary, the following recursive function does not satisfy the - guard condition: - - .. coqtop:: all - - Fail CoFixpoint filter (p:nat -> bool) (s:Stream) : Stream := - if p (hd s) then Seq (hd s) (filter p (tl s)) else filter p (tl s). - - The elimination of co-recursive definition is done lazily, i.e. the - definition is expanded only when it occurs at the head of an application - which is the argument of a case analysis expression. In any other - context, it is considered as a canonical expression which is completely - evaluated. We can test this using the command :cmd:`Eval`, which computes - the normal forms of a term: - - .. coqtop:: all - - Eval compute in (from 0). - Eval compute in (hd (from 0)). - Eval compute in (tl (from 0)). - - As in the :cmd:`Fixpoint` command, the :n:`with` clause allows simultaneously - defining several mutual cofixpoints. - - If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. - This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. - In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant - for which the computational behavior is relevant. See :ref:`proof-editing-mode`. - -.. _Computations: - -Computations ------------- - -.. insertprodn reduce pattern_occ - -.. prodn:: - reduce ::= Eval @red_expr in - red_expr ::= red - | hnf - | simpl {? @delta_flag } {? @ref_or_pattern_occ } - | cbv {? @strategy_flag } - | cbn {? @strategy_flag } - | lazy {? @strategy_flag } - | compute {? @delta_flag } - | vm_compute {? @ref_or_pattern_occ } - | native_compute {? @ref_or_pattern_occ } - | unfold {+, @unfold_occ } - | fold {+ @one_term } - | pattern {+, @pattern_occ } - | @ident - delta_flag ::= {? - } [ {+ @smart_qualid } ] - strategy_flag ::= {+ @red_flags } - | @delta_flag - red_flags ::= beta - | iota - | match - | fix - | cofix - | zeta - | delta {? @delta_flag } - ref_or_pattern_occ ::= @smart_qualid {? at @occs_nums } - | @one_term {? at @occs_nums } - occs_nums ::= {+ {| @num | @ident } } - | - {| @num | @ident } {* @int_or_var } - int_or_var ::= @int - | @ident - unfold_occ ::= @smart_qualid {? at @occs_nums } - pattern_occ ::= @one_term {? at @occs_nums } - -See :ref:`Conversion-rules`. - -.. todo:: Add text here - -.. _Assertions: - -Assertions and proofs ---------------------- - -An assertion states a proposition (or a type) of which the proof (or an -inhabitant of the type) is interactively built using tactics. The interactive -proof mode is described in Chapter :ref:`proofhandling` and the tactics in -Chapter :ref:`Tactics`. The basic assertion command is: - -.. cmd:: @thm_token @ident_decl {* @binder } : @type {* with @ident_decl {* @binder } : @type } - :name: Theorem; Lemma; Fact; Remark; Corollary; Proposition; Property - - .. insertprodn thm_token thm_token - - .. prodn:: - thm_token ::= Theorem - | Lemma - | Fact - | Remark - | Corollary - | Proposition - | Property - - After the statement is asserted, Coq needs a proof. Once a proof of - :n:`@type` under the assumptions represented by :n:`@binder`\s is given and - validated, the proof is generalized into a proof of :n:`forall {* @binder }, @type` and - the theorem is bound to the name :n:`@ident` in the environment. - - Forms using the :n:`with` clause are useful for theorems that are proved by simultaneous induction - over a mutually inductive assumption, or that assert mutually dependent - statements in some mutual co-inductive type. It is equivalent to - :cmd:`Fixpoint` or :cmd:`CoFixpoint` but using tactics to build the proof of - the statements (or the body of the specification, depending on the point of - view). The inductive or co-inductive types on which the induction or - coinduction has to be done is assumed to be non ambiguous and is guessed by - the system. - - Like in a :cmd:`Fixpoint` or :cmd:`CoFixpoint` definition, the induction hypotheses - have to be used on *structurally smaller* arguments (for a :cmd:`Fixpoint`) or - be *guarded by a constructor* (for a :cmd:`CoFixpoint`). The verification that - recursive proof arguments are correct is done only at the time of registering - the lemma in the environment. To know if the use of induction hypotheses is - correct at some time of the interactive development of a proof, use the - command :cmd:`Guarded`. - - .. exn:: The term @term has type @type which should be Set, Prop or Type. - :undocumented: - - .. exn:: @ident already exists. - :name: @ident already exists. (Theorem) - - The name you provided is already defined. You have then to choose - another name. - - .. exn:: Nested proofs are not allowed unless you turn the Nested Proofs Allowed flag on. - - You are asserting a new statement while already being in proof editing mode. - This feature, called nested proofs, is disabled by default. - To activate it, turn the :flag:`Nested Proofs Allowed` flag on. - -Proofs start with the keyword :cmd:`Proof`. Then Coq enters the proof editing mode -until the proof is completed. In proof editing mode, the user primarily enters -tactics, which are described in chapter :ref:`Tactics`. The user may also enter -commands to manage the proof editing mode. They are described in Chapter -:ref:`proofhandling`. - -When the proof is complete, use the :cmd:`Qed` command so the kernel verifies -the proof and adds it to the environment. - -.. note:: - - #. Several statements can be simultaneously asserted provided the - :flag:`Nested Proofs Allowed` flag was turned on. - - #. Not only other assertions but any vernacular command can be given - while in the process of proving a given assertion. In this case, the - command is understood as if it would have been given before the - statements still to be proved. Nonetheless, this practice is discouraged - and may stop working in future versions. - - #. Proofs ended by :cmd:`Qed` are declared opaque. Their content cannot be - unfolded (see :ref:`performingcomputations`), thus - realizing some form of *proof-irrelevance*. To be able to unfold a - proof, the proof should be ended by :cmd:`Defined`. - - #. :cmd:`Proof` is recommended but can currently be omitted. On the opposite - side, :cmd:`Qed` (or :cmd:`Defined`) is mandatory to validate a proof. - - #. One can also use :cmd:`Admitted` in place of :cmd:`Qed` to turn the - current asserted statement into an axiom and exit the proof editing mode. - -.. [1] - Except if the inductive type is empty in which case there is no - equation that can be used to infer the return type. + <meta http-equiv="refresh" content="0;URL=core/index.html"> diff --git a/doc/sphinx/language/module-system.rst b/doc/sphinx/language/module-system.rst index 15fee91245..f99b132d2a 100644 --- a/doc/sphinx/language/module-system.rst +++ b/doc/sphinx/language/module-system.rst @@ -1,456 +1,5 @@ -.. _themodulesystem: +:orphan: -The Module System -================= +.. raw:: html -The module system extends the Calculus of Inductive Constructions -providing a convenient way to structure large developments as well as -a means of massive abstraction. - - -Modules and module types ----------------------------- - -**Access path.** An access path is denoted by :math:`p` and can be -either a module variable :math:`X` or, if :math:`p′` is an access path -and :math:`id` an identifier, then :math:`p′.id` is an access path. - - -**Structure element.** A structure element is denoted by :math:`e` and -is either a definition of a constant, an assumption, a definition of -an inductive, a definition of a module, an alias of a module or a module -type abbreviation. - - -**Structure expression.** A structure expression is denoted by :math:`S` and can be: - -+ an access path :math:`p` -+ a plain structure :math:`\Struct~e ; … ; e~\End` -+ a functor :math:`\Functor(X:S)~S′`, where :math:`X` is a module variable, :math:`S` and :math:`S′` are - structure expressions -+ an application :math:`S~p`, where :math:`S` is a structure expression and :math:`p` an - access path -+ a refined structure :math:`S~\with~p := p`′ or :math:`S~\with~p := t:T` where :math:`S` is a - structure expression, :math:`p` and :math:`p′` are access paths, :math:`t` is a term and :math:`T` is - the type of :math:`t`. - -**Module definition.** A module definition is written :math:`\Mod{X}{S}{S'}` -and consists of a module variable :math:`X`, a module type -:math:`S` which can be any structure expression and optionally a -module implementation :math:`S′` which can be any structure expression -except a refined structure. - - -**Module alias.** A module alias is written :math:`\ModA{X}{p}` -and consists of a module variable :math:`X` and a module path -:math:`p`. - -**Module type abbreviation.** -A module type abbreviation is written :math:`\ModType{Y}{S}`, -where :math:`Y` is an identifier and :math:`S` is any structure -expression . - - -Typing Modules ------------------- - -In order to introduce the typing system we first slightly extend the syntactic -class of terms and environments given in section :ref:`The-terms`. The -environments, apart from definitions of constants and inductive types now also -hold any other structure elements. Terms, apart from variables, constants and -complex terms, include also access paths. - -We also need additional typing judgments: - - -+ :math:`\WFT{E}{S}`, denoting that a structure :math:`S` is well-formed, -+ :math:`\WTM{E}{p}{S}`, denoting that the module pointed by :math:`p` has type :math:`S` in - environment :math:`E`. -+ :math:`\WEV{E}{S}{\ovl{S}}`, denoting that a structure :math:`S` is evaluated to a - structure :math:`S` in weak head normal form. -+ :math:`\WS{E}{S_1}{S_2}` , denoting that a structure :math:`S_1` is a subtype of a - structure :math:`S_2`. -+ :math:`\WS{E}{e_1}{e_2}` , denoting that a structure element e_1 is more - precise than a structure element e_2. - -The rules for forming structures are the following: - -.. inference:: WF-STR - - \WF{E;E′}{} - ------------------------ - \WFT{E}{ \Struct~E′ ~\End} - -.. inference:: WF-FUN - - \WFT{E; \ModS{X}{S}}{ \ovl{S′} } - -------------------------- - \WFT{E}{ \Functor(X:S)~S′} - - -Evaluation of structures to weak head normal form: - -.. inference:: WEVAL-APP - - \begin{array}{c} - \WEV{E}{S}{\Functor(X:S_1 )~S_2}~~~~~\WEV{E}{S_1}{\ovl{S_1}} \\ - \WTM{E}{p}{S_3}~~~~~ \WS{E}{S_3}{\ovl{S_1}} - \end{array} - -------------------------- - \WEV{E}{S~p}{S_2 \{p/X,t_1 /p_1 .c_1 ,…,t_n /p_n.c_n \}} - - -In the last rule, :math:`\{t_1 /p_1 .c_1 ,…,t_n /p_n .c_n \}` is the resulting -substitution from the inlining mechanism. We substitute in :math:`S` the -inlined fields :math:`p_i .c_i` from :math:`\ModS{X}{S_1 }` by the corresponding delta- -reduced term :math:`t_i` in :math:`p`. - -.. inference:: WEVAL-WITH-MOD - - \begin{array}{c} - E[] ⊢ S \lra \Struct~e_1 ;…;e_i ; \ModS{X}{S_1 };e_{i+2} ;… ;e_n ~\End \\ - E;e_1 ;…;e_i [] ⊢ S_1 \lra \ovl{S_1} ~~~~~~ - E[] ⊢ p : S_2 \\ - E;e_1 ;…;e_i [] ⊢ S_2 <: \ovl{S_1} - \end{array} - ---------------------------------- - \begin{array}{c} - \WEV{E}{S~\with~x := p}{}\\ - \Struct~e_1 ;…;e_i ; \ModA{X}{p};e_{i+2} \{p/X\} ;…;e_n \{p/X\} ~\End - \end{array} - -.. inference:: WEVAL-WITH-MOD-REC - - \begin{array}{c} - \WEV{E}{S}{\Struct~e_1 ;…;e_i ; \ModS{X_1}{S_1 };e_{i+2} ;… ;e_n ~\End} \\ - \WEV{E;e_1 ;…;e_i }{S_1~\with~p := p_1}{\ovl{S_2}} - \end{array} - -------------------------- - \begin{array}{c} - \WEV{E}{S~\with~X_1.p := p_1}{} \\ - \Struct~e_1 ;…;e_i ; \ModS{X}{\ovl{S_2}};e_{i+2} \{p_1 /X_1.p\} ;…;e_n \{p_1 /X_1.p\} ~\End - \end{array} - -.. inference:: WEVAL-WITH-DEF - - \begin{array}{c} - \WEV{E}{S}{\Struct~e_1 ;…;e_i ;\Assum{}{c}{T_1};e_{i+2} ;… ;e_n ~\End} \\ - \WS{E;e_1 ;…;e_i }{Def()(c:=t:T)}{\Assum{}{c}{T_1}} - \end{array} - -------------------------- - \begin{array}{c} - \WEV{E}{S~\with~c := t:T}{} \\ - \Struct~e_1 ;…;e_i ;Def()(c:=t:T);e_{i+2} ;… ;e_n ~\End - \end{array} - -.. inference:: WEVAL-WITH-DEF-REC - - \begin{array}{c} - \WEV{E}{S}{\Struct~e_1 ;…;e_i ; \ModS{X_1 }{S_1 };e_{i+2} ;… ;e_n ~\End} \\ - \WEV{E;e_1 ;…;e_i }{S_1~\with~p := p_1}{\ovl{S_2}} - \end{array} - -------------------------- - \begin{array}{c} - \WEV{E}{S~\with~X_1.p := t:T}{} \\ - \Struct~e_1 ;…;e_i ; \ModS{X}{\ovl{S_2} };e_{i+2} ;… ;e_n ~\End - \end{array} - -.. inference:: WEVAL-PATH-MOD1 - - \begin{array}{c} - \WEV{E}{p}{\Struct~e_1 ;…;e_i ; \Mod{X}{S}{S_1};e_{i+2} ;… ;e_n End} \\ - \WEV{E;e_1 ;…;e_i }{S}{\ovl{S}} - \end{array} - -------------------------- - E[] ⊢ p.X \lra \ovl{S} - -.. inference:: WEVAL-PATH-MOD2 - - \WF{E}{} - \Mod{X}{S}{S_1}∈ E - \WEV{E}{S}{\ovl{S}} - -------------------------- - \WEV{E}{X}{\ovl{S}} - -.. inference:: WEVAL-PATH-ALIAS1 - - \begin{array}{c} - \WEV{E}{p}{~\Struct~e_1 ;…;e_i ; \ModA{X}{p_1};e_{i+2} ;… ;e_n End} \\ - \WEV{E;e_1 ;…;e_i }{p_1}{\ovl{S}} - \end{array} - -------------------------- - \WEV{E}{p.X}{\ovl{S}} - -.. inference:: WEVAL-PATH-ALIAS2 - - \WF{E}{} - \ModA{X}{p_1 }∈ E - \WEV{E}{p_1}{\ovl{S}} - -------------------------- - \WEV{E}{X}{\ovl{S}} - -.. inference:: WEVAL-PATH-TYPE1 - - \begin{array}{c} - \WEV{E}{p}{~\Struct~e_1 ;…;e_i ; \ModType{Y}{S};e_{i+2} ;… ;e_n End} \\ - \WEV{E;e_1 ;…;e_i }{S}{\ovl{S}} - \end{array} - -------------------------- - \WEV{E}{p.Y}{\ovl{S}} - -.. inference:: WEVAL-PATH-TYPE2 - - \WF{E}{} - \ModType{Y}{S}∈ E - \WEV{E}{S}{\ovl{S}} - -------------------------- - \WEV{E}{Y}{\ovl{S}} - - -Rules for typing module: - -.. inference:: MT-EVAL - - \WEV{E}{p}{\ovl{S}} - -------------------------- - E[] ⊢ p : \ovl{S} - -.. inference:: MT-STR - - E[] ⊢ p : S - -------------------------- - E[] ⊢ p : S/p - - -The last rule, called strengthening is used to make all module fields -manifestly equal to themselves. The notation :math:`S/p` has the following -meaning: - - -+ if :math:`S\lra~\Struct~e_1 ;…;e_n ~\End` then :math:`S/p=~\Struct~e_1 /p;…;e_n /p ~\End` - where :math:`e/p` is defined as follows (note that opaque definitions are processed - as assumptions): - - + :math:`\Def{}{c}{t}{T}/p = \Def{}{c}{t}{T}` - + :math:`\Assum{}{c}{U}/p = \Def{}{c}{p.c}{U}` - + :math:`\ModS{X}{S}/p = \ModA{X}{p.X}` - + :math:`\ModA{X}{p′}/p = \ModA{X}{p′}` - + :math:`\Ind{}{Γ_P}{Γ_C}{Γ_I}/p = \Indp{}{Γ_P}{Γ_C}{Γ_I}{p}` - + :math:`\Indpstr{}{Γ_P}{Γ_C}{Γ_I}{p'}{p} = \Indp{}{Γ_P}{Γ_C}{Γ_I}{p'}` - -+ if :math:`S \lra \Functor(X:S′)~S″` then :math:`S/p=S` - - -The notation :math:`\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}` -denotes an inductive definition that is definitionally equal to the -inductive definition in the module denoted by the path :math:`p`. All rules -which have :math:`\Ind{}{Γ_P}{Γ_C}{Γ_I}` as premises are also valid for -:math:`\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}`. We give the formation rule for -:math:`\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}` -below as well as the equality rules on inductive types and -constructors. - -The module subtyping rules: - -.. inference:: MSUB-STR - - \begin{array}{c} - \WS{E;e_1 ;…;e_n }{e_{σ(i)}}{e'_i ~\for~ i=1..m} \\ - σ : \{1… m\} → \{1… n\} ~\injective - \end{array} - -------------------------- - \WS{E}{\Struct~e_1 ;…;e_n ~\End}{~\Struct~e'_1 ;…;e'_m ~\End} - -.. inference:: MSUB-FUN - - \WS{E}{\ovl{S_1'}}{\ovl{S_1}} - \WS{E; \ModS{X}{S_1'}}{\ovl{S_2}}{\ovl{S_2'}} - -------------------------- - E[] ⊢ \Functor(X:S_1 ) S_2 <: \Functor(X:S_1') S_2' - - -Structure element subtyping rules: - -.. inference:: ASSUM-ASSUM - - E[] ⊢ T_1 ≤_{βδιζη} T_2 - -------------------------- - \WS{E}{\Assum{}{c}{T_1 }}{\Assum{}{c}{T_2 }} - -.. inference:: DEF-ASSUM - - E[] ⊢ T_1 ≤_{βδιζη} T_2 - -------------------------- - \WS{E}{\Def{}{c}{t}{T_1 }}{\Assum{}{c}{T_2 }} - -.. inference:: ASSUM-DEF - - E[] ⊢ T_1 ≤_{βδιζη} T_2 - E[] ⊢ c =_{βδιζη} t_2 - -------------------------- - \WS{E}{\Assum{}{c}{T_1 }}{\Def{}{c}{t_2 }{T_2 }} - -.. inference:: DEF-DEF - - E[] ⊢ T_1 ≤_{βδιζη} T_2 - E[] ⊢ t_1 =_{βδιζη} t_2 - -------------------------- - \WS{E}{\Def{}{c}{t_1 }{T_1 }}{\Def{}{c}{t_2 }{T_2 }} - -.. inference:: IND-IND - - E[] ⊢ Γ_P =_{βδιζη} Γ_P' - E[Γ_P ] ⊢ Γ_C =_{βδιζη} Γ_C' - E[Γ_P ;Γ_C ] ⊢ Γ_I =_{βδιζη} Γ_I' - -------------------------- - \WS{E}{\ind{Γ_P}{Γ_C}{Γ_I}}{\ind{Γ_P'}{Γ_C'}{Γ_I'}} - -.. inference:: INDP-IND - - E[] ⊢ Γ_P =_{βδιζη} Γ_P' - E[Γ_P ] ⊢ Γ_C =_{βδιζη} Γ_C' - E[Γ_P ;Γ_C ] ⊢ Γ_I =_{βδιζη} Γ_I' - -------------------------- - \WS{E}{\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}}{\ind{Γ_P'}{Γ_C'}{Γ_I'}} - -.. inference:: INDP-INDP - - \begin{array}{c} - E[] ⊢ Γ_P =_{βδιζη} Γ_P' - E[Γ_P ] ⊢ Γ_C =_{βδιζη} Γ_C' \\ - E[Γ_P ;Γ_C ] ⊢ Γ_I =_{βδιζη} Γ_I' - E[] ⊢ p =_{βδιζη} p' - \end{array} - -------------------------- - \WS{E}{\Indp{}{Γ_P}{Γ_C}{Γ_I}{p}}{\Indp{}{Γ_P'}{Γ_C'}{Γ_I'}{p'}} - -.. inference:: MOD-MOD - - \WS{E}{S_1}{S_2} - -------------------------- - \WS{E}{\ModS{X}{S_1 }}{\ModS{X}{S_2 }} - -.. inference:: ALIAS-MOD - - E[] ⊢ p : S_1 - \WS{E}{S_1}{S_2} - -------------------------- - \WS{E}{\ModA{X}{p}}{\ModS{X}{S_2 }} - -.. inference:: MOD-ALIAS - - E[] ⊢ p : S_2 - \WS{E}{S_1}{S_2} - E[] ⊢ X =_{βδιζη} p - -------------------------- - \WS{E}{\ModS{X}{S_1 }}{\ModA{X}{p}} - -.. inference:: ALIAS-ALIAS - - E[] ⊢ p_1 =_{βδιζη} p_2 - -------------------------- - \WS{E}{\ModA{X}{p_1 }}{\ModA{X}{p_2 }} - -.. inference:: MODTYPE-MODTYPE - - \WS{E}{S_1}{S_2} - \WS{E}{S_2}{S_1} - -------------------------- - \WS{E}{\ModType{Y}{S_1 }}{\ModType{Y}{S_2 }} - - -New environment formation rules - - -.. inference:: WF-MOD1 - - \WF{E}{} - \WFT{E}{S} - -------------------------- - WF(E; \ModS{X}{S})[] - -.. inference:: WF-MOD2 - - \WS{E}{S_2}{S_1} - \WF{E}{} - \WFT{E}{S_1} - \WFT{E}{S_2} - -------------------------- - \WF{E; \Mod{X}{S_1}{S_2}}{} - -.. inference:: WF-ALIAS - - \WF{E}{} - E[] ⊢ p : S - -------------------------- - \WF{E, \ModA{X}{p}}{} - -.. inference:: WF-MODTYPE - - \WF{E}{} - \WFT{E}{S} - -------------------------- - \WF{E, \ModType{Y}{S}}{} - -.. inference:: WF-IND - - \begin{array}{c} - \WF{E;\ind{Γ_P}{Γ_C}{Γ_I}}{} \\ - E[] ⊢ p:~\Struct~e_1 ;…;e_n ;\ind{Γ_P'}{Γ_C'}{Γ_I'};… ~\End : \\ - E[] ⊢ \ind{Γ_P'}{Γ_C'}{Γ_I'} <: \ind{Γ_P}{Γ_C}{Γ_I} - \end{array} - -------------------------- - \WF{E; \Indp{}{Γ_P}{Γ_C}{Γ_I}{p} }{} - - -Component access rules - - -.. inference:: ACC-TYPE1 - - E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\Assum{}{c}{T};… ~\End - -------------------------- - E[Γ] ⊢ p.c : T - -.. inference:: ACC-TYPE2 - - E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\Def{}{c}{t}{T};… ~\End - -------------------------- - E[Γ] ⊢ p.c : T - -Notice that the following rule extends the delta rule defined in section :ref:`Conversion-rules` - -.. inference:: ACC-DELTA - - E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\Def{}{c}{t}{U};… ~\End - -------------------------- - E[Γ] ⊢ p.c \triangleright_δ t - -In the rules below we assume -:math:`Γ_P` is :math:`[p_1 :P_1 ;…;p_r :P_r ]`, -:math:`Γ_I` is :math:`[I_1 :A_1 ;…;I_k :A_k ]`, -and :math:`Γ_C` is :math:`[c_1 :C_1 ;…;c_n :C_n ]`. - -.. inference:: ACC-IND1 - - E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\ind{Γ_P}{Γ_C}{Γ_I};… ~\End - -------------------------- - E[Γ] ⊢ p.I_j : (p_1 :P_1 )…(p_r :P_r )A_j - -.. inference:: ACC-IND2 - - E[Γ] ⊢ p :~\Struct~e_1 ;…;e_i ;\ind{Γ_P}{Γ_C}{Γ_I};… ~\End - -------------------------- - E[Γ] ⊢ p.c_m : (p_1 :P_1 )…(p_r :P_r )C_m I_j (I_j~p_1 …p_r )_{j=1… k} - -.. inference:: ACC-INDP1 - - E[] ⊢ p :~\Struct~e_1 ;…;e_i ; \Indp{}{Γ_P}{Γ_C}{Γ_I}{p'} ;… ~\End - -------------------------- - E[] ⊢ p.I_i \triangleright_δ p'.I_i - -.. inference:: ACC-INDP2 - - E[] ⊢ p :~\Struct~e_1 ;…;e_i ; \Indp{}{Γ_P}{Γ_C}{Γ_I}{p'} ;… ~\End - -------------------------- - E[] ⊢ p.c_i \triangleright_δ p'.c_i + <meta http-equiv="refresh" content="0;URL=core/modules.html"> diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 90173d65bf..a21f7e545c 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -28,9 +28,8 @@ especially about its foundations, please refer to :cite:`Del00`. Syntax ------ -The syntax of the tactic language is given below. See Chapter -:ref:`gallinaspecificationlanguage` for a description of the BNF metasyntax used -in these grammar rules. Various already defined entries will be used in this +The syntax of the tactic language is given below. +Various already defined entries will be used in this chapter: entries :token:`num`, :token:`int`, :token:`ident` :token:`qualid`, :token:`term`, :token:`cpattern` and :token:`tactic` represent respectively natural and integer numbers, diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 4be18ccda9..f8435fcffe 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -5464,6 +5464,17 @@ equivalences are indeed taken into account, otherwise only single .. cmd:: Search {? @pattern } {* {? - } {| @string | @pattern } {? % @ident} } {? in {+ {? - } @qualid } } :name: Search (ssreflect) + .. versionchanged:: 8.12 + + This command is only available when loading a separate plugin + (`ssrsearch`). + + .. deprecated:: 8.12 + + This command is deprecated since all the additional features it + provides have been integrated in the standard :cmd:`Search` + command. + This is the |SSR| extension of the Search command. :token:`qualid` is the name of an open module. This command returns the list of lemmas: @@ -5502,7 +5513,11 @@ equivalences are indeed taken into account, otherwise only single Unset Strict Implicit. Unset Printing Implicit Defensive. - .. coqtop:: all + .. coqtop:: in + + Require Import ssrsearch. + + .. coqtop:: all warn Search "~~". diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index ad799fbbcd..3fec940fad 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -2977,6 +2977,41 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. Performing computations --------------------------- +.. insertprodn red_expr pattern_occ + +.. prodn:: + red_expr ::= red + | hnf + | simpl {? @delta_flag } {? @ref_or_pattern_occ } + | cbv {? @strategy_flag } + | cbn {? @strategy_flag } + | lazy {? @strategy_flag } + | compute {? @delta_flag } + | vm_compute {? @ref_or_pattern_occ } + | native_compute {? @ref_or_pattern_occ } + | unfold {+, @unfold_occ } + | fold {+ @one_term } + | pattern {+, @pattern_occ } + | @ident + delta_flag ::= {? - } [ {+ @smart_qualid } ] + strategy_flag ::= {+ @red_flags } + | @delta_flag + red_flags ::= beta + | iota + | match + | fix + | cofix + | zeta + | delta {? @delta_flag } + ref_or_pattern_occ ::= @smart_qualid {? at @occs_nums } + | @one_term {? at @occs_nums } + occs_nums ::= {+ {| @num | @ident } } + | - {| @num | @ident } {* @int_or_var } + int_or_var ::= @int + | @ident + unfold_occ ::= @smart_qualid {? at @occs_nums } + pattern_occ ::= @one_term {? at @occs_nums } + This set of tactics implements different specialized usages of the tactic :tacn:`change`. diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 7191444bac..3db9d2e80c 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -96,38 +96,125 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). .. seealso:: Section :ref:`performingcomputations`. -.. cmd:: Search {+ {? - } @search_item } {? {| inside | outside } {+ @qualid } } +.. cmd:: Search {+ @search_query } {? {| inside | outside } {+ @qualid } } - .. insertprodn search_item search_item + This command can be used to filter the goal and the global context + to retrieve objects whose name or type satisfies a number of + conditions. Library files that were not loaded with :cmd:`Require` + are not considered. The :table:`Search Blacklist` table can also + be used to exclude some things from all calls to :cmd:`Search`. + + The output of the command is a list of qualified identifiers and + their types. If the :flag:`Search Output Name Only` flag is on, + the types are omitted. + + .. insertprodn search_query search_query .. prodn:: - search_item ::= @one_term - | @string {? % @scope_key } + search_query ::= @search_item + | - @search_query + | [ {+| {+ @search_query } } ] - Displays the name and type of all hypotheses of the - selected goal (if any) and theorems of the current context - matching :n:`@search_item`\s. - It's useful for finding the names of library lemmas. + Multiple :n:`@search_item`\s can be combined into a complex + :n:`@search_query`: - * :n:`@one_term` - Search for objects containing a subterm matching the pattern - :n:`@one_term` in which holes of the pattern are indicated by `_` or :n:`?@ident`. - If the same :n:`?@ident` occurs more than once in the pattern, all occurrences must - match the same value. + :n:`- @search_query` + Excludes the objects that would be filtered by + :n:`@search_query`. Cf. :ref:`this example + <search-disambiguate-notation>`. - * :n:`@string` - If :n:`@string` is a substring of a valid identifier, - search for objects whose name contains :n:`@string`. If :n:`@string` is a notation - string associated with a :n:`@qualid`, that's equivalent to :cmd:`Search` :n:`@qualid`. - For example, specifying `"+"` or `"_ + _"`, which are notations for `Nat.add`, are equivalent - to :cmd:`Search` `Nat.add`. + :n:`[ @search_query ... @search_query | ... | @search_query ... @search_query ]` + This is a disjunction of conjunctions of queries. A simple + conjunction can be expressed by having a single disjunctive + branch. For a conjunction at top-level, the surrounding + brackets are not required. - * :n:`% @scope` - limits the search to the scope bound to - the delimiting key :n:`@scope`, such as, for example, :n:`%nat`. - This clause may be used only if :n:`@string` contains a notation string. - (see Section :ref:`LocalInterpretationRulesForNotations`) + .. insertprodn search_item search_item - If you specify multiple :n:`@search_item`\s, all the conditions must be satisfied - for the object to be displayed. The minus sign `-` excludes objects that contain - the :n:`@search_item`. + .. prodn:: + search_item ::= {? {| head | hyp | concl | headhyp | headconcl } : } @string {? % @scope_key } + | {? {| head | hyp | concl | headhyp | headconcl } : } @one_term + | is : @logical_kind + + Searched objects can be filtered by patterns, by the constants they + contain (identified by their name or a notation) and by their + names. + The location of the pattern or constant within a term + + :n:`@one_term` + Search for objects whose type contains a subterm matching the + pattern :n:`@one_term`. Holes of the pattern are indicated by + `_` or :n:`?@ident`. If the same :n:`?@ident` occurs more than + once in the pattern, all occurrences in the subterm must be + identical. Cf. :ref:`this example <search-pattern>`. + + :n:`@string {? % @scope_key }` + - If :n:`@string` is a substring of a valid identifier and no + :n:`% @scope_key` is provided, search for objects whose name + contains :n:`@string`. Cf. :ref:`this example + <search-part-ident>`. + + - If :n:`@string` is not a substring of a valid identifier or if + the optional :n:`% @scope_key` is provided, search for objects + whose type contains the reference that this string, + interpreted as a notation, is attached to (as in + :n:`@smart_qualid`). Cf. :ref:`this example + <search-by-notation>`. + + .. note:: + + If the string is a substring of a valid identifier but you + still want to look for a reference by notation, you can put + it between single quotes or provide a scope explictly. + Cf. :ref:`this example <search-disambiguate-notation>`. + + :n:`hyp:` + The provided pattern or reference is matched against any subterm + of an hypothesis of the type of the objects. Cf. :ref:`this + example <search-hyp>`. + + :n:`headhyp:` + The provided pattern or reference is matched against the + subterms in head position (any partial applicative subterm) of + the hypotheses of the type of the objects. Cf. :ref:`the + previous example <search-hyp>`. + + :n:`concl:` + The provided pattern or reference is matched against any subterm + of the conclusion of the type of the objects. Cf. :ref:`this + example <search-concl>`. + + :n:`headconcl:` + The provided pattern or reference is matched against the + subterms in head position (any partial applicative subterm) of + the conclusion of the type of the objects. Cf. :ref:`the + previous example <search-concl>`. + + :n:`head:` + This is simply the union between `headconcl:` and `headhyp:`. + + :n:`is: @logical_kind` + .. insertprodn logical_kind logical_kind + + .. prodn:: + logical_kind ::= @thm_token + | @assumption_token + | Context + | Definition + | Example + | Coercion + | Instance + | Scheme + | Canonical + | Field + | Method + | Primitive + + Filters objects by the keyword that was used to define them + (`Theorem`, `Lemma`, `Axiom`, `Variable`, `Context`, + `Primitive`...) or its status (`Coercion`, `Instance`, `Scheme`, + `Canonical`, `Field` for record fields, `Method` for class + fields). Cf. :ref:`this example <search-by-keyword>`. Additional clauses: @@ -139,32 +226,123 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). There is no constant in the environment named :n:`@qualid`, where :n:`@qualid` is in an `inside` or `outside` clause. - .. example:: :cmd:`Search` examples + .. _search-pattern: - .. coqtop:: in + .. example:: Searching for a pattern + + .. coqtop:: none reset + + Require Import PeanoNat. + + We can repeat meta-variables to narrow down the search. Here, + we are looking for commutativity lemmas. + + .. coqtop:: all + + Search (_ ?n ?m = _ ?m ?n). + + .. _search-part-ident: + + .. example:: Searching for part of an identifier + + .. coqtop:: all reset + + Search "_assoc". + + .. _search-by-notation: + + .. example:: Searching for a reference by notation + + .. coqtop:: all reset + + Search "+". + + .. _search-disambiguate-notation: + + .. example:: Disambiguating between part of identifier and notation + + .. coqtop:: none reset + + Require Import PeanoNat. + + In this example, we show two ways of searching for all the + objects whose type contains `Nat.modulo` but which do not + contain the substring "mod". + + .. coqtop:: all + + Search "'mod'" -"mod". + Search "mod"%nat -"mod". + + .. _search-hyp: + + .. example:: Search in hypotheses + + The following search shows the objects whose type contains + `bool` in an hypothesis as a strict subterm only: + + .. coqtop:: none reset + + Add Search Blacklist "internal_". + + .. coqtop:: all + + Search hyp:bool -headhyp:bool. - Require Import ZArith. + .. _search-concl: + + .. example:: Search in conclusion + + The following search shows the objects whose type contains `bool` + in the conclusion as a strict subterm only: .. coqtop:: all - Search Z.mul Z.add "distr". - Search "+"%Z "*"%Z "distr" -Prop. - Search (?x * _ + ?x * _)%Z outside OmegaLemmas. + Search concl:bool -headconcl:bool. + + .. _search-by-keyword: + + .. example:: Search by keyword or status + + The following search shows the definitions whose type is a `nat` + or a function which returns a `nat` and the lemmas about `+`: + .. coqtop:: all reset + + Search [ is:Definition headconcl:nat | is:Lemma (_ + _) ]. + + The following search shows the instances whose type includes the + classes `Reflexive` or `Symmetric`: + + .. coqtop:: none reset + + Require Import Morphisms. + + .. coqtop:: all + + Search is:Instance [ Reflexive | Symmetric ]. .. cmd:: SearchHead @one_term {? {| inside | outside } {+ @qualid } } + .. deprecated:: 8.12 + + Use the `headconcl:` clause of :cmd:`Search` instead. + Displays the name and type of all hypotheses of the selected goal (if any) and theorems of the current context that have the form :n:`{? forall {* @binder }, } {* P__i -> } C` where :n:`@one_term` - matches a prefix of `C`. For example, a :n:`@one_term` of `f _ b` - matches `f a b`, which is a prefix of `C` when `C` is `f a b c`. + matches a subterm of `C` in head position. For example, a :n:`@one_term` of `f _ b` + matches `f a b`, which is a subterm of `C` in head position when `C` is `f a b c`. See :cmd:`Search` for an explanation of the `inside`/`outside` clauses. .. example:: :cmd:`SearchHead` examples - .. coqtop:: reset all + .. coqtop:: none reset + + Add Search Blacklist "internal_". + + .. coqtop:: all warn SearchHead le. SearchHead (@eq bool). @@ -225,6 +403,12 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). Use the :cmd:`Add` and :cmd:`Remove` commands to update the set of blacklisted strings. +.. flag:: Search Output Name Only + + This flag restricts the output of search commands to identifier names; + turning it on causes invocations of :cmd:`Search`, :cmd:`SearchHead`, + :cmd:`SearchPattern`, :cmd:`SearchRewrite` etc. to omit types from their + output, printing only identifiers. .. _requests-to-the-environment: @@ -253,6 +437,13 @@ Requests to the environment .. cmd:: Locate @smart_qualid + .. insertprodn smart_qualid by_notation + + .. prodn:: + smart_qualid ::= @qualid + | @by_notation + by_notation ::= @string {? % @scope_key } + Displays the full name of objects from |Coq|'s various qualified namespaces such as terms, modules and Ltac. It also displays notation definitions. @@ -706,13 +897,6 @@ Controlling display interpreted from left to right, so in case of an overlap, the flags on the right have higher priority, meaning that `A,-A` is equivalent to `-A`. -.. flag:: Search Output Name Only - - This flag restricts the output of search commands to identifier names; - turning it on causes invocations of :cmd:`Search`, :cmd:`SearchHead`, - :cmd:`SearchPattern`, :cmd:`SearchRewrite` etc. to omit types from their - output, printing only identifiers. - .. opt:: Printing Width @num :name: Printing Width @@ -747,6 +931,36 @@ Controlling display after each tactic. The information is used by the Prooftree tool in Proof General. (https://askra.de/software/prooftree) +.. extracted from Gallina extensions chapter + +.. _printing_constructions_full: + +Printing constructions in full +------------------------------ + +.. flag:: Printing All + + Coercions, implicit arguments, the type of pattern matching, but also + notations (see :ref:`syntax-extensions-and-notation-scopes`) can obfuscate the behavior of some + tactics (typically the tactics applying to occurrences of subterms are + sensitive to the implicit arguments). Turning this flag on + deactivates all high-level printing features such as coercions, + implicit arguments, returned type of pattern matching, notations and + various syntactic sugar for pattern matching or record projections. + Otherwise said, :flag:`Printing All` includes the effects of the flags + :flag:`Printing Implicit`, :flag:`Printing Coercions`, :flag:`Printing Synth`, + :flag:`Printing Projections`, and :flag:`Printing Notations`. To reactivate + the high-level printing features, use the command ``Unset Printing All``. + + .. note:: In some cases, setting :flag:`Printing All` may display terms + that are so big they become very hard to read. One technique to work around + this is use :cmd:`Undelimit Scope` and/or :cmd:`Close Scope` to turn off the + printing of notations bound to particular scope(s). This can be useful when + notations in a given scope are getting in the way of understanding + a goal, but turning off all notations with :flag:`Printing All` would make + the goal unreadable. + + .. see a contrived example here: https://github.com/coq/coq/pull/11718#discussion_r415481854 .. _vernac-controlling-the-reduction-strategies: diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 60cd4c4ad8..955f2055e4 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1429,10 +1429,31 @@ Abbreviations Notation F p P := (force2 p (fun p => P)). Check exists x y, F (x,y) (x >= 1 /\ y >= 2). +.. extracted from Gallina chapter + +Numerals and strings +-------------------- + +.. insertprodn primitive_notations primitive_notations + +.. prodn:: + primitive_notations ::= @numeral + | @string + +Numerals and strings have no predefined semantics in the calculus. They are +merely notations that can be bound to objects through the notation mechanism. +Initially, numerals are bound to Peano’s representation of natural +numbers (see :ref:`datatypes`). + +.. note:: + + Negative integers are not at the same level as :n:`@num`, for this + would make precedence unnatural. + .. _numeral-notations: Numeral notations ------------------ +~~~~~~~~~~~~~~~~~ .. cmd:: Numeral Notation @qualid @qualid__parse @qualid__print : @scope_name {? @numeral_modifier } :name: Numeral Notation @@ -1557,7 +1578,7 @@ Numeral notations opaque constants. String notations ------------------ +~~~~~~~~~~~~~~~~ .. cmd:: String Notation @qualid @qualid__parse @qualid__print : @scope_name :name: String Notation diff --git a/doc/sphinx/using/libraries/funind.rst b/doc/sphinx/using/libraries/funind.rst index 40f9eedcf0..3625eac4a5 100644 --- a/doc/sphinx/using/libraries/funind.rst +++ b/doc/sphinx/using/libraries/funind.rst @@ -190,9 +190,9 @@ Tactics .. note:: :n:`(@qualid {+ @term})` must be a correct full application - of :n:`@qualid`. In particular, the rules for implicit arguments are the - same as usual. For example use :n:`@qualid` if you want to write implicit - arguments explicitly. + of :n:`@qualid`. In particular, the rules for implicit arguments are the + same as usual. For example use :n:`@@qualid` if you want to write implicit + arguments explicitly. .. note:: Parentheses around :n:`@qualid {+ @term}` are not mandatory and can be skipped. diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 3af16cb731..0a9dba99a9 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -91,3 +91,4 @@ theories/setoid_ring/Rings_Z.v theories/setoid_ring/ZArithRing.v theories/ssr/ssrunder.v theories/ssr/ssrsetoid.v +theories/ssrsearch/ssrsearch.vo diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 426f67eb53..ab615d5f65 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -540,18 +540,15 @@ through the <tt>Require Import</tt> command.</p> Formalization of real numbers </dt> <dd> + <dl> + <dt> <b>Classical Reals</b>: + Real numbers with excluded middle, total order and least upper bounds + </dt> + <dd> theories/Reals/Rdefinitions.v - theories/Reals/Cauchy/ConstructiveCauchyReals.v - theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v - theories/Reals/Cauchy/ConstructiveCauchyAbs.v theories/Reals/ClassicalDedekindReals.v + theories/Reals/ClassicalConstructiveReals.v theories/Reals/Raxioms.v - theories/Reals/Abstract/ConstructiveReals.v - theories/Reals/Abstract/ConstructiveRealsMorphisms.v - theories/Reals/Abstract/ConstructiveLUB.v - theories/Reals/Abstract/ConstructiveAbs.v - theories/Reals/Abstract/ConstructiveLimits.v - theories/Reals/Abstract/ConstructiveSum.v theories/Reals/RIneq.v theories/Reals/DiscrR.v theories/Reals/ROrderedType.v @@ -597,7 +594,6 @@ through the <tt>Require Import</tt> command.</p> theories/Reals/Ranalysis5.v theories/Reals/Ranalysis_reg.v theories/Reals/Rcomplete.v - theories/Reals/Cauchy/ConstructiveRcomplete.v theories/Reals/RiemannInt.v theories/Reals/RiemannInt_SF.v theories/Reals/Rpow_def.v @@ -617,6 +613,31 @@ through the <tt>Require Import</tt> command.</p> (theories/Reals/Reals.v) theories/Reals/Runcountable.v </dd> + <dt> <b>Abstract Constructive Reals</b>: + Interface of constructive reals, proof of equivalence of all implementations. EXPERIMENTAL + </dt> + <dd> + theories/Reals/Abstract/ConstructiveReals.v + theories/Reals/Abstract/ConstructiveRealsMorphisms.v + theories/Reals/Abstract/ConstructiveLUB.v + theories/Reals/Abstract/ConstructiveAbs.v + theories/Reals/Abstract/ConstructiveLimits.v + theories/Reals/Abstract/ConstructiveMinMax.v + theories/Reals/Abstract/ConstructivePower.v + theories/Reals/Abstract/ConstructiveSum.v + </dd> + <dt> <b>Constructive Cauchy Reals</b>: + Cauchy sequences of rational numbers, implementation of the interface. EXPERIMENTAL + </dt> + <dd> + theories/Reals/Cauchy/ConstructiveRcomplete.v + theories/Reals/Cauchy/ConstructiveCauchyReals.v + theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v + theories/Reals/Cauchy/ConstructiveCauchyAbs.v + </dd> + + </dl> + </dd> <dt> <b>Program</b>: Support for dependently-typed programming @@ -686,5 +707,6 @@ through the <tt>Require Import</tt> command.</p> theories/Compat/Coq810.v theories/Compat/Coq811.v theories/Compat/Coq812.v + theories/Compat/Coq813.v </dd> </dl> diff --git a/doc/tools/coqrst/coqdoc/main.py b/doc/tools/coqrst/coqdoc/main.py index de0d912c03..522b9900a5 100644 --- a/doc/tools/coqrst/coqdoc/main.py +++ b/doc/tools/coqrst/coqdoc/main.py @@ -36,7 +36,7 @@ COQDOC_HEADER = "".join("(** remove printing {} *)".format(s) for s in COQDOC_SY def coqdoc(coq_code, coqdoc_bin=None): """Get the output of coqdoc on coq_code.""" coqdoc_bin = coqdoc_bin or os.path.join(os.getenv("COQBIN", ""), "coqdoc") - fd, filename = mkstemp(prefix="coqdoc-", suffix=".v") + fd, filename = mkstemp(prefix="coqdoc_", suffix=".v") if platform.system().startswith("CYGWIN"): # coqdoc currently doesn't accept cygwin style paths in the form "/cygdrive/c/..." filename = check_output(["cygpath", "-w", filename]).decode("utf-8").strip() diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index df11960403..e59f694aa7 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -27,13 +27,13 @@ from docutils.parsers.rst.roles import code_role #, set_classes from docutils.parsers.rst.directives.admonitions import BaseAdmonition from sphinx import addnodes -from sphinx.roles import XRefRole -from sphinx.errors import ExtensionError -from sphinx.util.nodes import set_source_info, set_role_source_info, make_refnode -from sphinx.util.logging import getLogger, get_node_location from sphinx.directives import ObjectDescription from sphinx.domains import Domain, ObjType, Index -from sphinx.domains.std import token_xrefs +from sphinx.errors import ExtensionError +from sphinx.roles import XRefRole +from sphinx.util.docutils import ReferenceRole +from sphinx.util.logging import getLogger, get_node_location +from sphinx.util.nodes import set_source_info, set_role_source_info, make_refnode from . import coqdoc from .repl import ansicolors @@ -1162,25 +1162,34 @@ GrammarProductionRole.role_name = "production" def GlossaryDefRole(typ, rawtext, text, lineno, inliner, options={}, content=[]): """Marks the definition of a glossary term inline in the text. Matching :term:`XXX` - constructs will link to it. The term will also appear in the Glossary Index. + constructs will link to it. Use the form :gdef:`text <term>` to display "text" + for the definition of "term", such as when "term" must be capitalized or plural + for grammatical reasons. The term will also appear in the Glossary Index. - Example:: + Examples:: A :gdef:`prime` number is divisible only by itself and 1. + :gdef:`Composite <composite>` numbers are the non-prime numbers. """ #pylint: disable=dangerous-default-value, unused-argument env = inliner.document.settings.env std = env.domaindata['std']['objects'] - key = ('term', text) + m = ReferenceRole.explicit_title_re.match(text) + if m: + (text, term) = m.groups() + text = text.strip() + else: + term = text + key = ('term', term) if key in std: MSG = 'Duplicate object: {}; other is at {}' - msg = MSG.format(text, env.doc2path(std[key][0])) + msg = MSG.format(term, env.doc2path(std[key][0])) inliner.document.reporter.warning(msg, line=lineno) - targetid = nodes.make_id('term-{}'.format(text)) + targetid = nodes.make_id('term-{}'.format(term)) std[key] = (env.docname, targetid) - target = nodes.target('', '', ids=[targetid], names=[text]) + target = nodes.target('', '', ids=[targetid], names=[term]) inliner.document.note_explicit_target(target) node = nodes.inline(rawtext, '', target, nodes.Text(text), classes=['term-defn']) set_role_source_info(inliner, lineno, node) diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 62cc8ea86b..a9a243868f 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -59,6 +59,8 @@ DELETE: [ | lookup_at_as_comma | test_only_starredidentrefs | test_bracket_ident +| test_hash_ident +| test_id_colon | test_lpar_id_colon | test_lpar_id_coloneq (* todo: grammar seems incorrect, repeats the "(" IDENT ":=" *) | test_lpar_id_rpar @@ -1231,8 +1233,8 @@ query_command: [ | WITH "SearchPattern" constr_pattern in_or_out_modules | REPLACE "SearchRewrite" constr_pattern in_or_out_modules "." | WITH "SearchRewrite" constr_pattern in_or_out_modules -| REPLACE "Search" searchabout_query searchabout_queries "." -| WITH "Search" searchabout_queries +| REPLACE "Search" search_query search_queries "." +| WITH "Search" search_queries ] vernac_toplevel: [ @@ -1457,17 +1459,10 @@ ne_in_or_out_modules: [ | DELETE "outside" LIST1 global ] -searchabout_query: [ -| REPLACE positive_search_mark ne_string OPT scope_delimiter -| WITH ne_string OPT scope_delimiter -| REPLACE positive_search_mark constr_pattern -| WITH constr_pattern -] - -searchabout_queries: [ +search_queries: [ | DELETE ne_in_or_out_modules -| REPLACE searchabout_query searchabout_queries -| WITH LIST1 ( positive_search_mark searchabout_query ) OPT ne_in_or_out_modules +| REPLACE search_query search_queries +| WITH LIST1 ( search_query ) OPT ne_in_or_out_modules | DELETE (* empty *) ] @@ -1475,6 +1470,27 @@ positive_search_mark: [ | OPTINREF ] +SPLICE: [ +| positive_search_mark +] + +search_query: [ +| REPLACE OPT "-" search_item +| WITH search_item +| "-" search_query +| REPLACE OPT "-" "[" LIST1 ( LIST1 search_query ) SEP "|" "]" +| WITH "[" LIST1 ( LIST1 search_query ) SEP "|" "]" +] + +search_item: [ +| REPLACE search_where ":" ne_string OPT scope_delimiter +| WITH OPT ( search_where ":" ) ne_string OPT scope_delimiter +| DELETE ne_string OPT scope_delimiter +| REPLACE search_where ":" constr_pattern +| WITH OPT ( search_where ":" ) constr_pattern +| DELETE constr_pattern +] + by_notation: [ | REPLACE ne_string OPT [ "%" IDENT ] | WITH ne_string OPT [ "%" scope_key ] @@ -1485,14 +1501,6 @@ scope_delimiter: [ | WITH "%" scope_key ] -(* Don't show these details *) -DELETE: [ -| register_token -| register_prim_token -| register_type_token -] - - decl_notation: [ | REPLACE ne_lstring ":=" constr only_parsing OPT [ ":" IDENT ] | WITH ne_lstring ":=" constr only_parsing OPT [ ":" scope_name ] @@ -1638,7 +1646,6 @@ SPLICE: [ | record_binder | at_level_opt | table_value -| positive_search_mark | in_or_out_modules | option_setting | orient @@ -1672,11 +1679,14 @@ SPLICE: [ | intropatterns | instance_name | ne_in_or_out_modules -| searchabout_queries +| search_queries | locatable | scope_delimiter | bignat | one_import_filter_name +| register_token +| search_where +| extended_def_token ] (* end SPLICE *) RENAME: [ @@ -1725,7 +1735,9 @@ RENAME: [ | record_binder_body field_body | class_rawexpr class | smart_global smart_qualid +(* | searchabout_query search_item +*) | option_table setting_name | argument_spec_block arg_specs | more_implicits_block implicits_alt @@ -1735,8 +1747,6 @@ RENAME: [ | numnotoption numeral_modifier ] -(* todo: positive_search_mark is a lousy name for OPT "-" *) - (* todo: doesn't work if up above... maybe because 'clause' doesn't exist? *) clause_dft_concl: [ | OPTINREF diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 92e9df51d5..1b0a5c28ee 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -798,58 +798,7 @@ gallina: [ ] register_token: [ -| register_prim_token -| register_type_token -] - -register_type_token: [ -| "#int63_type" -| "#float64_type" -] - -register_prim_token: [ -| "#int63_head0" -| "#int63_tail0" -| "#int63_add" -| "#int63_sub" -| "#int63_mul" -| "#int63_div" -| "#int63_mod" -| "#int63_lsr" -| "#int63_lsl" -| "#int63_land" -| "#int63_lor" -| "#int63_lxor" -| "#int63_addc" -| "#int63_subc" -| "#int63_addcarryc" -| "#int63_subcarryc" -| "#int63_mulc" -| "#int63_diveucl" -| "#int63_div21" -| "#int63_addmuldiv" -| "#int63_eq" -| "#int63_lt" -| "#int63_le" -| "#int63_compare" -| "#float64_opp" -| "#float64_abs" -| "#float64_eq" -| "#float64_lt" -| "#float64_le" -| "#float64_compare" -| "#float64_classify" -| "#float64_add" -| "#float64_sub" -| "#float64_mul" -| "#float64_div" -| "#float64_sqrt" -| "#float64_of_int63" -| "#float64_normfr_mantissa" -| "#float64_frshiftexp" -| "#float64_ldshiftexp" -| "#float64_next_up" -| "#float64_next_down" +| test_hash_ident "#" IDENT ] thm_token: [ @@ -1252,7 +1201,7 @@ query_command: [ | "SearchHead" constr_pattern in_or_out_modules "." | "SearchPattern" constr_pattern in_or_out_modules "." | "SearchRewrite" constr_pattern in_or_out_modules "." -| "Search" searchabout_query searchabout_queries "." +| "Search" search_query search_queries "." ] printable: [ @@ -1349,14 +1298,48 @@ positive_search_mark: [ | ] -searchabout_query: [ -| positive_search_mark ne_string OPT scope_delimiter -| positive_search_mark constr_pattern +search_query: [ +| positive_search_mark search_item +| positive_search_mark "[" LIST1 ( LIST1 search_query ) SEP "|" "]" ] -searchabout_queries: [ +search_item: [ +| test_id_colon search_where ":" ne_string OPT scope_delimiter +| "is" ":" logical_kind +| ne_string OPT scope_delimiter +| test_id_colon search_where ":" constr_pattern +| constr_pattern +] + +logical_kind: [ +| thm_token +| assumption_token +| "Context" +| extended_def_token +| "Primitive" +] + +extended_def_token: [ +| def_token +| "Coercion" +| "Instance" +| "Scheme" +| "Canonical" +| "Field" +| "Method" +] + +search_where: [ +| "head" +| "hyp" +| "concl" +| "headhyp" +| "headconcl" +] + +search_queries: [ | ne_in_or_out_modules -| searchabout_query searchabout_queries +| search_query search_queries | ] @@ -1910,9 +1893,13 @@ debug: [ | ] +eauto_search_strategy_name: [ +| "bfs" +| "dfs" +] + eauto_search_strategy: [ -| "(bfs)" -| "(dfs)" +| "(" eauto_search_strategy_name ")" | ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 11f06b7b8a..3a327fc748 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -823,7 +823,7 @@ command: [ | "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) | "Typeclasses" "Transparent" LIST0 qualid | "Typeclasses" "Opaque" LIST0 qualid -| "Typeclasses" "eauto" ":=" OPT "debug" OPT [ "(bfs)" | "(dfs)" ] OPT int +| "Typeclasses" "eauto" ":=" OPT "debug" OPT ( "(" eauto_search_strategy_name ")" ) OPT int | "Proof" "with" ltac_expr OPT [ "using" section_subset_expr ] | "Proof" "using" section_subset_expr OPT [ "with" ltac_expr ] | "Tactic" "Notation" OPT ( "(" "at" "level" num ")" ) LIST1 ltac_production_item ":=" ltac_expr @@ -940,7 +940,7 @@ command: [ | "SearchHead" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchPattern" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchRewrite" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) -| "Search" LIST1 ( OPT "-" search_item ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Time" sentence | "Redirect" string sentence | "Timeout" num sentence @@ -996,9 +996,31 @@ comment: [ | num ] +search_query: [ +| search_item +| "-" search_query +| "[" LIST1 ( LIST1 search_query ) SEP "|" "]" +] + search_item: [ -| one_term -| string OPT ( "%" scope_key ) +| OPT ( [ "head" | "hyp" | "concl" | "headhyp" | "headconcl" ] ":" ) string OPT ( "%" scope_key ) +| OPT ( [ "head" | "hyp" | "concl" | "headhyp" | "headconcl" ] ":" ) one_term +| "is" ":" logical_kind +] + +logical_kind: [ +| thm_token +| assumption_token +| "Context" +| "Definition" +| "Example" +| "Coercion" +| "Instance" +| "Scheme" +| "Canonical" +| "Field" +| "Method" +| "Primitive" ] univ_name_list: [ @@ -1085,6 +1107,11 @@ hints_path: [ | hints_path hints_path ] +eauto_search_strategy_name: [ +| "bfs" +| "dfs" +] + class: [ | "Funclass" | "Sortclass" diff --git a/engine/evd.ml b/engine/evd.ml index 5642145f6d..ff13676818 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -697,8 +697,7 @@ let empty = { extras = Store.empty; } -let from_env e = - { empty with universes = UState.make ~lbound:(Environ.universes_lbound e) (Environ.universes e) } +let from_env e = { empty with universes = UState.from_env e } let from_ctx ctx = { empty with universes = ctx } @@ -862,9 +861,6 @@ let universe_subst evd = let merge_context_set ?loc ?(sideff=false) rigid evd ctx' = {evd with universes = UState.merge ?loc ~sideff rigid evd.universes ctx'} -let merge_universe_subst evd subst = - {evd with universes = UState.merge_subst evd.universes subst } - let with_context_set ?loc rigid d (a, ctx) = (merge_context_set ?loc rigid d ctx, a) diff --git a/engine/evd.mli b/engine/evd.mli index c6c4a71b22..d9b7bd76e7 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -636,7 +636,6 @@ val merge_universe_context : evar_map -> UState.t -> evar_map val set_universe_context : evar_map -> UState.t -> evar_map val merge_context_set : ?loc:Loc.t -> ?sideff:bool -> rigid -> evar_map -> Univ.ContextSet.t -> evar_map -val merge_universe_subst : evar_map -> UnivSubst.universe_opt_subst -> evar_map val with_context_set : ?loc:Loc.t -> rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a diff --git a/engine/uState.ml b/engine/uState.ml index 99ac5f2ce8..7c60d8317c 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -63,6 +63,8 @@ let make ~lbound u = uctx_universes_lbound = lbound; uctx_initial_universes = u} +let from_env e = make ~lbound:(Environ.universes_lbound e) (Environ.universes e) + let is_empty ctx = ContextSet.is_empty ctx.uctx_local && LMap.is_empty ctx.uctx_univ_variables diff --git a/engine/uState.mli b/engine/uState.mli index 533a501b59..45a0f9964e 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -29,6 +29,8 @@ val make : lbound:UGraph.Bound.t -> UGraph.t -> t val make_with_initial_binders : lbound:UGraph.Bound.t -> UGraph.t -> lident list -> t +val from_env : Environ.env -> t + val is_empty : t -> bool val union : t -> t -> t diff --git a/ide/idetop.ml b/ide/idetop.ml index fa458e7c6e..bd99cbed1b 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -341,7 +341,10 @@ let import_search_constraint = function let search flags = let pstate = Vernacstate.Declare.get_pstate () in - List.map export_coq_object (Search.interface_search ?pstate ( + let sigma, env = match pstate with + | None -> let env = Global.env () in Evd.(from_env env, env) + | Some p -> Declare.get_goal_context p 1 in + List.map export_coq_object (Search.interface_search env sigma ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) [@@ocaml.warning "-3"] diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index a8fb5a3f45..3d99e1d227 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -618,8 +618,9 @@ let interp_univ_constraints env evd cstrs = let cstrs' = Univ.Constraint.add cstr cstrs in try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in evd, cstrs' - with Univ.UniverseInconsistency e -> - CErrors.user_err ~hdr:"interp_constraint" + with Univ.UniverseInconsistency e as exn -> + let _, info = Exninfo.capture exn in + CErrors.user_err ~hdr:"interp_constraint" ~info (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e) in List.fold_left interp (evd,Univ.Constraint.empty) cstrs diff --git a/interp/constrextern.ml b/interp/constrextern.ml index bb91dc28da..63079993c8 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -836,7 +836,7 @@ let rec flatten_application c = match DAst.get c with let same_binder_type ty nal c = match nal, DAst.get c with - | _::_, GProd (_,_,ty',_) -> glob_constr_eq ty ty' + | _::_, (GProd (_,_,ty',_) | GLambda (_,_,ty',_)) -> glob_constr_eq ty ty' | [], _ -> true | _ -> assert false diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 5ad8af6d57..ee041ed088 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -115,7 +115,7 @@ type internalization_error = | NotAProjectionOf of qualid * qualid | ProjectionsOfDifferentRecords of qualid * qualid -exception InternalizationError of internalization_error Loc.located +exception InternalizationError of internalization_error let explain_variable_capture id id' = Id.print id ++ str " is dependent in the type of " ++ Id.print id' ++ @@ -164,8 +164,13 @@ let explain_internalization_error e = explain_projections_of_diff_records inductive1_id inductive2_id in pp ++ str "." -let error_bad_inductive_type ?loc = - user_err ?loc (str +let _ = CErrors.register_handler (function + | InternalizationError e -> + Some (explain_internalization_error e) + | _ -> None) + +let error_bad_inductive_type ?loc ?info () = + user_err ?loc ?info (str "This should be an inductive type applied to patterns.") let error_parameter_not_implicit ?loc = @@ -368,7 +373,7 @@ let impls_term_list n ?(args = []) = (* Check if in binder "(x1 x2 .. xn : t)", none of x1 .. xn-1 occurs in t *) let rec check_capture ty = let open CAst in function | { loc; v = Name id } :: { v = Name id' } :: _ when occur_glob_constr id ty -> - raise (InternalizationError (loc,VariableCapture (id,id'))) + Loc.raise ?loc (InternalizationError (VariableCapture (id,id'))) | _::nal -> check_capture ty nal | [] -> @@ -1086,7 +1091,9 @@ let intern_extended_global_of_qualid qid = let intern_reference qid = let r = try intern_extended_global_of_qualid qid - with Not_found -> Nametab.error_global_not_found qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid in Smartlocate.global_of_extended_global r @@ -1170,16 +1177,20 @@ let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us let r, realref, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in check_applied_projection isproj realref qid; find_appl_head_data r, args2 - with Not_found -> + with Not_found as exn -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (* check_applied_projection ?? *) (gvar (loc,qualid_basename qid) us, [], []), args - else Nametab.error_global_not_found qid + else + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid else let r,realref,args2 = try intern_qualid qid intern env ntnvars us args - with Not_found -> Nametab.error_global_not_found qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid in check_applied_projection isproj realref qid; find_appl_head_data r, args2 @@ -1253,14 +1264,16 @@ let loc_of_lhs lhs = let check_linearity lhs ids = match has_duplicate ids with | Some id -> - raise (InternalizationError (loc_of_lhs lhs,NonLinearPattern id)) + let loc = loc_of_lhs lhs in + Loc.raise ?loc (InternalizationError (NonLinearPattern id)) | None -> () (* Match the number of pattern against the number of matched args *) let check_number_of_pattern loc n l = let p = List.length l in - if not (Int.equal n p) then raise (InternalizationError (loc,BadPatternsNumber (n,p))) + if not (Int.equal n p) then + Loc.raise ?loc (InternalizationError (BadPatternsNumber (n,p))) let check_or_pat_variables loc ids idsl = let eq_id {v=id} {v=id'} = Id.equal id id' in @@ -1392,7 +1405,7 @@ let find_constructor loc add_params ref = let find_pattern_variable qid = if qualid_is_ident qid then qualid_basename qid - else raise (InternalizationError(qid.CAst.loc,NotAConstructor qid)) + else Loc.raise ?loc:qid.CAst.loc (InternalizationError(NotAConstructor qid)) let check_duplicate ?loc fields = let eq (ref1, _) (ref2, _) = qualid_eq ref1 ref2 in @@ -1429,8 +1442,10 @@ let sort_fields ~complete loc fields completer = let gr = locate_reference first_field_ref in Dumpglob.add_glob ?loc:first_field_ref.CAst.loc gr; (gr, Recordops.find_projection gr) - with Not_found -> - raise (InternalizationError(first_field_ref.CAst.loc, NotAProjection first_field_ref)) + with Not_found as exn -> + let _, info = Exninfo.capture exn in + let info = Option.cata (Loc.add_loc info) info loc in + Exninfo.iraise (InternalizationError(NotAProjection first_field_ref), info) in (* the number of parameters *) let nparams = record.Recordops.s_EXPECTEDPARAM in @@ -1465,10 +1480,10 @@ let sort_fields ~complete loc fields completer = try Recordops.find_projection field_glob_ref with Not_found -> let inductive_ref = inductive_of_record floc record in - raise (InternalizationError(floc, NotAProjectionOf (field_ref, inductive_ref))) in + Loc.raise ?loc:floc (InternalizationError(NotAProjectionOf (field_ref, inductive_ref))) in let ind1 = inductive_of_record floc record in let ind2 = inductive_of_record floc this_field_record in - raise (InternalizationError(loc, ProjectionsOfDifferentRecords (ind1, ind2))) + Loc.raise ?loc (InternalizationError(ProjectionsOfDifferentRecords (ind1, ind2))) in if not regular && complete then (* "regular" is false when the field is defined @@ -1655,12 +1670,16 @@ let drop_notations_pattern looked_for genv = begin match drop_syndef top scopes head pl with | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) - | None -> raise (InternalizationError (loc,NotAConstructor head)) + | None -> Loc.raise ?loc (InternalizationError (NotAConstructor head)) end | CPatCstr (qid, Some expl_pl, pl) -> - let g = try Nametab.locate qid - with Not_found -> - raise (InternalizationError (loc,NotAConstructor qid)) in + let g = + try Nametab.locate qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + let info = Option.cata (Loc.add_loc info) info loc in + Exninfo.iraise (InternalizationError (NotAConstructor qid), info) + in if expl_pl == [] then (* Convention: (@r) deactivates all further implicit arguments and scopes *) DAst.make ?loc @@ RCPatCstr (g, List.map (in_pat false scopes) pl, []) @@ -1810,20 +1829,22 @@ let intern_ind_pattern genv ntnvars scopes pat = let no_not = try drop_notations_pattern (function (GlobRef.IndRef _ | GlobRef.ConstructRef _) -> () | _ -> raise Not_found) genv scopes pat - with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ?loc + with InternalizationError(NotAConstructor _) as exn -> + let _, info = Exninfo.capture exn in + error_bad_inductive_type ~info () in let loc = no_not.CAst.loc in match DAst.get no_not with | RCPatCstr (head, expl_pl, pl) -> - let c = (function GlobRef.IndRef ind -> ind | _ -> error_bad_inductive_type ?loc) head in + let c = (function GlobRef.IndRef ind -> ind | _ -> error_bad_inductive_type ?loc ()) head in let with_letin, pl2 = add_implicits_check_ind_length genv loc c (List.length expl_pl) pl in let idslpl = List.map (intern_pat genv ntnvars empty_alias) (expl_pl@pl2) in (with_letin, match product_of_cases_patterns empty_alias idslpl with | ids,[asubst,pl] -> (c,ids,asubst,chop_params_pattern loc c pl with_letin) - | _ -> error_bad_inductive_type ?loc) - | x -> error_bad_inductive_type ?loc + | _ -> error_bad_inductive_type ?loc ()) + | x -> error_bad_inductive_type ?loc () (**********************************************************************) (* Utilities for application *) @@ -1899,8 +1920,10 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let dl = Array.of_list dl in let n = try List.index0 Id.equal iddef lf - with Not_found -> - raise (InternalizationError (locid,UnboundFixName (false,iddef))) + with Not_found as exn -> + let _, info = Exninfo.capture exn in + let info = Option.cata (Loc.add_loc info) info locid in + Exninfo.iraise (InternalizationError (UnboundFixName (false,iddef)),info) in let env = restart_lambda_binders env in let idl_temp = Array.map @@ -1942,8 +1965,10 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let dl = Array.of_list dl in let n = try List.index0 Id.equal iddef lf - with Not_found -> - raise (InternalizationError (locid,UnboundFixName (true,iddef))) + with Not_found as exn -> + let _, info = Exninfo.capture exn in + let info = Option.cata (Loc.add_loc info) info locid in + Exninfo.iraise (InternalizationError (UnboundFixName (true,iddef)), info) in let env = restart_lambda_binders env in let idl_tmp = Array.map @@ -2171,7 +2196,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = DAst.make ?loc @@ GEvar (n, List.map (on_snd (intern_no_implicit env)) l) | CPatVar _ -> - raise (InternalizationError (loc,IllegalMetavariable)) + Loc.raise ?loc (InternalizationError IllegalMetavariable) (* end *) | CSort s -> DAst.make ?loc @@ @@ -2337,12 +2362,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (intern_no_implicit enva a) :: (intern_args env subscopes args) in - try - intern env c - with - InternalizationError (loc,e) -> - user_err ?loc ~hdr:"internalize" - (explain_internalization_error e) + intern env c (**************************************************************************) (* Functions to translate constr_expr into glob_constr *) @@ -2382,12 +2402,7 @@ let intern_gen kind env sigma let intern_constr env sigma c = intern_gen WithoutTypeConstraint env sigma c let intern_type env sigma c = intern_gen IsType env sigma c let intern_pattern globalenv patt = - try - intern_cases_pattern globalenv Id.Map.empty (None,[]) empty_alias patt - with - InternalizationError (loc,e) -> - user_err ?loc ~hdr:"internalize" (explain_internalization_error e) - + intern_cases_pattern globalenv Id.Map.empty (None,[]) empty_alias patt (*********************************************************************) (* Functions to parse and interpret constructions *) @@ -2500,7 +2515,6 @@ let my_intern_constr env lvar acc c = internalize env acc false lvar c let intern_context env impl_env binders = - try let lvar = (empty_ltac_sign, Id.Map.empty) in let ids = (* We assume all ids around are parts of the prefix of the current @@ -2514,8 +2528,6 @@ let intern_context env impl_env binders = tmp_scope = None; scopes = []; impls = impl_env; binder_block_names = Some (Some AbsPi,ids)}, []) binders in (lenv.impls, List.map glob_local_binder_of_extended bl) - with InternalizationError (loc,e) -> - user_err ?loc ~hdr:"internalize" (explain_internalization_error e) let interp_glob_context_evars ?(program_mode=false) env sigma k bl = let open EConstr in diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 14e5a81308..be1e3f05d2 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -49,3 +49,4 @@ val type_of_global_ref : Names.GlobRef.t -> string (** Registration of constant information *) val add_constant_kind : Names.Constant.t -> Decls.logical_kind -> unit +val constant_kind : Names.Constant.t -> Decls.logical_kind diff --git a/interp/modintern.ml b/interp/modintern.ml index ae152e1c1c..50f90ebea7 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -22,14 +22,15 @@ exception ModuleInternalizationError of module_internalization_error type module_kind = Module | ModType | ModAny -let error_not_a_module_loc kind loc qid = +let error_not_a_module_loc ~info kind loc qid = let s = string_of_qualid qid in let e = match kind with | Module -> Modops.ModuleTypingError (Modops.NotAModule s) | ModType -> Modops.ModuleTypingError (Modops.NotAModuleType s) | ModAny -> ModuleInternalizationError (NotAModuleNorModtype s) in - Loc.raise ?loc e + let info = Option.cata (Loc.add_loc info) info loc in + Exninfo.iraise (e,info) let error_application_to_not_path loc me = Loc.raise ?loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me)) @@ -57,7 +58,9 @@ let lookup_module_or_modtype kind qid = if kind == Module then raise Not_found; let mp = Nametab.locate_modtype qid in Dumpglob.dump_modref ?loc mp "mod"; (mp,ModType) - with Not_found -> error_not_a_module_loc kind loc qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + error_not_a_module_loc ~info kind loc qid let lookup_module lqid = fst (lookup_module_or_modtype Module lqid) diff --git a/interp/notation.ml b/interp/notation.ml index 3f13476355..d4a44d9622 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -125,13 +125,14 @@ let declare_scope scope = with Not_found -> scope_map := String.Map.add scope empty_scope !scope_map -let error_unknown_scope sc = - user_err ~hdr:"Notation" +let error_unknown_scope ~info sc = + user_err ~hdr:"Notation" ~info (str "Scope " ++ str sc ++ str " is not declared.") let find_scope ?(tolerant=false) scope = try String.Map.find scope !scope_map - with Not_found -> + with Not_found as exn -> + let _, info = Exninfo.capture exn in if tolerant then (* tolerant mode to be turn off after deprecation phase *) begin @@ -140,7 +141,7 @@ let find_scope ?(tolerant=false) scope = empty_scope end else - error_unknown_scope scope + error_unknown_scope ~info scope let check_scope ?(tolerant=false) scope = let _ = find_scope ~tolerant scope in () @@ -158,7 +159,9 @@ let normalize_scope sc = try let sc = String.Map.find sc !delimiters_map in let _ = String.Map.find sc !scope_map in sc - with Not_found -> error_unknown_scope sc + with Not_found as exn -> + let _, info = Exninfo.capture exn in + error_unknown_scope ~info sc (**********************************************************************) (* The global stack of scopes *) @@ -257,8 +260,10 @@ let remove_delimiters scope = try let _ = ignore (String.Map.find key !delimiters_map) in delimiters_map := String.Map.remove key !delimiters_map - with Not_found -> - assert false (* A delimiter for scope [scope] should exist *) + with Not_found as exn -> + let _, info = Exninfo.capture exn in + (* XXX info *) + CErrors.anomaly ~info (str "A delimiter for scope [scope] should exist") let find_delimiters_scope ?loc key = try String.Map.find key !delimiters_map @@ -1123,12 +1128,17 @@ let declare_string_interpreter ?(local=false) sc dir interp (patl,uninterp,b) = let check_required_module ?loc sc (sp,d) = try let _ = Nametab.global_of_path sp in () - with Not_found -> + with Not_found as exn -> + let _, info = Exninfo.capture exn in match d with - | [] -> user_err ?loc ~hdr:"prim_token_interpreter" - (str "Cannot interpret in " ++ str sc ++ str " because " ++ pr_path sp ++ str " could not be found in the current environment.") - | _ -> user_err ?loc ~hdr:"prim_token_interpreter" - (str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") + | [] -> + user_err ?loc ~info ~hdr:"prim_token_interpreter" + (str "Cannot interpret in " ++ str sc ++ str " because " ++ pr_path sp ++ + str " could not be found in the current environment.") + | _ -> + user_err ?loc ~info ~hdr:"prim_token_interpreter" + (str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ + str (List.last d) ++ str ".") (* Look if some notation or numeral printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) @@ -1250,8 +1260,9 @@ let interp_prim_token_gen ?loc g p local_scopes = try let (pat,loc), sc = find_interpretation p_as_ntn (find_prim_token ?loc g p) scopes in pat, (loc,sc) - with Not_found -> - user_err ?loc ~hdr:"interp_prim_token" + with Not_found as exn -> + let _, info = Exninfo.capture exn in + user_err ?loc ~info ~hdr:"interp_prim_token" ((match p with | Numeral _ -> str "No interpretation for numeral " ++ pr_notation (notation_of_prim_token p) @@ -1284,9 +1295,10 @@ let interp_notation ?loc ntn local_scopes = let (n,sc) = find_interpretation ntn (find_notation ntn) scopes in Option.iter (fun d -> warn_deprecated_notation ?loc (ntn,d)) n.not_deprecation; n.not_interp, (n.not_location, sc) - with Not_found -> - user_err ?loc - (str "Unknown interpretation for notation " ++ pr_notation ntn ++ str ".") + with Not_found as exn -> + let _, info = Exninfo.capture exn in + user_err ?loc ~info + (str "Unknown interpretation for notation " ++ pr_notation ntn ++ str ".") let uninterp_notations c = List.map_append (fun key -> keymap_find key !notations_key_table) diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 03977fcb4e..33d8aa6064 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -56,11 +56,15 @@ let global_inductive_with_alias qid = | ref -> user_err ?loc:qid.CAst.loc ~hdr:"global_inductive" (pr_qualid qid ++ spc () ++ str "is not an inductive type.") - with Not_found -> Nametab.error_global_not_found qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid let global_with_alias ?head qid = try locate_global_with_alias ?head qid - with Not_found -> Nametab.error_global_not_found qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid let smart_global ?(head = false) = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function | AN r -> diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 050f986367..b3a4bd7471 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -874,8 +874,11 @@ let compile ~fail_on_error ?universes:(universes=0) env c = (if !dump_bytecode then Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ; Some (init_code,!fun_code, Array.of_list fv) - with TooLargeInductive msg -> - let fn = if fail_on_error then CErrors.user_err ?loc:None ~hdr:"compile" else + with TooLargeInductive msg as exn -> + let _, info = Exninfo.capture exn in + let fn = if fail_on_error then + CErrors.user_err ?loc:None ~info ~hdr:"compile" + else (fun x -> Feedback.msg_warning x) in fn msg; None diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 62d465c703..cb64e36755 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -25,12 +25,17 @@ let _ = in Printexc.register_printer pr -let anomaly ?loc ?label pp = - Loc.raise ?loc (Anomaly (label, pp)) +let anomaly ?loc ?info ?label pp = + let info = Option.default Exninfo.null info in + let info = Option.cata (Loc.add_loc info) info loc in + Exninfo.iraise (Anomaly (label, pp), info) exception UserError of string option * Pp.t (* User errors *) -let user_err ?loc ?hdr strm = Loc.raise ?loc (UserError (hdr, strm)) +let user_err ?loc ?info ?hdr strm = + let info = Option.default Exninfo.null info in + let info = Option.cata (Loc.add_loc info) info loc in + Exninfo.iraise (UserError (hdr, strm), info) exception Timeout diff --git a/lib/cErrors.mli b/lib/cErrors.mli index 21d41c996d..cf1857cf04 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -21,7 +21,7 @@ val push : exn -> Exninfo.iexn [Anomaly] is used for system errors and [UserError] for the user's ones. *) -val anomaly : ?loc:Loc.t -> ?label:string -> Pp.t -> 'a +val anomaly : ?loc:Loc.t -> ?info:Exninfo.info -> ?label:string -> Pp.t -> 'a (** Raise an anomaly, with an optional location and an optional label identifying the anomaly. *) @@ -34,7 +34,7 @@ exception UserError of string option * Pp.t (** Main error signaling exception. It carries a header plus a pretty printing doc *) -val user_err : ?loc:Loc.t -> ?hdr:string -> Pp.t -> 'a +val user_err : ?loc:Loc.t -> ?info:Exninfo.info -> ?hdr:string -> Pp.t -> 'a (** Main error raising primitive. [user_err ?loc ?hdr pp] signals an error [pp] with optional header and location [hdr] [loc] *) diff --git a/library/nametab.ml b/library/nametab.ml index d9b4dc9122..a51c281f2b 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -43,8 +43,9 @@ end exception GlobalizationError of qualid -let error_global_not_found qid = - Loc.raise ?loc:qid.CAst.loc (GlobalizationError qid) +let error_global_not_found ~info qid = + let info = Option.cata (Loc.add_loc info) info qid.CAst.loc in + Exninfo.iraise (GlobalizationError qid, info) (* The visibility can be registered either - for all suffixes not shorter then a given int - when the object @@ -499,8 +500,9 @@ let global qid = user_err ?loc:qid.CAst.loc ~hdr:"global" (str "Unexpected reference to a notation: " ++ pr_qualid qid) - with Not_found -> - error_global_not_found qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + error_global_not_found ~info qid (* Exists functions ********************************************************) @@ -566,8 +568,10 @@ let shortest_qualid_of_universe ?loc kn = let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) - with Not_found as e -> - if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); raise e + with Not_found as exn -> + let exn, info = Exninfo.capture exn in + if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); + Exninfo.iraise (exn, info) let global_inductive qid = let open GlobRef in diff --git a/library/nametab.mli b/library/nametab.mli index 00cec35506..8a8b59733c 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -91,7 +91,7 @@ end exception GlobalizationError of qualid (** Raises a globalization error *) -val error_global_not_found : qualid -> 'a +val error_global_not_found : info:Exninfo.info -> qualid -> 'a (** {6 Register visibility of things } *) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index f09b35a6d1..e5665c59b8 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -40,7 +40,7 @@ let start_deriving f suchthat name : Lemmas.t = TNil sigma)))))) in - let info = Lemmas.Info.make ~proof_ending:(Lemmas.Proof_ending.(End_derive {f; name})) ~kind () in + let info = Lemmas.Info.make ~proof_ending:(Declare.Proof_ending.(End_derive {f; name})) ~kind () in let lemma = Lemmas.start_dependent_lemma ~name ~poly ~info goals in Lemmas.pf_map (Declare.Proof.map_proof begin fun p -> Util.pi1 @@ Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index f7d78551d8..a0627dbe63 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -581,7 +581,7 @@ let rec locate_ref = function with Nametab.GlobalizationError _ | UserError _ -> None in match mpo, ro with - | None, None -> Nametab.error_global_not_found qid + | None, None -> Nametab.error_global_not_found ~info:Exninfo.null qid | None, Some r -> let refs,mps = locate_ref l in r::refs,mps | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps | Some mp, Some r -> diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 68e1087b74..a1094e39a4 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -18,6 +18,7 @@ open Indfun_common open Indfun open Stdarg open Tacarg +open Extraargs open Tactypes open Pcoq.Prim open Pcoq.Constr @@ -96,14 +97,12 @@ let functional_induction b c x pat = } TACTIC EXTEND newfunind -| ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - { - let c = match cl with - | [] -> assert false - | [c] -> c - | c::cl -> EConstr.applist(c,cl) - in - Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl } +| ["functional" "induction" lconstr(c) fun_ind_using(princl) with_names(pat)] -> + { + (Extratactics.onSomeWithHoles + (fun x -> functional_induction true c x pat) princl) + } + END (***** debug only ***) TACTIC EXTEND snewfunind diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 53dc518bd3..bcfdb5318e 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -97,13 +97,19 @@ let intern_global_reference ist qid = else if qualid_is_ident qid && find_hyp (qualid_basename qid) ist then let id = qualid_basename qid in ArgArg (qid.CAst.loc, GlobRef.VarRef id) - else match locate_global_with_alias ~head:true qid with - | r -> ArgArg (qid.CAst.loc, r) - | exception Not_found -> - if not !strict_check && qualid_is_ident qid then - let id = qualid_basename qid in - ArgArg (qid.CAst.loc, GlobRef.VarRef id) - else Nametab.error_global_not_found qid + else + let r = + try locate_global_with_alias ~head:true qid + with + | Not_found as exn -> + if not !strict_check && qualid_is_ident qid then + let id = qualid_basename qid in + GlobRef.VarRef id + else + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid + in + ArgArg (qid.CAst.loc, r) let intern_ltac_variable ist qid = if qualid_is_ident qid && find_var (qualid_basename qid) ist then @@ -148,9 +154,10 @@ let intern_isolated_tactic_reference strict ist qid = with Not_found -> (* Tolerance for compatibility, allow not to use "constr:" *) try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist qid)) - with Not_found -> - (* Reference not found *) - Nametab.error_global_not_found qid + with Not_found as exn -> + (* Reference not found *) + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid (* Internalize an applied tactic reference *) @@ -167,9 +174,10 @@ let intern_applied_tactic_reference ist qid = with Not_found -> (* A global tactic *) try intern_applied_global_tactic_reference qid - with Not_found -> - (* Reference not found *) - Nametab.error_global_not_found qid + with Not_found as exn -> + (* Reference not found *) + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid (* Intern a reference parsed in a non-tactic entry *) @@ -182,7 +190,7 @@ let intern_non_tactic_reference strict ist qid = with Not_found -> (* Tolerance for compatibility, allow not to use "ltac:" *) try intern_isolated_global_tactic_reference qid - with Not_found -> + with Not_found as exn -> (* By convention, use IntroIdentifier for unbound ident, when not in a def *) if qualid_is_ident qid && not strict then let id = qualid_basename qid in @@ -190,7 +198,8 @@ let intern_non_tactic_reference strict ist qid = TacGeneric ipat else (* Reference not found *) - Nametab.error_global_not_found qid + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid let intern_message_token ist = function | (MsgString _ | MsgInt _ as x) -> x diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 5abe18e00c..97f7a198e6 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -378,7 +378,9 @@ let interp_reference ist env sigma = function with Not_found -> try GlobRef.VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> Nametab.error_global_not_found (qualid_of_ident ?loc id) + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info (qualid_of_ident ?loc id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in @@ -391,17 +393,21 @@ let interp_evaluable ist env sigma = function (* Maybe [id] has been introduced by Intro-like tactics *) begin try try_interp_evaluable env (loc, id) - with Not_found -> + with Not_found as exn -> match r with | EvalConstRef _ -> r - | _ -> Nametab.error_global_not_found (qualid_of_ident ?loc id) + | _ -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info (qualid_of_ident ?loc id) end | ArgArg (r,None) -> r | ArgVar {loc;v=id} -> try try_interp_ltac_var (coerce_to_evaluable_ref env sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> try try_interp_evaluable env (loc, id) - with Not_found -> Nametab.error_global_not_found (qualid_of_ident ?loc id) + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info (qualid_of_ident ?loc id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = @@ -663,8 +669,9 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = let c = coerce_to_closed_constr env x in Inr (pattern_of_constr env sigma (EConstr.to_constr sigma c)) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (make ?loc id) - with Not_found -> - Nametab.error_global_not_found (qualid_of_ident ?loc id)) + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info (qualid_of_ident ?loc id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 9051bbb5ca..3360a9a51c 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -93,9 +93,9 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct there is a pending lock which could cause a deadlock. Should it be an anomaly or produce a warning ? *) - () + ignore (lseek fd pos SEEK_SET) in - ignore (lseek fd pos SEEK_SET) + () (* We make the assumption that an acquired lock can always be released *) diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 4b78e64d98..24772a8514 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -15,7 +15,6 @@ open Names module CoqConstr = Constr open CoqConstr -open Termops open Constrexpr open Constrexpr_ops open Pcoq @@ -23,8 +22,6 @@ open Pcoq.Prim open Pcoq.Constr open Pvernac.Vernac_ open Ltac_plugin -open Notation_ops -open Notation_term open Glob_term open Stdarg open Pp @@ -32,10 +29,8 @@ open Ppconstr open Printer open Util open Extraargs -open Evar_kinds open Ssrprinters open Ssrcommon -open Ssrparser } @@ -129,7 +124,7 @@ GRAMMAR EXTEND Gram ] ]; END -(** Vernacular commands: Prenex Implicits and Search *)(***********************) +(** Vernacular commands: Prenex Implicits *) (* This should really be implemented as an extension to the implicit *) (* arguments feature, but unfortuately that API is sealed. The current *) @@ -187,298 +182,6 @@ GRAMMAR EXTEND Gram ; END -(** Extend Search to subsume SearchAbout, also adding hidden Type coercions. *) - -(* Main prefilter *) - -{ - -type raw_glob_search_about_item = - | RGlobSearchSubPattern of constr_expr - | RGlobSearchString of Loc.t * string * string option - -let pr_search_item env sigma = function - | RGlobSearchString (_,s,_) -> str s - | RGlobSearchSubPattern p -> pr_constr_expr env sigma p - -let wit_ssr_searchitem = add_genarg "ssr_searchitem" pr_search_item - -let pr_ssr_search_item env sigma _ _ _ = pr_search_item env sigma - -(* Workaround the notation API that can only print notations *) - -let is_ident s = try CLexer.check_ident s; true with _ -> false - -let is_ident_part s = is_ident ("H" ^ s) - -let interp_search_notation ?loc tag okey = - let err msg = CErrors.user_err ?loc ~hdr:"interp_search_notation" msg in - let mk_pntn s for_key = - let n = String.length s in - let s' = Bytes.make (n + 2) ' ' in - let rec loop i i' = - if i >= n then s', i' - 2 else if s.[i] = ' ' then loop (i + 1) i' else - let j = try String.index_from s (i + 1) ' ' with _ -> n in - let m = j - i in - if s.[i] = '\'' && i < j - 2 && s.[j - 1] = '\'' then - (String.blit s (i + 1) s' i' (m - 2); loop (j + 1) (i' + m - 1)) - else if for_key && is_ident (String.sub s i m) then - (Bytes.set s' i' '_'; loop (j + 1) (i' + 2)) - else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in - loop 0 1 in - let trim_ntn (pntn, m) = (InConstrEntrySomeLevel,Bytes.sub_string pntn 1 (max 0 m)) in - let pr_ntn ntn = str "(" ++ Notation.pr_notation ntn ++ str ")" in - let pr_and_list pr = function - | [x] -> pr x - | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x - | [] -> mt () in - let pr_sc sc = str (if sc = "" then "independently" else sc) in - let pr_scs = function - | [""] -> pr_sc "" - | scs -> str "in " ++ pr_and_list pr_sc scs in - let generator, pr_tag_sc = - let ign _ = mt () in match okey with - | Some key -> - let sc = Notation.find_delimiters_scope ?loc key in - let pr_sc s_in = str s_in ++ spc() ++ str sc ++ pr_comma() in - Notation.pr_scope ign sc, pr_sc - | None -> Notation.pr_scopes ign, ign in - let qtag s_in = pr_tag_sc s_in ++ qstring tag ++ spc()in - let ptag, ttag = - let ptag, m = mk_pntn tag false in - if m <= 0 then err (str "empty notation fragment"); - ptag, trim_ntn (ptag, m) in - let last = ref "" and last_sc = ref "" in - let scs = ref [] and ntns = ref [] in - let push_sc sc = match !scs with - | "" :: scs' -> scs := "" :: sc :: scs' - | scs' -> scs := sc :: scs' in - let get s _ _ = match !last with - | "Scope " -> last_sc := s; last := "" - | "Lonely notation" -> last_sc := ""; last := "" - | "\"" -> - let pntn, m = mk_pntn s true in - if String.string_contains ~where:(Bytes.to_string pntn) ~what:(Bytes.to_string ptag) then begin - let ntn = trim_ntn (pntn, m) in - match !ntns with - | [] -> ntns := [ntn]; scs := [!last_sc] - | ntn' :: _ when ntn' = ntn -> push_sc !last_sc - | _ when ntn = ttag -> ntns := ntn :: !ntns; scs := [!last_sc] - | _ :: ntns' when List.mem ntn ntns' -> () - | ntn' :: ntns' -> ntns := ntn' :: ntn :: ntns' - end; - last := "" - | _ -> last := s in - pp_with (Format.make_formatter get (fun _ -> ())) generator; - let ntn = match !ntns with - | [] -> - err (hov 0 (qtag "in" ++ str "does not occur in any notation")) - | ntn :: ntns' when ntn = ttag -> - if ntns' <> [] then begin - let pr_ntns' = pr_and_list pr_ntn ntns' in - Feedback.msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) - end; ntn - | [ntn] -> - Feedback.msg_notice (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn - | ntns' -> - let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in - err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in - let (nvars, body), ((_, pat), osc) = match !scs with - | [sc] -> Notation.interp_notation ?loc ntn (None, [sc]) - | scs' -> - try Notation.interp_notation ?loc ntn (None, []) with _ -> - let e = pr_ntn ntn ++ spc() ++ str "is defined " ++ pr_scs scs' in - err (hov 4 (str "ambiguous: " ++ pr_tag_sc "in" ++ e)) in - let sc = Option.default "" osc in - let _ = - let m_sc = - if osc <> None then str "In " ++ str sc ++ pr_comma() else mt() in - let ntn_pat = trim_ntn (mk_pntn pat false) in - let rbody = glob_constr_of_notation_constr ?loc body in - let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in - let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in - Feedback.msg_notice (hov 0 m) in - if List.length !scs > 1 then - let scs' = List.remove (=) sc !scs in - let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in - Feedback.msg_warning (hov 4 w) - else if String.string_contains ~where:(snd ntn) ~what:" .. " then - err (pr_ntn ntn ++ str " is an n-ary notation"); - let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in - let rec sub () = function - | NVar x when List.mem_assoc x nvars -> DAst.make ?loc @@ GPatVar (FirstOrderPatVar x) - | c -> - glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), None, x) sub () c in - let _, npat = Patternops.pattern_of_glob_constr (sub () body) in - Search.GlobSearchSubPattern npat - -} - -ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem - PRINTED BY { pr_ssr_search_item env sigma } - | [ string(s) ] -> { RGlobSearchString (loc,s,None) } - | [ string(s) "%" preident(key) ] -> { RGlobSearchString (loc,s,Some key) } - | [ constr_pattern(p) ] -> { RGlobSearchSubPattern p } -END - -{ - -let pr_ssr_search_arg env sigma _ _ _ = - let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item env sigma p in - pr_list spc pr_item - -} - -ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list - PRINTED BY { pr_ssr_search_arg env sigma } - | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> { (false, p) :: a } - | [ ssr_search_item(p) ssr_search_arg(a) ] -> { (true, p) :: a } - | [ ] -> { [] } -END - -{ - -(* Main type conclusion pattern filter *) - -let rec splay_search_pattern na = function - | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp - | Pattern.PLetIn (_, _, _, bp) -> splay_search_pattern na bp - | Pattern.PRef hr -> hr, na - | _ -> CErrors.user_err (Pp.str "no head constant in head search pattern") - -let push_rels_assum l e = - let l = List.map (fun (n,t) -> n, EConstr.Unsafe.to_constr t) l in - push_rels_assum l e - -let coerce_search_pattern_to_sort hpat = - let env = Global.env () in - let sigma = Evd.(from_env env) in - let mkPApp fp n_imps args = - let args' = Array.append (Array.make n_imps (Pattern.PMeta None)) args in - Pattern.PApp (fp, args') in - let hr, na = splay_search_pattern 0 hpat in - let dc, ht = - let hr, _ = Typeops.type_of_global_in_context env hr (* FIXME *) in - Reductionops.splay_prod env sigma (EConstr.of_constr hr) in - let np = List.length dc in - if np < na then CErrors.user_err (Pp.str "too many arguments in head search pattern") else - let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in - let warn () = - Feedback.msg_warning (str "Listing only lemmas with conclusion matching " ++ - pr_constr_pattern_env env sigma hpat') in - if EConstr.isSort sigma ht then begin warn (); true, hpat' end else - let filter_head, coe_path = - try - let _, cp = - Coercionops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in - warn (); - true, cp - with _ -> false, [] in - let coerce hp coe_index = - let coe_ref = coe_index.Coercionops.coe_value in - try - let n_imps = Option.get (Coercionops.hide_coercion coe_ref) in - mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] - with Not_found | Option.IsNone -> - errorstrm (str "need explicit coercion " ++ pr_global coe_ref ++ spc () - ++ str "to interpret head search pattern as type") in - filter_head, List.fold_left coerce hpat' coe_path - -let interp_head_pat hpat = - let filter_head, p = coerce_search_pattern_to_sort hpat in - let rec loop c = match CoqConstr.kind c with - | Cast (c', _, _) -> loop c' - | Prod (_, _, c') -> loop c' - | LetIn (_, _, _, c') -> loop c' - | _ -> - let env = Global.env () in - let sigma = Evd.from_env env in - Constr_matching.is_matching env sigma p (EConstr.of_constr c) in - filter_head, loop - -let all_true _ = true - -let rec interp_search_about args accu = match args with -| [] -> accu -| (flag, arg) :: rem -> - fun gr env typ -> - let ans = Search.search_filter arg gr env typ in - (if flag then ans else not ans) && interp_search_about rem accu gr env typ - -let interp_search_arg arg = - let arg = List.map (fun (x,arg) -> x, match arg with - | RGlobSearchString (loc,s,key) -> - if is_ident_part s then Search.GlobSearchString s else - interp_search_notation ~loc s key - | RGlobSearchSubPattern p -> - let env = Global.env () in - let _, p = Constrintern.intern_constr_pattern env (Evd.from_env env) p in - Search.GlobSearchSubPattern p) arg - in - let hpat, a1 = match arg with - | (_, Search.GlobSearchSubPattern (Pattern.PMeta _)) :: a' -> all_true, a' - | (true, Search.GlobSearchSubPattern p) :: a' -> - let filter_head, p = interp_head_pat p in - if filter_head then p, a' else all_true, arg - | _ -> all_true, arg in - let is_string = - function (_, Search.GlobSearchString _) -> true | _ -> false in - let a2, a3 = List.partition is_string a1 in - interp_search_about (a2 @ a3) (fun gr env typ -> hpat typ) - -(* Module path postfilter *) - -let pr_modloc (b, m) = if b then str "-" ++ pr_qualid m else pr_qualid m - -let wit_ssrmodloc = add_genarg "ssrmodloc" (fun env sigma -> pr_modloc) - -let pr_ssr_modlocs _ _ _ ml = - if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml - -} - -ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY { pr_ssr_modlocs } - | [ ] -> { [] } -END - -GRAMMAR EXTEND Gram - GLOBAL: ssr_modlocs; - modloc: [[ "-"; m = global -> { true, m } | m = global -> { false, m } ]]; - ssr_modlocs: [[ "in"; ml = LIST1 modloc -> { ml } ]]; -END - -{ - -let interp_modloc mr = - let interp_mod (_, qid) = - try Nametab.full_name_module qid with Not_found -> - CErrors.user_err ?loc:qid.CAst.loc (str "No Module " ++ pr_qualid qid) in - let mr_out, mr_in = List.partition fst mr in - let interp_bmod b = function - | [] -> fun _ _ _ -> true - | rmods -> Search.module_filter (List.map interp_mod rmods, b) in - let is_in = interp_bmod false mr_in and is_out = interp_bmod true mr_out in - fun gr env typ -> is_in gr env typ && is_out gr env typ - -(* The unified, extended vernacular "Search" command *) - -let ssrdisplaysearch gr env t = - let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in - Feedback.msg_notice (hov 2 pr_res ++ fnl ()) - -} - -VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY -| [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> - { let hpat = interp_search_arg a in - let in_mod = interp_modloc mr in - let post_filter gr env typ = in_mod gr env typ && hpat gr env typ in - let display gr env typ = - if post_filter gr env typ then ssrdisplaysearch gr env typ - in - Search.generic_search None display } -END - (** View hint database and View application. *)(* ******************************) (* There are three databases of lemmas used to mediate the application *) @@ -597,6 +300,35 @@ VERNAC COMMAND EXTEND HintView CLASSIFIED AS SIDEFF Ssrview.AdaptorDb.declare k hints } END +(** Search compatibility *) + +{ + + let warn_search_moved_enabled = ref true + let warn_search_moved = CWarnings.create ~name:"ssr-search-moved" + ~category:"deprecated" ~default:CWarnings.Enabled + (fun () -> + (Pp.strbrk + "SSReflect's Search command has been moved to the \ + ssrsearch module; please Require that module if you \ + still want to use SSReflect's Search command")) + +open G_vernac +} + +GRAMMAR EXTEND Gram + GLOBAL: query_command; + + query_command: + [ [ IDENT "Search"; s = search_query; l = search_queries; "." -> + { let (sl,m) = l in + if !warn_search_moved_enabled then warn_search_moved (); + fun g -> + Vernacexpr.VernacSearch (Vernacexpr.Search (s::sl),g, m) } + ] ] +; +END + (** Keyword compatibility fixes. *) (* Coq v8.1 notation uses "by" and "of" quasi-keywords, i.e., reserved *) diff --git a/plugins/ssr/ssrvernac.mli b/plugins/ssr/ssrvernac.mli index 327a2d4660..93339313f0 100644 --- a/plugins/ssr/ssrvernac.mli +++ b/plugins/ssr/ssrvernac.mli @@ -9,3 +9,5 @@ (************************************************************************) (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) + +val warn_search_moved_enabled : bool ref diff --git a/plugins/ssrsearch/dune b/plugins/ssrsearch/dune new file mode 100644 index 0000000000..2851835eae --- /dev/null +++ b/plugins/ssrsearch/dune @@ -0,0 +1,7 @@ +(library + (name ssrsearch_plugin) + (public_name coq.plugins.ssrsearch) + (synopsis "Deprecated Search command from SSReflect") + (libraries coq.plugins.ssreflect)) + +(coq.pp (modules g_search)) diff --git a/plugins/ssrsearch/g_search.mlg b/plugins/ssrsearch/g_search.mlg new file mode 100644 index 0000000000..6d68cc13ab --- /dev/null +++ b/plugins/ssrsearch/g_search.mlg @@ -0,0 +1,325 @@ +(** Extend Search to subsume SearchAbout, also adding hidden Type coercions. *) + +(* Main prefilter *) + +{ + +module CoqConstr = Constr +open CoqConstr +open Constrexpr +open Evar_kinds +open Glob_term +open Ltac_plugin +open Notation_ops +open Notation_term +open Pcoq.Prim +open Pcoq.Constr +open Pp +open Ppconstr +open Printer +open Stdarg +open Ssreflect_plugin.Ssrprinters +open Ssreflect_plugin.Ssrcommon +open Ssreflect_plugin.Ssrparser +open Termops +open Util + +type raw_glob_search_about_item = + | RGlobSearchSubPattern of constr_expr + | RGlobSearchString of Loc.t * string * string option + +let pr_search_item env sigma = function + | RGlobSearchString (_,s,_) -> str s + | RGlobSearchSubPattern p -> pr_constr_expr env sigma p + +let wit_ssr_searchitem = add_genarg "ssr_searchitem" pr_search_item + +let pr_ssr_search_item env sigma _ _ _ = pr_search_item env sigma + +(* Workaround the notation API that can only print notations *) + +let is_ident s = try CLexer.check_ident s; true with _ -> false + +let is_ident_part s = is_ident ("H" ^ s) + +let interp_search_notation ?loc tag okey = + let err msg = CErrors.user_err ?loc ~hdr:"interp_search_notation" msg in + let mk_pntn s for_key = + let n = String.length s in + let s' = Bytes.make (n + 2) ' ' in + let rec loop i i' = + if i >= n then s', i' - 2 else if s.[i] = ' ' then loop (i + 1) i' else + let j = try String.index_from s (i + 1) ' ' with _ -> n in + let m = j - i in + if s.[i] = '\'' && i < j - 2 && s.[j - 1] = '\'' then + (String.blit s (i + 1) s' i' (m - 2); loop (j + 1) (i' + m - 1)) + else if for_key && is_ident (String.sub s i m) then + (Bytes.set s' i' '_'; loop (j + 1) (i' + 2)) + else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in + loop 0 1 in + let trim_ntn (pntn, m) = (InConstrEntrySomeLevel,Bytes.sub_string pntn 1 (max 0 m)) in + let pr_ntn ntn = str "(" ++ Notation.pr_notation ntn ++ str ")" in + let pr_and_list pr = function + | [x] -> pr x + | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x + | [] -> mt () in + let pr_sc sc = str (if sc = "" then "independently" else sc) in + let pr_scs = function + | [""] -> pr_sc "" + | scs -> str "in " ++ pr_and_list pr_sc scs in + let generator, pr_tag_sc = + let ign _ = mt () in match okey with + | Some key -> + let sc = Notation.find_delimiters_scope ?loc key in + let pr_sc s_in = str s_in ++ spc() ++ str sc ++ pr_comma() in + Notation.pr_scope ign sc, pr_sc + | None -> Notation.pr_scopes ign, ign in + let qtag s_in = pr_tag_sc s_in ++ qstring tag ++ spc()in + let ptag, ttag = + let ptag, m = mk_pntn tag false in + if m <= 0 then err (str "empty notation fragment"); + ptag, trim_ntn (ptag, m) in + let last = ref "" and last_sc = ref "" in + let scs = ref [] and ntns = ref [] in + let push_sc sc = match !scs with + | "" :: scs' -> scs := "" :: sc :: scs' + | scs' -> scs := sc :: scs' in + let get s _ _ = match !last with + | "Scope " -> last_sc := s; last := "" + | "Lonely notation" -> last_sc := ""; last := "" + | "\"" -> + let pntn, m = mk_pntn s true in + if String.string_contains ~where:(Bytes.to_string pntn) ~what:(Bytes.to_string ptag) then begin + let ntn = trim_ntn (pntn, m) in + match !ntns with + | [] -> ntns := [ntn]; scs := [!last_sc] + | ntn' :: _ when ntn' = ntn -> push_sc !last_sc + | _ when ntn = ttag -> ntns := ntn :: !ntns; scs := [!last_sc] + | _ :: ntns' when List.mem ntn ntns' -> () + | ntn' :: ntns' -> ntns := ntn' :: ntn :: ntns' + end; + last := "" + | _ -> last := s in + pp_with (Format.make_formatter get (fun _ -> ())) generator; + let ntn = match !ntns with + | [] -> + err (hov 0 (qtag "in" ++ str "does not occur in any notation")) + | ntn :: ntns' when ntn = ttag -> + if ntns' <> [] then begin + let pr_ntns' = pr_and_list pr_ntn ntns' in + Feedback.msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) + end; ntn + | [ntn] -> + Feedback.msg_notice (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn + | ntns' -> + let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in + err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in + let (nvars, body), ((_, pat), osc) = match !scs with + | [sc] -> Notation.interp_notation ?loc ntn (None, [sc]) + | scs' -> + try Notation.interp_notation ?loc ntn (None, []) with _ -> + let e = pr_ntn ntn ++ spc() ++ str "is defined " ++ pr_scs scs' in + err (hov 4 (str "ambiguous: " ++ pr_tag_sc "in" ++ e)) in + let sc = Option.default "" osc in + let _ = + let m_sc = + if osc <> None then str "In " ++ str sc ++ pr_comma() else mt() in + let ntn_pat = trim_ntn (mk_pntn pat false) in + let rbody = glob_constr_of_notation_constr ?loc body in + let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in + let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in + Feedback.msg_notice (hov 0 m) in + if List.length !scs > 1 then + let scs' = List.remove (=) sc !scs in + let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in + Feedback.msg_warning (hov 4 w) + else if String.string_contains ~where:(snd ntn) ~what:" .. " then + err (pr_ntn ntn ++ str " is an n-ary notation"); + let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in + let rec sub () = function + | NVar x when List.mem_assoc x nvars -> DAst.make ?loc @@ GPatVar (FirstOrderPatVar x) + | c -> + glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), None, x) sub () c in + let _, npat = Patternops.pattern_of_glob_constr (sub () body) in + Search.GlobSearchSubPattern (Vernacexpr.Anywhere,false,npat) + +} + +ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem + PRINTED BY { pr_ssr_search_item env sigma } + | [ string(s) ] -> { RGlobSearchString (loc,s,None) } + | [ string(s) "%" preident(key) ] -> { RGlobSearchString (loc,s,Some key) } + | [ constr_pattern(p) ] -> { RGlobSearchSubPattern p } +END + +{ + +let pr_ssr_search_arg env sigma _ _ _ = + let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item env sigma p in + pr_list spc pr_item + +} + +ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list + PRINTED BY { pr_ssr_search_arg env sigma } + | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> { (false, p) :: a } + | [ ssr_search_item(p) ssr_search_arg(a) ] -> { (true, p) :: a } + | [ ] -> { [] } +END + +{ + +(* Main type conclusion pattern filter *) + +let rec splay_search_pattern na = function + | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp + | Pattern.PLetIn (_, _, _, bp) -> splay_search_pattern na bp + | Pattern.PRef hr -> hr, na + | _ -> CErrors.user_err (Pp.str "no head constant in head search pattern") + +let push_rels_assum l e = + let l = List.map (fun (n,t) -> n, EConstr.Unsafe.to_constr t) l in + push_rels_assum l e + +let coerce_search_pattern_to_sort hpat = + let env = Global.env () in + let sigma = Evd.(from_env env) in + let mkPApp fp n_imps args = + let args' = Array.append (Array.make n_imps (Pattern.PMeta None)) args in + Pattern.PApp (fp, args') in + let hr, na = splay_search_pattern 0 hpat in + let dc, ht = + let hr, _ = Typeops.type_of_global_in_context env hr (* FIXME *) in + Reductionops.splay_prod env sigma (EConstr.of_constr hr) in + let np = List.length dc in + if np < na then CErrors.user_err (Pp.str "too many arguments in head search pattern") else + let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in + let warn () = + Feedback.msg_warning (str "Listing only lemmas with conclusion matching " ++ + pr_constr_pattern_env env sigma hpat') in + if EConstr.isSort sigma ht then begin warn (); true, hpat' end else + let filter_head, coe_path = + try + let _, cp = + Coercionops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in + warn (); + true, cp + with _ -> false, [] in + let coerce hp coe_index = + let coe_ref = coe_index.Coercionops.coe_value in + try + let n_imps = Option.get (Coercionops.hide_coercion coe_ref) in + mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] + with Not_found | Option.IsNone -> + errorstrm (str "need explicit coercion " ++ pr_global coe_ref ++ spc () + ++ str "to interpret head search pattern as type") in + filter_head, List.fold_left coerce hpat' coe_path + +let interp_head_pat hpat = + let filter_head, p = coerce_search_pattern_to_sort hpat in + let rec loop c = match CoqConstr.kind c with + | Cast (c', _, _) -> loop c' + | Prod (_, _, c') -> loop c' + | LetIn (_, _, _, c') -> loop c' + | _ -> + let env = Global.env () in + let sigma = Evd.from_env env in + Constr_matching.is_matching env sigma p (EConstr.of_constr c) in + filter_head, loop + +let all_true _ = true + +let rec interp_search_about args accu = match args with +| [] -> accu +| (flag, arg) :: rem -> + fun gr kind env typ -> + let ans = Search.search_filter arg gr kind env (Evd.from_env env) typ in + (if flag then ans else not ans) && interp_search_about rem accu gr kind env typ + +let interp_search_arg arg = + let arg = List.map (fun (x,arg) -> x, match arg with + | RGlobSearchString (loc,s,key) -> + if is_ident_part s then Search.GlobSearchString s else + interp_search_notation ~loc s key + | RGlobSearchSubPattern p -> + let env = Global.env () in + let _, p = Constrintern.intern_constr_pattern env (Evd.from_env env) p in + Search.GlobSearchSubPattern (Vernacexpr.Anywhere,false,p)) arg + in + let hpat, a1 = match arg with + | (_, Search.GlobSearchSubPattern (Vernacexpr.Anywhere,false,Pattern.PMeta _)) :: a' -> all_true, a' + | (true, Search.GlobSearchSubPattern (Vernacexpr.Anywhere,false,p)) :: a' -> + let filter_head, p = interp_head_pat p in + if filter_head then p, a' else all_true, arg + | (_, (Search.GlobSearchSubPattern (Vernacexpr.(InHyp|InConcl),_,_) + |Search.GlobSearchSubPattern (Vernacexpr.Anywhere,true,_))) :: a' -> CErrors.user_err (str "Unsupported.") + | _ -> all_true, arg in + let is_string = + function (_, Search.GlobSearchString _) -> true | _ -> false in + let a2, a3 = List.partition is_string a1 in + interp_search_about (a2 @ a3) (fun gr kind env typ -> hpat typ) + +(* Module path postfilter *) + +let pr_modloc (b, m) = if b then str "-" ++ pr_qualid m else pr_qualid m + +let wit_ssrmodloc = add_genarg "ssrmodloc" (fun env sigma -> pr_modloc) + +let pr_ssr_modlocs _ _ _ ml = + if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml + +} + +ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY { pr_ssr_modlocs } + | [ ] -> { [] } +END + +GRAMMAR EXTEND Gram + GLOBAL: ssr_modlocs; + modloc: [[ "-"; m = global -> { true, m } | m = global -> { false, m } ]]; + ssr_modlocs: [[ "in"; ml = LIST1 modloc -> { ml } ]]; +END + +{ + +let interp_modloc mr = + let interp_mod (_, qid) = + try Nametab.full_name_module qid with Not_found -> + CErrors.user_err ?loc:qid.CAst.loc (str "No Module " ++ pr_qualid qid) in + let mr_out, mr_in = List.partition fst mr in + let interp_bmod b = function + | [] -> fun _ _ _ _ _ -> true + | rmods -> Search.module_filter (List.map interp_mod rmods, b) in + let is_in = interp_bmod false mr_in and is_out = interp_bmod true mr_out in + fun gr kind env typ -> is_in gr kind env (Evd.from_env env) typ && is_out gr kind env (Evd.from_env env) typ + +(* The unified, extended vernacular "Search" command *) + +let ssrdisplaysearch gr env t = + let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in + Feedback.msg_notice (hov 2 pr_res ++ fnl ()) + +(* Remove the warning entirely when this plugin is loaded. *) +let _ = + Ssreflect_plugin.Ssrvernac.warn_search_moved_enabled := false + +let deprecated_search = + CWarnings.create + ~name:"deprecated-ssr-search" + ~category:"deprecated" + (fun () -> Pp.(str"SSReflect's Search command is deprecated.")) + +} + +VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY +| [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> + { deprecated_search (); + let hpat = interp_search_arg a in + let in_mod = interp_modloc mr in + let post_filter gr kind env typ = in_mod gr kind env typ && hpat gr kind env typ in + let display gr kind env typ = + if post_filter gr kind env typ then ssrdisplaysearch gr env typ + in + let env = Global.env () in + Search.generic_search env display } +END diff --git a/plugins/ssrsearch/ssrsearch_plugin.mlpack b/plugins/ssrsearch/ssrsearch_plugin.mlpack new file mode 100644 index 0000000000..0c32130d65 --- /dev/null +++ b/plugins/ssrsearch/ssrsearch_plugin.mlpack @@ -0,0 +1 @@ +G_search diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index f931a32bf8..d759f82d35 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -146,8 +146,9 @@ let coerce ?loc env sigma (x : EConstr.constr) (y : EConstr.constr) let rec coerce_unify env sigma x y = let x = hnf env sigma x and y = hnf env sigma y in try - (Evarconv.unify_leq_delay env sigma x y, None) - with UnableToUnify _ -> coerce' env sigma x y + Evarconv.unify_leq_delay env sigma x y, None + with + Evarconv.UnableToUnify _ -> coerce' env sigma x y and coerce' env sigma x y : evar_map * (evar_map -> EConstr.constr -> evar_map * EConstr.constr) option = let subco sigma = subset_coerce env sigma x y in let dest_prod c = @@ -165,16 +166,20 @@ let coerce ?loc env sigma (x : EConstr.constr) (y : EConstr.constr) let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in aux sigma (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co - with UnableToUnify _ -> + with UnableToUnify _ as exn -> + let _, info = Exninfo.capture exn in let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in let sigma = try unify_leq_delay env sigma eqT eqT' - with UnableToUnify _ -> raise NoSubtacCoercion + with UnableToUnify _ -> + let e, info = Exninfo.capture exn in + Exninfo.iraise (NoSubtacCoercion,info) in (* Disallow equalities on arities *) - if Reductionops.is_arity env sigma eqT then raise NoSubtacCoercion; + if Reductionops.is_arity env sigma eqT then + Exninfo.iraise (NoSubtacCoercion,info); let restargs = lift_args 1 (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) in @@ -448,7 +453,8 @@ let inh_app_fun_core ~program_mode env sigma j = try let t,p = lookup_path_to_fun_from env sigma j.uj_type in apply_coercion env sigma p j t - with Not_found | NoCoercion -> + with (Not_found | NoCoercion) as exn -> + let _, info = Exninfo.capture exn in if program_mode then try let sigma, (coercef, t, trace) = mu env sigma t in @@ -457,7 +463,7 @@ let inh_app_fun_core ~program_mode env sigma j = (sigma, res, trace) with NoSubtacCoercion | NoCoercion -> (sigma,j,IdCoe) - else raise NoCoercion + else Exninfo.iraise (NoCoercion,info) (* Try to coerce to a funclass; returns [j] if no coercion is applicable *) let inh_app_fun ~program_mode resolve_tc env sigma j = @@ -523,7 +529,9 @@ let inh_coerce_to_fail flags env sigma rigidonly v t c1 = with Not_found -> raise NoCoercion in try (unify_leq_delay ~flags env sigma t' c1, v', trace) - with UnableToUnify _ -> raise NoCoercion + with Evarconv.UnableToUnify _ as exn -> + let _, info = Exninfo.capture exn in + Exninfo.iraise (NoCoercion,info) let default_flags_of env = default_flags_of TransparentState.full @@ -532,7 +540,8 @@ let rec inh_conv_coerce_to_fail ?loc env sigma ?(flags=default_flags_of env) rig try (unify_leq_delay ~flags env sigma t c1, v, IdCoe) with UnableToUnify (best_failed_sigma,e) -> try inh_coerce_to_fail flags env sigma rigidonly v t c1 - with NoCoercion -> + with NoCoercion as exn -> + let _, info = Exninfo.capture exn in match EConstr.kind sigma (whd_all env sigma t), EConstr.kind sigma (whd_all env sigma c1) @@ -557,7 +566,8 @@ let rec inh_conv_coerce_to_fail ?loc env sigma ?(flags=default_flags_of env) rig let (sigma,v2',trace2) = inh_conv_coerce_to_fail ?loc env1 sigma rigidonly v2 t2 u2 in let trace = ProdCoe { na=name; ty=u1; dom=trace1; body=trace2 } in (sigma, mkLambda (name, u1, v2'), trace) - | _ -> raise (NoCoercionNoUnifier (best_failed_sigma,e)) + | _ -> + Exninfo.iraise (NoCoercionNoUnifier (best_failed_sigma,e), info) (* 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 flags env sigma cj t = @@ -565,26 +575,30 @@ let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env sig try let (sigma, val', trace) = inh_conv_coerce_to_fail ?loc env sigma ~flags rigidonly cj.uj_val cj.uj_type t in (sigma, val', Some trace) - with NoCoercionNoUnifier (best_failed_sigma,e) -> + with NoCoercionNoUnifier (best_failed_sigma,e) as exn -> + let _, info = Exninfo.capture exn in try if program_mode then let (sigma, val') = coerce_itf ?loc env sigma cj.uj_val cj.uj_type t in (sigma, val', None) - else raise NoSubtacCoercion + else Exninfo.iraise (NoSubtacCoercion,info) with - | NoSubtacCoercion when not resolve_tc || not (get_use_typeclasses_for_conversion ()) -> - error_actual_type ?loc env best_failed_sigma cj t e - | NoSubtacCoercion -> + | NoSubtacCoercion as exn when not resolve_tc || not (get_use_typeclasses_for_conversion ()) -> + let _, info = Exninfo.capture exn in + error_actual_type ?loc ~info env best_failed_sigma cj t e + | NoSubtacCoercion as exn -> + let _, info = Exninfo.capture exn in let sigma' = saturate_evd env sigma in try if sigma' == sigma then - error_actual_type ?loc env best_failed_sigma cj t e + error_actual_type ?loc ~info env best_failed_sigma cj t e else let sigma = sigma' in let (sigma, val', trace) = inh_conv_coerce_to_fail ?loc env sigma rigidonly cj.uj_val cj.uj_type t in (sigma, val', Some trace) - with NoCoercionNoUnifier (_sigma,_error) -> - error_actual_type ?loc env best_failed_sigma cj t e + with NoCoercionNoUnifier (_sigma,_error) as exn -> + let _, info = Exninfo.capture exn in + error_actual_type ?loc ~info env best_failed_sigma cj t e in (sigma,{ uj_val = val'; uj_type = t },otrace) diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 6994a7b78f..414663c826 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -69,15 +69,17 @@ let precatchable_exception = function | Nametab.GlobalizationError _ -> true | _ -> false -let raise_pretype_error ?loc (env,sigma,te) = - Loc.raise ?loc (PretypeError(env,sigma,te)) +let raise_pretype_error ?loc ?info (env,sigma,te) = + let info = Option.default Exninfo.null info in + let info = Option.cata (Loc.add_loc info) info loc in + Exninfo.iraise (PretypeError(env,sigma,te),info) let raise_type_error ?loc (env,sigma,te) = Loc.raise ?loc (PretypeError(env,sigma,TypingError te)) -let error_actual_type ?loc env sigma {uj_val=c;uj_type=actty} expty reason = +let error_actual_type ?loc ?info env sigma {uj_val=c;uj_type=actty} expty reason = let j = {uj_val=c;uj_type=actty} in - raise_pretype_error ?loc + raise_pretype_error ?loc ?info (env, sigma, ActualTypeNotCoercible (j, expty, reason)) let error_actual_type_core ?loc env sigma {uj_val=c;uj_type=actty} expty = diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 7086584642..70f218d617 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -75,7 +75,7 @@ val precatchable_exception : exn -> bool (** Raising errors *) val error_actual_type : - ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> + ?loc:Loc.t -> ?info:Exninfo.info -> env -> Evd.evar_map -> unsafe_judgment -> constr -> unification_error -> 'b val error_actual_type_core : diff --git a/printing/printer.ml b/printing/printer.ml index c2f73715f0..2ad9e268c2 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -905,7 +905,7 @@ let pr_assumptionset env sigma s = let pr_axiom env ax typ = match ax with | Constant kn -> - safe_pr_constant env kn ++ safe_pr_ltype env sigma typ + hov 1 (safe_pr_constant env kn ++ cut() ++ safe_pr_ltype env sigma typ) | Positive m -> hov 2 (safe_pr_inductive env m ++ spc () ++ strbrk"is assumed to be positive.") | Guarded gr -> @@ -917,17 +917,17 @@ let pr_assumptionset env sigma s = let (v, a, o, tr) = accu in match t with | Variable id -> - let var = pr_id id ++ str " : " ++ pr_ltype_env env sigma typ in + let var = pr_id id ++ spc() ++ str ": " ++ pr_ltype_env env sigma typ in (var :: v, a, o, tr) | Axiom (axiom, []) -> let ax = pr_axiom env axiom typ in (v, ax :: a, o, tr) | Axiom (axiom,l) -> let ax = pr_axiom env axiom typ ++ - cut() ++ + spc() ++ prlist_with_sep cut (fun (lbl, ctx, ty) -> - str " used in " ++ Label.print lbl ++ - str " to prove:" ++ safe_pr_ltype_relctx (ctx,ty)) + str "used in " ++ Label.print lbl ++ + str " to prove" ++ fnl() ++ safe_pr_ltype_relctx (ctx,ty)) l in (v, ax :: a, o, tr) | Opaque kn -> diff --git a/stm/stm.ml b/stm/stm.ml index b296f8f08f..04f08e488b 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -202,7 +202,7 @@ let mkTransCmd cast cids ceff cqueue = (* Parts of the system state that are morally part of the proof state *) let summary_pstate = Evarutil.meta_counter_summary_tag, Evd.evar_counter_summary_tag, - DeclareObl.program_tcc_summary_tag + Declare.Obls.State.prg_tag type cached_state = | EmptyState @@ -878,7 +878,7 @@ end = struct (* {{{ *) Vernacstate.LemmaStack.t option * int * (* Evarutil.meta_counter_summary_tag *) int * (* Evd.evar_counter_summary_tag *) - DeclareObl.ProgramDecl.t CEphemeron.key Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) + Declare.Obls.State.t type partial_state = [ `Full of Vernacstate.t @@ -1684,7 +1684,9 @@ end = struct (* {{{ *) (* STATE We use the state resulting from reaching start. *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_qed_delay_proof ~id:stop ~st ~proof ~info ~loc ~control:[] (Proved (opaque,None))); - `OK proof + (* Is this name the same than the one in scope? *) + let name = Declare.get_po_name proof in + `OK name end with e -> let (e, info) = Exninfo.capture e in @@ -1723,7 +1725,7 @@ end = struct (* {{{ *) | `ERROR -> exit 1 | `ERROR_ADMITTED -> cst, false | `OK_ADMITTED -> cst, false - | `OK { Declare.name } -> + | `OK name -> let con = Nametab.locate_constant (Libnames.qualid_of_ident name) in let c = Global.lookup_constant con in let o = match c.Declarations.const_body with @@ -3308,7 +3310,7 @@ let unreachable_state_hook = Hooks.unreachable_state_hook let document_add_hook = Hooks.document_add_hook let document_edit_hook = Hooks.document_edit_hook let sentence_exec_hook = Hooks.sentence_exec_hook -let () = Hook.set DeclareObl.stm_get_fix_exn (fun () -> !State.fix_exn_ref) +let () = Declare.Obls.stm_get_fix_exn := (fun () -> !State.fix_exn_ref) type document = VCS.vcs let backup () = VCS.backup () diff --git a/tactics/declareScheme.ml b/tactics/declareScheme.ml index 84fa1ee508..f7fe595df5 100644 --- a/tactics/declareScheme.ml +++ b/tactics/declareScheme.ml @@ -40,3 +40,5 @@ let declare_scheme kind indcl = Lib.add_anonymous_leaf (inScheme (kind,indcl)) let lookup_scheme kind ind = CString.Map.find kind (Indmap.find ind !scheme_map) + +let all_schemes () = Indmap.domain !scheme_map diff --git a/tactics/declareScheme.mli b/tactics/declareScheme.mli index 5a771009bd..d10cb4ef15 100644 --- a/tactics/declareScheme.mli +++ b/tactics/declareScheme.mli @@ -10,3 +10,4 @@ val declare_scheme : string -> (Names.inductive * Names.Constant.t) array -> unit val lookup_scheme : string -> Names.inductive -> Names.Constant.t +val all_schemes : unit -> Names.Indset.t diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache.test-suite Binary files differindex 046cb067c5..046cb067c5 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache.test-suite diff --git a/test-suite/Makefile b/test-suite/Makefile index dece21885c..5dd4f42af3 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -117,10 +117,11 @@ VSUBSYSTEMS := prerequisite success failure $(BUGS) output output-coqtop \ # All subsystems SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools $(UNIT_TESTS) -PREREQUISITELOG = prerequisite/admit.v.log \ - prerequisite/make_local.v.log prerequisite/make_notation.v.log \ - prerequisite/bind_univs.v.log prerequisite/module_bug8416.v.log \ - prerequisite/module_bug7192.v.log +.csdp.cache: .csdp.cache.test-suite + cp $< $@ + chmod u+w $@ + +PREREQUISITELOG = $(addsuffix .log,$(wildcard prerequisite/*.v)) .csdp.cache ####################################################################### # Phony targets @@ -284,8 +285,8 @@ OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) # ML files from unit-test framework, not containing tests -UNIT_SRCFILES:=$(shell find ./unit-tests/src -name *.ml) -UNIT_ALLMLFILES:=$(shell find ./unit-tests -name *.ml) +UNIT_SRCFILES:=$(shell find ./unit-tests/src -name '*.ml') +UNIT_ALLMLFILES:=$(shell find ./unit-tests -name '*.ml') UNIT_MLFILES:=$(filter-out $(UNIT_SRCFILES),$(UNIT_ALLMLFILES)) UNIT_LOGFILES:=$(patsubst %.ml,%.ml.log,$(UNIT_MLFILES)) @@ -315,11 +316,6 @@ unit-tests/%.ml.log: unit-tests/%.ml unit-tests/src/$(UNIT_LINK) $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq.toplevel,oUnit \ -I unit-tests/src $(UNIT_LINK) $< -o $<.test; $(HIDE)./$<.test -unit-tests/ide/%.ml.log: unit-tests/ide/%.ml unit-tests/src/$(UNIT_LINK) - $(SHOW) 'TEST $<' - $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq.ide,oUnit \ - -I unit-tests/src $(UNIT_LINK) $< -o $<.test; - $(HIDE)./$<.test ####################################################################### # Other generic tests @@ -478,6 +474,7 @@ approve-output: output output-coqtop output/MExtraction.out: ../plugins/micromega/micromega.ml $(SHOW) GEN $@ $(HIDE) cp $< $@ + $(HIDE) chmod u+w $@ $(HIDE) echo >> $@ $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out diff --git a/test-suite/coq-makefile/template/init.sh b/test-suite/coq-makefile/template/init.sh index 30be5e6456..ab89e12592 100755 --- a/test-suite/coq-makefile/template/init.sh +++ b/test-suite/coq-makefile/template/init.sh @@ -9,10 +9,18 @@ cd _test || exit 1 mkdir -p src mkdir -p theories/sub -cp ../../template/theories/sub/testsub.v theories/sub -cp ../../template/theories/test.v theories -cp ../../template/src/test.mlg src -cp ../../template/src/test_aux.mli src -cp ../../template/src/test.mli src -cp ../../template/src/test_plugin.mlpack src -cp ../../template/src/test_aux.ml src +cp_file() { + local _TARGET=$1 + cp ../../template/$_TARGET $_TARGET + chmod u+w $_TARGET +} + +# We chmod +w as to fix the case where the sources are read-only, as +# for example when using Dune's cache. +cp_file theories/sub/testsub.v +cp_file theories/test.v +cp_file src/test.mlg +cp_file src/test_aux.mli +cp_file src/test.mli +cp_file src/test_plugin.mlpack +cp_file src/test_aux.ml diff --git a/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired index 541b307b5e..85aeab2c69 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired @@ -3,4 +3,4 @@ 0m00.47s | 394716 ko | Total Time / Peak Mem | 0m00.45s | 394392 ko || +0m00.01s || 324 ko | +4.44% | +0.08% ----------------------------------------------------------------------------------------------------------------------------- 0m00.42s | 394716 ko | Fast.vo | 0m00.02s | 57164 ko || +0m00.40s || 337552 ko | +1999.99% | +590.49% -0m00.05s | 57124 ko | Slow.vo | 0m00.43s | 394392 ko || -0m00.38s || -337268 ko | -88.37% | -85.51%
\ No newline at end of file +0m00.05s | 57124 ko | Slow.vo | 0m00.43s | 394392 ko || -0m00.38s || -337268 ko | -88.37% | -85.51% diff --git a/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired b/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired index 71e4ee0b32..ed5454b480 100644 --- a/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired +++ b/test-suite/coq-makefile/timing/per-file-after/A.v.timing.diff.desired @@ -1,9 +1,9 @@ After | Code | Before || Change | % Change ---------------------------------------------------------------------------------------------------- - 0m14.06s | Total | 0m00.72s || +0m13.34s | +1854.02% + 0m15.00s | Total | 0m00.72s || +0m14.28s | +1983.61% ---------------------------------------------------------------------------------------------------- -0m13.582s | Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] | 0m00.353s || +0m13.22s | +3747.59% -0m00.335s | Chars 069 - 162 [Definition~foo0~:=~Eval~comp~i...] | 0m00.225s || +0m00.11s | +48.88% -0m00.152s | Chars 000 - 026 [Require~Coq.ZArith.BinInt.] | 0m00.142s || +0m00.01s | +7.04% +0m14.578s | Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] | 0m00.356s || +0m14.22s | +3994.94% +0m00.284s | Chars 069 - 162 [Definition~foo0~:=~Eval~comp~i...] | 0m00.225s || +0m00.05s | +26.22% + 0m00.14s | Chars 000 - 026 [Require~Coq.ZArith.BinInt.] | 0m00.139s || +0m00.00s | +0.71% 0m00.s | Chars 027 - 068 [Declare~Reduction~comp~:=~nati...] | N/A || +0m00.00s | N/A - N/A | Chars 027 - 068 [Declare~Reduction~comp~:=~vm_c...] | 0m00.s || +0m00.00s | N/A
\ No newline at end of file + N/A | Chars 027 - 068 [Declare~Reduction~comp~:=~vm_c...] | 0m00.s || +0m00.00s | N/A diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-absolute.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-absolute.log.expected index e7d289858b..948e28fbc6 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-absolute.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-absolute.log.expected @@ -23,4 +23,4 @@ 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% - 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12%
\ No newline at end of file + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-auto.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-auto.log.expected index 36f86e0e1e..ea36822c8d 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-auto.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-auto.log.expected @@ -23,4 +23,4 @@ 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% - 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12%
\ No newline at end of file + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-diff.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-diff.log.expected index 6415223693..b6c21a3145 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-diff.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real-diff.log.expected @@ -23,4 +23,4 @@ 3m22.96s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m37.80s | 3307052 ko || -0m14.84s || -4544 ko | -6.81% | -0.13% 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09% 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% - 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27%
\ No newline at end of file + 4m16.77s | 1617000 ko | Specific/X25519/C64/ladderstep | 5m16.83s | 1621500 ko || -1m00.06s || -4500 ko | -18.95% | -0.27% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real.log.expected index 36f86e0e1e..ea36822c8d 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-real.log.expected @@ -23,4 +23,4 @@ 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% - 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12%
\ No newline at end of file + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-absolute.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-absolute.log.expected index 84d20f484a..a964c29da8 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-absolute.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-absolute.log.expected @@ -23,4 +23,4 @@ 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% - 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12%
\ No newline at end of file + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-auto.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-auto.log.expected index 7576dca88b..59af8c3145 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-auto.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-auto.log.expected @@ -23,4 +23,4 @@ 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% - 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12%
\ No newline at end of file + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-diff.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-diff.log.expected index 1173a6fe29..5ee974c9f3 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-diff.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user-diff.log.expected @@ -23,4 +23,4 @@ 3m09.62s | 3302508 ko | Specific/NISTP256/AMD64/femul | 3m22.52s | 3307052 ko || -0m12.90s || -4544 ko | -6.36% | -0.13% 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09% 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% - 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27%
\ No newline at end of file + 4m01.34s | 1617000 ko | Specific/X25519/C64/ladderstep | 4m59.49s | 1621500 ko || -0m58.15s || -4500 ko | -19.41% | -0.27% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user.log.expected index 7576dca88b..59af8c3145 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both-user.log.expected @@ -23,4 +23,4 @@ 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% - 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12%
\ No newline at end of file + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-real.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-real.log.expected index 94122d8190..317497c68a 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-real.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-real.log.expected @@ -23,4 +23,4 @@ 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework - 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline
\ No newline at end of file + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-user.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-user.log.expected index 94122d8190..317497c68a 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-user.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty-user.log.expected @@ -23,4 +23,4 @@ 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework - 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline
\ No newline at end of file + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected index 6104c78380..ee9fca7eb4 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/003-non-utf8/time-of-build-pretty.log.expected @@ -304,4 +304,4 @@ 0m00.04s | 54440 ko | bedrock2/deps/coqutil/src/dlet 0m00.04s | 54804 ko | bedrock2/deps/coqutil/src/sanity 0m00.04s | 56096 ko | bedrock2/deps/riscv-coq/src/Utility/MMIOTrace - 0m00.03s | 54716 ko | bedrock2/compiler/src/util/LogGoal
\ No newline at end of file + 0m00.03s | 54716 ko | bedrock2/compiler/src/util/LogGoal diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-real.v.timing.diff.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-real.v.timing.diff.expected index 76b0a35cb2..37f144b19b 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-real.v.timing.diff.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-real.v.timing.diff.expected @@ -26,4 +26,4 @@ 0m00.s | Chars 186-194 ~ 202-210 [exact~I.] | N/A || +0m00.00s | N/A N/A | Chars 186-198 ~ 202-214 [constructor.] | 0m00.s || +0m00.00s | N/A 0m00.s | Chars 195-199 ~ 215-219 [Qed.] | 0m00.s || +0m00.00s | N/A - 0m00.s | Chars 200-257 ~ 220-277 [Goal~_~List.repeat~Z.div_eucl~...] | 0m00.s || +0m00.00s | N/A
\ No newline at end of file + 0m00.s | Chars 200-257 ~ 220-277 [Goal~_~List.repeat~Z.div_eucl~...] | 0m00.s || +0m00.00s | N/A diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-user.v.timing.diff.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-user.v.timing.diff.expected index 1e27d5d12b..a77215b67d 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-user.v.timing.diff.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/004-per-file-fuzz/foo-user.v.timing.diff.expected @@ -26,4 +26,4 @@ 0m00.s | Chars 173-183 ~ 189-199 [Goal~_~True.] | 0m00.s || +0m00.00s | N/A 0m00.s | Chars 186-194 ~ 202-210 [exact~I.] | N/A || +0m00.00s | N/A N/A | Chars 186-198 ~ 202-214 [constructor.] | 0m00.s || +0m00.00s | N/A - 0m00.s | Chars 195-199 ~ 215-219 [Qed.] | 0m00.s || +0m00.00s | N/A
\ No newline at end of file + 0m00.s | Chars 195-199 ~ 215-219 [Qed.] | 0m00.s || +0m00.00s | N/A diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-absolute.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-absolute.log.expected index 2a2d2c1b2f..9d6231f2ce 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-absolute.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-absolute.log.expected @@ -23,4 +23,4 @@ 0m01.85s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.95s | 648632 ko || -0m00.09s || -2332 ko | -5.12% | -0.35% 0m07.33s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.40s | 578344 ko || -0m00.07s || -3956 ko | -0.94% | -0.68% 0m01.93s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.73s | 546112 ko || +0m00.19s || -1940 ko | +11.56% | -0.35% - 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12%
\ No newline at end of file + 0m01.38s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.18s | 539160 ko || +0m00.19s || 648 ko | +16.94% | +0.12% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-auto.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-auto.log.expected index 7e4cfaec1c..4864c1aaf7 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-auto.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-auto.log.expected @@ -23,4 +23,4 @@ 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% - 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00%
\ No newline at end of file + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-diff.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-diff.log.expected index 7842f91f1f..27d3a9c683 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-diff.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real-diff.log.expected @@ -23,4 +23,4 @@ 0m43.34s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m43.78s | 799668 ko || -0m00.43s || -6292 ko | -1.00% | -0.78% 0m39.72s | 825448 ko | Specific/X25519/C64/femul | 0m42.98s | 839624 ko || -0m03.25s || -14176 ko | -7.58% | -1.68% 3m01.77s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m27.94s | 1656912 ko || -0m26.16s || -67396 ko | -12.58% | -4.06% - 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09%
\ No newline at end of file + 2m35.79s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m59.21s | 1549104 ko || -0m23.42s || -94408 ko | -13.06% | -6.09% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real.log.expected index 7e4cfaec1c..4864c1aaf7 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-real.log.expected @@ -23,4 +23,4 @@ 0m27.81s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m28.91s | 756216 ko || -0m01.10s || -136 ko | -3.80% | -0.01% 0m22.81s | 766300 ko | Specific/X25519/C64/feadd | 0m23.43s | 766168 ko || -0m00.62s || 132 ko | -2.64% | +0.01% 0m11.15s | 687760 ko | Specific/X25519/C64/Synthesis | 0m11.23s | 687812 ko || -0m00.08s || -52 ko | -0.71% | -0.00% - 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00%
\ No newline at end of file + 0m31.00s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m32.08s | 765212 ko || -0m01.07s || -4 ko | -3.36% | -0.00% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-absolute.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-absolute.log.expected index ea116a804f..48e168657c 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-absolute.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-absolute.log.expected @@ -23,4 +23,4 @@ 0m01.67s | 646300 ko | Specific/Framework/SynthesisFramework | 0m01.72s | 648632 ko || -0m00.05s || -2332 ko | -2.90% | -0.35% 0m07.18s | 574388 ko | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s | 578344 ko || -0m00.04s || -3956 ko | -0.55% | -0.68% 0m01.72s | 544172 ko | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s | 546112 ko || +0m00.13s || -1940 ko | +8.86% | -0.35% - 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12%
\ No newline at end of file + 0m01.19s | 539808 ko | Compilers/Z/Bounds/Pipeline | 0m01.04s | 539160 ko || +0m00.14s || 648 ko | +14.42% | +0.12% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-auto.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-auto.log.expected index 128f140662..fc26998b8f 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-auto.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-auto.log.expected @@ -23,4 +23,4 @@ 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% - 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00%
\ No newline at end of file + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-diff.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-diff.log.expected index 79dc49892f..1fcdb84025 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-diff.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user-diff.log.expected @@ -23,4 +23,4 @@ 0m39.59s | 793376 ko | Specific/NISTP256/AMD64/fesub | 0m40.09s | 799668 ko || -0m00.50s || -6292 ko | -1.24% | -0.78% 0m36.32s | 825448 ko | Specific/X25519/C64/femul | 0m39.50s | 839624 ko || -0m03.17s || -14176 ko | -8.05% | -1.68% 2m48.52s | 1589516 ko | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s | 1656912 ko || -0m24.42s || -67396 ko | -12.66% | -4.06% - 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09%
\ No newline at end of file + 2m23.70s | 1454696 ko | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s | 1549104 ko || -0m20.41s || -94408 ko | -12.43% | -6.09% diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user.log.expected index 128f140662..fc26998b8f 100644 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user.log.expected +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/005-correct-diff-sorting-order-mem/time-of-build-both-user.log.expected @@ -23,4 +23,4 @@ 0m25.50s | 756080 ko | Specific/NISTP256/AMD64/fenz | 0m26.41s | 756216 ko || -0m00.91s || -136 ko | -3.44% | -0.01% 0m20.93s | 766300 ko | Specific/X25519/C64/feadd | 0m21.41s | 766168 ko || -0m00.48s || 132 ko | -2.24% | +0.01% 0m10.37s | 687760 ko | Specific/X25519/C64/Synthesis | 0m10.30s | 687812 ko || +0m00.06s || -52 ko | +0.67% | -0.00% - 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00%
\ No newline at end of file + 0m28.51s | 765208 ko | Specific/NISTP256/AMD64/feopp | 0m29.46s | 765212 ko || -0m00.94s || -4 ko | -3.22% | -0.00% diff --git a/test-suite/ltac2/notations.v b/test-suite/ltac2/notations.v index 3d2a875e38..32c8a7cbe7 100644 --- a/test-suite/ltac2/notations.v +++ b/test-suite/ltac2/notations.v @@ -1,6 +1,8 @@ From Ltac2 Require Import Ltac2. From Coq Require Import ZArith String List. +(** * Test cases for the notation system itself *) + Open Scope Z_scope. Check 1 + 1 : Z. @@ -22,3 +24,9 @@ Lemma maybe : list bool. Proof. refine (sl ["left" =? "right"]). Qed. + +(** * Test cases for specific notations with special contexts *) + +(** ** Test eval ... in / reduction tactics *) + +(** Moved to test-suite/output/ltac2_notations_eval_in.v so that the output can be checked s*) diff --git a/test-suite/misc/redirect_printing.out b/test-suite/misc/redirect_printing.out new file mode 100644 index 0000000000..4f45c4d4c2 --- /dev/null +++ b/test-suite/misc/redirect_printing.out @@ -0,0 +1,2 @@ +nat_ind + : forall P : nat -> Prop, P 0 -> (forall n : nat, P n -> P (S n)) -> forall n : nat, P n diff --git a/test-suite/misc/redirect_printing.sh b/test-suite/misc/redirect_printing.sh new file mode 100755 index 0000000000..7da17407f3 --- /dev/null +++ b/test-suite/misc/redirect_printing.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +$coqc misc/redirect_printing.v +diff -u redirect_test.out misc/redirect_printing.out diff --git a/test-suite/misc/redirect_printing.v b/test-suite/misc/redirect_printing.v new file mode 100644 index 0000000000..2f9096bcb8 --- /dev/null +++ b/test-suite/misc/redirect_printing.v @@ -0,0 +1,2 @@ +Set Printing Width 999999. +Redirect "redirect_test" Check nat_ind. diff --git a/test-suite/output/ImplicitTypes.out b/test-suite/output/ImplicitTypes.out index 824c260e92..42cb2309e0 100644 --- a/test-suite/output/ImplicitTypes.out +++ b/test-suite/output/ImplicitTypes.out @@ -14,6 +14,12 @@ forall b1 b2, b1 = b2 : Prop fun b => b = b : bool -> Prop +fun b c : bool => b = c + : bool -> bool -> Prop +fun c b : bool => b = c + : bool -> bool -> Prop +fun b1 b2 => b1 = b2 + : bool -> bool -> Prop fix f b (n : nat) {struct n} : bool := match n with | 0 => b diff --git a/test-suite/output/ImplicitTypes.v b/test-suite/output/ImplicitTypes.v index dbc83f9229..205c6a67bf 100644 --- a/test-suite/output/ImplicitTypes.v +++ b/test-suite/output/ImplicitTypes.v @@ -23,6 +23,9 @@ Check forall b1 b2, b1 = b2. (* Check in "fun" *) Check fun b => b = b. +Check fun b c => b = c. +Check fun c b => b = c. +Check fun b1 b2 => b1 = b2. (* Check in binders *) Check fix f b n := match n with 0 => b | S p => f b p end. diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out index 190c34262f..ca4858d7a7 100644 --- a/test-suite/output/PrintAssumptions.out +++ b/test-suite/output/PrintAssumptions.out @@ -7,17 +7,17 @@ bli : Type Axioms: bli : Type Axioms: -extensionality : forall (P Q : Type) (f g : P -> Q), - (forall x : P, f x = g x) -> f = g +extensionality + : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Axioms: -extensionality : forall (P Q : Type) (f g : P -> Q), - (forall x : P, f x = g x) -> f = g +extensionality + : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Axioms: -extensionality : forall (P Q : Type) (f g : P -> Q), - (forall x : P, f x = g x) -> f = g +extensionality + : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Axioms: -extensionality : forall (P Q : Type) (f g : P -> Q), - (forall x : P, f x = g x) -> f = g +extensionality + : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Closed under the global context Closed under the global context Axioms: diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index c01f4b2e19..317e9c3757 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -18,7 +18,6 @@ le_sind: P n -> (forall m : nat, n <= m -> P m -> P (S m)) -> forall n0 : nat, n <= n0 -> P n0 -(use "About" for full details on implicit arguments) false: bool true: bool is_true: bool -> Prop @@ -136,7 +135,6 @@ bool_choice: forall [S : Set] [R1 R2 : S -> Prop], (forall x : S, {R1 x} + {R2 x}) -> {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} -(use "About" for full details on implicit arguments) mult_n_O: forall n : nat, 0 = n * 0 plus_O_n: forall n : nat, 0 + n = n plus_n_O: forall n : nat, n = n + 0 @@ -162,7 +160,6 @@ f_equal2_mult: f_equal2_nat: forall (B : Type) (f : nat -> nat -> B) (x1 y1 x2 y2 : nat), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2 -(use "About" for full details on implicit arguments) Numeral.internal_numeral_dec_lb: forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true Numeral.internal_int_dec_lb1: @@ -216,7 +213,6 @@ bool_choice: forall [S : Set] [R1 R2 : S -> Prop], (forall x : S, {R1 x} + {R2 x}) -> {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} -(use "About" for full details on implicit arguments) Numeral.internal_numeral_dec_lb: forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true Numeral.internal_numeral_dec_bl: @@ -266,23 +262,15 @@ Hexadecimal.internal_uint_dec_lb0: 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 -(use "About" for full details on implicit arguments) andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true -(use "About" for full details on implicit arguments) h: n <> newdef n h': newdef n <> n -(use "About" for full details on implicit arguments) h: n <> newdef n h': newdef n <> n -(use "About" for full details on implicit arguments) h: n <> newdef n -(use "About" for full details on implicit arguments) h: n <> newdef n -(use "About" for full details on implicit arguments) h: n <> newdef n h': newdef n <> n -(use "About" for full details on implicit arguments) -(use "About" for full details on implicit arguments) The command has indeed failed with message: [Focus] No such goal. The command has indeed failed with message: @@ -291,14 +279,179 @@ The command has indeed failed with message: Query commands only support the single numbered goal selector. h: P n h': ~ P n -(use "About" for full details on implicit arguments) h: P n h': ~ P n -(use "About" for full details on implicit arguments) h: P n h': ~ P n -(use "About" for full details on implicit arguments) h: P n -(use "About" for full details on implicit arguments) h: P n -(use "About" for full details on implicit arguments) +a: A +b: A +or_assoc: forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C +and_assoc: forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C +eq_trans_assoc: + forall [A : Type] [x y z t : A] (e : x = y) (e' : y = z) (e'' : z = t), + eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e'' +plus_O_n: forall n : nat, 0 + n = n +plus_n_O: forall n : nat, n = n + 0 +plus_n_Sm: forall n m : nat, S (n + m) = n + S m +plus_Sn_m: forall n m : nat, S n + m = S (n + m) +mult_n_Sm: forall n m : nat, n * m + n = n * S m +f_equal2_plus: + forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 +nat_rect_plus: + forall (n m : nat) {A : Type} (f : A -> A) (x : A), + nat_rect (fun _ : nat => A) x (fun _ : nat => f) (n + m) = + nat_rect (fun _ : nat => A) + (nat_rect (fun _ : nat => A) x (fun _ : nat => f) m) + (fun _ : nat => f) n +Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat +Numeral.internal_numeral_dec_bl: + forall x y : Numeral.numeral, Numeral.numeral_beq x y = true -> x = y +Numeral.internal_int_dec_bl1: + forall x y : Numeral.int, Numeral.int_beq x y = true -> x = y +Numeral.internal_uint_dec_bl1: + forall x y : Numeral.uint, Numeral.uint_beq x y = true -> x = y +Hexadecimal.internal_hexadecimal_dec_bl: + forall x y : Hexadecimal.hexadecimal, + Hexadecimal.hexadecimal_beq x y = true -> x = y +Hexadecimal.internal_int_dec_bl0: + forall x y : Hexadecimal.int, Hexadecimal.int_beq x y = true -> x = y +Decimal.internal_decimal_dec_bl: + forall x y : Decimal.decimal, Decimal.decimal_beq x y = true -> x = y +Decimal.internal_int_dec_bl: + forall x y : Decimal.int, Decimal.int_beq x y = true -> x = y +Byte.of_bits: + bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) -> + Byte.byte +Byte.to_bits_of_bits: + forall + b : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))), + Byte.to_bits (Byte.of_bits b) = b +Numeral.internal_numeral_dec_lb: + forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true +Numeral.internal_uint_dec_lb1: + forall x y : Numeral.uint, x = y -> Numeral.uint_beq x y = true +Numeral.internal_int_dec_lb1: + forall x y : Numeral.int, x = y -> Numeral.int_beq x y = true +Decimal.internal_int_dec_lb: + forall x y : Decimal.int, x = y -> Decimal.int_beq x y = true +Hexadecimal.internal_hexadecimal_dec_lb: + forall x y : Hexadecimal.hexadecimal, + x = y -> Hexadecimal.hexadecimal_beq x y = true +Hexadecimal.internal_int_dec_lb0: + forall x y : Hexadecimal.int, x = y -> Hexadecimal.int_beq x y = true +Decimal.internal_decimal_dec_lb: + forall x y : Decimal.decimal, x = y -> Decimal.decimal_beq x y = true +Byte.to_bits: + Byte.byte -> + bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) +Hexadecimal.internal_uint_dec_bl0: + forall x : Hexadecimal.uint, + (fun x0 : Hexadecimal.uint => + forall y : Hexadecimal.uint, Hexadecimal.uint_beq x0 y = true -> x0 = y) x +Decimal.internal_uint_dec_lb: + forall x : Decimal.uint, + (fun x0 : Decimal.uint => + forall y : Decimal.uint, x0 = y -> Decimal.uint_beq x0 y = true) x +Decimal.internal_uint_dec_bl: + forall x : Decimal.uint, + (fun x0 : Decimal.uint => + forall y : Decimal.uint, Decimal.uint_beq x0 y = true -> x0 = y) x +Hexadecimal.internal_uint_dec_lb0: + forall x : Hexadecimal.uint, + (fun x0 : Hexadecimal.uint => + forall y : Hexadecimal.uint, x0 = y -> Hexadecimal.uint_beq x0 y = true) x +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 +Byte.to_bits_of_bits: + forall + b : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))), + Byte.to_bits (Byte.of_bits b) = b +bool_choice: + forall [S : Set] [R1 R2 : S -> Prop], + (forall x : S, {R1 x} + {R2 x}) -> + {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} +Nat.two: nat +Nat.zero: nat +Nat.one: nat +Nat.succ: nat -> nat +Nat.log2: nat -> nat +Nat.sqrt: nat -> nat +Nat.square: nat -> nat +Nat.double: nat -> nat +Nat.pred: nat -> nat +Nat.ldiff: nat -> nat -> nat +Nat.tail_mul: nat -> nat -> nat +Nat.land: nat -> nat -> nat +Nat.div: nat -> nat -> nat +Nat.modulo: nat -> nat -> nat +Nat.lor: nat -> nat -> nat +Nat.lxor: nat -> nat -> nat +Nat.of_hex_uint: Hexadecimal.uint -> nat +Nat.of_uint: Decimal.uint -> nat +Nat.of_num_uint: Numeral.uint -> nat +length: forall [A : Type], list A -> nat +plus_n_O: forall n : nat, n = n + 0 +plus_O_n: forall n : nat, 0 + n = n +plus_n_Sm: forall n m : nat, S (n + m) = n + S m +plus_Sn_m: forall n m : nat, S n + m = S (n + m) +mult_n_Sm: forall n m : nat, n * m + n = n * S m +Nat.land_comm: forall a b : nat, Nat.land a b = Nat.land b a +Nat.lor_comm: forall a b : nat, Nat.lor a b = Nat.lor b a +Nat.lxor_comm: forall a b : nat, Nat.lxor a b = Nat.lxor b a +Nat.lcm_comm: forall a b : nat, Nat.lcm a b = Nat.lcm b a +Nat.min_comm: forall n m : nat, Nat.min n m = Nat.min m n +Nat.gcd_comm: forall n m : nat, Nat.gcd n m = Nat.gcd m n +Bool.xorb_comm: forall b b' : bool, xorb b b' = xorb b' b +Nat.max_comm: forall n m : nat, Nat.max n m = Nat.max m n +Nat.mul_comm: forall n m : nat, n * m = m * n +Nat.add_comm: forall n m : nat, n + m = m + n +Bool.orb_comm: forall b1 b2 : bool, (b1 || b2)%bool = (b2 || b1)%bool +Bool.andb_comm: forall b1 b2 : bool, (b1 && b2)%bool = (b2 && b1)%bool +Nat.eqb_sym: forall x y : nat, (x =? y) = (y =? x) +Nat.bit0_eqb: forall a : nat, Nat.testbit a 0 = (a mod 2 =? 1) +Nat.land_ones: forall a n : nat, Nat.land a (Nat.ones n) = a mod 2 ^ n +Nat.div_exact: forall a b : nat, b <> 0 -> a = b * (a / b) <-> a mod b = 0 +Nat.testbit_spec': + forall a n : nat, Nat.b2n (Nat.testbit a n) = (a / 2 ^ n) mod 2 +Nat.pow_div_l: + forall a b c : nat, b <> 0 -> a mod b = 0 -> (a / b) ^ c = a ^ c / b ^ c +Nat.testbit_eqb: forall a n : nat, Nat.testbit a n = ((a / 2 ^ n) mod 2 =? 1) +Nat.testbit_false: + forall a n : nat, Nat.testbit a n = false <-> (a / 2 ^ n) mod 2 = 0 +Nat.testbit_true: + forall a n : nat, Nat.testbit a n = true <-> (a / 2 ^ n) mod 2 = 1 +Nat.bit0_eqb: forall a : nat, Nat.testbit a 0 = (a mod 2 =? 1) +Nat.land_ones: forall a n : nat, Nat.land a (Nat.ones n) = a mod 2 ^ n +Nat.div_exact: forall a b : nat, b <> 0 -> a = b * (a / b) <-> a mod b = 0 +Nat.testbit_spec': + forall a n : nat, Nat.b2n (Nat.testbit a n) = (a / 2 ^ n) mod 2 +Nat.pow_div_l: + forall a b c : nat, b <> 0 -> a mod b = 0 -> (a / b) ^ c = a ^ c / b ^ c +Nat.testbit_eqb: forall a n : nat, Nat.testbit a n = ((a / 2 ^ n) mod 2 =? 1) +Nat.testbit_false: + forall a n : nat, Nat.testbit a n = false <-> (a / 2 ^ n) mod 2 = 0 +Nat.testbit_true: + forall a n : nat, Nat.testbit a n = true <-> (a / 2 ^ n) mod 2 = 1 +iff_Symmetric: Symmetric iff +iff_Reflexive: Reflexive iff +impl_Reflexive: Reflexive Basics.impl +eq_Symmetric: forall {A : Type}, Symmetric eq +eq_Reflexive: forall {A : Type}, Reflexive eq +Equivalence_Symmetric: + forall {A : Type} {R : Relation_Definitions.relation A}, + Equivalence R -> Symmetric R +Equivalence_Reflexive: + forall {A : Type} {R : Relation_Definitions.relation A}, + Equivalence R -> Reflexive R +PER_Symmetric: + forall {A : Type} {R : Relation_Definitions.relation A}, + PER R -> Symmetric R +PreOrder_Reflexive: + forall {A : Type} {R : Relation_Definitions.relation A}, + PreOrder R -> Reflexive R +reflexive_eq_dom_reflexive: + forall {A B : Type} {R' : Relation_Definitions.relation B}, + Reflexive R' -> Reflexive (eq ==> R')%signature diff --git a/test-suite/output/Search.v b/test-suite/output/Search.v index 82096f29bf..4ec7a760b9 100644 --- a/test-suite/output/Search.v +++ b/test-suite/output/Search.v @@ -35,3 +35,34 @@ Goal forall n (P:nat -> Prop), P n -> ~P n -> False. Abort. +Module M. +Section S. +Variable A:Type. +Variable a:A. +Theorem Thm (b:A) : True. +Search A. (* Test search in hypotheses *) +Abort. +End S. +End M. + +(* Reproduce the example of the doc *) + +Reset Initial. + +Search "_assoc". +Search "+". +Search hyp:bool -headhyp:bool. +Search concl:bool -headconcl:bool. +Search [ is:Definition headconcl:nat | is:Lemma (_ + _) ]. + +Require Import PeanoNat. + +Search (_ ?n ?m = _ ?m ?n). +Search "'mod'" -"mod". +Search "mod"%nat -"mod". + +Reset Initial. + +Require Import Morphisms. + +Search is:Instance [ Reflexive | Symmetric ]. diff --git a/test-suite/output/SearchHead.out b/test-suite/output/SearchHead.out index d42dc575c2..9554581ebe 100644 --- a/test-suite/output/SearchHead.out +++ b/test-suite/output/SearchHead.out @@ -1,10 +1,17 @@ +File "stdin", line 3, characters 0-14: +Warning: +SearchHead is deprecated. Use the headconcl: clause of Search instead. +[deprecated-searchhead,deprecated] 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_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 le_S_n: forall n m : nat, S n <= S m -> n <= m -(use "About" for full details on implicit arguments) +File "stdin", line 4, characters 0-16: +Warning: +SearchHead is deprecated. Use the headconcl: clause of Search instead. +[deprecated-searchhead,deprecated] false: bool true: bool negb: bool -> bool @@ -28,7 +35,10 @@ Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool Decimal.int_beq: Decimal.int -> Decimal.int -> bool Decimal.uint_beq: Decimal.uint -> Decimal.uint -> bool -(use "About" for full details on implicit arguments) +File "stdin", line 5, characters 0-21: +Warning: +SearchHead is deprecated. Use the headconcl: clause of Search instead. +[deprecated-searchhead,deprecated] mult_n_O: forall n : nat, 0 = n * 0 plus_O_n: forall n : nat, 0 + n = n plus_n_O: forall n : nat, n = n + 0 @@ -47,8 +57,13 @@ f_equal2_plus: forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2 f_equal2_mult: forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2 -(use "About" for full details on implicit arguments) +File "stdin", line 11, characters 2-20: +Warning: +SearchHead is deprecated. Use the headconcl: clause of Search instead. +[deprecated-searchhead,deprecated] h: newdef n -(use "About" for full details on implicit arguments) +File "stdin", line 17, characters 2-15: +Warning: +SearchHead is deprecated. Use the headconcl: clause of Search instead. +[deprecated-searchhead,deprecated] h: P n -(use "About" for full details on implicit arguments) diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out index 13d0a9e55b..80b03e8a0b 100644 --- a/test-suite/output/SearchPattern.out +++ b/test-suite/output/SearchPattern.out @@ -21,7 +21,6 @@ Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool Decimal.int_beq: Decimal.int -> Decimal.int -> bool Decimal.uint_beq: Decimal.uint -> Decimal.uint -> bool -(use "About" for full details on implicit arguments) Nat.two: nat Nat.zero: nat Nat.one: nat @@ -61,8 +60,6 @@ Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat Nat.log2_iter: nat -> nat -> nat -> nat -> nat length: forall [A : Type], list A -> nat Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat -(use "About" for full details on implicit arguments) -(use "About" for full details on implicit arguments) Nat.div2: nat -> nat Nat.sqrt: nat -> nat Nat.log2: nat -> nat @@ -92,29 +89,19 @@ Nat.of_hex_uint_acc: Hexadecimal.uint -> nat -> nat Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat Nat.log2_iter: nat -> nat -> nat -> nat -> nat Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat -(use "About" for full details on implicit arguments) mult_n_Sm: forall n m : nat, n * m + n = n * S m -(use "About" for full details on implicit arguments) iff_refl: forall A : Prop, A <-> A le_n: forall n : nat, n <= n identity_refl: forall [A : Type] (a : A), identity a a eq_refl: forall {A : Type} {x : A}, x = x Nat.divmod: nat -> nat -> nat -> nat -> nat * nat -(use "About" for full details on implicit arguments) +(use "About" for full details on the implicit arguments of eq_refl) conj: forall [A B : Prop], A -> B -> A /\ B pair: forall {A B : Type}, A -> B -> A * B Nat.divmod: nat -> nat -> nat -> nat -> nat * nat -(use "About" for full details on implicit arguments) -(use "About" for full details on implicit arguments) h: n <> newdef n -(use "About" for full details on implicit arguments) h: n <> newdef n -(use "About" for full details on implicit arguments) h: P n -(use "About" for full details on implicit arguments) h': ~ P n -(use "About" for full details on implicit arguments) h: P n -(use "About" for full details on implicit arguments) h: P n -(use "About" for full details on implicit arguments) diff --git a/test-suite/output/SearchRewrite.out b/test-suite/output/SearchRewrite.out index 3c0880b20c..5edea5dff6 100644 --- a/test-suite/output/SearchRewrite.out +++ b/test-suite/output/SearchRewrite.out @@ -1,10 +1,5 @@ plus_n_O: forall n : nat, n = n + 0 -(use "About" for full details on implicit arguments) plus_O_n: forall n : nat, 0 + n = n -(use "About" for full details on implicit arguments) h: n = newdef n -(use "About" for full details on implicit arguments) h: n = newdef n -(use "About" for full details on implicit arguments) h: n = newdef n -(use "About" for full details on implicit arguments) diff --git a/test-suite/output/ltac2_notations_eval_in.out b/test-suite/output/ltac2_notations_eval_in.out new file mode 100644 index 0000000000..15e43b7fb9 --- /dev/null +++ b/test-suite/output/ltac2_notations_eval_in.out @@ -0,0 +1,21 @@ +- : constr = +constr:((fix add (n m : nat) {struct n} : nat := + match n with + | 0 => m + | S p => S (add p m) + end) (1 + 2) 3) +- : constr = constr:(S (0 + 2 + 3)) +- : constr = constr:(6) +- : constr = constr:(1 + 2 + 3) +- : constr = constr:(6) +- : constr = constr:(1 + 2 + 3) +- : constr = constr:(1 + 2 + 3) +- : constr = constr:(6) +- : constr = constr:(1 + 2 + 3) +- : constr = constr:(1 + 2 + 3) +- : constr = constr:(6) +- : constr = constr:(1 + 2 + 3) +- : constr = constr:(1 + 2 + 3) +- : constr list = [constr:(0 <> 0); constr:(0 = 0 -> False); +constr:((fun P : Prop => P -> False) (0 = 0)); constr:( +0 <> 0)] diff --git a/test-suite/output/ltac2_notations_eval_in.v b/test-suite/output/ltac2_notations_eval_in.v new file mode 100644 index 0000000000..4a11e7cae0 --- /dev/null +++ b/test-suite/output/ltac2_notations_eval_in.v @@ -0,0 +1,42 @@ +From Ltac2 Require Import Ltac2. +From Coq Require Import ZArith. + +(** * Test eval ... in / reduction tactics *) + +(** The below test cases test if the notation syntax works - not the tactics as such *) + +Ltac2 Eval (eval red in (1+2+3)). + +Ltac2 Eval (eval hnf in (1+2+3)). + +Ltac2 Eval (eval simpl in (1+2+3)). + +Ltac2 Eval (eval simpl Z.add in (1+2+3)). + +Ltac2 Eval (eval cbv in (1+2+3)). + +Ltac2 Eval (eval cbv delta [Z.add] beta iota in (1+2+3)). + +Ltac2 Eval (eval cbv delta [Z.add Pos.add] beta iota in (1+2+3)). + +Ltac2 Eval (eval cbn in (1+2+3)). + +Ltac2 Eval (eval cbn delta [Z.add] beta iota in (1+2+3)). + +Ltac2 Eval (eval cbn delta [Z.add Pos.add] beta iota in (1+2+3)). + +Ltac2 Eval (eval lazy in (1+2+3)). + +Ltac2 Eval (eval lazy delta [Z.add] beta iota in (1+2+3)). + +Ltac2 Eval (eval lazy delta [Z.add Pos.add] beta iota in (1+2+3)). + +(* The example for [fold] in the reference manual *) + +Ltac2 Eval ( + let t1 := '(~0=0) in + let t2 := eval unfold not in $t1 in + let t3 := eval pattern (0=0) in $t2 in + let t4 := eval fold not in $t3 in + [t1; t2; t3; t4] +). diff --git a/test-suite/success/CompatCurrentFlag.v b/test-suite/success/CompatCurrentFlag.v index c86548440b..97b4e39168 100644 --- a/test-suite/success/CompatCurrentFlag.v +++ b/test-suite/success/CompatCurrentFlag.v @@ -1,3 +1,3 @@ -(* -*- coq-prog-args: ("-compat" "8.12") -*- *) +(* -*- coq-prog-args: ("-compat" "8.13") -*- *) (** Check that the current compatibility flag actually requires the relevant modules. *) -Import Coq.Compat.Coq812. +Import Coq.Compat.Coq813. diff --git a/test-suite/success/CompatOldFlag.v b/test-suite/success/CompatOldFlag.v index a1c1209db6..c06dd6e450 100644 --- a/test-suite/success/CompatOldFlag.v +++ b/test-suite/success/CompatOldFlag.v @@ -1,5 +1,5 @@ -(* -*- coq-prog-args: ("-compat" "8.10") -*- *) +(* -*- coq-prog-args: ("-compat" "8.11") -*- *) (** Check that the current-minus-two compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq813. Import Coq.Compat.Coq812. Import Coq.Compat.Coq811. -Import Coq.Compat.Coq810. diff --git a/test-suite/success/CompatOldOldFlag.v b/test-suite/success/CompatOldOldFlag.v new file mode 100644 index 0000000000..f408e95d2e --- /dev/null +++ b/test-suite/success/CompatOldOldFlag.v @@ -0,0 +1,6 @@ +(* -*- coq-prog-args: ("-compat" "8.10") -*- *) +(** Check that the current-minus-three compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq813. +Import Coq.Compat.Coq812. +Import Coq.Compat.Coq811. +Import Coq.Compat.Coq810. diff --git a/test-suite/success/CompatPreviousFlag.v b/test-suite/success/CompatPreviousFlag.v index 00f4747e3e..83010f2149 100644 --- a/test-suite/success/CompatPreviousFlag.v +++ b/test-suite/success/CompatPreviousFlag.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-compat" "8.11") -*- *) +(* -*- coq-prog-args: ("-compat" "8.12") -*- *) (** Check that the current-minus-one compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq813. Import Coq.Compat.Coq812. -Import Coq.Compat.Coq811. diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v index f87f2e2a9d..e371cf251f 100644 --- a/test-suite/success/Funind.v +++ b/test-suite/success/Funind.v @@ -77,7 +77,7 @@ Functional Scheme app_ind := Induction for app Sort Prop. Lemma appnil : forall (A : Set) (l l' : list A), l' = nil -> l = l ++ l'. intros A l l'. - functional induction app A l l'; intuition. + functional induction app l l'; intuition. rewrite <- H0; trivial. Qed. diff --git a/test-suite/tools/update-compat/run.sh b/test-suite/tools/update-compat/run.sh index 7ff5571ffb..61273c4f37 100755 --- a/test-suite/tools/update-compat/run.sh +++ b/test-suite/tools/update-compat/run.sh @@ -6,4 +6,4 @@ SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" # we assume that the script lives in test-suite/tools/update-compat/, # and that update-compat.py lives in dev/tools/ cd "${SCRIPT_DIR}/../../.." -dev/tools/update-compat.py --assert-unchanged --release || exit $? +dev/tools/update-compat.py --assert-unchanged --master || exit $? diff --git a/test-suite/unit-tests/ide/lex_tests.ml b/test-suite/unit-tests/ide/lex_tests.ml deleted file mode 100644 index 3082acdf1f..0000000000 --- a/test-suite/unit-tests/ide/lex_tests.ml +++ /dev/null @@ -1,50 +0,0 @@ -open Utest - -let log_out_ch = open_log_out_ch __FILE__ - -let lex s = - let n = - let last = String.length s - 1 in - if s.[last] = '.' then Some last else None in - let stop = ref None in - let f i _ = assert(!stop = None); stop := Some i in - begin try Coq_lex.delimit_sentences f s - with Coq_lex.Unterminated -> () end; - if n <> !stop then begin - let p_opt = function None -> "None" | Some i -> "Some " ^ string_of_int i in - Printf.fprintf log_out_ch "ERROR: %S\nEXPECTED: %s\nGOT: %s\n" s (p_opt n) (p_opt !stop) - end; - n = !stop - -let i2s i = "test at line: " ^ string_of_int i - -let tests = [ - - mk_bool_test (i2s __LINE__) "no quotation" @@ lex - "foo.+1 bar." - ; - mk_bool_test (i2s __LINE__) "quotation" @@ lex - "foo constr:(xxx)." - ; - mk_bool_test (i2s __LINE__) "quotation with dot" @@ lex - "foo constr:(xxx. yyy)." - ; - mk_bool_test (i2s __LINE__) "quotation with dot double paren" @@ lex - "foo constr:((xxx. (foo.+1 ) \")\" yyy))." - ; - mk_bool_test (i2s __LINE__) "quotation with dot paren [" @@ lex - "foo constr:[xxx. (foo.+1 ) \")\" yyy]." - ; - mk_bool_test (i2s __LINE__) "quotation with dot double paren [" @@ lex - "foo constr:[[xxx. (foo.+1 ) \")\" yyy]]." - ; - mk_bool_test (i2s __LINE__) "quotation with dot triple paren [" @@ lex - "foo constr:[[[xxx. (foo.+1 @@ [] ) \"]])\" yyy]]]." - ; - mk_bool_test (i2s __LINE__) "quotation nesting {" @@ lex - "bar:{{ foo {{ hello. }} }}." - ; - -] - -let _ = run_tests __FILE__ log_out_ch tests diff --git a/test-suite/unit-tests/printing/proof_diffs_test.ml b/test-suite/unit-tests/printing/proof_diffs_test.ml index d0b8d21b69..60267cd859 100644 --- a/test-suite/unit-tests/printing/proof_diffs_test.ml +++ b/test-suite/unit-tests/printing/proof_diffs_test.ml @@ -76,11 +76,14 @@ let _ = add_test "tokenize_string/diff_mode in lexer" t open Pp +let write_diffs_option s = + Goptions.set_string_option_value Proof_diffs.opt_name s + (* example that was failing from #8922 *) let t () = - Proof_diffs.write_diffs_option "removed"; + write_diffs_option "removed"; ignore (diff_str "X : ?Goal" "X : forall x : ?Goal0, ?Goal1"); - Proof_diffs.write_diffs_option "on" + write_diffs_option "on" let _ = add_test "shorten_diff_span failure from #8922" t (* note pp_to_string concatenates adjacent strings, could become one token, @@ -181,7 +184,7 @@ let _ = if false then add_test "diff_pp/add_diff_tags token containing white spa let add_entries map idents rhs_pp = let make_entry() = { idents; rhs_pp; done_ = false } in - List.iter (fun ident -> map := (StringMap.add ident (make_entry ()) !map); ()) idents;; + List.iter (fun ident -> map := (CString.Map.add ident (make_entry ()) !map); ()) idents;; let print_list hyps = List.iter (fun x -> cprintf "%s\n" (string_of_ppcmds (flatten x))) hyps let db_print_list hyps = List.iter (fun x -> cprintf "%s\n" (db_string_of_pp (flatten x))) hyps @@ -194,11 +197,11 @@ let db_print_list hyps = List.iter (fun x -> cprintf "%s\n" (db_string_of_pp (fl let t () = write_diffs_option "removed"; (* turn on "removed" option *) let o_line_idents = [ ["a"]; ["b"]] in - let o_hyp_map = ref StringMap.empty in + let o_hyp_map = ref CString.Map.empty in add_entries o_hyp_map ["a"] (str " : foo"); add_entries o_hyp_map ["b"] (str " : bar car"); let n_line_idents = [ ["b"]; ["a"]] in - let n_hyp_map = ref StringMap.empty in + let n_hyp_map = ref CString.Map.empty in add_entries n_hyp_map ["b"] (str " : car"); add_entries n_hyp_map ["a"] (str " : foo bar"); let expected = [flatten (wrap_in_bg "diff.removed" (seq [str "b"; str " : "; (tag "diff.removed" (str "bar")); str " car" ])); @@ -224,11 +227,11 @@ let _ = add_test "diff_hyps simple diffs" t let t () = write_diffs_option "removed"; (* turn on "removed" option *) let o_line_idents = [ ["a"]; ["c"; "d"]] in - let o_hyp_map = ref StringMap.empty in + let o_hyp_map = ref CString.Map.empty in add_entries o_hyp_map ["a"] (str " : nat"); add_entries o_hyp_map ["c"; "d"] (str " : int"); let n_line_idents = [ ["a"; "b"]; ["d"]] in - let n_hyp_map = ref StringMap.empty in + let n_hyp_map = ref CString.Map.empty in add_entries n_hyp_map ["a"; "b"] (str " : nat"); add_entries n_hyp_map ["d"] (str " : int"); let expected = [flatten (wrap_in_bg "diff.added" (seq [str "a"; (tag "start.diff.added" (str ", ")); (tag "end.diff.added" (str "b")); str " : nat" ])); @@ -264,12 +267,12 @@ DIFFS let t () = write_diffs_option "removed"; (* turn on "removed" option *) let o_line_idents = [ ["a"]; ["b"]; ["c"]] in - let o_hyp_map = ref StringMap.empty in + let o_hyp_map = ref CString.Map.empty in add_entries o_hyp_map ["a"] (str " : foo"); add_entries o_hyp_map ["b"] (str " : bar"); add_entries o_hyp_map ["c"] (str " : nat"); let n_line_idents = [ ["b"; "a"; "c"] ] in - let n_hyp_map = ref StringMap.empty in + let n_hyp_map = ref CString.Map.empty in add_entries n_hyp_map ["b"; "a"; "c"] (str " : nat"); let expected = [flatten (wrap_in_bg "diff.removed" (seq [str "b"; str " : "; (tag "diff.removed" (str "bar"))])); flatten (wrap_in_bg "diff.added" (seq [str "b"; str " : "; (tag "diff.added" (str "nat"))])); @@ -302,10 +305,10 @@ DIFFS let t () = write_diffs_option "removed"; (* turn on "removed" option *) let o_line_idents = [ ["b"; "a"; "c"] ] in - let o_hyp_map = ref StringMap.empty in + let o_hyp_map = ref CString.Map.empty in add_entries o_hyp_map ["b"; "a"; "c"] (str " : nat"); let n_line_idents = [ ["a"]; ["b"]; ["c"]] in - let n_hyp_map = ref StringMap.empty in + let n_hyp_map = ref CString.Map.empty in add_entries n_hyp_map ["a"] (str " : foo"); add_entries n_hyp_map ["b"] (str " : bar"); add_entries n_hyp_map ["c"] (str " : nat"); diff --git a/theories/Compat/Coq812.v b/theories/Compat/Coq812.v index ee4bac3542..f52b559f84 100644 --- a/theories/Compat/Coq812.v +++ b/theories/Compat/Coq812.v @@ -9,4 +9,6 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.12 *) + +Require Export Coq.Compat.Coq813. Set Firstorder Solver auto with *. diff --git a/theories/Compat/Coq813.v b/theories/Compat/Coq813.v new file mode 100644 index 0000000000..92544c6ed9 --- /dev/null +++ b/theories/Compat/Coq813.v @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Compatibility file for making Coq act similar to Coq v8.13 *) diff --git a/theories/Reals/Abstract/ConstructiveAbs.v b/theories/Reals/Abstract/ConstructiveAbs.v index 31397cbddd..b6ceeef46a 100644 --- a/theories/Reals/Abstract/ConstructiveAbs.v +++ b/theories/Reals/Abstract/ConstructiveAbs.v @@ -17,7 +17,10 @@ Local Open Scope ConstructiveReals. (** Properties of constructive absolute value (defined in ConstructiveReals.CRabs). - Definition of minimum, maximum and their properties. *) + Definition of minimum, maximum and their properties. + + WARNING: this file is experimental and likely to change in future releases. +*) Instance CRabs_morph : forall {R : ConstructiveReals}, @@ -322,626 +325,3 @@ Proof. rewrite <- CRabs_opp in H. exact (CRle_trans _ _ _ (CRle_abs _) H). Qed. - - -(* Minimum *) - -Definition CRmin {R : ConstructiveReals} (x y : CRcarrier R) : CRcarrier R - := (x + y - CRabs _ (y - x)) * CR_of_Q _ (1#2). - -Lemma CRmin_lt_r : forall {R : ConstructiveReals} (x y : CRcarrier R), - CRmin x y < y -> CRmin x y == x. -Proof. - intros. unfold CRmin. unfold CRmin in H. - apply (CRmult_eq_reg_r (CR_of_Q R 2)). - left; apply CR_of_Q_pos; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l, CRmult_1_r. - rewrite CRabs_right. unfold CRminus. - rewrite CRopp_plus_distr, CRplus_assoc, <- (CRplus_assoc y). - rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity. - apply (CRmult_lt_compat_r (CR_of_Q R 2)) in H. - 2: apply CR_of_Q_pos; reflexivity. - intro abs. contradict H. - apply (CRle_trans _ (x + y - CRabs R (y - x))). - rewrite CRabs_left. 2: apply CRlt_asym, abs. - unfold CRminus. rewrite CRopp_involutive, CRplus_comm. - rewrite CRplus_assoc, <- (CRplus_assoc (-x)), CRplus_opp_l. - rewrite CRplus_0_l, (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. - rewrite CRmult_1_r. apply CRle_refl. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. apply CRle_refl. -Qed. - -Add Parametric Morphism {R : ConstructiveReals} : CRmin - with signature (CReq R) ==> (CReq R) ==> (CReq R) - as CRmin_morph. -Proof. - intros. unfold CRmin. - apply CRmult_morph. 2: reflexivity. - unfold CRminus. - rewrite H, H0. reflexivity. -Qed. - -Instance CRmin_morphT - : forall {R : ConstructiveReals}, - CMorphisms.Proper - (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (@CRmin R). -Proof. - intros R x y H z t H0. - rewrite H, H0. reflexivity. -Qed. - -Lemma CRmin_l : forall {R : ConstructiveReals} (x y : CRcarrier R), - CRmin x y <= x. -Proof. - intros. unfold CRmin. - apply (CRmult_le_reg_r (CR_of_Q R 2)). - apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. - apply (CRplus_le_reg_r (CRabs _ (y + - x)+ -x)). - rewrite CRplus_assoc, <- (CRplus_assoc (-CRabs _ (y + - x))). - rewrite CRplus_opp_l, CRplus_0_l. - rewrite (CRplus_comm x), CRplus_assoc, CRplus_opp_l, CRplus_0_r. - apply CRle_abs. -Qed. - -Lemma CRmin_r : forall {R : ConstructiveReals} (x y : CRcarrier R), - CRmin x y <= y. -Proof. - intros. unfold CRmin. - apply (CRmult_le_reg_r (CR_of_Q R 2)). - apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - rewrite (CRplus_comm x). - unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. - apply (CRplus_le_reg_l (-x)). - rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite <- (CRopp_involutive y), <- CRopp_plus_distr, <- CRopp_plus_distr. - apply CRopp_ge_le_contravar. rewrite CRabs_opp, CRplus_comm. - apply CRle_abs. -Qed. - -Lemma CRnegPartAbsMin : forall {R : ConstructiveReals} (x : CRcarrier R), - CRmin 0 x == (x - CRabs _ x) * (CR_of_Q _ (1#2)). -Proof. - intros. unfold CRmin. unfold CRminus. rewrite CRplus_0_l. - apply CRmult_morph. 2: reflexivity. rewrite CRopp_0, CRplus_0_r. reflexivity. -Qed. - -Lemma CRmin_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), - CRmin x y == CRmin y x. -Proof. - intros. unfold CRmin. apply CRmult_morph. 2: reflexivity. - rewrite CRabs_minus_sym. unfold CRminus. - rewrite (CRplus_comm x y). reflexivity. -Qed. - -Lemma CRmin_mult : - forall {R : ConstructiveReals} (p q r : CRcarrier R), - 0 <= r -> CRmin (r * p) (r * q) == r * CRmin p q. -Proof. - intros R p q r H. unfold CRmin. - setoid_replace (r * q - r * p) with (r * (q - p)). - rewrite CRabs_mult. - rewrite (CRabs_right r). 2: exact H. - rewrite <- CRmult_assoc. apply CRmult_morph. 2: reflexivity. - unfold CRminus. rewrite CRopp_mult_distr_r. - do 2 rewrite <- CRmult_plus_distr_l. reflexivity. - unfold CRminus. rewrite CRopp_mult_distr_r. - rewrite <- CRmult_plus_distr_l. reflexivity. -Qed. - -Lemma CRmin_plus : forall {R : ConstructiveReals} (x y z : CRcarrier R), - x + CRmin y z == CRmin (x + y) (x + z). -Proof. - intros. unfold CRmin. - unfold CRminus. setoid_replace (x + z + - (x + y)) with (z-y). - apply (CRmult_eq_reg_r (CR_of_Q _ 2)). - left. apply CR_of_Q_lt; reflexivity. - rewrite CRmult_plus_distr_r. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. - do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. - rewrite (CRplus_comm x). apply CRplus_assoc. - rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. - apply CRplus_morph. 2: reflexivity. - rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. - apply CRplus_0_l. -Qed. - -Lemma CRmin_left : forall {R : ConstructiveReals} (x y : CRcarrier R), - x <= y -> CRmin x y == x. -Proof. - intros. unfold CRmin. - apply (CRmult_eq_reg_r (CR_of_Q R 2)). - left. apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - rewrite CRabs_right. unfold CRminus. rewrite CRopp_plus_distr. - rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. apply CRopp_involutive. - rewrite <- (CRplus_opp_r x). apply CRplus_le_compat. - exact H. apply CRle_refl. -Qed. - -Lemma CRmin_right : forall {R : ConstructiveReals} (x y : CRcarrier R), - y <= x -> CRmin x y == y. -Proof. - intros. unfold CRmin. - apply (CRmult_eq_reg_r (CR_of_Q R 2)). - left. apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - rewrite CRabs_left. unfold CRminus. do 2 rewrite CRopp_plus_distr. - rewrite (CRplus_comm x y). - rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - do 2 rewrite CRopp_involutive. - rewrite CRplus_comm, CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. - rewrite <- (CRplus_opp_r x). apply CRplus_le_compat. - exact H. apply CRle_refl. -Qed. - -Lemma CRmin_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), - z < x -> z < y -> z < CRmin x y. -Proof. - intros. unfold CRmin. - apply (CRmult_lt_reg_r (CR_of_Q R 2)). - apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - apply (CRplus_lt_reg_l _ (CRabs _ (y - x) - (z*CR_of_Q R 2))). - unfold CRminus. rewrite CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_r. - rewrite (CRplus_comm (CRabs R (y + - x))). - rewrite (CRplus_comm (x+y)), CRplus_assoc. - rewrite <- (CRplus_assoc (CRabs R (y + - x))), CRplus_opp_r, CRplus_0_l. - rewrite <- (CRplus_comm (x+y)). - apply CRabs_def1. - - unfold CRminus. rewrite <- (CRplus_comm y), CRplus_assoc. - apply CRplus_lt_compat_l. - apply (CRplus_lt_reg_l R (-x)). - rewrite CRopp_mult_distr_l. - rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. - rewrite CRmult_1_r. apply CRplus_le_lt_compat. - apply CRlt_asym. - apply CRopp_gt_lt_contravar, H. - apply CRopp_gt_lt_contravar, H. - - rewrite CRopp_plus_distr, CRopp_involutive. - rewrite CRplus_comm, CRplus_assoc. - apply CRplus_lt_compat_l. - apply (CRplus_lt_reg_l R (-y)). - rewrite CRopp_mult_distr_l. - rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. - rewrite CRmult_1_r. apply CRplus_le_lt_compat. - apply CRlt_asym. - apply CRopp_gt_lt_contravar, H0. - apply CRopp_gt_lt_contravar, H0. -Qed. - -Lemma CRmin_contract : forall {R : ConstructiveReals} (x y a : CRcarrier R), - CRabs _ (CRmin x a - CRmin y a) <= CRabs _ (x - y). -Proof. - intros. unfold CRmin. - unfold CRminus. rewrite CRopp_mult_distr_l, <- CRmult_plus_distr_r. - rewrite (CRabs_morph - _ ((x - y + (CRabs _ (a - y) - CRabs _ (a - x))) * CR_of_Q R (1 # 2))). - rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). - 2: apply CR_of_Q_le; discriminate. - apply (CRle_trans _ - ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) - * CR_of_Q R (1 # 2))). - apply CRmult_le_compat_r. - apply CR_of_Q_le. discriminate. - apply (CRle_trans - _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - y) - CRabs _ (a - x)))). - apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. - rewrite (CRabs_morph (x-y) ((a-y)-(a-x))). - apply CRabs_triang_inv2. - unfold CRminus. rewrite (CRplus_comm (a + - y)). - rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. - rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. - rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. - reflexivity. - rewrite <- CRmult_plus_distr_l. - rewrite <- (CR_of_Q_plus R 1 1). - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. apply CRle_refl. - unfold CRminus. apply CRmult_morph. 2: reflexivity. - do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - rewrite <- CRplus_assoc. rewrite CRplus_comm, CRopp_plus_distr. - rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - rewrite CRopp_plus_distr. rewrite (CRplus_comm (-a)). - rewrite CRplus_assoc, <- (CRplus_assoc (-a)), CRplus_opp_l. - rewrite CRplus_0_l, CRopp_involutive. reflexivity. -Qed. - -Lemma CRmin_glb : forall {R : ConstructiveReals} (x y z:CRcarrier R), - z <= x -> z <= y -> z <= CRmin x y. -Proof. - intros. unfold CRmin. - apply (CRmult_le_reg_r (CR_of_Q R 2)). - apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - apply (CRplus_le_reg_l (CRabs _ (y-x) - (z*CR_of_Q R 2))). - unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. - rewrite (CRplus_comm (CRabs R (y + - x) + - (z * CR_of_Q R 2))). - rewrite CRplus_assoc, <- (CRplus_assoc (- CRabs R (y + - x))). - rewrite CRplus_opp_l, CRplus_0_l. - apply CRabs_le. split. - - do 2 rewrite CRopp_plus_distr. - rewrite CRopp_involutive, (CRplus_comm y), CRplus_assoc. - apply CRplus_le_compat_l, (CRplus_le_reg_l y). - rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. - rewrite CRmult_1_r. apply CRplus_le_compat; exact H0. - - rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. - apply (CRplus_le_reg_l (-x)). - rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite CRopp_mult_distr_l. - rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. - rewrite CRmult_1_r. - apply CRplus_le_compat; apply CRopp_ge_le_contravar; exact H. -Qed. - -Lemma CRmin_assoc : forall {R : ConstructiveReals} (a b c : CRcarrier R), - CRmin a (CRmin b c) == CRmin (CRmin a b) c. -Proof. - split. - - apply CRmin_glb. - + apply (CRle_trans _ (CRmin a b)). - apply CRmin_l. apply CRmin_l. - + apply CRmin_glb. - apply (CRle_trans _ (CRmin a b)). - apply CRmin_l. apply CRmin_r. apply CRmin_r. - - apply CRmin_glb. - + apply CRmin_glb. apply CRmin_l. - apply (CRle_trans _ (CRmin b c)). - apply CRmin_r. apply CRmin_l. - + apply (CRle_trans _ (CRmin b c)). - apply CRmin_r. apply CRmin_r. -Qed. - -Lemma CRlt_min : forall {R : ConstructiveReals} (x y z : CRcarrier R), - z < CRmin x y -> prod (z < x) (z < y). -Proof. - intros. destruct (CR_Q_dense R _ _ H) as [q qmaj]. - destruct qmaj. - split. - - apply (CRlt_le_trans _ (CR_of_Q R q) _ c). - intro abs. apply (CRlt_asym _ _ c0). - apply (CRle_lt_trans _ x). apply CRmin_l. exact abs. - - apply (CRlt_le_trans _ (CR_of_Q R q) _ c). - intro abs. apply (CRlt_asym _ _ c0). - apply (CRle_lt_trans _ y). apply CRmin_r. exact abs. -Qed. - - - -(* Maximum *) - -Definition CRmax {R : ConstructiveReals} (x y : CRcarrier R) : CRcarrier R - := (x + y + CRabs _ (y - x)) * CR_of_Q _ (1#2). - -Add Parametric Morphism {R : ConstructiveReals} : CRmax - with signature (CReq R) ==> (CReq R) ==> (CReq R) - as CRmax_morph. -Proof. - intros. unfold CRmax. - apply CRmult_morph. 2: reflexivity. unfold CRminus. - rewrite H, H0. reflexivity. -Qed. - -Instance CRmax_morphT - : forall {R : ConstructiveReals}, - CMorphisms.Proper - (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (@CRmax R). -Proof. - intros R x y H z t H0. - rewrite H, H0. reflexivity. -Qed. - -Lemma CRmax_lub : forall {R : ConstructiveReals} (x y z:CRcarrier R), - x <= z -> y <= z -> CRmax x y <= z. -Proof. - intros. unfold CRmax. - apply (CRmult_le_reg_r (CR_of_Q _ 2)). - apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - apply (CRplus_le_reg_l (-x-y)). - rewrite <- CRplus_assoc. unfold CRminus. - rewrite <- CRopp_plus_distr, CRplus_opp_l, CRplus_0_l. - apply CRabs_le. split. - - repeat rewrite CRopp_plus_distr. - do 2 rewrite CRopp_involutive. - rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. - apply (CRplus_le_reg_l (-x)). - rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - rewrite CRopp_plus_distr. - apply CRplus_le_compat; apply CRopp_ge_le_contravar; assumption. - - rewrite (CRplus_comm y), CRopp_plus_distr, CRplus_assoc. - apply CRplus_le_compat_l. - apply (CRplus_le_reg_l y). - rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - apply CRplus_le_compat; assumption. -Qed. - -Lemma CRmax_l : forall {R : ConstructiveReals} (x y : CRcarrier R), - x <= CRmax x y. -Proof. - intros. unfold CRmax. - apply (CRmult_le_reg_r (CR_of_Q R 2)). - apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - setoid_replace 2%Q with (1+1)%Q. rewrite CR_of_Q_plus. - rewrite CRmult_plus_distr_l, CRmult_1_r, CRplus_assoc. - apply CRplus_le_compat_l. - apply (CRplus_le_reg_l (-y)). - rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite CRabs_minus_sym, CRplus_comm. - apply CRle_abs. reflexivity. -Qed. - -Lemma CRmax_r : forall {R : ConstructiveReals} (x y : CRcarrier R), - y <= CRmax x y. -Proof. - intros. unfold CRmax. - apply (CRmult_le_reg_r (CR_of_Q _ 2)). - apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - rewrite (CRplus_comm x). - rewrite CRplus_assoc. apply CRplus_le_compat_l. - apply (CRplus_le_reg_l (-x)). - rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - rewrite CRplus_comm. apply CRle_abs. -Qed. - -Lemma CRposPartAbsMax : forall {R : ConstructiveReals} (x : CRcarrier R), - CRmax 0 x == (x + CRabs _ x) * (CR_of_Q R (1#2)). -Proof. - intros. unfold CRmax. unfold CRminus. rewrite CRplus_0_l. - apply CRmult_morph. 2: reflexivity. rewrite CRopp_0, CRplus_0_r. reflexivity. -Qed. - -Lemma CRmax_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), - CRmax x y == CRmax y x. -Proof. - intros. unfold CRmax. - rewrite CRabs_minus_sym. apply CRmult_morph. - 2: reflexivity. rewrite (CRplus_comm x y). reflexivity. -Qed. - -Lemma CRmax_plus : forall {R : ConstructiveReals} (x y z : CRcarrier R), - x + CRmax y z == CRmax (x + y) (x + z). -Proof. - intros. unfold CRmax. - setoid_replace (x + z - (x + y)) with (z-y). - apply (CRmult_eq_reg_r (CR_of_Q _ 2)). - left. apply CR_of_Q_lt; reflexivity. - rewrite CRmult_plus_distr_r. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - rewrite CRmult_1_r. - do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. - do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. - rewrite (CRplus_comm x). apply CRplus_assoc. - unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. - apply CRplus_morph. 2: reflexivity. - rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. - apply CRplus_0_l. -Qed. - -Lemma CRmax_left : forall {R : ConstructiveReals} (x y : CRcarrier R), - y <= x -> CRmax x y == x. -Proof. - intros. unfold CRmax. - apply (CRmult_eq_reg_r (CR_of_Q R 2)). - left. apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - rewrite CRabs_left. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. - rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. - rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r. exact H. -Qed. - -Lemma CRmax_right : forall {R : ConstructiveReals} (x y : CRcarrier R), - x <= y -> CRmax x y == y. -Proof. - intros. unfold CRmax. - apply (CRmult_eq_reg_r (CR_of_Q R 2)). - left. apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. - rewrite (CRplus_comm x y). - rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - rewrite CRabs_right. unfold CRminus. rewrite CRplus_comm. - rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. - rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r. exact H. -Qed. - -Lemma CRmax_contract : forall {R : ConstructiveReals} (x y a : CRcarrier R), - CRabs _ (CRmax x a - CRmax y a) <= CRabs _ (x - y). -Proof. - intros. unfold CRmax. - rewrite (CRabs_morph - _ ((x - y + (CRabs _ (a - x) - CRabs _ (a - y))) * CR_of_Q R (1 # 2))). - rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). - 2: apply CR_of_Q_le; discriminate. - apply (CRle_trans - _ ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) - * CR_of_Q R (1 # 2))). - apply CRmult_le_compat_r. - apply CR_of_Q_le. discriminate. - apply (CRle_trans - _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - x) - CRabs _ (a - y)))). - apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. - rewrite (CRabs_minus_sym x y). - rewrite (CRabs_morph (y-x) ((a-x)-(a-y))). - apply CRabs_triang_inv2. - unfold CRminus. rewrite (CRplus_comm (a + - x)). - rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. - rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. - rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. - reflexivity. - rewrite <- CRmult_plus_distr_l. - rewrite <- (CR_of_Q_plus R 1 1). - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. apply CRle_refl. - unfold CRminus. rewrite CRopp_mult_distr_l. - rewrite <- CRmult_plus_distr_r. apply CRmult_morph. 2: reflexivity. - do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - rewrite <- CRplus_assoc. rewrite CRplus_comm, CRopp_plus_distr. - rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - rewrite CRopp_plus_distr. rewrite (CRplus_comm (-a)). - rewrite CRplus_assoc, <- (CRplus_assoc (-a)), CRplus_opp_l. - rewrite CRplus_0_l. apply CRplus_comm. -Qed. - -Lemma CRmax_lub_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), - x < z -> y < z -> CRmax x y < z. -Proof. - intros. unfold CRmax. - apply (CRmult_lt_reg_r (CR_of_Q R 2)). - apply CR_of_Q_lt; reflexivity. - rewrite CRmult_assoc, <- CR_of_Q_mult. - setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. - rewrite CRmult_1_r. - apply (CRplus_lt_reg_l _ (-y -x)). unfold CRminus. - rewrite CRplus_assoc, <- (CRplus_assoc (-x)), <- (CRplus_assoc (-x)). - rewrite CRplus_opp_l, CRplus_0_l, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. - apply CRabs_def1. - - rewrite (CRplus_comm y), (CRplus_comm (-y)), CRplus_assoc. - apply CRplus_lt_compat_l. - apply (CRplus_lt_reg_l _ y). - rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. - rewrite CRmult_1_r. apply CRplus_le_lt_compat. - apply CRlt_asym, H0. exact H0. - - rewrite CRopp_plus_distr, CRopp_involutive. - rewrite CRplus_assoc. apply CRplus_lt_compat_l. - apply (CRplus_lt_reg_l _ x). - rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. - rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. - rewrite CRmult_1_r. apply CRplus_le_lt_compat. - apply CRlt_asym, H. exact H. -Qed. - -Lemma CRmax_assoc : forall {R : ConstructiveReals} (a b c : CRcarrier R), - CRmax a (CRmax b c) == CRmax (CRmax a b) c. -Proof. - split. - - apply CRmax_lub. - + apply CRmax_lub. apply CRmax_l. - apply (CRle_trans _ (CRmax b c)). - apply CRmax_l. apply CRmax_r. - + apply (CRle_trans _ (CRmax b c)). - apply CRmax_r. apply CRmax_r. - - apply CRmax_lub. - + apply (CRle_trans _ (CRmax a b)). - apply CRmax_l. apply CRmax_l. - + apply CRmax_lub. - apply (CRle_trans _ (CRmax a b)). - apply CRmax_r. apply CRmax_l. apply CRmax_r. -Qed. - -Lemma CRmax_min_mult_neg : - forall {R : ConstructiveReals} (p q r:CRcarrier R), - r <= 0 -> CRmax (r * p) (r * q) == r * CRmin p q. -Proof. - intros R p q r H. unfold CRmin, CRmax. - setoid_replace (r * q - r * p) with (r * (q - p)). - rewrite CRabs_mult. - rewrite (CRabs_left r), <- CRmult_assoc. - apply CRmult_morph. 2: reflexivity. unfold CRminus. - rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, - CRmult_plus_distr_l, CRmult_plus_distr_l. - reflexivity. exact H. - unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. -Qed. - -Lemma CRlt_max : forall {R : ConstructiveReals} (x y z : CRcarrier R), - CRmax x y < z -> prod (x < z) (y < z). -Proof. - intros. destruct (CR_Q_dense R _ _ H) as [q qmaj]. - destruct qmaj. - split. - - apply (CRlt_le_trans _ (CR_of_Q R q)). - apply (CRle_lt_trans _ (CRmax x y)). apply CRmax_l. exact c. - apply CRlt_asym, c0. - - apply (CRlt_le_trans _ (CR_of_Q R q)). - apply (CRle_lt_trans _ (CRmax x y)). apply CRmax_r. exact c. - apply CRlt_asym, c0. -Qed. - -Lemma CRmax_mult : - forall {R : ConstructiveReals} (p q r:CRcarrier R), - 0 <= r -> CRmax (r * p) (r * q) == r * CRmax p q. -Proof. - intros R p q r H. unfold CRmin, CRmax. - setoid_replace (r * q - r * p) with (r * (q - p)). - rewrite CRabs_mult. - rewrite (CRabs_right r), <- CRmult_assoc. - apply CRmult_morph. 2: reflexivity. - rewrite CRmult_plus_distr_l, CRmult_plus_distr_l. - reflexivity. exact H. - unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. -Qed. - -Lemma CRmin_max_mult_neg : - forall {R : ConstructiveReals} (p q r:CRcarrier R), - r <= 0 -> CRmin (r * p) (r * q) == r * CRmax p q. -Proof. - intros R p q r H. unfold CRmin, CRmax. - setoid_replace (r * q - r * p) with (r * (q - p)). - rewrite CRabs_mult. - rewrite (CRabs_left r), <- CRmult_assoc. - apply CRmult_morph. 2: reflexivity. unfold CRminus. - rewrite CRopp_mult_distr_l, CRopp_involutive, - CRmult_plus_distr_l, CRmult_plus_distr_l. - reflexivity. exact H. - unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. -Qed. diff --git a/theories/Reals/Abstract/ConstructiveLUB.v b/theories/Reals/Abstract/ConstructiveLUB.v index 1c19c6aa40..883bb50634 100644 --- a/theories/Reals/Abstract/ConstructiveLUB.v +++ b/theories/Reals/Abstract/ConstructiveLUB.v @@ -11,7 +11,10 @@ (** Proof that LPO and the excluded middle for negations imply the existence of least upper bounds for all non-empty and bounded - subsets of the real numbers. *) + subsets of the real numbers. + + WARNING: this file is experimental and likely to change in future releases. +*) Require Import QArith_base Qabs. Require Import ConstructiveReals. diff --git a/theories/Reals/Abstract/ConstructiveLimits.v b/theories/Reals/Abstract/ConstructiveLimits.v index 64dcd2e1ec..6fe4d4ca3f 100644 --- a/theories/Reals/Abstract/ConstructiveLimits.v +++ b/theories/Reals/Abstract/ConstructiveLimits.v @@ -11,13 +11,15 @@ Require Import QArith Qabs. Require Import ConstructiveReals. Require Import ConstructiveAbs. -Require Import ConstructiveSum. Local Open Scope ConstructiveReals. (** Definitions and basic properties of limits of real sequences - and series. *) + and series. + + WARNING: this file is experimental and likely to change in future releases. +*) Lemma CR_cv_extens @@ -219,18 +221,6 @@ Proof. exists p. intros. apply CRlt_asym. apply pmaj. apply H. Qed. -Definition series_cv {R : ConstructiveReals} - (un : nat -> CRcarrier R) (s : CRcarrier R) : Set - := CR_cv R (CRsum un) s. - -Definition series_cv_lim_lt {R : ConstructiveReals} - (un : nat -> CRcarrier R) (x : CRcarrier R) : Set - := { l : CRcarrier R & prod (series_cv un l) (l < x) }. - -Definition series_cv_le_lim {R : ConstructiveReals} - (x : CRcarrier R) (un : nat -> CRcarrier R) : Set - := { l : CRcarrier R & prod (series_cv un l) (x <= l) }. - Lemma CR_cv_minus : forall {R : ConstructiveReals} (An Bn:nat -> CRcarrier R) (l1 l2:CRcarrier R), @@ -260,13 +250,6 @@ Proof. rewrite CRplus_0_l. exact H1. Qed. -Lemma series_cv_unique : - forall {R : ConstructiveReals} (Un:nat -> CRcarrier R) (l1 l2:CRcarrier R), - series_cv Un l1 -> series_cv Un l2 -> l1 == l2. -Proof. - intros. apply (CR_cv_unique (CRsum Un)); assumption. -Qed. - Lemma CR_cv_scale : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (a : CRcarrier R) (s : CRcarrier R), CR_cv R u s -> CR_cv R (fun n => u n * a) (s * a). @@ -328,17 +311,6 @@ Proof. - rewrite Qinv_plus_distr. reflexivity. Qed. -Lemma series_cv_eq : forall {R : ConstructiveReals} - (u v : nat -> CRcarrier R) (s : CRcarrier R), - (forall n:nat, u n == v n) - -> series_cv u s - -> series_cv v s. -Proof. - intros. intros p. specialize (H0 p). destruct H0 as [N H0]. - exists N. intros. unfold CRminus. - rewrite <- (CRsum_eq u). apply H0, H1. intros. apply H. -Qed. - Lemma CR_growing_transit : forall {R : ConstructiveReals} (un : nat -> CRcarrier R), (forall n:nat, un n <= un (S n)) -> forall n p : nat, le n p -> un n <= un p. @@ -439,135 +411,6 @@ Proof. apply Nat.add_le_mono_l. apply le_0_n. Qed. -Lemma series_cv_maj : forall {R : ConstructiveReals} - (un vn : nat -> CRcarrier R) (s : CRcarrier R), - (forall n:nat, CRabs R (un n) <= vn n) - -> series_cv vn s - -> { l : CRcarrier R & prod (series_cv un l) (l <= s) }. -Proof. - intros. destruct (CR_complete R (CRsum un)). - - intros n. - specialize (H0 (2*n)%positive) as [N maj]. - exists N. intros i j H0 H1. - apply (CRle_trans _ (CRsum vn (max i j) - CRsum vn (min i j))). - apply Abs_sum_maj. apply H. - setoid_replace (CRsum vn (max i j) - CRsum vn (min i j)) - with (CRabs R (CRsum vn (max i j) - (CRsum vn (min i j)))). - setoid_replace (CRsum vn (Init.Nat.max i j) - CRsum vn (Init.Nat.min i j)) - with (CRsum vn (Init.Nat.max i j) - s - (CRsum vn (Init.Nat.min i j) - s)). - apply (CRle_trans _ _ _ (CRabs_triang _ _)). - setoid_replace (1#n)%Q with ((1#2*n) + (1#2*n))%Q. - rewrite CR_of_Q_plus. - apply CRplus_le_compat. - apply maj. apply (le_trans _ i). assumption. apply Nat.le_max_l. - rewrite CRabs_opp. apply maj. - apply Nat.min_case. apply (le_trans _ i). assumption. apply le_refl. - assumption. rewrite Qinv_plus_distr. reflexivity. - unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. - reflexivity. rewrite CRopp_plus_distr, CRopp_involutive. - rewrite CRplus_comm, CRplus_assoc, CRplus_opp_r, CRplus_0_r. - reflexivity. - rewrite CRabs_right. reflexivity. - rewrite <- (CRplus_opp_r (CRsum vn (Init.Nat.min i j))). - apply CRplus_le_compat. apply pos_sum_more. - intros. apply (CRle_trans _ (CRabs R (un k))). apply CRabs_pos. - apply H. apply (le_trans _ i). apply Nat.le_min_l. apply Nat.le_max_l. - apply CRle_refl. - - exists x. split. assumption. - (* x <= s *) - apply (CRplus_le_reg_r (-x)). rewrite CRplus_opp_r. - apply (CR_cv_bound_down (fun n => CRsum vn n - CRsum un n) _ _ 0). - intros. rewrite <- (CRplus_opp_r (CRsum un n)). - apply CRplus_le_compat. apply sum_Rle. - intros. apply (CRle_trans _ (CRabs R (un k))). - apply CRle_abs. apply H. apply CRle_refl. - apply CR_cv_plus. assumption. - apply CR_cv_opp. assumption. -Qed. - -Lemma series_cv_abs_lt - : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (l : CRcarrier R), - (forall n:nat, CRabs R (un n) <= vn n) - -> series_cv_lim_lt vn l - -> series_cv_lim_lt un l. -Proof. - intros. destruct H0 as [x [H0 H1]]. - destruct (series_cv_maj un vn x H H0) as [x0 H2]. - exists x0. split. apply H2. apply (CRle_lt_trans _ x). - apply H2. apply H1. -Qed. - -Definition series_cv_abs {R : ConstructiveReals} (u : nat -> CRcarrier R) - : CR_cauchy R (CRsum (fun n => CRabs R (u n))) - -> { l : CRcarrier R & series_cv u l }. -Proof. - intros. apply CR_complete in H. destruct H. - destruct (series_cv_maj u (fun k => CRabs R (u k)) x). - intro n. apply CRle_refl. assumption. exists x0. apply p. -Qed. - -Lemma series_cv_abs_eq - : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (a : CRcarrier R) - (cau : CR_cauchy R (CRsum (fun n => CRabs R (u n)))), - series_cv u a - -> (a == (let (l,_):= series_cv_abs u cau in l))%ConstructiveReals. -Proof. - intros. destruct (series_cv_abs u cau). - apply (series_cv_unique u). exact H. exact s. -Qed. - -Lemma series_cv_abs_cv - : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) - (cau : CR_cauchy R (CRsum (fun n => CRabs R (u n)))), - series_cv u (let (l,_):= series_cv_abs u cau in l). -Proof. - intros. destruct (series_cv_abs u cau). exact s. -Qed. - -Lemma series_cv_opp : forall {R : ConstructiveReals} - (s : CRcarrier R) (u : nat -> CRcarrier R), - series_cv u s - -> series_cv (fun n => - u n) (- s). -Proof. - intros. intros p. specialize (H p) as [N H]. - exists N. intros n H0. - setoid_replace (CRsum (fun n0 : nat => - u n0) n - - s) - with (-(CRsum (fun n0 : nat => u n0) n - s)). - rewrite CRabs_opp. - apply H, H0. unfold CRminus. - rewrite sum_opp. rewrite CRopp_plus_distr. reflexivity. -Qed. - -Lemma series_cv_scale : forall {R : ConstructiveReals} - (a : CRcarrier R) (s : CRcarrier R) (u : nat -> CRcarrier R), - series_cv u s - -> series_cv (fun n => (u n) * a) (s * a). -Proof. - intros. - apply (CR_cv_eq _ (fun n => CRsum u n * a)). - intro n. rewrite sum_scale. reflexivity. apply CR_cv_scale, H. -Qed. - -Lemma series_cv_plus : forall {R : ConstructiveReals} - (u v : nat -> CRcarrier R) (s t : CRcarrier R), - series_cv u s - -> series_cv v t - -> series_cv (fun n => u n + v n) (s + t). -Proof. - intros. apply (CR_cv_eq _ (fun n => CRsum u n + CRsum v n)). - intro n. symmetry. apply sum_plus. apply CR_cv_plus. exact H. exact H0. -Qed. - -Lemma series_cv_nonneg : forall {R : ConstructiveReals} - (u : nat -> CRcarrier R) (s : CRcarrier R), - (forall n:nat, 0 <= u n) -> series_cv u s -> 0 <= s. -Proof. - intros. apply (CRle_trans 0 (CRsum u 0)). apply H. - apply (growing_ineq (CRsum u)). intro n. simpl. - rewrite <- CRplus_0_r. apply CRplus_le_compat. - rewrite CRplus_0_r. apply CRle_refl. apply H. apply H0. -Qed. - Lemma CR_cv_le : forall {R : ConstructiveReals} (u v : nat -> CRcarrier R) (a b : CRcarrier R), (forall n:nat, u n <= v n) @@ -612,251 +455,6 @@ Proof. rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. Qed. -Lemma series_cv_triangle : forall {R : ConstructiveReals} - (u : nat -> CRcarrier R) (s sAbs : CRcarrier R), - series_cv u s - -> series_cv (fun n => CRabs R (u n)) sAbs - -> CRabs R s <= sAbs. -Proof. - intros. - apply (CR_cv_le (fun n => CRabs R (CRsum u n)) - (CRsum (fun n => CRabs R (u n)))). - intros. apply multiTriangleIneg. apply CR_cv_abs_cont. assumption. assumption. -Qed. - -Lemma CR_double : forall {R : ConstructiveReals} (x:CRcarrier R), - CR_of_Q R 2 * x == x + x. -Proof. - intros R x. rewrite (CR_of_Q_morph R 2 (1+1)). - 2: reflexivity. rewrite CR_of_Q_plus. - rewrite CRmult_plus_distr_r, CRmult_1_l. reflexivity. -Qed. - -Lemma GeoCvZero : forall {R : ConstructiveReals}, - CR_cv R (fun n:nat => CRpow (CR_of_Q R (1#2)) n) 0. -Proof. - intro R. assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). - { induction n. unfold INR; simpl. - apply CRzero_lt_one. unfold INR. fold (1+n)%nat. - rewrite Nat2Z.inj_add. - rewrite (CR_of_Q_morph R _ ((Z.of_nat 1 # 1) + (Z.of_nat n #1))). - 2: symmetry; apply Qinv_plus_distr. - rewrite CR_of_Q_plus. - replace (CRpow (CR_of_Q R 2) (1 + n)) - with (CR_of_Q R 2 * CRpow (CR_of_Q R 2) n). - 2: reflexivity. rewrite CR_double. - apply CRplus_le_lt_compat. - 2: exact IHn. simpl. - apply pow_R1_Rle. apply CR_of_Q_le. discriminate. } - intros p. exists (Pos.to_nat p). intros. - unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. - rewrite CRabs_right. - 2: apply pow_le; apply CR_of_Q_le; discriminate. - apply CRlt_asym. - apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos p # 1))). - apply CR_of_Q_lt. reflexivity. rewrite <- CR_of_Q_mult. - rewrite (CR_of_Q_morph R ((Z.pos p # 1) * (1 # p)) 1). - 2: unfold Qmult, Qeq, Qnum, Qden; ring_simplify; reflexivity. - apply (CRmult_lt_reg_r (CRpow (CR_of_Q R 2) i)). - apply pow_lt. simpl. - apply CR_of_Q_lt. reflexivity. - rewrite CRmult_assoc. rewrite pow_mult. - rewrite (pow_proper (CR_of_Q R (1 # 2) * CR_of_Q R 2) 1), pow_one. - rewrite CRmult_1_r, CRmult_1_l. - apply (CRle_lt_trans _ (INR i)). 2: exact (H i). clear H. - apply CR_of_Q_le. unfold Qle,Qnum,Qden. - do 2 rewrite Z.mul_1_r. - rewrite <- positive_nat_Z. apply Nat2Z.inj_le, H0. - rewrite <- CR_of_Q_mult. setoid_replace ((1#2)*2)%Q with 1%Q. - reflexivity. reflexivity. -Qed. - -Lemma GeoFiniteSum : forall {R : ConstructiveReals} (n:nat), - CRsum (CRpow (CR_of_Q R (1#2))) n == CR_of_Q R 2 - CRpow (CR_of_Q R (1#2)) n. -Proof. - induction n. - - unfold CRsum, CRpow. simpl (1%ConstructiveReals). - unfold CRminus. rewrite (CR_of_Q_plus R 1 1). - rewrite CRplus_assoc. - rewrite CRplus_opp_r, CRplus_0_r. reflexivity. - - setoid_replace (CRsum (CRpow (CR_of_Q R (1 # 2))) (S n)) - with (CRsum (CRpow (CR_of_Q R (1 # 2))) n + CRpow (CR_of_Q R (1 # 2)) (S n)). - 2: reflexivity. - rewrite IHn. clear IHn. unfold CRminus. - rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - apply (CRplus_eq_reg_l - (CRpow (CR_of_Q R (1 # 2)) n + CRpow (CR_of_Q R (1 # 2)) (S n))). - rewrite (CRplus_assoc _ _ (-CRpow (CR_of_Q R (1 # 2)) (S n))), - CRplus_opp_r, CRplus_0_r. - rewrite (CRplus_comm (CRpow (CR_of_Q R (1 # 2)) n)), CRplus_assoc. - rewrite <- (CRplus_assoc (CRpow (CR_of_Q R (1 # 2)) n)), CRplus_opp_r, - CRplus_0_l, <- CR_double. - setoid_replace (CRpow (CR_of_Q R (1 # 2)) (S n)) - with (CR_of_Q R (1 # 2) * CRpow (CR_of_Q R (1 # 2)) n). - 2: reflexivity. - rewrite <- CRmult_assoc, <- CR_of_Q_mult. - setoid_replace (2 * (1 # 2))%Q with 1%Q. - apply CRmult_1_l. reflexivity. -Qed. - -Lemma GeoHalfBelowTwo : forall {R : ConstructiveReals} (n:nat), - CRsum (CRpow (CR_of_Q R (1#2))) n < CR_of_Q R 2. -Proof. - intros. rewrite <- (CRplus_0_r (CR_of_Q R 2)), GeoFiniteSum. - apply CRplus_lt_compat_l. rewrite <- CRopp_0. - apply CRopp_gt_lt_contravar. - apply pow_lt. apply CR_of_Q_lt. reflexivity. -Qed. - -Lemma GeoHalfTwo : forall {R : ConstructiveReals}, - series_cv (fun n => CRpow (CR_of_Q R (1#2)) n) (CR_of_Q R 2). -Proof. - intro R. - apply (CR_cv_eq _ (fun n => CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) n)). - - intro n. rewrite GeoFiniteSum. reflexivity. - - assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). - { induction n. unfold INR; simpl. - apply CRzero_lt_one. apply (CRlt_le_trans _ (CRpow (CR_of_Q R 2) n + 1)). - unfold INR. - rewrite Nat2Z.inj_succ, <- Z.add_1_l. - rewrite (CR_of_Q_morph R _ (1 + (Z.of_nat n #1))). - 2: symmetry; apply Qinv_plus_distr. rewrite CR_of_Q_plus. - rewrite CRplus_comm. - apply CRplus_lt_compat_r, IHn. - setoid_replace (CRpow (CR_of_Q R 2) (S n)) - with (CRpow (CR_of_Q R 2) n + CRpow (CR_of_Q R 2) n). - apply CRplus_le_compat. apply CRle_refl. - apply pow_R1_Rle. apply CR_of_Q_le. discriminate. - rewrite <- CR_double. reflexivity. } - intros n. exists (Pos.to_nat n). intros. - setoid_replace (CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) i - CR_of_Q R 2) - with (- CRpow (CR_of_Q R (1 # 2)) i). - rewrite CRabs_opp. rewrite CRabs_right. - assert (0 < CR_of_Q R 2). - { apply CR_of_Q_lt. reflexivity. } - rewrite (pow_proper _ (CRinv R (CR_of_Q R 2) (inr H1))). - rewrite pow_inv. apply CRlt_asym. - apply (CRmult_lt_reg_l (CRpow (CR_of_Q R 2) i)). apply pow_lt, H1. - rewrite CRinv_r. - apply (CRmult_lt_reg_r (CR_of_Q R (Z.pos n#1))). - apply CR_of_Q_lt. reflexivity. - rewrite CRmult_1_l, CRmult_assoc. - rewrite <- CR_of_Q_mult. - rewrite (CR_of_Q_morph R ((1 # n) * (Z.pos n # 1)) 1). 2: reflexivity. - rewrite CRmult_1_r. apply (CRle_lt_trans _ (INR i)). - 2: apply H. apply CR_of_Q_le. - unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. destruct i. - exfalso. inversion H0. pose proof (Pos2Nat.is_pos n). - rewrite H3 in H2. inversion H2. - apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. - apply (le_trans _ _ _ H0). rewrite SuccNat2Pos.id_succ. apply le_refl. - apply (CRmult_eq_reg_l (CR_of_Q R 2)). right. exact H1. - rewrite CRinv_r. rewrite <- CR_of_Q_mult. - setoid_replace (2 * (1 # 2))%Q with 1%Q. - reflexivity. reflexivity. - apply CRlt_asym, pow_lt. - apply CR_of_Q_lt. reflexivity. - unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. - rewrite CRplus_opp_l, CRplus_0_l. reflexivity. -Qed. - -Lemma series_cv_remainder_maj : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) - (s eps : CRcarrier R) - (N : nat), - series_cv u s - -> 0 < eps - -> (forall n:nat, 0 <= u n) - -> CRabs R (CRsum u N - s) <= eps - -> forall n:nat, CRsum (fun k=> u (N + S k)%nat) n <= eps. -Proof. - intros. pose proof (sum_assoc u N n). - rewrite <- (CRsum_eq (fun k : nat => u (S N + k)%nat)). - apply (CRplus_le_reg_l (CRsum u N)). rewrite <- H3. - apply (CRle_trans _ s). apply growing_ineq. - 2: apply H. - intro k. simpl. rewrite <- CRplus_0_r, CRplus_assoc. - apply CRplus_le_compat_l. rewrite CRplus_0_l. apply H1. - rewrite CRabs_minus_sym in H2. - rewrite CRplus_comm. apply (CRplus_le_reg_r (-CRsum u N)). - rewrite CRplus_assoc. rewrite CRplus_opp_r. rewrite CRplus_0_r. - apply (CRle_trans _ (CRabs R (s - CRsum u N))). apply CRle_abs. - assumption. intros. rewrite Nat.add_succ_r. reflexivity. -Qed. - -Lemma series_cv_abs_remainder : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) - (s sAbs : CRcarrier R) - (n : nat), - series_cv u s - -> series_cv (fun n => CRabs R (u n)) sAbs - -> CRabs R (CRsum u n - s) - <= sAbs - CRsum (fun n => CRabs R (u n)) n. -Proof. - intros. - apply (CR_cv_le (fun N => CRabs R (CRsum u n - (CRsum u (n + N)))) - (fun N => CRsum (fun n : nat => CRabs R (u n)) (n + N) - - CRsum (fun n : nat => CRabs R (u n)) n)). - - intro N. destruct N. rewrite plus_0_r. unfold CRminus. - rewrite CRplus_opp_r. rewrite CRplus_opp_r. - rewrite CRabs_right. apply CRle_refl. apply CRle_refl. - rewrite Nat.add_succ_r. - replace (S (n + N)) with (S n + N)%nat. 2: reflexivity. - unfold CRminus. rewrite sum_assoc. rewrite sum_assoc. - rewrite CRopp_plus_distr. - rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l, CRabs_opp. - rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. - rewrite CRplus_0_l. apply multiTriangleIneg. - - apply CR_cv_dist_cont. intros eps. - specialize (H eps) as [N lim]. - exists N. intros. rewrite plus_comm. apply lim. apply (le_trans N i). - assumption. rewrite <- (plus_0_r i). rewrite <- plus_assoc. - apply Nat.add_le_mono_l. apply le_0_n. - - apply CR_cv_plus. 2: apply CR_cv_const. intros eps. - specialize (H0 eps) as [N lim]. - exists N. intros. rewrite plus_comm. apply lim. apply (le_trans N i). - assumption. rewrite <- (plus_0_r i). rewrite <- plus_assoc. - apply Nat.add_le_mono_l. apply le_0_n. -Qed. - -Lemma series_cv_minus : forall {R : ConstructiveReals} - (u v : nat -> CRcarrier R) (s t : CRcarrier R), - series_cv u s - -> series_cv v t - -> series_cv (fun n => u n - v n) (s - t). -Proof. - intros. apply (CR_cv_eq _ (fun n => CRsum u n - CRsum v n)). - intro n. symmetry. unfold CRminus. rewrite sum_plus. - rewrite sum_opp. reflexivity. - apply CR_cv_plus. exact H. apply CR_cv_opp. exact H0. -Qed. - -Lemma series_cv_le : forall {R : ConstructiveReals} - (un vn : nat -> CRcarrier R) (a b : CRcarrier R), - (forall n:nat, un n <= vn n) - -> series_cv un a - -> series_cv vn b - -> a <= b. -Proof. - intros. apply (CRplus_le_reg_r (-a)). rewrite CRplus_opp_r. - apply (series_cv_nonneg (fun n => vn n - un n)). - intro n. apply (CRplus_le_reg_r (un n)). - rewrite CRplus_0_l. unfold CRminus. - rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. - apply H. apply series_cv_minus; assumption. -Qed. - -Lemma series_cv_series : forall {R : ConstructiveReals} - (u : nat -> nat -> CRcarrier R) (s : nat -> CRcarrier R) (n : nat), - (forall i:nat, le i n -> series_cv (u i) (s i)) - -> series_cv (fun i => CRsum (fun j => u j i) n) (CRsum s n). -Proof. - induction n. - - intros. simpl. specialize (H O). - apply (series_cv_eq (u O)). reflexivity. apply H. apply le_refl. - - intros. simpl. apply (series_cv_plus). 2: apply (H (S n)). - apply IHn. 2: apply le_refl. intros. apply H. - apply (le_trans _ n _ H0). apply le_S. apply le_refl. -Qed. - Lemma CR_cv_shift : forall {R : ConstructiveReals} f k l, CR_cv R (fun n => f (n + k)%nat) l -> CR_cv R f l. @@ -880,49 +478,3 @@ Proof. intros R f' k l cvf eps; destruct (cvf eps) as [N Pn]. exists N; intros n nN; apply Pn; auto with arith. Qed. - -Lemma series_cv_shift : - forall {R : ConstructiveReals} (f : nat -> CRcarrier R) k l, - series_cv (fun n => f (S k + n)%nat) l - -> series_cv f (l + CRsum f k). -Proof. - intros. intro p. specialize (H p) as [n nmaj]. - exists (S k+n)%nat. intros. destruct (Nat.le_exists_sub (S k) i). - apply (le_trans _ (S k + 0)). rewrite Nat.add_0_r. apply le_refl. - apply (le_trans _ (S k + n)). apply Nat.add_le_mono_l, le_0_n. - exact H. destruct H0. subst i. - rewrite Nat.add_comm in H. rewrite <- Nat.add_le_mono_r in H. - specialize (nmaj x H). unfold CRminus. - rewrite Nat.add_comm, (sum_assoc f k x). - setoid_replace (CRsum f k + CRsum (fun k0 : nat => f (S k + k0)%nat) x - (l + CRsum f k)) - with (CRsum (fun k0 : nat => f (S k + k0)%nat) x - l). - exact nmaj. unfold CRminus. rewrite (CRplus_comm (CRsum f k)). - rewrite CRplus_assoc. apply CRplus_morph. reflexivity. - rewrite CRplus_comm, CRopp_plus_distr, CRplus_assoc. - rewrite CRplus_opp_l, CRplus_0_r. reflexivity. -Qed. - -Lemma series_cv_shift' : forall {R : ConstructiveReals} - (un : nat -> CRcarrier R) (s : CRcarrier R) (shift : nat), - series_cv un s - -> series_cv (fun n => un (n+shift)%nat) - (s - match shift with - | O => 0 - | S p => CRsum un p - end). -Proof. - intros. destruct shift as [|p]. - - unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. - apply (series_cv_eq un). intros. - rewrite plus_0_r. reflexivity. apply H. - - apply (CR_cv_eq _ (fun n => CRsum un (n + S p) - CRsum un p)). - intros. rewrite plus_comm. unfold CRminus. - rewrite sum_assoc. simpl. rewrite CRplus_comm, <- CRplus_assoc. - rewrite CRplus_opp_l, CRplus_0_l. - apply CRsum_eq. intros. rewrite (plus_comm i). reflexivity. - apply CR_cv_plus. apply (CR_cv_shift' _ (S p) _ H). - intros n. exists (Pos.to_nat n). intros. - unfold CRminus. simpl. - rewrite CRopp_involutive, CRplus_opp_l. rewrite CRabs_right. - apply CR_of_Q_le. discriminate. apply CRle_refl. -Qed. diff --git a/theories/Reals/Abstract/ConstructiveMinMax.v b/theories/Reals/Abstract/ConstructiveMinMax.v new file mode 100644 index 0000000000..b66d416ca4 --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveMinMax.v @@ -0,0 +1,664 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <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) *) +(************************************************************************) +(************************************************************************) + +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveAbs. +Require Import ConstructiveRealsMorphisms. + +Local Open Scope ConstructiveReals. + +(** Definition and properties of minimum and maximum. + + WARNING: this file is experimental and likely to change in future releases. + *) + + +(* Minimum *) + +Definition CRmin {R : ConstructiveReals} (x y : CRcarrier R) : CRcarrier R + := (x + y - CRabs _ (y - x)) * CR_of_Q _ (1#2). + +Lemma CRmin_lt_r : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y < y -> CRmin x y == x. +Proof. + intros. unfold CRmin. unfold CRmin in H. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left; apply CR_of_Q_pos; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l, CRmult_1_r. + rewrite CRabs_right. unfold CRminus. + rewrite CRopp_plus_distr, CRplus_assoc, <- (CRplus_assoc y). + rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity. + apply (CRmult_lt_compat_r (CR_of_Q R 2)) in H. + 2: apply CR_of_Q_pos; reflexivity. + intro abs. contradict H. + apply (CRle_trans _ (x + y - CRabs R (y - x))). + rewrite CRabs_left. 2: apply CRlt_asym, abs. + unfold CRminus. rewrite CRopp_involutive, CRplus_comm. + rewrite CRplus_assoc, <- (CRplus_assoc (-x)), CRplus_opp_l. + rewrite CRplus_0_l, (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRle_refl. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. apply CRle_refl. +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : CRmin + with signature (CReq R) ==> (CReq R) ==> (CReq R) + as CRmin_morph. +Proof. + intros. unfold CRmin. + apply CRmult_morph. 2: reflexivity. + unfold CRminus. + rewrite H, H0. reflexivity. +Qed. + +Instance CRmin_morphT + : forall {R : ConstructiveReals}, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (@CRmin R). +Proof. + intros R x y H z t H0. + rewrite H, H0. reflexivity. +Qed. + +Lemma CRmin_l : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y <= x. +Proof. + intros. unfold CRmin. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_r (CRabs _ (y + - x)+ -x)). + rewrite CRplus_assoc, <- (CRplus_assoc (-CRabs _ (y + - x))). + rewrite CRplus_opp_l, CRplus_0_l. + rewrite (CRplus_comm x), CRplus_assoc, CRplus_opp_l, CRplus_0_r. + apply CRle_abs. +Qed. + +Lemma CRmin_r : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y <= y. +Proof. + intros. unfold CRmin. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + rewrite (CRplus_comm x). + unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite <- (CRopp_involutive y), <- CRopp_plus_distr, <- CRopp_plus_distr. + apply CRopp_ge_le_contravar. rewrite CRabs_opp, CRplus_comm. + apply CRle_abs. +Qed. + +Lemma CRnegPartAbsMin : forall {R : ConstructiveReals} (x : CRcarrier R), + CRmin 0 x == (x - CRabs _ x) * (CR_of_Q _ (1#2)). +Proof. + intros. unfold CRmin. unfold CRminus. rewrite CRplus_0_l. + apply CRmult_morph. 2: reflexivity. rewrite CRopp_0, CRplus_0_r. reflexivity. +Qed. + +Lemma CRmin_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y == CRmin y x. +Proof. + intros. unfold CRmin. apply CRmult_morph. 2: reflexivity. + rewrite CRabs_minus_sym. unfold CRminus. + rewrite (CRplus_comm x y). reflexivity. +Qed. + +Lemma CRmin_mult : + forall {R : ConstructiveReals} (p q r : CRcarrier R), + 0 <= r -> CRmin (r * p) (r * q) == r * CRmin p q. +Proof. + intros R p q r H. unfold CRmin. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_right r). 2: exact H. + rewrite <- CRmult_assoc. apply CRmult_morph. 2: reflexivity. + unfold CRminus. rewrite CRopp_mult_distr_r. + do 2 rewrite <- CRmult_plus_distr_l. reflexivity. + unfold CRminus. rewrite CRopp_mult_distr_r. + rewrite <- CRmult_plus_distr_l. reflexivity. +Qed. + +Lemma CRmin_plus : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x + CRmin y z == CRmin (x + y) (x + z). +Proof. + intros. unfold CRmin. + unfold CRminus. setoid_replace (x + z + - (x + y)) with (z-y). + apply (CRmult_eq_reg_r (CR_of_Q _ 2)). + left. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_plus_distr_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. + do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite (CRplus_comm x). apply CRplus_assoc. + rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. + apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. + apply CRplus_0_l. +Qed. + +Lemma CRmin_left : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= y -> CRmin x y == x. +Proof. + intros. unfold CRmin. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + rewrite CRabs_right. unfold CRminus. rewrite CRopp_plus_distr. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. apply CRopp_involutive. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat. + exact H. apply CRle_refl. +Qed. + +Lemma CRmin_right : forall {R : ConstructiveReals} (x y : CRcarrier R), + y <= x -> CRmin x y == y. +Proof. + intros. unfold CRmin. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + rewrite CRabs_left. unfold CRminus. do 2 rewrite CRopp_plus_distr. + rewrite (CRplus_comm x y). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + do 2 rewrite CRopp_involutive. + rewrite CRplus_comm, CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat. + exact H. apply CRle_refl. +Qed. + +Lemma CRmin_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), + z < x -> z < y -> z < CRmin x y. +Proof. + intros. unfold CRmin. + apply (CRmult_lt_reg_r (CR_of_Q R 2)). + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + apply (CRplus_lt_reg_l _ (CRabs _ (y - x) - (z*CR_of_Q R 2))). + unfold CRminus. rewrite CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_r. + rewrite (CRplus_comm (CRabs R (y + - x))). + rewrite (CRplus_comm (x+y)), CRplus_assoc. + rewrite <- (CRplus_assoc (CRabs R (y + - x))), CRplus_opp_r, CRplus_0_l. + rewrite <- (CRplus_comm (x+y)). + apply CRabs_def1. + - unfold CRminus. rewrite <- (CRplus_comm y), CRplus_assoc. + apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R (-x)). + rewrite CRopp_mult_distr_l. + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym. + apply CRopp_gt_lt_contravar, H. + apply CRopp_gt_lt_contravar, H. + - rewrite CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_comm, CRplus_assoc. + apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R (-y)). + rewrite CRopp_mult_distr_l. + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym. + apply CRopp_gt_lt_contravar, H0. + apply CRopp_gt_lt_contravar, H0. +Qed. + +Lemma CRmin_contract : forall {R : ConstructiveReals} (x y a : CRcarrier R), + CRabs _ (CRmin x a - CRmin y a) <= CRabs _ (x - y). +Proof. + intros. unfold CRmin. + unfold CRminus. rewrite CRopp_mult_distr_l, <- CRmult_plus_distr_r. + rewrite (CRabs_morph + _ ((x - y + (CRabs _ (a - y) - CRabs _ (a - x))) * CR_of_Q R (1 # 2))). + rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). + 2: apply CR_of_Q_le; discriminate. + apply (CRle_trans _ + ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) + * CR_of_Q R (1 # 2))). + apply CRmult_le_compat_r. + apply CR_of_Q_le. discriminate. + apply (CRle_trans + _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - y) - CRabs _ (a - x)))). + apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. + rewrite (CRabs_morph (x-y) ((a-y)-(a-x))). + apply CRabs_triang_inv2. + unfold CRminus. rewrite (CRplus_comm (a + - y)). + rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. + rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. + reflexivity. + rewrite <- CRmult_plus_distr_l. + rewrite <- (CR_of_Q_plus R 1 1). + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. apply CRle_refl. + unfold CRminus. apply CRmult_morph. 2: reflexivity. + do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc. rewrite CRplus_comm, CRopp_plus_distr. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRopp_plus_distr. rewrite (CRplus_comm (-a)). + rewrite CRplus_assoc, <- (CRplus_assoc (-a)), CRplus_opp_l. + rewrite CRplus_0_l, CRopp_involutive. reflexivity. +Qed. + +Lemma CRmin_glb : forall {R : ConstructiveReals} (x y z:CRcarrier R), + z <= x -> z <= y -> z <= CRmin x y. +Proof. + intros. unfold CRmin. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + apply (CRplus_le_reg_l (CRabs _ (y-x) - (z*CR_of_Q R 2))). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + rewrite (CRplus_comm (CRabs R (y + - x) + - (z * CR_of_Q R 2))). + rewrite CRplus_assoc, <- (CRplus_assoc (- CRabs R (y + - x))). + rewrite CRplus_opp_l, CRplus_0_l. + apply CRabs_le. split. + - do 2 rewrite CRopp_plus_distr. + rewrite CRopp_involutive, (CRplus_comm y), CRplus_assoc. + apply CRplus_le_compat_l, (CRplus_le_reg_l y). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_compat; exact H0. + - rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite CRopp_mult_distr_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. + rewrite CRmult_1_r. + apply CRplus_le_compat; apply CRopp_ge_le_contravar; exact H. +Qed. + +Lemma CRmin_assoc : forall {R : ConstructiveReals} (a b c : CRcarrier R), + CRmin a (CRmin b c) == CRmin (CRmin a b) c. +Proof. + split. + - apply CRmin_glb. + + apply (CRle_trans _ (CRmin a b)). + apply CRmin_l. apply CRmin_l. + + apply CRmin_glb. + apply (CRle_trans _ (CRmin a b)). + apply CRmin_l. apply CRmin_r. apply CRmin_r. + - apply CRmin_glb. + + apply CRmin_glb. apply CRmin_l. + apply (CRle_trans _ (CRmin b c)). + apply CRmin_r. apply CRmin_l. + + apply (CRle_trans _ (CRmin b c)). + apply CRmin_r. apply CRmin_r. +Qed. + +Lemma CRlt_min : forall {R : ConstructiveReals} (x y z : CRcarrier R), + z < CRmin x y -> prod (z < x) (z < y). +Proof. + intros. destruct (CR_Q_dense R _ _ H) as [q qmaj]. + destruct qmaj. + split. + - apply (CRlt_le_trans _ (CR_of_Q R q) _ c). + intro abs. apply (CRlt_asym _ _ c0). + apply (CRle_lt_trans _ x). apply CRmin_l. exact abs. + - apply (CRlt_le_trans _ (CR_of_Q R q) _ c). + intro abs. apply (CRlt_asym _ _ c0). + apply (CRle_lt_trans _ y). apply CRmin_r. exact abs. +Qed. + + + +(* Maximum *) + +Definition CRmax {R : ConstructiveReals} (x y : CRcarrier R) : CRcarrier R + := (x + y + CRabs _ (y - x)) * CR_of_Q _ (1#2). + +Add Parametric Morphism {R : ConstructiveReals} : CRmax + with signature (CReq R) ==> (CReq R) ==> (CReq R) + as CRmax_morph. +Proof. + intros. unfold CRmax. + apply CRmult_morph. 2: reflexivity. unfold CRminus. + rewrite H, H0. reflexivity. +Qed. + +Instance CRmax_morphT + : forall {R : ConstructiveReals}, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (@CRmax R). +Proof. + intros R x y H z t H0. + rewrite H, H0. reflexivity. +Qed. + +Lemma CRmax_lub : forall {R : ConstructiveReals} (x y z:CRcarrier R), + x <= z -> y <= z -> CRmax x y <= z. +Proof. + intros. unfold CRmax. + apply (CRmult_le_reg_r (CR_of_Q _ 2)). + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + apply (CRplus_le_reg_l (-x-y)). + rewrite <- CRplus_assoc. unfold CRminus. + rewrite <- CRopp_plus_distr, CRplus_opp_l, CRplus_0_l. + apply CRabs_le. split. + - repeat rewrite CRopp_plus_distr. + do 2 rewrite CRopp_involutive. + rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + rewrite CRopp_plus_distr. + apply CRplus_le_compat; apply CRopp_ge_le_contravar; assumption. + - rewrite (CRplus_comm y), CRopp_plus_distr, CRplus_assoc. + apply CRplus_le_compat_l. + apply (CRplus_le_reg_l y). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + apply CRplus_le_compat; assumption. +Qed. + +Lemma CRmax_l : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= CRmax x y. +Proof. + intros. unfold CRmax. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + setoid_replace 2%Q with (1+1)%Q. rewrite CR_of_Q_plus. + rewrite CRmult_plus_distr_l, CRmult_1_r, CRplus_assoc. + apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-y)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite CRabs_minus_sym, CRplus_comm. + apply CRle_abs. reflexivity. +Qed. + +Lemma CRmax_r : forall {R : ConstructiveReals} (x y : CRcarrier R), + y <= CRmax x y. +Proof. + intros. unfold CRmax. + apply (CRmult_le_reg_r (CR_of_Q _ 2)). + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + rewrite (CRplus_comm x). + rewrite CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite CRplus_comm. apply CRle_abs. +Qed. + +Lemma CRposPartAbsMax : forall {R : ConstructiveReals} (x : CRcarrier R), + CRmax 0 x == (x + CRabs _ x) * (CR_of_Q R (1#2)). +Proof. + intros. unfold CRmax. unfold CRminus. rewrite CRplus_0_l. + apply CRmult_morph. 2: reflexivity. rewrite CRopp_0, CRplus_0_r. reflexivity. +Qed. + +Lemma CRmax_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmax x y == CRmax y x. +Proof. + intros. unfold CRmax. + rewrite CRabs_minus_sym. apply CRmult_morph. + 2: reflexivity. rewrite (CRplus_comm x y). reflexivity. +Qed. + +Lemma CRmax_plus : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x + CRmax y z == CRmax (x + y) (x + z). +Proof. + intros. unfold CRmax. + setoid_replace (x + z - (x + y)) with (z-y). + apply (CRmult_eq_reg_r (CR_of_Q _ 2)). + left. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_plus_distr_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + rewrite CRmult_1_r. + do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. + do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite (CRplus_comm x). apply CRplus_assoc. + unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. + apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. + apply CRplus_0_l. +Qed. + +Lemma CRmax_left : forall {R : ConstructiveReals} (x y : CRcarrier R), + y <= x -> CRmax x y == x. +Proof. + intros. unfold CRmax. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRabs_left. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r. exact H. +Qed. + +Lemma CRmax_right : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= y -> CRmax x y == y. +Proof. + intros. unfold CRmax. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CRmult_1_r. + rewrite (CRplus_comm x y). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRabs_right. unfold CRminus. rewrite CRplus_comm. + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r. exact H. +Qed. + +Lemma CRmax_contract : forall {R : ConstructiveReals} (x y a : CRcarrier R), + CRabs _ (CRmax x a - CRmax y a) <= CRabs _ (x - y). +Proof. + intros. unfold CRmax. + rewrite (CRabs_morph + _ ((x - y + (CRabs _ (a - x) - CRabs _ (a - y))) * CR_of_Q R (1 # 2))). + rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). + 2: apply CR_of_Q_le; discriminate. + apply (CRle_trans + _ ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) + * CR_of_Q R (1 # 2))). + apply CRmult_le_compat_r. + apply CR_of_Q_le. discriminate. + apply (CRle_trans + _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - x) - CRabs _ (a - y)))). + apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. + rewrite (CRabs_minus_sym x y). + rewrite (CRabs_morph (y-x) ((a-x)-(a-y))). + apply CRabs_triang_inv2. + unfold CRminus. rewrite (CRplus_comm (a + - x)). + rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. + rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. + reflexivity. + rewrite <- CRmult_plus_distr_l. + rewrite <- (CR_of_Q_plus R 1 1). + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. apply CRle_refl. + unfold CRminus. rewrite CRopp_mult_distr_l. + rewrite <- CRmult_plus_distr_r. apply CRmult_morph. 2: reflexivity. + do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc. rewrite CRplus_comm, CRopp_plus_distr. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRopp_plus_distr. rewrite (CRplus_comm (-a)). + rewrite CRplus_assoc, <- (CRplus_assoc (-a)), CRplus_opp_l. + rewrite CRplus_0_l. apply CRplus_comm. +Qed. + +Lemma CRmax_lub_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x < z -> y < z -> CRmax x y < z. +Proof. + intros. unfold CRmax. + apply (CRmult_lt_reg_r (CR_of_Q R 2)). + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CRmult_1_r. + apply (CRplus_lt_reg_l _ (-y -x)). unfold CRminus. + rewrite CRplus_assoc, <- (CRplus_assoc (-x)), <- (CRplus_assoc (-x)). + rewrite CRplus_opp_l, CRplus_0_l, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + apply CRabs_def1. + - rewrite (CRplus_comm y), (CRplus_comm (-y)), CRplus_assoc. + apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l _ y). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym, H0. exact H0. + - rewrite CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_assoc. apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l _ x). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym, H. exact H. +Qed. + +Lemma CRmax_assoc : forall {R : ConstructiveReals} (a b c : CRcarrier R), + CRmax a (CRmax b c) == CRmax (CRmax a b) c. +Proof. + split. + - apply CRmax_lub. + + apply CRmax_lub. apply CRmax_l. + apply (CRle_trans _ (CRmax b c)). + apply CRmax_l. apply CRmax_r. + + apply (CRle_trans _ (CRmax b c)). + apply CRmax_r. apply CRmax_r. + - apply CRmax_lub. + + apply (CRle_trans _ (CRmax a b)). + apply CRmax_l. apply CRmax_l. + + apply CRmax_lub. + apply (CRle_trans _ (CRmax a b)). + apply CRmax_r. apply CRmax_l. apply CRmax_r. +Qed. + +Lemma CRmax_min_mult_neg : + forall {R : ConstructiveReals} (p q r:CRcarrier R), + r <= 0 -> CRmax (r * p) (r * q) == r * CRmin p q. +Proof. + intros R p q r H. unfold CRmin, CRmax. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_left r), <- CRmult_assoc. + apply CRmult_morph. 2: reflexivity. unfold CRminus. + rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, + CRmult_plus_distr_l, CRmult_plus_distr_l. + reflexivity. exact H. + unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. +Qed. + +Lemma CRlt_max : forall {R : ConstructiveReals} (x y z : CRcarrier R), + CRmax x y < z -> prod (x < z) (y < z). +Proof. + intros. destruct (CR_Q_dense R _ _ H) as [q qmaj]. + destruct qmaj. + split. + - apply (CRlt_le_trans _ (CR_of_Q R q)). + apply (CRle_lt_trans _ (CRmax x y)). apply CRmax_l. exact c. + apply CRlt_asym, c0. + - apply (CRlt_le_trans _ (CR_of_Q R q)). + apply (CRle_lt_trans _ (CRmax x y)). apply CRmax_r. exact c. + apply CRlt_asym, c0. +Qed. + +Lemma CRmax_mult : + forall {R : ConstructiveReals} (p q r:CRcarrier R), + 0 <= r -> CRmax (r * p) (r * q) == r * CRmax p q. +Proof. + intros R p q r H. unfold CRmin, CRmax. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_right r), <- CRmult_assoc. + apply CRmult_morph. 2: reflexivity. + rewrite CRmult_plus_distr_l, CRmult_plus_distr_l. + reflexivity. exact H. + unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. +Qed. + +Lemma CRmin_max_mult_neg : + forall {R : ConstructiveReals} (p q r:CRcarrier R), + r <= 0 -> CRmin (r * p) (r * q) == r * CRmax p q. +Proof. + intros R p q r H. unfold CRmin, CRmax. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_left r), <- CRmult_assoc. + apply CRmult_morph. 2: reflexivity. unfold CRminus. + rewrite CRopp_mult_distr_l, CRopp_involutive, + CRmult_plus_distr_l, CRmult_plus_distr_l. + reflexivity. exact H. + unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. +Qed. + +Lemma CRmorph_min : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (a b : CRcarrier R1), + CRmorph f (CRmin a b) + == CRmin (CRmorph f a) (CRmorph f b). +Proof. + intros. unfold CRmin. + rewrite CRmorph_mult. apply CRmult_morph. + 2: apply CRmorph_rat. + unfold CRminus. do 2 rewrite CRmorph_plus. apply CRplus_morph. + apply CRplus_morph. reflexivity. reflexivity. + rewrite CRmorph_opp. apply CRopp_morph. + rewrite <- CRmorph_abs. apply CRabs_morph. + rewrite CRmorph_plus. apply CRplus_morph. + reflexivity. + rewrite CRmorph_opp. apply CRopp_morph, CRmorph_proper. reflexivity. +Qed. diff --git a/theories/Reals/Abstract/ConstructivePower.v b/theories/Reals/Abstract/ConstructivePower.v new file mode 100644 index 0000000000..2bde1aef42 --- /dev/null +++ b/theories/Reals/Abstract/ConstructivePower.v @@ -0,0 +1,251 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <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) *) +(************************************************************************) + +Require Import QArith Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveRealsMorphisms. +Require Import ConstructiveAbs. +Require Import ConstructiveLimits. +Require Import ConstructiveSum. + +Local Open Scope ConstructiveReals. + + +(** + Definition and properties of powers. + + WARNING: this file is experimental and likely to change in future releases. +*) + +Fixpoint CRpow {R : ConstructiveReals} (r:CRcarrier R) (n:nat) : CRcarrier R := + match n with + | O => 1 + | S n => r * (CRpow r n) + end. + +Lemma CRpow_ge_one : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), + 1 <= x + -> 1 <= CRpow x n. +Proof. + induction n. + - intros. apply CRle_refl. + - intros. simpl. apply (CRle_trans _ (x * 1)). + rewrite CRmult_1_r. exact H. + apply CRmult_le_compat_l_half. apply (CRlt_le_trans _ 1). + apply CRzero_lt_one. exact H. + apply IHn. exact H. +Qed. + +Lemma CRpow_ge_zero : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), + 0 <= x + -> 0 <= CRpow x n. +Proof. + induction n. + - intros. apply CRlt_asym, CRzero_lt_one. + - intros. simpl. apply CRmult_le_0_compat. + exact H. apply IHn. exact H. +Qed. + +Lemma CRpow_gt_zero : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), + 0 < x + -> 0 < CRpow x n. +Proof. + induction n. + - intros. apply CRzero_lt_one. + - intros. simpl. apply CRmult_lt_0_compat. exact H. + apply IHn. exact H. +Qed. + +Lemma CRpow_mult : forall {R : ConstructiveReals} (x y : CRcarrier R) (n:nat), + CRpow x n * CRpow y n == CRpow (x*y) n. +Proof. + induction n. + - simpl. rewrite CRmult_1_r. reflexivity. + - simpl. rewrite <- IHn. do 2 rewrite <- (Rmul_assoc (CRisRing R)). + apply CRmult_morph. reflexivity. + rewrite <- (Rmul_comm (CRisRing R)). rewrite <- (Rmul_assoc (CRisRing R)). + apply CRmult_morph. reflexivity. + rewrite <- (Rmul_comm (CRisRing R)). reflexivity. +Qed. + +Lemma CRpow_one : forall {R : ConstructiveReals} (n:nat), + @CRpow R 1 n == 1. +Proof. + induction n. reflexivity. + transitivity (CRmult R 1 (CRpow 1 n)). reflexivity. + rewrite IHn. rewrite CRmult_1_r. reflexivity. +Qed. + +Lemma CRpow_proper : forall {R : ConstructiveReals} (x y : CRcarrier R) (n : nat), + x == y -> CRpow x n == CRpow y n. +Proof. + induction n. + - intros. reflexivity. + - intros. simpl. rewrite IHn, H. reflexivity. exact H. +Qed. + +Lemma CRpow_inv : forall {R : ConstructiveReals} (x : CRcarrier R) (xPos : 0 < x) (n : nat), + CRpow (CRinv R x (inr xPos)) n + == CRinv R (CRpow x n) (inr (CRpow_gt_zero x n xPos)). +Proof. + induction n. + - rewrite CRinv_1. reflexivity. + - transitivity (CRinv R x (inr xPos) * CRpow (CRinv R x (inr xPos)) n). + reflexivity. rewrite IHn. + assert (0 < x * CRpow x n). + { apply CRmult_lt_0_compat. exact xPos. apply CRpow_gt_zero, xPos. } + rewrite <- (CRinv_mult_distr _ _ _ _ (inr H)). + apply CRinv_morph. reflexivity. +Qed. + +Lemma CRpow_plus_distr : forall {R : ConstructiveReals} (x : CRcarrier R) (n p:nat), + CRpow x n * CRpow x p == CRpow x (n+p). +Proof. + induction n. + - intros. simpl. rewrite CRmult_1_l. reflexivity. + - intros. simpl. rewrite CRmult_assoc. apply CRmult_morph. + reflexivity. apply IHn. +Qed. + +Lemma CR_double : forall {R : ConstructiveReals} (x:CRcarrier R), + CR_of_Q R 2 * x == x + x. +Proof. + intros R x. rewrite (CR_of_Q_morph R 2 (1+1)). + 2: reflexivity. rewrite CR_of_Q_plus. + rewrite CRmult_plus_distr_r, CRmult_1_l. reflexivity. +Qed. + +Lemma GeoCvZero : forall {R : ConstructiveReals}, + CR_cv R (fun n:nat => CRpow (CR_of_Q R (1#2)) n) 0. +Proof. + intro R. assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). + { induction n. unfold INR; simpl. + apply CRzero_lt_one. unfold INR. fold (1+n)%nat. + rewrite Nat2Z.inj_add. + rewrite (CR_of_Q_morph R _ ((Z.of_nat 1 # 1) + (Z.of_nat n #1))). + 2: symmetry; apply Qinv_plus_distr. + rewrite CR_of_Q_plus. + replace (CRpow (CR_of_Q R 2) (1 + n)) + with (CR_of_Q R 2 * CRpow (CR_of_Q R 2) n). + 2: reflexivity. rewrite CR_double. + apply CRplus_le_lt_compat. + 2: exact IHn. simpl. + apply CRpow_ge_one. apply CR_of_Q_le. discriminate. } + intros p. exists (Pos.to_nat p). intros. + unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. + rewrite CRabs_right. + 2: apply CRpow_ge_zero; apply CR_of_Q_le; discriminate. + apply CRlt_asym. + apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos p # 1))). + apply CR_of_Q_lt. reflexivity. rewrite <- CR_of_Q_mult. + rewrite (CR_of_Q_morph R ((Z.pos p # 1) * (1 # p)) 1). + 2: unfold Qmult, Qeq, Qnum, Qden; ring_simplify; reflexivity. + apply (CRmult_lt_reg_r (CRpow (CR_of_Q R 2) i)). + apply CRpow_gt_zero. + apply CR_of_Q_lt. reflexivity. + rewrite CRmult_assoc. rewrite CRpow_mult. + rewrite (CRpow_proper (CR_of_Q R (1 # 2) * CR_of_Q R 2) 1), CRpow_one. + rewrite CRmult_1_r, CRmult_1_l. + apply (CRle_lt_trans _ (INR i)). 2: exact (H i). clear H. + apply CR_of_Q_le. unfold Qle,Qnum,Qden. + do 2 rewrite Z.mul_1_r. + rewrite <- positive_nat_Z. apply Nat2Z.inj_le, H0. + rewrite <- CR_of_Q_mult. setoid_replace ((1#2)*2)%Q with 1%Q. + reflexivity. reflexivity. +Qed. + +Lemma GeoFiniteSum : forall {R : ConstructiveReals} (n:nat), + CRsum (CRpow (CR_of_Q R (1#2))) n == CR_of_Q R 2 - CRpow (CR_of_Q R (1#2)) n. +Proof. + induction n. + - unfold CRsum, CRpow. simpl (1%ConstructiveReals). + unfold CRminus. rewrite (CR_of_Q_plus R 1 1). + rewrite CRplus_assoc. + rewrite CRplus_opp_r, CRplus_0_r. reflexivity. + - setoid_replace (CRsum (CRpow (CR_of_Q R (1 # 2))) (S n)) + with (CRsum (CRpow (CR_of_Q R (1 # 2))) n + CRpow (CR_of_Q R (1 # 2)) (S n)). + 2: reflexivity. + rewrite IHn. clear IHn. unfold CRminus. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + apply (CRplus_eq_reg_l + (CRpow (CR_of_Q R (1 # 2)) n + CRpow (CR_of_Q R (1 # 2)) (S n))). + rewrite (CRplus_assoc _ _ (-CRpow (CR_of_Q R (1 # 2)) (S n))), + CRplus_opp_r, CRplus_0_r. + rewrite (CRplus_comm (CRpow (CR_of_Q R (1 # 2)) n)), CRplus_assoc. + rewrite <- (CRplus_assoc (CRpow (CR_of_Q R (1 # 2)) n)), CRplus_opp_r, + CRplus_0_l, <- CR_double. + setoid_replace (CRpow (CR_of_Q R (1 # 2)) (S n)) + with (CR_of_Q R (1 # 2) * CRpow (CR_of_Q R (1 # 2)) n). + 2: reflexivity. + rewrite <- CRmult_assoc, <- CR_of_Q_mult. + setoid_replace (2 * (1 # 2))%Q with 1%Q. + apply CRmult_1_l. reflexivity. +Qed. + +Lemma GeoHalfBelowTwo : forall {R : ConstructiveReals} (n:nat), + CRsum (CRpow (CR_of_Q R (1#2))) n < CR_of_Q R 2. +Proof. + intros. rewrite <- (CRplus_0_r (CR_of_Q R 2)), GeoFiniteSum. + apply CRplus_lt_compat_l. rewrite <- CRopp_0. + apply CRopp_gt_lt_contravar. + apply CRpow_gt_zero. apply CR_of_Q_lt. reflexivity. +Qed. + +Lemma GeoHalfTwo : forall {R : ConstructiveReals}, + series_cv (fun n => CRpow (CR_of_Q R (1#2)) n) (CR_of_Q R 2). +Proof. + intro R. + apply (CR_cv_eq _ (fun n => CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) n)). + - intro n. rewrite GeoFiniteSum. reflexivity. + - assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). + { induction n. unfold INR; simpl. + apply CRzero_lt_one. apply (CRlt_le_trans _ (CRpow (CR_of_Q R 2) n + 1)). + unfold INR. + rewrite Nat2Z.inj_succ, <- Z.add_1_l. + rewrite (CR_of_Q_morph R _ (1 + (Z.of_nat n #1))). + 2: symmetry; apply Qinv_plus_distr. rewrite CR_of_Q_plus. + rewrite CRplus_comm. + apply CRplus_lt_compat_r, IHn. + setoid_replace (CRpow (CR_of_Q R 2) (S n)) + with (CRpow (CR_of_Q R 2) n + CRpow (CR_of_Q R 2) n). + apply CRplus_le_compat. apply CRle_refl. + apply CRpow_ge_one. apply CR_of_Q_le. discriminate. + rewrite <- CR_double. reflexivity. } + intros n. exists (Pos.to_nat n). intros. + setoid_replace (CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) i - CR_of_Q R 2) + with (- CRpow (CR_of_Q R (1 # 2)) i). + rewrite CRabs_opp. rewrite CRabs_right. + assert (0 < CR_of_Q R 2). + { apply CR_of_Q_lt. reflexivity. } + rewrite (CRpow_proper _ (CRinv R (CR_of_Q R 2) (inr H1))). + rewrite CRpow_inv. apply CRlt_asym. + apply (CRmult_lt_reg_l (CRpow (CR_of_Q R 2) i)). apply CRpow_gt_zero, H1. + rewrite CRinv_r. + apply (CRmult_lt_reg_r (CR_of_Q R (Z.pos n#1))). + apply CR_of_Q_lt. reflexivity. + rewrite CRmult_1_l, CRmult_assoc. + rewrite <- CR_of_Q_mult. + rewrite (CR_of_Q_morph R ((1 # n) * (Z.pos n # 1)) 1). 2: reflexivity. + rewrite CRmult_1_r. apply (CRle_lt_trans _ (INR i)). + 2: apply H. apply CR_of_Q_le. + unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. destruct i. + exfalso. inversion H0. pose proof (Pos2Nat.is_pos n). + rewrite H3 in H2. inversion H2. + apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. + apply (le_trans _ _ _ H0). rewrite SuccNat2Pos.id_succ. apply le_refl. + apply (CRmult_eq_reg_l (CR_of_Q R 2)). right. exact H1. + rewrite CRinv_r. rewrite <- CR_of_Q_mult. + setoid_replace (2 * (1 # 2))%Q with 1%Q. + reflexivity. reflexivity. + apply CRlt_asym, CRpow_gt_zero. + apply CR_of_Q_lt. reflexivity. + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_l. reflexivity. +Qed. diff --git a/theories/Reals/Abstract/ConstructiveReals.v b/theories/Reals/Abstract/ConstructiveReals.v index 019428a5b0..60fad8795a 100644 --- a/theories/Reals/Abstract/ConstructiveReals.v +++ b/theories/Reals/Abstract/ConstructiveReals.v @@ -64,7 +64,10 @@ Structure R := { on the real numbers. In "Sheaves in Geometry and Logic", MacLane and Moerdijk show a topos in which all functions R -> Z are constant. Consequently all functions R -> Q are constant and - it is not possible to approximate real numbers by rational numbers. *) + it is not possible to approximate real numbers by rational numbers. + + WARNING: this file is experimental and likely to change in future releases. + *) Require Import QArith Qabs Qround. diff --git a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v index cf302dc847..53b5aca38c 100644 --- a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v +++ b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v @@ -23,14 +23,16 @@ Apart from the speed, those unique isomorphisms also serve as sanity checks of the interface ConstructiveReals : - it captures a concept with a strong notion of uniqueness. *) + it captures a concept with a strong notion of uniqueness. + + WARNING: this file is experimental and likely to change in future releases. +*) Require Import QArith. Require Import Qabs. Require Import ConstructiveReals. Require Import ConstructiveLimits. Require Import ConstructiveAbs. -Require Import ConstructiveSum. Local Open Scope ConstructiveReals. @@ -889,37 +891,6 @@ Proof. apply CRmorph_one. Qed. -Lemma CRmorph_sum : forall {R1 R2 : ConstructiveReals} - (f : @ConstructiveRealsMorphism R1 R2) - (un : nat -> CRcarrier R1) (n : nat), - CRmorph f (CRsum un n) == - CRsum (fun n0 : nat => CRmorph f (un n0)) n. -Proof. - induction n. - - reflexivity. - - simpl. rewrite CRmorph_plus, IHn. reflexivity. -Qed. - -Lemma CRmorph_INR : forall {R1 R2 : ConstructiveReals} - (f : @ConstructiveRealsMorphism R1 R2) - (n : nat), - CRmorph f (INR n) == INR n. -Proof. - induction n. - - apply CRmorph_rat. - - simpl. unfold INR. - rewrite (CRmorph_proper f _ (1 + CR_of_Q R1 (Z.of_nat n # 1))). - rewrite CRmorph_plus. unfold INR in IHn. - rewrite IHn. rewrite CRmorph_one, <- CR_of_Q_plus. - apply CR_of_Q_morph. rewrite Qinv_plus_distr. - unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. - rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. - rewrite <- CR_of_Q_plus. - apply CR_of_Q_morph. rewrite Qinv_plus_distr. - unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. - rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. -Qed. - Lemma CRmorph_rat_cv : forall {R1 R2 : ConstructiveReals} (qn : nat -> Q), @@ -1139,34 +1110,3 @@ Proof. rewrite <- (CRmorph_rat f (1#p)) in H. apply (CRmorph_le_inv f) in H. exact H. Qed. - -Lemma CRmorph_min : forall {R1 R2 : ConstructiveReals} - (f : @ConstructiveRealsMorphism R1 R2) - (a b : CRcarrier R1), - CRmorph f (CRmin a b) - == CRmin (CRmorph f a) (CRmorph f b). -Proof. - intros. unfold CRmin. - rewrite CRmorph_mult. apply CRmult_morph. - 2: apply CRmorph_rat. - unfold CRminus. do 2 rewrite CRmorph_plus. apply CRplus_morph. - apply CRplus_morph. reflexivity. reflexivity. - rewrite CRmorph_opp. apply CRopp_morph. - rewrite <- CRmorph_abs. apply CRabs_morph. - rewrite CRmorph_plus. apply CRplus_morph. - reflexivity. - rewrite CRmorph_opp. apply CRopp_morph, CRmorph_proper. reflexivity. -Qed. - -Lemma CRmorph_series_cv : forall {R1 R2 : ConstructiveReals} - (f : @ConstructiveRealsMorphism R1 R2) - (un : nat -> CRcarrier R1) - (l : CRcarrier R1), - series_cv un l - -> series_cv (fun n => CRmorph f (un n)) (CRmorph f l). -Proof. - intros. - apply (CR_cv_eq _ (fun n => CRmorph f (CRsum un n))). - intro n. apply CRmorph_sum. - apply CRmorph_cv, H. -Qed. diff --git a/theories/Reals/Abstract/ConstructiveSum.v b/theories/Reals/Abstract/ConstructiveSum.v index 3be03bf615..147c45e4f4 100644 --- a/theories/Reals/Abstract/ConstructiveSum.v +++ b/theories/Reals/Abstract/ConstructiveSum.v @@ -10,13 +10,17 @@ Require Import QArith Qabs. Require Import ConstructiveReals. +Require Import ConstructiveRealsMorphisms. Require Import ConstructiveAbs. +Require Import ConstructiveLimits. Local Open Scope ConstructiveReals. (** Definition and properties of finite sums and powers. + + WARNING: this file is experimental and likely to change in future releases. *) Fixpoint CRsum {R : ConstructiveReals} @@ -26,12 +30,6 @@ Fixpoint CRsum {R : ConstructiveReals} | S i => CRsum f i + f (S i) end. -Fixpoint CRpow {R : ConstructiveReals} (r:CRcarrier R) (n:nat) : CRcarrier R := - match n with - | O => 1 - | S n => r * (CRpow r n) - end. - Lemma CRsum_eq : forall {R : ConstructiveReals} (An Bn:nat -> CRcarrier R) (N:nat), (forall i:nat, (i <= N)%nat -> An i == Bn i) -> @@ -260,89 +258,333 @@ Proof. reflexivity. rewrite CRplus_0_r. rewrite CRplus_assoc. reflexivity. Qed. +Definition series_cv {R : ConstructiveReals} + (un : nat -> CRcarrier R) (s : CRcarrier R) : Set + := CR_cv R (CRsum un) s. + +Definition series_cv_lim_lt {R : ConstructiveReals} + (un : nat -> CRcarrier R) (x : CRcarrier R) : Set + := { l : CRcarrier R & prod (series_cv un l) (l < x) }. -(* Power *) +Definition series_cv_le_lim {R : ConstructiveReals} + (x : CRcarrier R) (un : nat -> CRcarrier R) : Set + := { l : CRcarrier R & prod (series_cv un l) (x <= l) }. -Lemma pow_R1_Rle : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), - 1 <= x - -> 1 <= CRpow x n. +Lemma series_cv_maj : forall {R : ConstructiveReals} + (un vn : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, CRabs R (un n) <= vn n) + -> series_cv vn s + -> { l : CRcarrier R & prod (series_cv un l) (l <= s) }. Proof. - induction n. - - intros. apply CRle_refl. - - intros. simpl. apply (CRle_trans _ (x * 1)). - rewrite CRmult_1_r. exact H. - apply CRmult_le_compat_l_half. apply (CRlt_le_trans _ 1). - apply CRzero_lt_one. exact H. - apply IHn. exact H. + intros. destruct (CR_complete R (CRsum un)). + - intros n. + specialize (H0 (2*n)%positive) as [N maj]. + exists N. intros i j H0 H1. + apply (CRle_trans _ (CRsum vn (max i j) - CRsum vn (min i j))). + apply Abs_sum_maj. apply H. + setoid_replace (CRsum vn (max i j) - CRsum vn (min i j)) + with (CRabs R (CRsum vn (max i j) - (CRsum vn (min i j)))). + setoid_replace (CRsum vn (Init.Nat.max i j) - CRsum vn (Init.Nat.min i j)) + with (CRsum vn (Init.Nat.max i j) - s - (CRsum vn (Init.Nat.min i j) - s)). + apply (CRle_trans _ _ _ (CRabs_triang _ _)). + setoid_replace (1#n)%Q with ((1#2*n) + (1#2*n))%Q. + rewrite CR_of_Q_plus. + apply CRplus_le_compat. + apply maj. apply (le_trans _ i). assumption. apply Nat.le_max_l. + rewrite CRabs_opp. apply maj. + apply Nat.min_case. apply (le_trans _ i). assumption. apply le_refl. + assumption. rewrite Qinv_plus_distr. reflexivity. + unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. + reflexivity. rewrite CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_comm, CRplus_assoc, CRplus_opp_r, CRplus_0_r. + reflexivity. + rewrite CRabs_right. reflexivity. + rewrite <- (CRplus_opp_r (CRsum vn (Init.Nat.min i j))). + apply CRplus_le_compat. apply pos_sum_more. + intros. apply (CRle_trans _ (CRabs R (un k))). apply CRabs_pos. + apply H. apply (le_trans _ i). apply Nat.le_min_l. apply Nat.le_max_l. + apply CRle_refl. + - exists x. split. assumption. + (* x <= s *) + apply (CRplus_le_reg_r (-x)). rewrite CRplus_opp_r. + apply (CR_cv_bound_down (fun n => CRsum vn n - CRsum un n) _ _ 0). + intros. rewrite <- (CRplus_opp_r (CRsum un n)). + apply CRplus_le_compat. apply sum_Rle. + intros. apply (CRle_trans _ (CRabs R (un k))). + apply CRle_abs. apply H. apply CRle_refl. + apply CR_cv_plus. assumption. + apply CR_cv_opp. assumption. Qed. -Lemma pow_le : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), - 0 <= x - -> 0 <= CRpow x n. +Lemma series_cv_abs_lt + : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (l : CRcarrier R), + (forall n:nat, CRabs R (un n) <= vn n) + -> series_cv_lim_lt vn l + -> series_cv_lim_lt un l. Proof. - induction n. - - intros. apply CRlt_asym, CRzero_lt_one. - - intros. simpl. apply CRmult_le_0_compat. - exact H. apply IHn. exact H. + intros. destruct H0 as [x [H0 H1]]. + destruct (series_cv_maj un vn x H H0) as [x0 H2]. + exists x0. split. apply H2. apply (CRle_lt_trans _ x). + apply H2. apply H1. Qed. -Lemma pow_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), - 0 < x - -> 0 < CRpow x n. +Definition series_cv_abs {R : ConstructiveReals} (u : nat -> CRcarrier R) + : CR_cauchy R (CRsum (fun n => CRabs R (u n))) + -> { l : CRcarrier R & series_cv u l }. Proof. - induction n. - - intros. apply CRzero_lt_one. - - intros. simpl. apply CRmult_lt_0_compat. exact H. - apply IHn. exact H. + intros. apply CR_complete in H. destruct H. + destruct (series_cv_maj u (fun k => CRabs R (u k)) x). + intro n. apply CRle_refl. assumption. exists x0. apply p. Qed. -Lemma pow_mult : forall {R : ConstructiveReals} (x y : CRcarrier R) (n:nat), - CRpow x n * CRpow y n == CRpow (x*y) n. +Lemma series_cv_unique : + forall {R : ConstructiveReals} (Un:nat -> CRcarrier R) (l1 l2:CRcarrier R), + series_cv Un l1 -> series_cv Un l2 -> l1 == l2. Proof. - induction n. - - simpl. rewrite CRmult_1_r. reflexivity. - - simpl. rewrite <- IHn. do 2 rewrite <- (Rmul_assoc (CRisRing R)). - apply CRmult_morph. reflexivity. - rewrite <- (Rmul_comm (CRisRing R)). rewrite <- (Rmul_assoc (CRisRing R)). - apply CRmult_morph. reflexivity. - rewrite <- (Rmul_comm (CRisRing R)). reflexivity. + intros. apply (CR_cv_unique (CRsum Un)); assumption. Qed. -Lemma pow_one : forall {R : ConstructiveReals} (n:nat), - @CRpow R 1 n == 1. +Lemma series_cv_abs_eq + : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (a : CRcarrier R) + (cau : CR_cauchy R (CRsum (fun n => CRabs R (u n)))), + series_cv u a + -> (a == (let (l,_):= series_cv_abs u cau in l))%ConstructiveReals. Proof. - induction n. reflexivity. - transitivity (CRmult R 1 (CRpow 1 n)). reflexivity. - rewrite IHn. rewrite CRmult_1_r. reflexivity. + intros. destruct (series_cv_abs u cau). + apply (series_cv_unique u). exact H. exact s. Qed. -Lemma pow_proper : forall {R : ConstructiveReals} (x y : CRcarrier R) (n : nat), - x == y -> CRpow x n == CRpow y n. +Lemma series_cv_abs_cv + : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (cau : CR_cauchy R (CRsum (fun n => CRabs R (u n)))), + series_cv u (let (l,_):= series_cv_abs u cau in l). Proof. - induction n. - - intros. reflexivity. - - intros. simpl. rewrite IHn, H. reflexivity. exact H. + intros. destruct (series_cv_abs u cau). exact s. +Qed. + +Lemma series_cv_opp : forall {R : ConstructiveReals} + (s : CRcarrier R) (u : nat -> CRcarrier R), + series_cv u s + -> series_cv (fun n => - u n) (- s). +Proof. + intros. intros p. specialize (H p) as [N H]. + exists N. intros n H0. + setoid_replace (CRsum (fun n0 : nat => - u n0) n - - s) + with (-(CRsum (fun n0 : nat => u n0) n - s)). + rewrite CRabs_opp. + apply H, H0. unfold CRminus. + rewrite sum_opp. rewrite CRopp_plus_distr. reflexivity. +Qed. + +Lemma series_cv_scale : forall {R : ConstructiveReals} + (a : CRcarrier R) (s : CRcarrier R) (u : nat -> CRcarrier R), + series_cv u s + -> series_cv (fun n => (u n) * a) (s * a). +Proof. + intros. + apply (CR_cv_eq _ (fun n => CRsum u n * a)). + intro n. rewrite sum_scale. reflexivity. apply CR_cv_scale, H. +Qed. + +Lemma series_cv_plus : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (s t : CRcarrier R), + series_cv u s + -> series_cv v t + -> series_cv (fun n => u n + v n) (s + t). +Proof. + intros. apply (CR_cv_eq _ (fun n => CRsum u n + CRsum v n)). + intro n. symmetry. apply sum_plus. apply CR_cv_plus. exact H. exact H0. +Qed. + +Lemma series_cv_minus : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (s t : CRcarrier R), + series_cv u s + -> series_cv v t + -> series_cv (fun n => u n - v n) (s - t). +Proof. + intros. apply (CR_cv_eq _ (fun n => CRsum u n - CRsum v n)). + intro n. symmetry. unfold CRminus. rewrite sum_plus. + rewrite sum_opp. reflexivity. + apply CR_cv_plus. exact H. apply CR_cv_opp. exact H0. +Qed. + +Lemma series_cv_nonneg : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, 0 <= u n) -> series_cv u s -> 0 <= s. +Proof. + intros. apply (CRle_trans 0 (CRsum u 0)). apply H. + apply (growing_ineq (CRsum u)). intro n. simpl. + rewrite <- CRplus_0_r. apply CRplus_le_compat. + rewrite CRplus_0_r. apply CRle_refl. apply H. apply H0. Qed. -Lemma pow_inv : forall {R : ConstructiveReals} (x : CRcarrier R) (xPos : 0 < x) (n : nat), - CRpow (CRinv R x (inr xPos)) n - == CRinv R (CRpow x n) (inr (pow_lt x n xPos)). +Lemma series_cv_eq : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, u n == v n) + -> series_cv u s + -> series_cv v s. +Proof. + intros. intros p. specialize (H0 p). destruct H0 as [N H0]. + exists N. intros. unfold CRminus. + rewrite <- (CRsum_eq u). apply H0, H1. intros. apply H. +Qed. + +Lemma series_cv_remainder_maj : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (s eps : CRcarrier R) + (N : nat), + series_cv u s + -> 0 < eps + -> (forall n:nat, 0 <= u n) + -> CRabs R (CRsum u N - s) <= eps + -> forall n:nat, CRsum (fun k=> u (N + S k)%nat) n <= eps. +Proof. + intros. pose proof (sum_assoc u N n). + rewrite <- (CRsum_eq (fun k : nat => u (S N + k)%nat)). + apply (CRplus_le_reg_l (CRsum u N)). rewrite <- H3. + apply (CRle_trans _ s). apply growing_ineq. + 2: apply H. + intro k. simpl. rewrite <- CRplus_0_r, CRplus_assoc. + apply CRplus_le_compat_l. rewrite CRplus_0_l. apply H1. + rewrite CRabs_minus_sym in H2. + rewrite CRplus_comm. apply (CRplus_le_reg_r (-CRsum u N)). + rewrite CRplus_assoc. rewrite CRplus_opp_r. rewrite CRplus_0_r. + apply (CRle_trans _ (CRabs R (s - CRsum u N))). apply CRle_abs. + assumption. intros. rewrite Nat.add_succ_r. reflexivity. +Qed. + + +Lemma series_cv_abs_remainder : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (s sAbs : CRcarrier R) + (n : nat), + series_cv u s + -> series_cv (fun n => CRabs R (u n)) sAbs + -> CRabs R (CRsum u n - s) + <= sAbs - CRsum (fun n => CRabs R (u n)) n. +Proof. + intros. + apply (CR_cv_le (fun N => CRabs R (CRsum u n - (CRsum u (n + N)))) + (fun N => CRsum (fun n : nat => CRabs R (u n)) (n + N) + - CRsum (fun n : nat => CRabs R (u n)) n)). + - intro N. destruct N. rewrite plus_0_r. unfold CRminus. + rewrite CRplus_opp_r. rewrite CRplus_opp_r. + rewrite CRabs_right. apply CRle_refl. apply CRle_refl. + rewrite Nat.add_succ_r. + replace (S (n + N)) with (S n + N)%nat. 2: reflexivity. + unfold CRminus. rewrite sum_assoc. rewrite sum_assoc. + rewrite CRopp_plus_distr. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l, CRabs_opp. + rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. + rewrite CRplus_0_l. apply multiTriangleIneg. + - apply CR_cv_dist_cont. intros eps. + specialize (H eps) as [N lim]. + exists N. intros. rewrite plus_comm. apply lim. apply (le_trans N i). + assumption. rewrite <- (plus_0_r i). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. + - apply CR_cv_plus. 2: apply CR_cv_const. intros eps. + specialize (H0 eps) as [N lim]. + exists N. intros. rewrite plus_comm. apply lim. apply (le_trans N i). + assumption. rewrite <- (plus_0_r i). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. +Qed. + +Lemma series_cv_triangle : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (s sAbs : CRcarrier R), + series_cv u s + -> series_cv (fun n => CRabs R (u n)) sAbs + -> CRabs R s <= sAbs. +Proof. + intros. + apply (CR_cv_le (fun n => CRabs R (CRsum u n)) + (CRsum (fun n => CRabs R (u n)))). + intros. apply multiTriangleIneg. apply CR_cv_abs_cont. assumption. assumption. +Qed. + +Lemma series_cv_shift : + forall {R : ConstructiveReals} (f : nat -> CRcarrier R) k l, + series_cv (fun n => f (S k + n)%nat) l + -> series_cv f (l + CRsum f k). +Proof. + intros. intro p. specialize (H p) as [n nmaj]. + exists (S k+n)%nat. intros. destruct (Nat.le_exists_sub (S k) i). + apply (le_trans _ (S k + 0)). rewrite Nat.add_0_r. apply le_refl. + apply (le_trans _ (S k + n)). apply Nat.add_le_mono_l, le_0_n. + exact H. destruct H0. subst i. + rewrite Nat.add_comm in H. rewrite <- Nat.add_le_mono_r in H. + specialize (nmaj x H). unfold CRminus. + rewrite Nat.add_comm, (sum_assoc f k x). + setoid_replace (CRsum f k + CRsum (fun k0 : nat => f (S k + k0)%nat) x - (l + CRsum f k)) + with (CRsum (fun k0 : nat => f (S k + k0)%nat) x - l). + exact nmaj. unfold CRminus. rewrite (CRplus_comm (CRsum f k)). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRplus_comm, CRopp_plus_distr, CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_r. reflexivity. +Qed. + +Lemma series_cv_shift' : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (s : CRcarrier R) (shift : nat), + series_cv un s + -> series_cv (fun n => un (n+shift)%nat) + (s - match shift with + | O => 0 + | S p => CRsum un p + end). +Proof. + intros. destruct shift as [|p]. + - unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. + apply (series_cv_eq un). intros. + rewrite plus_0_r. reflexivity. apply H. + - apply (CR_cv_eq _ (fun n => CRsum un (n + S p) - CRsum un p)). + intros. rewrite plus_comm. unfold CRminus. + rewrite sum_assoc. simpl. rewrite CRplus_comm, <- CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_l. + apply CRsum_eq. intros. rewrite (plus_comm i). reflexivity. + apply CR_cv_plus. apply (CR_cv_shift' _ (S p) _ H). + intros n. exists (Pos.to_nat n). intros. + unfold CRminus. simpl. + rewrite CRopp_involutive, CRplus_opp_l. rewrite CRabs_right. + apply CR_of_Q_le. discriminate. apply CRle_refl. +Qed. + +Lemma CRmorph_sum : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1) (n : nat), + CRmorph f (CRsum un n) == + CRsum (fun n0 : nat => CRmorph f (un n0)) n. Proof. induction n. - - rewrite CRinv_1. reflexivity. - - transitivity (CRinv R x (inr xPos) * CRpow (CRinv R x (inr xPos)) n). - reflexivity. rewrite IHn. - assert (0 < x * CRpow x n). - { apply CRmult_lt_0_compat. exact xPos. apply pow_lt, xPos. } - rewrite <- (CRinv_mult_distr _ _ _ _ (inr H)). - apply CRinv_morph. reflexivity. + - reflexivity. + - simpl. rewrite CRmorph_plus, IHn. reflexivity. Qed. -Lemma pow_plus_distr : forall {R : ConstructiveReals} (x : CRcarrier R) (n p:nat), - CRpow x n * CRpow x p == CRpow x (n+p). +Lemma CRmorph_INR : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (n : nat), + CRmorph f (INR n) == INR n. Proof. induction n. - - intros. simpl. rewrite CRmult_1_l. reflexivity. - - intros. simpl. rewrite CRmult_assoc. apply CRmult_morph. - reflexivity. apply IHn. + - apply CRmorph_rat. + - simpl. unfold INR. + rewrite (CRmorph_proper f _ (1 + CR_of_Q R1 (Z.of_nat n # 1))). + rewrite CRmorph_plus. unfold INR in IHn. + rewrite IHn. rewrite CRmorph_one, <- CR_of_Q_plus. + apply CR_of_Q_morph. rewrite Qinv_plus_distr. + unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. + rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. + rewrite <- CR_of_Q_plus. + apply CR_of_Q_morph. rewrite Qinv_plus_distr. + unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. + rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. +Qed. + +Lemma CRmorph_series_cv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1) + (l : CRcarrier R1), + series_cv un l + -> series_cv (fun n => CRmorph f (un n)) (CRmorph f l). +Proof. + intros. + apply (CR_cv_eq _ (fun n => CRmorph f (CRsum un n))). + intro n. apply CRmorph_sum. + apply CRmorph_cv, H. Qed. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v index f8c6429982..10b435d8b0 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v @@ -20,6 +20,8 @@ Local Open Scope CReal_scope. The constructive formulation of the absolute value on the real numbers. This is followed by the constructive definitions of minimum and maximum, as min x y := (x + y - |x-y|) / 2. + + WARNING: this file is experimental and likely to change in future releases. *) diff --git a/theories/Reals/Cauchy/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v index 70574f6135..b332457a7b 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyReals.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v @@ -39,6 +39,8 @@ Require CMorphisms. WARNING: this module is not meant to be imported directly, please import `Reals.Abstract.ConstructiveReals` instead. + + WARNING: this file is experimental and likely to change in future releases. *) Definition QCauchySeq (un : positive -> Q) : Prop diff --git a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v index f4daedcb97..7b7eb716e6 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v @@ -9,7 +9,10 @@ (************************************************************************) (************************************************************************) -(* The multiplication and division of Cauchy reals. *) +(** The multiplication and division of Cauchy reals. + + WARNING: this file is experimental and likely to change in future releases. +*) Require Import QArith Qabs Qround. Require Import Logic.ConstructiveEpsilon. diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index 754f9be5fe..a6843d598c 100644 --- a/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -16,6 +16,11 @@ Require Import ConstructiveCauchyRealsMult. Require Import Logic.ConstructiveEpsilon. Require Import ConstructiveCauchyAbs. +(** Proof that Cauchy reals are Cauchy-complete. + + WARNING: this file is experimental and likely to change in future releases. + *) + Local Open Scope CReal_scope. (* We use <= in sort Prop rather than < in sort Set, diff --git a/theories/Reals/ClassicalConstructiveReals.v b/theories/Reals/ClassicalConstructiveReals.v new file mode 100644 index 0000000000..baeb937add --- /dev/null +++ b/theories/Reals/ClassicalConstructiveReals.v @@ -0,0 +1,310 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <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) *) +(************************************************************************) +(************************************************************************) + +(** Proof that classical reals are constructive reals with + extra properties, namely total order, existence of all + least upper bounds and setoid equivalence simplifying to + Leibniz equality. + + From this point of view, the quotient Rabst and Rrepr + between classical Dedekind reals and constructive Cauchy reals + becomes an isomorphism for the ConstructiveReals structure. + + This allows to apply results from constructive reals to + classical reals. *) + +Require Import QArith_base. +Require Import Rdefinitions. +Require Import Raxioms. +Require Import ConstructiveReals. +Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. +Require Import ConstructiveRcomplete. +Require Import ConstructiveCauchyAbs. +Require Import ConstructiveRealsMorphisms. + +Local Open Scope R_scope. + +(* Rlt is the transport of CRealLt via Rasbt, Rrepr, + so it is linear as CRealLt. *) +Lemma RisLinearOrder : isLinearOrder Rlt. +Proof. + split. split. + - intros. exact (Rlt_asym _ _ H H0). + - intros. exact (Rlt_trans _ _ _ H H0). + - intros. destruct (total_order_T x y). destruct s. + left. exact r. right. subst x. exact H. right. + exact (Rlt_trans _ x _ r H). +Qed. + +Lemma RdisjunctEpsilon + : forall a b c d : R, (a < b)%R \/ (c < d)%R -> (a < b)%R + (c < d)%R. +Proof. + intros. destruct (total_order_T a b). + - destruct s. + left. exact r. right. destruct H. + exfalso. subst a. exact (Rlt_asym b b H H). exact H. + - right. destruct H. exfalso. exact (Rlt_asym _ _ H r). exact H. +Qed. + +(* The constructive equality on R. *) +Definition Req_constr (x y : R) : Prop + := (x < y -> False) /\ (y < x -> False). + +Lemma Req_constr_refl : forall x:R, Req_constr x x. +Proof. + split. intro H. exact (Rlt_asym _ _ H H). + intro H. exact (Rlt_asym _ _ H H). +Qed. + +Lemma Req_constr_leibniz : forall x y:R, Req_constr x y -> x = y. +Proof. + intros. destruct (total_order_T x y). destruct s. + - exfalso. destruct H. contradiction. + - exact e. + - exfalso. destruct H. contradiction. +Qed. + +Definition IQR (q : Q) := Rabst (inject_Q q). + +Lemma IQR_zero_quot : Req_constr (IQR 0) R0. +Proof. + unfold IQR. rewrite R0_def. apply Req_constr_refl. +Qed. + +(* Not RealField.RTheory, because it uses Leibniz equality. *) +Lemma Rring : ring_theory (IQR 0) (IQR 1) Rplus Rmult + (fun x y : R => (x + - y)%R) Ropp Req_constr. +Proof. + split. + - intro x. replace (IQR 0 + x) with x. apply Req_constr_refl. + apply Rquot1. rewrite Rrepr_plus. unfold IQR. rewrite Rquot2. + rewrite CReal_plus_0_l. reflexivity. + - intros. replace (x + y) with (y + x). apply Req_constr_refl. + apply Rquot1. do 2 rewrite Rrepr_plus. apply CReal_plus_comm. + - intros. replace (x + (y + z)) with (x + y + z). + apply Req_constr_refl. apply Rquot1. + do 4 rewrite Rrepr_plus. apply CReal_plus_assoc. + - intro x. replace (IQR 1 * x) with x. apply Req_constr_refl. + unfold IQR. + apply Rquot1. rewrite Rrepr_mult, Rquot2, CReal_mult_1_l. reflexivity. + - intros. replace (x * y) with (y * x). apply Req_constr_refl. + apply Rquot1. do 2 rewrite Rrepr_mult. apply CReal_mult_comm. + - intros. replace (x * (y * z)) with (x * y * z). + apply Req_constr_refl. apply Rquot1. + do 4 rewrite Rrepr_mult. apply CReal_mult_assoc. + - intros. replace ((x + y) * z) with (x * z + y * z). + apply Req_constr_refl. apply Rquot1. + rewrite Rrepr_mult, Rrepr_plus, Rrepr_plus, Rrepr_mult, Rrepr_mult. + symmetry. apply CReal_mult_plus_distr_r. + - intros. apply Req_constr_refl. + - intros. replace (x + - x) with R0. unfold IQR. + rewrite R0_def. apply Req_constr_refl. + apply Rquot1. rewrite Rrepr_plus, Rrepr_opp, CReal_plus_opp_r, Rrepr_0. + reflexivity. +Qed. + +Lemma RringExt : ring_eq_ext Rplus Rmult Ropp Req_constr. +Proof. + split. + - intros x y H z t H0. apply Req_constr_leibniz in H. + apply Req_constr_leibniz in H0. destruct H, H0. apply Req_constr_refl. + - intros x y H z t H0. apply Req_constr_leibniz in H. + apply Req_constr_leibniz in H0. destruct H, H0. apply Req_constr_refl. + - intros x y H. apply Req_constr_leibniz in H. destruct H. apply Req_constr_refl. +Qed. + +Lemma Rleft_inverse : + forall r : R, (sum (r < IQR 0) (IQR 0 < r)) -> Req_constr (/ r * r) (IQR 1). +Proof. + intros. rewrite Rinv_l. + unfold IQR. rewrite <- R1_def. apply Req_constr_refl. destruct H. + - intro abs. subst r. unfold IQR in r0. rewrite <- R0_def in r0. + apply (Rlt_asym _ _ r0 r0). + - intro abs. subst r. unfold IQR in r0. rewrite <- R0_def in r0. + apply (Rlt_asym _ _ r0 r0). +Qed. + +Lemma Rinv_pos : forall r : R, (sum (r < IQR 0) (IQR 0 < r)) -> IQR 0 < r -> IQR 0 < / r. +Proof. + intros. rewrite Rlt_def. apply CRealLtForget. + rewrite Rlt_def in H0. apply CRealLtEpsilon in H0. + unfold IQR in H0. rewrite Rquot2 in H0. + rewrite (Rrepr_inv r (inr H0)). unfold IQR. rewrite Rquot2. + apply CReal_inv_0_lt_compat, H0. +Qed. + +Lemma Rmult_pos : forall x y : R, IQR 0 < x -> IQR 0 < y -> IQR 0 < x * y. +Proof. + intros. rewrite Rlt_def. apply CRealLtForget. + unfold IQR. rewrite Rquot2. + rewrite Rrepr_mult. apply CReal_mult_lt_0_compat. + rewrite Rlt_def in H. apply CRealLtEpsilon in H. + unfold IQR in H. rewrite Rquot2 in H. exact H. + unfold IQR in H0. rewrite Rlt_def in H0. apply CRealLtEpsilon in H0. + rewrite Rquot2 in H0. exact H0. +Qed. + +Lemma Rplus_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. +Proof. + intros. rewrite Rlt_def in H. apply CRealLtEpsilon in H. + rewrite Rrepr_plus, Rrepr_plus in H. + apply CReal_plus_lt_reg_l in H. rewrite Rlt_def. + apply CRealLtForget. exact H. +Qed. + +Lemma Rzero_lt_one : IQR 0 < IQR 1. +Proof. + rewrite Rlt_def. apply CRealLtForget. + unfold IQR. rewrite Rquot2, Rquot2. + apply CRealLt_0_1. +Qed. + +Lemma plus_IQR : forall q r : Q, + IQR (q + r) = IQR q + IQR r. +Proof. + intros. unfold IQR. apply Rquot1. + rewrite Rquot2, Rrepr_plus, Rquot2, Rquot2. apply inject_Q_plus. +Qed. + +Lemma mult_IQR : forall q r : Q, + IQR (q * r) = IQR q * IQR r. +Proof. + intros. unfold IQR. apply Rquot1. + rewrite Rquot2, Rrepr_mult, Rquot2, Rquot2. apply inject_Q_mult. +Qed. + +Lemma IQR_lt : forall n m:Q, (n < m)%Q -> IQR n < IQR m. +Proof. + intros. rewrite Rlt_def. apply CRealLtForget. + unfold IQR. rewrite Rquot2, Rquot2. apply inject_Q_lt, H. +Qed. + +Lemma lt_IQR : forall n m:Q, IQR n < IQR m -> (n < m)%Q. +Proof. + intros. rewrite Rlt_def in H. apply CRealLtEpsilon in H. + unfold IQR in H. rewrite Rquot2, Rquot2 in H. + apply lt_inject_Q, H. +Qed. + +Lemma IQR_plus_quot : forall q r : Q, Req_constr (IQR (q + r)) (IQR q + IQR r). +Proof. + intros. rewrite plus_IQR. apply Req_constr_refl. +Qed. + +Lemma IQR_mult_quot : forall q r : Q, Req_constr (IQR (q * r)) (IQR q * IQR r). +Proof. + intros. rewrite mult_IQR. apply Req_constr_refl. +Qed. + +Lemma Rabove_pos : forall x : R, {n : positive & x < IQR (Z.pos n # 1)}. +Proof. + intros. destruct (Rup_nat (Rrepr x)) as [n nmaj]. + exists (Pos.of_nat n). unfold IQR. rewrite Rlt_def, Rquot2. + apply CRealLtForget. apply (CReal_lt_le_trans _ _ _ nmaj). + apply inject_Q_le. unfold Qle, Qnum, Qden. + do 2 rewrite Z.mul_1_r. destruct n. discriminate. + rewrite <- positive_nat_Z. rewrite Nat2Pos.id. apply Z.le_refl. + discriminate. +Qed. + +Lemma Rarchimedean : forall x y : R, x < y -> {q : Q & ((x < IQR q) * (IQR q < y))%type}. +Proof. + intros. rewrite Rlt_def in H. apply CRealLtEpsilon in H. + apply FQ_dense in H. destruct H as [q [H2 H3]]. + exists q. split. rewrite Rlt_def. apply CRealLtForget. + unfold IQR. rewrite Rquot2. exact H2. + rewrite Rlt_def. apply CRealLtForget. + unfold IQR. rewrite Rquot2. exact H3. +Qed. + +Lemma RabsLUB : forall x y : R, (y < x -> False) /\ (y < - x -> False) <-> (y < Rabst (CReal_abs (Rrepr x)) -> False). +Proof. + split. + - intros. rewrite Rlt_def in H0. + apply CRealLtEpsilon in H0. rewrite Rquot2 in H0. + destruct H. apply (CReal_abs_le (Rrepr x) (Rrepr y)). 2: exact H0. + split. apply (CReal_plus_le_reg_l (Rrepr y - Rrepr x)). + ring_simplify. intro abs2. apply H1. rewrite Rlt_def. + apply CRealLtForget. rewrite Rrepr_opp. exact abs2. + intro abs2. apply H. rewrite Rlt_def. + apply CRealLtForget. exact abs2. + - intros. split. intro abs. apply H. + rewrite Rlt_def. apply CRealLtForget. rewrite Rquot2. + rewrite Rlt_def in abs. apply CRealLtEpsilon in abs. + apply (CReal_lt_le_trans _ _ _ abs). apply CReal_le_abs. + intro abs. apply H. + rewrite Rlt_def. apply CRealLtForget. rewrite Rquot2. + rewrite Rlt_def in abs. apply CRealLtEpsilon in abs. + apply (CReal_lt_le_trans _ _ _ abs). + rewrite <- CReal_abs_opp, Rrepr_opp. apply CReal_le_abs. +Qed. + +Lemma Rcomplete : forall xn : nat -> R, + (forall p : positive, + {n : nat | + forall i j : nat, + (n <= i)%nat -> (n <= j)%nat -> IQR (1 # p) < Rabst (CReal_abs (Rrepr (xn i + - xn j))) -> False}) -> + {l : R & + forall p : positive, + {n : nat | + forall i : nat, (n <= i)%nat -> IQR (1 # p) < Rabst (CReal_abs (Rrepr (xn i + - l))) -> False}}. +Proof. + intros. destruct (Rcauchy_complete (fun n => Rrepr (xn n))) as [l llim]. + - intro p. specialize (H p) as [n nmaj]. exists n. intros. + specialize (nmaj i j H H0). unfold IQR in nmaj. + intro abs. apply nmaj. rewrite Rlt_def. apply CRealLtForget. + rewrite Rquot2, Rquot2. apply (CReal_lt_le_trans _ _ _ abs). + rewrite Rrepr_plus, Rrepr_opp. apply CRealLe_refl. + - exists (Rabst l). intros. specialize (llim p) as [n nmaj]. + exists n. intros. specialize (nmaj i H0). + unfold IQR in H1. apply nmaj. rewrite Rlt_def in H1. + apply CRealLtEpsilon in H1. rewrite Rquot2, Rquot2 in H1. + apply (CReal_lt_le_trans _ _ _ H1). + rewrite Rrepr_plus, Rrepr_opp, Rquot2. apply CRealLe_refl. +Qed. + +Definition Rabs_quot (x : R) := Rabst (CReal_abs (Rrepr x)). +Definition Rinv_quot (x : R) (xnz : sum (x < IQR 0) (IQR 0 < x)) := Rinv x. +Definition Rlt_epsilon (x y : R) (H : x < y) := H. + +Definition DRealConstructive : ConstructiveReals + := Build_ConstructiveReals + R Rlt RisLinearOrder Rlt + Rlt_epsilon Rlt_epsilon + RdisjunctEpsilon IQR IQR_lt lt_IQR + Rplus Ropp Rmult + IQR_plus_quot IQR_mult_quot + Rring RringExt Rzero_lt_one + Rplus_lt_compat_l Rplus_reg_l Rmult_pos + Rinv_quot Rleft_inverse Rinv_pos + Rarchimedean Rabove_pos + Rabs_quot RabsLUB Rcomplete. + +Definition Rrepr_morphism + : @ConstructiveRealsMorphism DRealConstructive CRealConstructive. +Proof. + apply (Build_ConstructiveRealsMorphism + DRealConstructive CRealConstructive Rrepr). + - intro q. simpl. unfold IQR. rewrite Rquot2. apply CRealEq_refl. + - intros. simpl. simpl in H. rewrite Rlt_def in H. + apply CRealLtEpsilon in H. exact H. +Defined. + +Definition Rabst_morphism + : @ConstructiveRealsMorphism CRealConstructive DRealConstructive. +Proof. + apply (Build_ConstructiveRealsMorphism + CRealConstructive DRealConstructive Rabst). + - intro q. apply Req_constr_refl. + - intros. simpl. simpl in H. rewrite Rlt_def. + apply CRealLtForget. rewrite Rquot2, Rquot2. exact H. +Defined. diff --git a/theories/dune b/theories/dune index b9af76d699..de8dcdc5b1 100644 --- a/theories/dune +++ b/theories/dune @@ -33,6 +33,7 @@ coq.plugins.funind coq.plugins.ssreflect + coq.plugins.ssrsearch coq.plugins.derive)) (include_subdirs qualified) diff --git a/theories/ssrsearch/ssrsearch.v b/theories/ssrsearch/ssrsearch.v new file mode 100644 index 0000000000..37ab8f4bac --- /dev/null +++ b/theories/ssrsearch/ssrsearch.v @@ -0,0 +1,2 @@ +Require Import ssreflect. +Declare ML Module "ssrsearch_plugin". diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index c4620f5b50..a3078af4a1 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -468,6 +468,7 @@ def make_table_string(stats_dict, for name in names]) def print_or_write_table(table, files): + if table[-1] != '\n': table += '\n' if len(files) == 0 or '-' in files: if hasattr(sys.stdout, 'buffer'): sys.stdout.buffer.write(table.encode("utf-8")) diff --git a/tools/coqdoc/dune b/tools/coqdoc/dune index 9c0a6ccffe..e3c792f277 100644 --- a/tools/coqdoc/dune +++ b/tools/coqdoc/dune @@ -9,6 +9,6 @@ (name main) (public_name coqdoc) (package coq) - (libraries str coq.config)) + (libraries str coq.config coq.clib)) (ocamllex cpretty) diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 1be247366d..6ebf9b71d6 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -127,6 +127,9 @@ let rec name_of_path p name dirname suffix = let coq_module filename = let bfname = Filename.chop_extension filename in let dirname, fname = normalize_filename bfname in + let _ = match Unicode.ident_refutation fname with + | Some err -> eprintf "\ncoqdoc: not a valid filename %s.v\n" fname; exit 1 + | None -> () in let rec change_prefix = function (* Follow coqc: if in scope of -R, substitute logical name *) (* otherwise, keep only base name *) diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index c7ad5edb1f..eb386ea3e8 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -263,6 +263,7 @@ let get_native_name s = with _ -> "" let get_compat_file = function + | "8.13" -> "Coq.Compat.Coq813" | "8.12" -> "Coq.Compat.Coq812" | "8.11" -> "Coq.Compat.Coq811" | "8.10" -> "Coq.Compat.Coq810" diff --git a/user-contrib/Ltac2/Notations.v b/user-contrib/Ltac2/Notations.v index 390b39bab1..931d753521 100644 --- a/user-contrib/Ltac2/Notations.v +++ b/user-contrib/Ltac2/Notations.v @@ -396,6 +396,39 @@ Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause Std.native pl (default_on_concl cl). Ltac2 Notation native_compute := native_compute. +Ltac2 Notation "eval" "red" "in" c(constr) := + Std.eval_red c. + +Ltac2 Notation "eval" "hnf" "in" c(constr) := + Std.eval_hnf c. + +Ltac2 Notation "eval" "simpl" s(strategy) pl(opt(seq(pattern, occurrences))) "in" c(constr) := + Std.eval_simpl s pl c. + +Ltac2 Notation "eval" "cbv" s(strategy) "in" c(constr) := + Std.eval_cbv s c. + +Ltac2 Notation "eval" "cbn" s(strategy) "in" c(constr) := + Std.eval_cbn s c. + +Ltac2 Notation "eval" "lazy" s(strategy) "in" c(constr) := + Std.eval_lazy s c. + +Ltac2 Notation "eval" "unfold" pl(list1(seq(reference, occurrences), ",")) "in" c(constr) := + Std.eval_unfold pl c. + +Ltac2 Notation "eval" "fold" pl(thunk(list1(open_constr))) "in" c(constr) := + Std.eval_fold (pl ()) c. + +Ltac2 Notation "eval" "pattern" pl(list1(seq(constr, occurrences), ",")) "in" c(constr) := + Std.eval_pattern pl c. + +Ltac2 Notation "eval" "vm_compute" pl(opt(seq(pattern, occurrences))) "in" c(constr) := + Std.eval_vm pl c. + +Ltac2 Notation "eval" "native_compute" pl(opt(seq(pattern, occurrences))) "in" c(constr) := + Std.eval_native pl c. + Ltac2 change0 p cl := let (pat, c) := p in Std.change pat c (default_on_concl cl). diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index e77040a8db..0299da6a25 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1162,8 +1162,9 @@ let () = | Tac2qexpr.QReference qid -> let gr = try Nametab.locate qid - with Not_found -> - Nametab.error_global_not_found qid + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid in GlbVal gr, gtypref t_reference in diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 5323c9f1c6..bb640a83f6 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -385,7 +385,7 @@ let build_beq_scheme mode kn = Vars.substl subst cores.(i) in create_input fix), - UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ())) + UState.from_env (Global.env ())) let beq_scheme_kind = declare_mutual_scheme_object "_beq" @@ -707,7 +707,7 @@ let make_bl_scheme mode mind = let lnonparrec,lnamesparrec = (* TODO subst *) context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal = compute_bl_goal ind lnamesparrec nparrec in - let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let uctx = UState.from_env (Global.env ()) in let side_eff = side_effect_of_mode mode in let bl_goal = EConstr.of_constr bl_goal in let (ans, _, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal @@ -840,7 +840,7 @@ let make_lb_scheme mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal = compute_lb_goal ind lnamesparrec nparrec in - let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let uctx = UState.from_env (Global.env ()) in let side_eff = side_effect_of_mode mode in let lb_goal = EConstr.of_constr lb_goal in let (ans, _, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal @@ -1010,7 +1010,7 @@ let make_eq_decidability mode mind = let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let u = Univ.Instance.empty in - let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let uctx = UState.from_env (Global.env ()) in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let side_eff = side_effect_of_mode mode in diff --git a/vernac/classes.ml b/vernac/classes.ml index 55af2e1a7d..21e2afe6a9 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -345,7 +345,7 @@ let declare_instance_program env sigma ~global ~poly name pri impargs udecl term let hook = Declare.Hook.make hook in let uctx = Evd.evar_universe_context sigma in let scope, kind = Declare.Global Declare.ImportDefaultBehavior, Decls.Instance in - let _ : DeclareObl.progress = + let _ : Declare.Obls.progress = Obligations.add_definition ~name ~term ~udecl ~scope ~poly ~kind ~hook ~impargs ~uctx typ obls in () diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 95f3955309..d56917271c 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -126,8 +126,8 @@ let do_definition_program ?hook ~name ~scope ~poly ~kind udecl bl red_option c c let (body, types), evd, udecl, impargs = interp_definition ~program_mode udecl bl ~poly red_option c ctypopt in - let term, ty, uctx, obls = Declare.prepare_obligation ~name ~poly ~body ~types ~udecl evd in - let _ : DeclareObl.progress = + let term, ty, uctx, obls = Declare.prepare_obligation ~name ~body ~types evd in + let _ : Declare.Obls.progress = Obligations.add_definition ~name ~term ty ~uctx ~udecl ~impargs ~scope ~poly ~kind ?hook obls in () diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 4e9e24b119..4aa46e0a86 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -273,7 +273,7 @@ let collect_evars_of_term evd c ty = evars (Evd.from_ctx (Evd.evar_universe_context evd)) let do_program_recursive ~scope ~poly fixkind fixl = - let cofix = fixkind = DeclareObl.IsCoFixpoint in + let cofix = fixkind = Declare.Obls.IsCoFixpoint in let (env, rec_sign, udecl, evd), fix, info = interp_recursive ~cofix ~program_mode:true fixl in @@ -314,8 +314,8 @@ let do_program_recursive ~scope ~poly fixkind fixl = end in let uctx = Evd.evar_universe_context evd in let kind = match fixkind with - | DeclareObl.IsFixpoint _ -> Decls.Fixpoint - | DeclareObl.IsCoFixpoint -> Decls.CoFixpoint + | Declare.Obls.IsFixpoint _ -> Decls.Fixpoint + | Declare.Obls.IsCoFixpoint -> Decls.CoFixpoint in let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in Obligations.add_mutual_definitions defs ~poly ~scope ~kind ~udecl ~uctx ntns fixkind @@ -345,7 +345,7 @@ let do_fixpoint ~scope ~poly l = | _, _ when List.for_all (fun ro -> match ro with None | Some { CAst.v = CStructRec _} -> true | _ -> false) g -> let annots = List.map (fun fix -> Vernacexpr.(ComFixpoint.adjust_rec_order ~structonly:true fix.binders fix.rec_order)) l in - let fixkind = DeclareObl.IsFixpoint annots in + let fixkind = Declare.Obls.IsFixpoint annots in let l = List.map2 (fun fix rec_order -> { fix with Vernacexpr.rec_order }) l annots in do_program_recursive ~scope ~poly fixkind l @@ -355,4 +355,4 @@ let do_fixpoint ~scope ~poly l = let do_cofixpoint ~scope ~poly fixl = let fixl = List.map (fun fix -> { fix with Vernacexpr.rec_order = None }) fixl in - do_program_recursive ~scope ~poly DeclareObl.IsCoFixpoint fixl + do_program_recursive ~scope ~poly Declare.Obls.IsCoFixpoint fixl diff --git a/vernac/comSearch.ml b/vernac/comSearch.ml new file mode 100644 index 0000000000..9de8d6fbc3 --- /dev/null +++ b/vernac/comSearch.ml @@ -0,0 +1,140 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Interpretation of search commands *) + +open CErrors +open Names +open Util +open Pp +open Printer +open Search +open Vernacexpr +open Goptions + +let global_module qid = + try Nametab.full_name_module qid + with Not_found -> + user_err ?loc:qid.CAst.loc ~hdr:"global_module" + (str "Module/section " ++ Ppconstr.pr_qualid qid ++ str " not found.") + +let interp_search_restriction = function + | SearchOutside l -> (List.map global_module l, true) + | SearchInside l -> (List.map global_module l, false) + +let kind_searcher = Decls.(function + (* Kinds referring to the keyword introducing the object *) + | IsAssumption _ + | IsDefinition (Definition | Example | Fixpoint | CoFixpoint | Method | StructureComponent | Let) + | IsProof _ + | IsPrimitive as k -> Inl k + (* Kinds referring to the status of the object *) + | IsDefinition (Coercion | SubClass | IdentityCoercion as k') -> + let coercions = Coercionops.coercions () in + Inr (fun gr -> List.exists (fun c -> GlobRef.equal c.Coercionops.coe_value gr && + (k' <> SubClass && k' <> IdentityCoercion || c.Coercionops.coe_is_identity)) coercions) + | IsDefinition CanonicalStructure -> + let canonproj = Recordops.canonical_projections () in + Inr (fun gr -> List.exists (fun c -> GlobRef.equal (snd c).Recordops.o_ORIGIN gr) canonproj) + | IsDefinition Scheme -> + let schemes = DeclareScheme.all_schemes () in + Inr (fun gr -> Indset.exists (fun c -> GlobRef.equal (GlobRef.IndRef c) gr) schemes) + | IsDefinition Instance -> + let instances = Typeclasses.all_instances () in + Inr (fun gr -> List.exists (fun c -> GlobRef.equal c.Typeclasses.is_impl gr) instances)) + +let interp_search_item env sigma = + function + | SearchSubPattern ((where,head),pat) -> + let _,pat = Constrintern.intern_constr_pattern env sigma pat in + GlobSearchSubPattern (where,head,pat) + | SearchString ((Anywhere,false),s,None) when Id.is_valid s -> + GlobSearchString s + | SearchString ((where,head),s,sc) -> + (try + let ref = + Notation.interp_notation_as_global_reference + ~head:false (fun _ -> true) s sc in + GlobSearchSubPattern (where,head,Pattern.PRef ref) + with UserError _ -> + user_err ~hdr:"interp_search_item" + (str "Unable to interpret " ++ quote (str s) ++ str " as a reference.")) + | SearchKind k -> + match kind_searcher k with + | Inl k -> GlobSearchKind k + | Inr f -> GlobSearchFilter f + +let rec interp_search_request env sigma = function + | b, SearchLiteral i -> b, GlobSearchLiteral (interp_search_item env sigma i) + | b, SearchDisjConj l -> b, GlobSearchDisjConj (List.map (List.map (interp_search_request env sigma)) l) + +(* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the + `search_output_name_only` option to avoid excessive printing when + searching. + + The motivation was to make search usable for IDE completion, + however, it is still too slow due to the non-indexed nature of the + underlying search mechanism. + + In the future we should deprecate the option and provide a fast, + indexed name-searching interface. +*) +let search_output_name_only = ref false + +let () = + declare_bool_option + { optdepr = false; + optkey = ["Search";"Output";"Name";"Only"]; + optread = (fun () -> !search_output_name_only); + optwrite = (:=) search_output_name_only } + +let deprecated_searchhead = + CWarnings.create + ~name:"deprecated-searchhead" + ~category:"deprecated" + (fun () -> Pp.str("SearchHead is deprecated. Use the headconcl: clause of Search instead.")) + +let interp_search env sigma s r = + let r = interp_search_restriction r in + let get_pattern c = snd (Constrintern.intern_constr_pattern env sigma c) in + let warnlist = ref [] in + let pr_search ref kind env c = + let pr = pr_global ref in + let pp = if !search_output_name_only + then pr + else begin + let open Impargs in + let impls = implicits_of_global ref in + let impargs = select_stronger_impargs impls in + let impargs = List.map binding_kind_of_status impargs in + if List.length impls > 1 || + List.exists Glob_term.(function Explicit -> false | MaxImplicit | NonMaxImplicit -> true) + (List.skipn_at_least (Termops.nb_prod_modulo_zeta Evd.(from_env env) (EConstr.of_constr c)) impargs) + then warnlist := pr :: !warnlist; + let pc = pr_ltype_env env Evd.(from_env env) ~impargs c in + hov 2 (pr ++ str":" ++ spc () ++ pc) + end + in Feedback.msg_notice pp + in + (match s with + | SearchPattern c -> + (Search.search_pattern env sigma (get_pattern c) r |> Search.prioritize_search) pr_search + | SearchRewrite c -> + (Search.search_rewrite env sigma (get_pattern c) r |> Search.prioritize_search) pr_search + | SearchHead c -> + deprecated_searchhead (); + (Search.search_by_head env sigma (get_pattern c) r |> Search.prioritize_search) pr_search + | Search sl -> + (Search.search env sigma (List.map (interp_search_request env Evd.(from_env env)) sl) r |> + Search.prioritize_search) pr_search); + if !warnlist <> [] then + Feedback.msg_notice (str "(" ++ + hov 0 (strbrk "use \"About\" for full details on the implicit arguments of " ++ + pr_enum (fun x -> x) !warnlist ++ str ")")) diff --git a/vernac/comSearch.mli b/vernac/comSearch.mli new file mode 100644 index 0000000000..42f59984ff --- /dev/null +++ b/vernac/comSearch.mli @@ -0,0 +1,14 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Interpretation of search commands *) + +val interp_search : Environ.env -> Evd.evar_map -> + Vernacexpr.searchable -> Vernacexpr.search_restriction -> unit diff --git a/vernac/declare.ml b/vernac/declare.ml index c3f95c5297..c77d4909da 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -120,7 +120,7 @@ let get_open_goals ps = (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + List.length shelf -type import_status = ImportDefaultBehavior | ImportNeedQualified +type import_status = Locality.import_status = ImportDefaultBehavior | ImportNeedQualified (** Declaration of constants and parameters *) @@ -155,6 +155,8 @@ type proof_object = ; uctx: UState.t } +let get_po_name { name } = name + let private_poly_univs = Goptions.declare_bool_option_and_ref ~depr:false @@ -847,23 +849,6 @@ let get_current_context pf = let p = get_proof pf in Proof.get_proof_context p -module Proof = struct - type nonrec t = t - let get_proof = get_proof - let get_proof_name = get_proof_name - let get_used_variables = get_used_variables - let get_universe_decl = get_universe_decl - let get_initial_euctx = get_initial_euctx - let map_proof = map_proof - let map_fold_proof = map_fold_proof - let map_fold_proof_endline = map_fold_proof_endline - let set_endline_tactic = set_endline_tactic - let set_used_variables = set_used_variables - let compact = compact_the_proof - let update_global_env = update_global_env - let get_open_goals = get_open_goals -end - let declare_definition_scheme ~internal ~univs ~role ~name c = let kind = Decls.(IsDefinition Scheme) in let entry = pure_definition_entry ~univs c in @@ -876,7 +861,7 @@ let _ = Abstract.declare_abstract := declare_abstract let declare_universe_context = DeclareUctx.declare_universe_context -type locality = Discharge | Global of import_status +type locality = Locality.locality = | Discharge | Global of import_status (* Hooks naturally belong here as they apply to both definitions and lemmas *) module Hook = struct @@ -1022,25 +1007,20 @@ let declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ?hook let entry, uctx = prepare_definition ?fix_exn ~opaque ~poly ~udecl ~types ~body ?inline sigma in declare_entry ~name ~scope ~kind ~impargs ?obls ?hook ~uctx entry -let prepare_obligation ?opaque ?inline ~name ~poly ~udecl ~types ~body sigma = +let prepare_obligation ~name ~types ~body sigma = + let env = Global.env () in + let types = match types with + | Some t -> t + | None -> Retyping.get_type_of env sigma body + in let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false - sigma (fun nf -> nf body, Option.map nf types) + sigma (fun nf -> nf body, nf types) in - let univs = Evd.check_univ_decl ~poly sigma udecl in - let ce = definition_entry ?opaque ?inline ?types ~univs body in - let env = Global.env () in - let (c,ctx), sideff = Future.force ce.proof_entry_body in - assert(Safe_typing.is_empty_private_constants sideff.Evd.seff_private); - assert(Univ.ContextSet.is_empty ctx); RetrieveObl.check_evars env sigma; - let c = EConstr.of_constr c in - let typ = match ce.proof_entry_type with - | Some t -> EConstr.of_constr t - | None -> Retyping.get_type_of env sigma c - in - let obls, _, c, cty = RetrieveObl.retrieve_obligations env name sigma 0 c typ in + let body, types = EConstr.(of_constr body, of_constr types) in + let obls, _, body, cty = RetrieveObl.retrieve_obligations env name sigma 0 body types in let uctx = Evd.evar_universe_context sigma in - c, cty, uctx, obls + body, cty, uctx, obls let prepare_parameter ~poly ~udecl ~types sigma = let env = Global.env () in @@ -1053,3 +1033,980 @@ let prepare_parameter ~poly ~udecl ~types sigma = (* Compat: will remove *) exception AlreadyDeclared = DeclareUniv.AlreadyDeclared + +module Obls = struct + +open Constr + +type 'a obligation_body = DefinedObl of 'a | TermObl of constr + +module Obligation = struct + type t = + { obl_name : Id.t + ; obl_type : types + ; obl_location : Evar_kinds.t Loc.located + ; obl_body : pconstant obligation_body option + ; obl_status : bool * Evar_kinds.obligation_definition_status + ; obl_deps : Int.Set.t + ; obl_tac : unit Proofview.tactic option } + + let set_type ~typ obl = {obl with obl_type = typ} + let set_body ~body obl = {obl with obl_body = Some body} +end + +type obligations = {obls : Obligation.t array; remaining : int} +type fixpoint_kind = IsFixpoint of lident option list | IsCoFixpoint + +module ProgramDecl = struct + type t = + { prg_name : Id.t + ; prg_body : constr + ; prg_type : constr + ; prg_ctx : UState.t + ; prg_univdecl : UState.universe_decl + ; prg_obligations : obligations + ; prg_deps : Id.t list + ; prg_fixkind : fixpoint_kind option + ; prg_implicits : Impargs.manual_implicits + ; prg_notations : Vernacexpr.decl_notation list + ; prg_poly : bool + ; prg_scope : locality + ; prg_kind : Decls.definition_object_kind + ; prg_reduce : constr -> constr + ; prg_hook : Hook.t option + ; prg_opaque : bool } + + open Obligation + + let make ?(opaque = false) ?hook n ~udecl ~uctx ~impargs ~poly ~scope ~kind b + t deps fixkind notations obls reduce = + let obls', b = + match b with + | None -> + assert (Int.equal (Array.length obls) 0); + let n = Nameops.add_suffix n "_obligation" in + ( [| { obl_name = n + ; obl_body = None + ; obl_location = Loc.tag Evar_kinds.InternalHole + ; obl_type = t + ; obl_status = (false, Evar_kinds.Expand) + ; obl_deps = Int.Set.empty + ; obl_tac = None } |] + , mkVar n ) + | Some b -> + ( Array.mapi + (fun i (n, t, l, o, d, tac) -> + { obl_name = n + ; obl_body = None + ; obl_location = l + ; obl_type = t + ; obl_status = o + ; obl_deps = d + ; obl_tac = tac }) + obls + , b ) + in + let ctx = UState.make_flexible_nonalgebraic uctx in + { prg_name = n + ; prg_body = b + ; prg_type = reduce t + ; prg_ctx = ctx + ; prg_univdecl = udecl + ; prg_obligations = {obls = obls'; remaining = Array.length obls'} + ; prg_deps = deps + ; prg_fixkind = fixkind + ; prg_notations = notations + ; prg_implicits = impargs + ; prg_poly = poly + ; prg_scope = scope + ; prg_kind = kind + ; prg_reduce = reduce + ; prg_hook = hook + ; prg_opaque = opaque } + + let set_uctx ~uctx prg = {prg with prg_ctx = uctx} +end + +open Obligation +open ProgramDecl + +(* Saving an obligation *) + +(* XXX: Is this the right place for this? *) +let it_mkLambda_or_LetIn_or_clean t ctx = + let open Context.Rel.Declaration in + let fold t decl = + if is_local_assum decl then Term.mkLambda_or_LetIn decl t + else if Vars.noccurn 1 t then Vars.subst1 mkProp t + else Term.mkLambda_or_LetIn decl t + in + Context.Rel.fold_inside fold ctx ~init:t + +(* XXX: Is this the right place for this? *) +let decompose_lam_prod c ty = + let open Context.Rel.Declaration in + let rec aux ctx c ty = + match (Constr.kind c, Constr.kind ty) with + | LetIn (x, b, t, c), LetIn (x', b', t', ty) + when Constr.equal b b' && Constr.equal t t' -> + let ctx' = Context.Rel.add (LocalDef (x, b', t')) ctx in + aux ctx' c ty + | _, LetIn (x', b', t', ty) -> + let ctx' = Context.Rel.add (LocalDef (x', b', t')) ctx in + aux ctx' (lift 1 c) ty + | LetIn (x, b, t, c), _ -> + let ctx' = Context.Rel.add (LocalDef (x, b, t)) ctx in + aux ctx' c (lift 1 ty) + | Lambda (x, b, t), Prod (x', b', t') + (* By invariant, must be convertible *) -> + let ctx' = Context.Rel.add (LocalAssum (x, b')) ctx in + aux ctx' t t' + | Cast (c, _, _), _ -> aux ctx c ty + | _, _ -> (ctx, c, ty) + in + aux Context.Rel.empty c ty + +(* XXX: What's the relation of this with Abstract.shrink ? *) +let shrink_body c ty = + let ctx, b, ty = + match ty with + | None -> + let ctx, b = Term.decompose_lam_assum c in + (ctx, b, None) + | Some ty -> + let ctx, b, ty = decompose_lam_prod c ty in + (ctx, b, Some ty) + in + let b', ty', n, args = + List.fold_left + (fun (b, ty, i, args) decl -> + if Vars.noccurn 1 b && Option.cata (Vars.noccurn 1) true ty then + (Vars.subst1 mkProp b, Option.map (Vars.subst1 mkProp) ty, succ i, args) + else + let open Context.Rel.Declaration in + let args = if is_local_assum decl then mkRel i :: args else args in + ( Term.mkLambda_or_LetIn decl b + , Option.map (Term.mkProd_or_LetIn decl) ty + , succ i + , args )) + (b, ty, 1, []) ctx + in + (ctx, b', ty', Array.of_list args) + +(***********************************************************************) +(* Saving an obligation *) +(***********************************************************************) + +let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] + +let add_hint local prg cst = + let locality = if local then Goptions.OptLocal else Goptions.OptExport in + Hints.add_hints ~locality [Id.to_string prg.prg_name] (unfold_entry cst) + +(* true = hide obligations *) +let get_hide_obligations = + Goptions.declare_bool_option_and_ref + ~depr:true + ~key:["Hide"; "Obligations"] + ~value:false + +let declare_obligation prg obl ~uctx ~types ~body = + let univs = UState.univ_entry ~poly:prg.prg_poly uctx in + let body = prg.prg_reduce body in + let types = Option.map prg.prg_reduce types in + match obl.obl_status with + | _, Evar_kinds.Expand -> (false, {obl with obl_body = Some (TermObl body)}) + | force, Evar_kinds.Define opaque -> + let opaque = (not force) && opaque in + let poly = prg.prg_poly in + let ctx, body, ty, args = + if not poly then shrink_body body types + else ([], body, types, [||]) + in + let ce = definition_entry ?types:ty ~opaque ~univs body in + (* ppedrot: seems legit to have obligations as local *) + let constant = + declare_constant ~name:obl.obl_name + ~local:ImportNeedQualified + ~kind:Decls.(IsProof Property) + (DefinitionEntry ce) + in + if not opaque then + add_hint (Locality.make_section_locality None) prg constant; + definition_message obl.obl_name; + let body = + match univs with + | Entries.Polymorphic_entry (_, uctx) -> + Some (DefinedObl (constant, Univ.UContext.instance uctx)) + | Entries.Monomorphic_entry _ -> + Some + (TermObl + (it_mkLambda_or_LetIn_or_clean + (mkApp (mkConst constant, args)) + ctx)) + in + (true, {obl with obl_body = body}) + +(* Updating the obligation meta-info on close *) + +let not_transp_msg = + Pp.( + str "Obligation should be transparent but was declared opaque." + ++ spc () + ++ str "Use 'Defined' instead.") + +let pperror cmd = CErrors.user_err ~hdr:"Program" cmd +let err_not_transp () = pperror not_transp_msg + +module ProgMap = Id.Map + +module StateFunctional = struct + + type t = ProgramDecl.t CEphemeron.key ProgMap.t + + let _empty = ProgMap.empty + + let pending pm = + ProgMap.filter + (fun _ v -> (CEphemeron.get v).prg_obligations.remaining > 0) + pm + + let num_pending pm = pending pm |> ProgMap.cardinal + + let first_pending pm = + pending pm |> ProgMap.choose_opt + |> Option.map (fun (_, v) -> CEphemeron.get v) + + let get_unique_open_prog pm name : (_, Id.t list) result = + match name with + | Some n -> + Option.cata + (fun p -> Ok (CEphemeron.get p)) + (Error []) (ProgMap.find_opt n pm) + | None -> ( + let n = num_pending pm in + match n with + | 0 -> Error [] + | 1 -> Option.cata (fun p -> Ok p) (Error []) (first_pending pm) + | _ -> + let progs = Id.Set.elements (ProgMap.domain pm) in + Error progs ) + + let add t key prg = ProgMap.add key (CEphemeron.create prg) t + + let fold t ~f ~init = + let f k v acc = f k (CEphemeron.get v) acc in + ProgMap.fold f t init + + let all pm = ProgMap.bindings pm |> List.map (fun (_,v) -> CEphemeron.get v) + let find m t = ProgMap.find_opt t m |> Option.map CEphemeron.get +end + +module State = struct + + type t = StateFunctional.t + + open StateFunctional + + let prg_ref, prg_tag = + Summary.ref_tag ProgMap.empty ~name:"program-tcc-table" + + let num_pending () = num_pending !prg_ref + let first_pending () = first_pending !prg_ref + let get_unique_open_prog id = get_unique_open_prog !prg_ref id + let add id prg = prg_ref := add !prg_ref id prg + let fold ~f ~init = fold !prg_ref ~f ~init + let all () = all !prg_ref + let find id = find !prg_ref id + +end + +(* In all cases, the use of the map is read-only so we don't expose the ref *) +let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] + +let check_solved_obligations ~what_for : unit = + if not (ProgMap.is_empty !State.prg_ref) then + let keys = map_keys !State.prg_ref in + let have_string = if Int.equal (List.length keys) 1 then " has " else " have " in + CErrors.user_err ~hdr:"Program" + Pp.( + str "Unsolved obligations when closing " + ++ what_for ++ str ":" ++ spc () + ++ prlist_with_sep spc (fun x -> Id.print x) keys + ++ str have_string + ++ str "unsolved obligations" ) + +let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) +let progmap_remove pm prg = ProgMap.remove prg.prg_name pm +let progmap_replace prg' pm = map_replace prg'.prg_name prg' pm +let obligations_solved prg = Int.equal prg.prg_obligations.remaining 0 + +let obligations_message rem = + Format.asprintf "%s %s remaining" + (if rem > 0 then string_of_int rem else "No more") + (CString.plural rem "obligation") + |> Pp.str |> Flags.if_verbose Feedback.msg_info + +type progress = Remain of int | Dependent | Defined of GlobRef.t + +let get_obligation_body expand obl = + match obl.obl_body with + | None -> None + | Some c -> ( + if expand && snd obl.obl_status == Evar_kinds.Expand then + match c with + | DefinedObl pc -> Some (Environ.constant_value_in (Global.env ()) pc) + | TermObl c -> Some c + else + match c with DefinedObl pc -> Some (mkConstU pc) | TermObl c -> Some c ) + +let obl_substitution expand obls deps = + Int.Set.fold + (fun x acc -> + let xobl = obls.(x) in + match get_obligation_body expand xobl with + | None -> acc + | Some oblb -> (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) + deps [] + +let rec intset_to = function + | -1 -> Int.Set.empty + | n -> Int.Set.add n (intset_to (pred n)) + +let obligation_substitution expand prg = + let obls = prg.prg_obligations.obls in + let ints = intset_to (pred (Array.length obls)) in + obl_substitution expand obls ints + +let hide_obligation () = + Coqlib.check_required_library ["Coq"; "Program"; "Tactics"]; + UnivGen.constr_of_monomorphic_global + (Coqlib.lib_ref "program.tactics.obligation") + +(* XXX: Is this the right place? *) +let rec prod_app t n = + match + Constr.kind + (EConstr.Unsafe.to_constr + (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) + (* FIXME *) + with + | Prod (_, _, b) -> Vars.subst1 n b + | LetIn (_, b, t, b') -> prod_app (Vars.subst1 b b') n + | _ -> + CErrors.user_err ~hdr:"prod_app" + Pp.(str "Needed a product, but didn't find one" ++ fnl ()) + +(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) +let prod_applist t nL = List.fold_left prod_app t nL + +let replace_appvars subst = + let rec aux c = + let f, l = decompose_app c in + if isVar f then + try + let c' = List.map (Constr.map aux) l in + let t, b = Id.List.assoc (destVar f) subst in + mkApp + ( delayed_force hide_obligation + , [|prod_applist t c'; Term.applistc b c'|] ) + with Not_found -> Constr.map aux c + else Constr.map aux c + in + Constr.map aux + +let subst_prog subst prg = + if get_hide_obligations () then + ( replace_appvars subst prg.prg_body + , replace_appvars subst (* Termops.refresh_universes *) prg.prg_type ) + else + let subst' = List.map (fun (n, (_, b)) -> (n, b)) subst in + ( Vars.replace_vars subst' prg.prg_body + , Vars.replace_vars subst' (* Termops.refresh_universes *) prg.prg_type ) + +let stm_get_fix_exn = ref (fun _ x -> x) + +let declare_definition prg = + let varsubst = obligation_substitution true prg in + let sigma = Evd.from_ctx prg.prg_ctx in + let body, types = subst_prog varsubst prg in + let body, types = EConstr.(of_constr body, Some (of_constr types)) in + (* All these should be grouped into a struct a some point *) + let opaque, poly, udecl, hook = + (prg.prg_opaque, prg.prg_poly, prg.prg_univdecl, prg.prg_hook) + in + let name, scope, kind, impargs = + ( prg.prg_name + , prg.prg_scope + , Decls.(IsDefinition prg.prg_kind) + , prg.prg_implicits ) + in + let fix_exn = !stm_get_fix_exn () in + let obls = List.map (fun (id, (_, c)) -> (id, c)) varsubst in + (* XXX: This is doing normalization twice *) + let kn = + declare_definition ~name ~scope ~kind ~impargs ?hook ~obls + ~fix_exn ~opaque ~poly ~udecl ~types ~body sigma + in + let pm = progmap_remove !State.prg_ref prg in + State.prg_ref := pm; + kn + +let rec lam_index n t acc = + match Constr.kind t with + | Lambda ({Context.binder_name = Name n'}, _, _) when Id.equal n n' -> acc + | Lambda (_, _, b) -> lam_index n b (succ acc) + | _ -> raise Not_found + +let compute_possible_guardness_evidences n fixbody fixtype = + match n with + | Some {CAst.loc; v = n} -> [lam_index n fixbody 0] + | None -> + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual + fixpoints ?) *) + let m = Termops.nb_prod Evd.empty (EConstr.of_constr fixtype) (* FIXME *) in + let ctx = fst (Term.decompose_prod_n_assum m fixtype) in + List.map_i (fun i _ -> i) 0 ctx + +let declare_mutual_definition l = + let len = List.length l in + let first = List.hd l in + let defobl x = + let oblsubst = obligation_substitution true x in + 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, r, x.prg_reduce typ, x.prg_implicits) in + let oblsubst = List.map (fun (id, (_, c)) -> (id, c)) oblsubst in + (def, oblsubst) + in + let defs, obls = + List.fold_right + (fun x (defs, obls) -> + let xdef, xobls = defobl x in + (xdef :: defs, xobls @ obls)) + l ([], []) + in + (* let fixdefs = List.map reduce_fix fixdefs in *) + let fixdefs, fixrs, fixtypes, fixitems = + List.fold_right2 + (fun (d, r, typ, impargs) name (a1, a2, a3, a4) -> + ( d :: a1 + , r :: a2 + , typ :: a3 + , Recthm.{name; typ; impargs; args = []} :: a4 )) + defs first.prg_deps ([], [], [], []) + in + let fixkind = Option.get first.prg_fixkind in + let arrrec, recvec = (Array.of_list fixtypes, Array.of_list fixdefs) in + let rvec = Array.of_list fixrs in + let namevec = Array.of_list (List.map (fun x -> Name x.prg_name) l) in + let rec_declaration = (Array.map2 Context.make_annot namevec rvec, arrrec, recvec) in + let possible_indexes = + match fixkind with + | IsFixpoint wfl -> + Some (List.map3 compute_possible_guardness_evidences wfl fixdefs fixtypes) + | IsCoFixpoint -> None + in + (* In the future we will pack all this in a proper record *) + let poly, scope, ntns, opaque = + (first.prg_poly, first.prg_scope, first.prg_notations, first.prg_opaque) + in + let kind = + if fixkind != IsCoFixpoint then Decls.(IsDefinition Fixpoint) + else Decls.(IsDefinition CoFixpoint) + in + (* Declare the recursive definitions *) + let udecl = UState.default_univ_decl in + let kns = + declare_mutually_recursive ~scope ~opaque ~kind ~udecl ~ntns + ~uctx:first.prg_ctx ~rec_declaration ~possible_indexes ~poly + ~restrict_ucontext:false fixitems + in + (* Only for the first constant *) + let dref = List.hd kns in + Hook.( + call ?hook:first.prg_hook {S.uctx = first.prg_ctx; obls; scope; dref}); + let pm = List.fold_left progmap_remove !State.prg_ref l in + State.prg_ref := pm; + dref + +let update_obls prg obls rem = + let prg_obligations = {obls; remaining = rem} in + let prg' = {prg with prg_obligations} in + let pm = progmap_replace prg' !State.prg_ref in + State.prg_ref := pm; + obligations_message rem; + if rem > 0 then Remain rem + else + match prg'.prg_deps with + | [] -> + let kn = declare_definition prg' in + let pm = progmap_remove !State.prg_ref prg' in + State.prg_ref := pm; + Defined kn + | l -> + let progs = + List.map (fun x -> CEphemeron.get (ProgMap.find x pm)) prg'.prg_deps + in + if List.for_all (fun x -> obligations_solved x) progs then + let kn = declare_mutual_definition progs in + Defined kn + else Dependent + +let dependencies obls n = + let res = ref Int.Set.empty in + Array.iteri + (fun i obl -> + if (not (Int.equal i n)) && Int.Set.mem n obl.obl_deps then + res := Int.Set.add i !res) + obls; + !res + +let update_program_decl_on_defined prg obls num obl ~uctx rem ~auto = + let obls = Array.copy obls in + let () = obls.(num) <- obl in + let prg = {prg with prg_ctx = uctx} in + let _progress = update_obls prg obls (pred rem) in + let () = + if pred rem > 0 then + let deps = dependencies obls num in + if not (Int.Set.is_empty deps) then + let _progress = auto (Some prg.prg_name) deps None in + () + else () + else () + in + () + +type obligation_resolver = + Id.t option + -> Int.Set.t + -> unit Proofview.tactic option + -> progress + +type obligation_qed_info = {name : Id.t; num : int; auto : obligation_resolver} + +let obligation_terminator entries uctx {name; num; auto} = + match entries with + | [entry] -> + let env = Global.env () in + let ty = entry.proof_entry_type in + let body, uctx = inline_private_constants ~uctx env entry in + let sigma = Evd.from_ctx uctx in + Inductiveops.control_only_guard (Global.env ()) sigma + (EConstr.of_constr body); + (* Declare the obligation ourselves and drop the hook *) + let prg = Option.get (State.find name) in + let {obls; remaining = rem} = prg.prg_obligations in + let obl = obls.(num) in + let status = + match (obl.obl_status, entry.proof_entry_opaque) with + | (_, Evar_kinds.Expand), true -> err_not_transp () + | (true, _), true -> err_not_transp () + | (false, _), true -> Evar_kinds.Define true + | (_, Evar_kinds.Define true), false -> Evar_kinds.Define false + | (_, status), false -> status + in + let obl = {obl with obl_status = (false, status)} in + let uctx = if prg.prg_poly then uctx else UState.union prg.prg_ctx uctx in + let defined, obl = declare_obligation prg obl ~body ~types:ty ~uctx in + let prg_ctx = + if prg.prg_poly then + (* Polymorphic *) + (* We merge the new universes and constraints of the + polymorphic obligation with the existing ones *) + UState.union prg.prg_ctx uctx + else if + (* The first obligation, if defined, + declares the univs of the constant, + each subsequent obligation declares its own additional + universes and constraints if any *) + defined + then + UState.from_env (Global.env ()) + else uctx + in + update_program_decl_on_defined prg obls num obl ~uctx:prg_ctx rem ~auto + | _ -> + CErrors.anomaly + Pp.( + str + "[obligation_terminator] close_proof returned more than one proof \ + term") + +(* Similar to the terminator but for the admitted path; this assumes + the admitted constant was already declared. + + FIXME: There is duplication of this code with obligation_terminator + and Obligations.admit_obligations *) +let obligation_admitted_terminator {name; num; auto} ctx' dref = + let prg = Option.get (State.find name) in + let {obls; remaining = rem} = prg.prg_obligations in + let obl = obls.(num) in + let cst = match dref with GlobRef.ConstRef cst -> cst | _ -> assert false in + let transparent = Environ.evaluable_constant cst (Global.env ()) in + let () = + match obl.obl_status with + | true, Evar_kinds.Expand | true, Evar_kinds.Define true -> + if not transparent then err_not_transp () + | _ -> () + in + let inst, ctx' = + if not prg.prg_poly (* Not polymorphic *) then + (* The universe context was declared globally, we continue + from the new global environment. *) + let ctx = UState.from_env (Global.env ()) in + let ctx' = UState.merge_subst ctx (UState.subst ctx') in + (Univ.Instance.empty, ctx') + else + (* We get the right order somehow, but surely it could be enforced in a clearer way. *) + let uctx = UState.context ctx' in + (Univ.UContext.instance uctx, ctx') + in + let obl = {obl with obl_body = Some (DefinedObl (cst, inst))} in + let () = if transparent then add_hint true prg cst in + update_program_decl_on_defined prg obls num obl ~uctx:ctx' rem ~auto + +end + +(************************************************************************) +(* Commom constant saving path, for both Qed and Admitted *) +(************************************************************************) + +(* Support for mutually proved theorems *) + +module Proof_ending = struct + + type t = + | Regular + | End_obligation of Obls.obligation_qed_info + | End_derive of { f : Id.t; name : Id.t } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } + +end + +type lemma_possible_guards = int list list + +module Info = struct + + type t = + { hook : Hook.t option + ; proof_ending : Proof_ending.t CEphemeron.key + (* This could be improved and the CEphemeron removed *) + ; scope : locality + ; kind : Decls.logical_kind + (* thms and compute guard are specific only to start_lemma_with_initialization + regular terminator *) + ; thms : Recthm.t list + ; compute_guard : lemma_possible_guards + } + + let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=Global ImportDefaultBehavior) + ?(kind=Decls.(IsProof Lemma)) ?(compute_guard=[]) ?(thms=[]) () = + { hook + ; compute_guard + ; proof_ending = CEphemeron.create proof_ending + ; thms + ; scope + ; kind + } + + (* This is used due to a deficiency on the API, should fix *) + let add_first_thm ~info ~name ~typ ~impargs = + let thms = + { Recthm.name + ; impargs + ; typ = EConstr.Unsafe.to_constr typ + ; args = [] } :: info.thms + in + { info with thms } + +end + +(* XXX: this should be unified with the code for non-interactive + mutuals previously on this file. *) +module MutualEntry : sig + + val declare_variable + : info:Info.t + -> uctx:UState.t + -> Entries.parameter_entry + -> Names.GlobRef.t list + + val declare_mutdef + (* Common to all recthms *) + : info:Info.t + -> uctx:UState.t + -> Evd.side_effects proof_entry + -> Names.GlobRef.t list + +end = struct + + (* XXX: Refactor this with the code in [Declare.declare_mutdef] *) + let guess_decreasing env possible_indexes ((body, ctx), eff) = + let open Constr in + match Constr.kind body with + | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> + let env = Safe_typing.push_private_constants env eff.Evd.seff_private in + let indexes = Pretyping.search_guard env possible_indexes fixdecls in + (mkFix ((indexes,0),fixdecls), ctx), eff + | _ -> (body, ctx), eff + + let select_body i t = + let open Constr in + match Constr.kind t with + | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) + | CoFix (0,decls) -> mkCoFix (i,decls) + | _ -> + CErrors.anomaly + Pp.(str "Not a proof by induction: " ++ + Termops.Internal.debug_print_constr (EConstr.of_constr t) ++ str ".") + + let declare_mutdef ~uctx ~info pe i Recthm.{ name; impargs; typ; _} = + let { Info.hook; scope; kind; compute_guard; _ } = info in + (* if i = 0 , we don't touch the type; this is for compat + but not clear it is the right thing to do. + *) + let pe, ubind = + if i > 0 && not (CList.is_empty compute_guard) + then Internal.map_entry_type pe ~f:(fun _ -> Some typ), UnivNames.empty_binders + else pe, UState.universe_binders uctx + in + (* We when compute_guard was [] in the previous step we should not + substitute the body *) + let pe = match compute_guard with + | [] -> pe + | _ -> + Internal.map_entry_body pe + ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) + in + declare_entry ~name ~scope ~kind ?hook ~impargs ~uctx pe + + let declare_mutdef ~info ~uctx const = + let pe = match info.Info.compute_guard with + | [] -> + (* Not a recursive statement *) + const + | possible_indexes -> + (* Try all combinations... not optimal *) + let env = Global.env() in + Internal.map_entry_body const + ~f:(guess_decreasing env possible_indexes) + in + List.map_i (declare_mutdef ~info ~uctx pe) 0 info.Info.thms + + let declare_variable ~info ~uctx pe = + let { Info.scope; hook } = info in + List.map_i ( + fun i { Recthm.name; typ; impargs } -> + declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + ) 0 info.Info.thms + +end + +(************************************************************************) +(* Admitting a lemma-like constant *) +(************************************************************************) + +(* Admitted *) +let get_keep_admitted_vars = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Keep"; "Admitted"; "Variables"] + ~value:true + +let compute_proof_using_for_admitted proof typ pproofs = + if not (get_keep_admitted_vars ()) then None + else match get_used_variables proof, pproofs with + | Some _ as x, _ -> x + | None, pproof :: _ -> + let env = Global.env () in + let ids_typ = Environ.global_vars_set env typ in + (* [pproof] is evar-normalized by [partial_proof]. We don't + count variables appearing only in the type of evars. *) + let ids_def = Environ.global_vars_set env (EConstr.Unsafe.to_constr pproof) in + Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) + | _ -> None + +let finish_admitted ~info ~uctx pe = + let cst = MutualEntry.declare_variable ~info ~uctx pe in + (* If the constant was an obligation we need to update the program map *) + match CEphemeron.get info.Info.proof_ending with + | Proof_ending.End_obligation oinfo -> + Obls.obligation_admitted_terminator oinfo uctx (List.hd cst) + | _ -> () + +let save_lemma_admitted ~proof ~info = + let udecl = get_universe_decl proof in + let Proof.{ poly; entry } = Proof.data (get_proof proof) in + let typ = match Proofview.initial_goals entry with + | [typ] -> snd typ + | _ -> CErrors.anomaly ~label:"Lemmas.save_lemma_admitted" (Pp.str "more than one statement.") + in + let typ = EConstr.Unsafe.to_constr typ in + let iproof = get_proof proof in + let pproofs = Proof.partial_proof iproof in + let sec_vars = compute_proof_using_for_admitted proof typ pproofs in + let uctx = get_initial_euctx proof in + let univs = UState.check_univ_decl ~poly uctx udecl in + finish_admitted ~info ~uctx (sec_vars, (typ, univs), None) + +(************************************************************************) +(* Saving a lemma-like constant *) +(************************************************************************) + +let finish_proved po info = + match po with + | { entries=[const]; uctx } -> + let _r : Names.GlobRef.t list = MutualEntry.declare_mutdef ~info ~uctx const in + () + | _ -> + CErrors.anomaly ~label:"finish_proved" Pp.(str "close_proof returned more than one proof term") + +let finish_derived ~f ~name ~entries = + (* [f] and [name] correspond to the proof of [f] and of [suchthat], respectively. *) + + let f_def, lemma_def = + match entries with + | [_;f_def;lemma_def] -> + f_def, lemma_def + | _ -> assert false + in + (* The opacity of [f_def] is adjusted to be [false], as it + must. Then [f] is declared in the global environment. *) + let f_def = Internal.set_opacity ~opaque:false f_def in + let f_kind = Decls.(IsDefinition Definition) in + let f_def = DefinitionEntry f_def in + let f_kn = declare_constant ~name:f ~kind:f_kind f_def in + let f_kn_term = Constr.mkConst f_kn in + (* In the type and body of the proof of [suchthat] there can be + references to the variable [f]. It needs to be replaced by + references to the constant [f] declared above. This substitution + performs this precise action. *) + let substf c = Vars.replace_vars [f,f_kn_term] c in + (* Extracts the type of the proof of [suchthat]. *) + let lemma_pretype typ = + match typ with + | Some t -> Some (substf t) + | None -> assert false (* Declare always sets type here. *) + in + (* The references of [f] are subsituted appropriately. *) + let lemma_def = Internal.map_entry_type lemma_def ~f:lemma_pretype in + (* The same is done in the body of the proof. *) + let lemma_def = Internal.map_entry_body lemma_def ~f:(fun ((b,ctx),fx) -> (substf b, ctx), fx) in + let lemma_def = DefinitionEntry lemma_def in + let _ : Names.Constant.t = declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in + () + +let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = + + let obls = ref 1 in + let sigma, recobls = + CList.fold_left2_map (fun sigma (_evar_env, ev, _evi, local_context, _type) entry -> + let id = + match Evd.evar_ident ev sigma0 with + | Some id -> id + | None -> let n = !obls in incr obls; Nameops.add_suffix i ("_obligation_" ^ string_of_int n) + in + let entry, args = Internal.shrink_entry local_context entry in + let cst = declare_constant ~name:id ~kind (DefinitionEntry entry) in + let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in + let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in + sigma, cst) sigma0 + types proof_obj.entries + in + hook recobls sigma + +let finalize_proof proof_obj proof_info = + let open Proof_ending in + match CEphemeron.default proof_info.Info.proof_ending Regular with + | Regular -> + finish_proved proof_obj proof_info + | End_obligation oinfo -> + Obls.obligation_terminator proof_obj.entries proof_obj.uctx oinfo + | End_derive { f ; name } -> + finish_derived ~f ~name ~entries:proof_obj.entries + | End_equations { hook; i; types; sigma } -> + finish_proved_equations ~kind:proof_info.Info.kind ~hook i proof_obj types sigma + +let err_save_forbidden_in_place_of_qed () = + CErrors.user_err (Pp.str "Cannot use Save with more than one constant or in this proof mode") + +let process_idopt_for_save ~idopt info = + match idopt with + | None -> info + | Some { CAst.v = save_name } -> + (* Save foo was used; we override the info in the first theorem *) + let thms = + match info.Info.thms, CEphemeron.default info.Info.proof_ending Proof_ending.Regular with + | [ { Recthm.name; _} as decl ], Proof_ending.Regular -> + [ { decl with Recthm.name = save_name } ] + | _ -> + err_save_forbidden_in_place_of_qed () + in { info with Info.thms } + +let save_lemma_proved ~proof ~info ~opaque ~idopt = + (* Env and sigma are just used for error printing in save_remaining_recthms *) + let proof_obj = close_proof ~opaque ~keep_body_ucst_separate:false proof in + let proof_info = process_idopt_for_save ~idopt info in + finalize_proof proof_obj proof_info + +(***********************************************************************) +(* Special case to close a lemma without forcing a proof *) +(***********************************************************************) +let save_lemma_admitted_delayed ~proof ~info = + let { entries; uctx } = proof in + if List.length entries <> 1 then + CErrors.user_err Pp.(str "Admitted does not support multiple statements"); + let { proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in + let poly = match proof_entry_universes with + | Entries.Monomorphic_entry _ -> false + | Entries.Polymorphic_entry (_, _) -> true in + let typ = match proof_entry_type with + | None -> CErrors.user_err Pp.(str "Admitted requires an explicit statement"); + | Some typ -> typ in + let ctx = UState.univ_entry ~poly uctx in + let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in + finish_admitted ~uctx ~info (sec_vars, (typ, ctx), None) + +let save_lemma_proved_delayed ~proof ~info ~idopt = + (* vio2vo calls this but with invalid info, we have to workaround + that to add the name to the info structure *) + if CList.is_empty info.Info.thms then + let name = get_po_name proof in + let info = Info.add_first_thm ~info ~name ~typ:EConstr.mkSet ~impargs:[] in + finalize_proof proof info + else + let info = process_idopt_for_save ~idopt info in + finalize_proof proof info + +module Proof = struct + type nonrec t = t + let get_proof = get_proof + let get_proof_name = get_proof_name + let map_proof = map_proof + let map_fold_proof = map_fold_proof + let map_fold_proof_endline = map_fold_proof_endline + let set_endline_tactic = set_endline_tactic + let set_used_variables = set_used_variables + let compact = compact_the_proof + let update_global_env = update_global_env + let get_open_goals = get_open_goals +end diff --git a/vernac/declare.mli b/vernac/declare.mli index 340c035d1d..647896e2f5 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -17,9 +17,9 @@ open Entries environment. It also updates some accesory tables such as [Nametab] (name resolution), [Impargs], and [Notations]. *) -(** We provide two kind of fuctions: +(** We provide two kind of functions: - - one go functions, that will register a constant in one go, suited + - one-go functions, that will register a constant in one go, suited for non-interactive definitions where the term is given. - two-phase [start/declare] functions which will create an @@ -29,6 +29,13 @@ open Entries Internally, these functions mainly differ in that usually, the first case doesn't require setting up the tactic engine. + Note that the API in this file is still in a state of flux, don't + hesitate to contact the maintainers if you have any question. + + Additionally, this file does contain some low-level functions, marked + as such; these functions are unstable and should not be used unless you + already know what they are doing. + *) (** [Declare.Proof.t] Construction of constants using interactive proofs. *) @@ -41,11 +48,6 @@ module Proof : sig val get_proof : t -> Proof.t val get_proof_name : t -> Names.Id.t - (** XXX: These 3 are only used in lemmas *) - val get_used_variables : t -> Names.Id.Set.t option - val get_universe_decl : t -> UState.universe_decl - val get_initial_euctx : t -> UState.t - val map_proof : (Proof.t -> Proof.t) -> t -> t val map_fold_proof : (Proof.t -> Proof.t * 'a) -> t -> t * 'a val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a @@ -97,39 +99,33 @@ val start_dependent_proof (** Proof entries represent a proof that has been finished, but still not registered with the kernel. - XXX: Scheduled for removal from public API, don't rely on it *) -type 'a proof_entry = private { - proof_entry_body : 'a Entries.const_entry_body; - (* List of section variables *) - proof_entry_secctx : Id.Set.t option; - (* State id on which the completion of type checking is reported *) - proof_entry_feedback : Stateid.t option; - proof_entry_type : Constr.types option; - proof_entry_universes : Entries.universes_entry; - proof_entry_opaque : bool; - proof_entry_inline_code : bool; -} - -(** XXX: Scheduled for removal from public API, don't rely on it *) -type proof_object = private - { name : Names.Id.t - (** name of the proof *) - ; entries : Evd.side_effects proof_entry list - (** list of the proof terms (in a form suitable for definitions). *) - ; uctx: UState.t - (** universe state *) - } + XXX: This is an internal, low-level API and could become scheduled + for removal from the public API, use higher-level declare APIs + instead *) +type 'a proof_entry + +(** XXX: This is an internal, low-level API and could become scheduled + for removal from the public API, use higher-level declare APIs + instead *) +type proof_object + +(** Used by the STM only to store info, should go away *) +val get_po_name : proof_object -> Id.t val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Proof.t -> proof_object (** Declaration of local constructions (Variable/Hypothesis/Local) *) -(** XXX: Scheduled for removal from public API, don't rely on it *) +(** XXX: This is an internal, low-level API and could become scheduled + for removal from the public API, use higher-level declare APIs + instead *) type variable_declaration = | SectionLocalDef of Evd.side_effects proof_entry | SectionLocalAssum of { typ:types; impl:Glob_term.binding_kind; } -(** XXX: Scheduled for removal from public API, don't rely on it *) +(** XXX: This is an internal, low-level API and could become scheduled + for removal from the public API, use higher-level declare APIs + instead *) type 'a constant_entry = | DefinitionEntry of 'a proof_entry | ParameterEntry of parameter_entry @@ -144,7 +140,9 @@ val declare_variable (** Declaration of global constructions i.e. Definition/Theorem/Axiom/Parameter/... - XXX: Scheduled for removal from public API, use `DeclareDef` instead *) + XXX: This is an internal, low-level API and could become scheduled + for removal from the public API, use higher-level declare APIs + instead *) val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool @@ -160,7 +158,7 @@ val definition_entry -> constr -> Evd.side_effects proof_entry -type import_status = ImportDefaultBehavior | ImportNeedQualified +type import_status = Locality.import_status = ImportDefaultBehavior | ImportNeedQualified (** [declare_constant id cd] declares a global declaration (constant/parameter) with name [id] in the current section; it returns @@ -169,7 +167,9 @@ type import_status = ImportDefaultBehavior | ImportNeedQualified internal specify if the constant has been created by the kernel or by the user, and in the former case, if its errors should be silent - XXX: Scheduled for removal from public API, use `DeclareDef` instead *) + XXX: This is an internal, low-level API and could become scheduled + for removal from the public API, use higher-level declare APIs + instead *) val declare_constant : ?local:import_status -> name:Id.t @@ -177,17 +177,6 @@ val declare_constant -> Evd.side_effects constant_entry -> Constant.t -(** [inline_private_constants ~sideff ~uctx env ce] will inline the - constants in [ce]'s body and return the body plus the updated - [UState.t]. - - XXX: Scheduled for removal from public API, don't rely on it *) -val inline_private_constants - : uctx:UState.t - -> Environ.env - -> Evd.side_effects proof_entry - -> Constr.t * UState.t - (** Declaration messages *) (** XXX: Scheduled for removal from public API, do not use *) @@ -201,13 +190,6 @@ val check_exists : Id.t -> unit module Internal : sig - val map_entry_body : f:('a Entries.proof_output -> 'b Entries.proof_output) -> 'a proof_entry -> 'b proof_entry - val map_entry_type : f:(Constr.t option -> Constr.t option) -> 'a proof_entry -> 'a proof_entry - (* Overriding opacity is indeed really hacky *) - val set_opacity : opaque:bool -> 'a proof_entry -> 'a proof_entry - - val shrink_entry : EConstr.named_context -> 'a proof_entry -> 'a proof_entry * Constr.constr list - type constant_obj val objConstant : constant_obj Libobject.Dyn.tag @@ -233,6 +215,7 @@ val close_future_proof : feedback_id:Stateid.t -> Proof.t -> closed_proof_output Returns [false] if an unsafe tactic has been used. *) val by : unit Proofview.tactic -> Proof.t -> Proof.t * bool +(** Semantics of this function is a bit dubious, use with care *) val build_by_tactic : ?side_eff:bool -> Environ.env @@ -260,7 +243,7 @@ val get_current_goal_context : Proof.t -> Evd.evar_map * Environ.env environment and empty evar_map. *) val get_current_context : Proof.t -> Evd.evar_map * Environ.env -(** Temporarily re-exported for 3rd party code; don't use *) +(** XXX: Temporarily re-exported for 3rd party code; don't use *) val build_constant_by_tactic : name:Names.Id.t -> ?opaque:opacity_flag -> @@ -270,11 +253,12 @@ val build_constant_by_tactic : EConstr.types -> unit Proofview.tactic -> Evd.side_effects proof_entry * bool * UState.t +[@@ocaml.deprecated "This function is deprecated, used newer API in declare"] val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit [@@ocaml.deprecated "Use DeclareUctx.declare_universe_context"] -type locality = Discharge | Global of import_status +type locality = Locality.locality = Discharge | Global of import_status (** Declaration hooks *) module Hook : sig @@ -303,7 +287,9 @@ module Hook : sig val call : ?hook:t -> S.t -> unit end -(** Declare an interactively-defined constant *) +(** XXX: This is an internal, low-level API and could become scheduled + for removal from the public API, use higher-level declare APIs + instead *) val declare_entry : name:Id.t -> scope:locality @@ -361,6 +347,8 @@ module Recthm : sig } end +type lemma_possible_guards = int list list + val declare_mutually_recursive : opaque:bool -> scope:locality @@ -370,19 +358,16 @@ val declare_mutually_recursive -> udecl:UState.universe_decl -> ntns:Vernacexpr.decl_notation list -> rec_declaration:Constr.rec_declaration - -> possible_indexes:int list list option + -> possible_indexes:lemma_possible_guards option -> ?restrict_ucontext:bool (** XXX: restrict_ucontext should be always true, this seems like a bug in obligations, so this parameter should go away *) -> Recthm.t list -> Names.GlobRef.t list +(** Prepare API, to be removed once we provide the corresponding 1-step API *) val prepare_obligation - : ?opaque:bool - -> ?inline:bool - -> name:Id.t - -> poly:bool - -> udecl:UState.universe_decl + : name:Id.t -> types:EConstr.t option -> body:EConstr.t -> Evd.evar_map @@ -397,3 +382,208 @@ val prepare_parameter (* Compat: will remove *) exception AlreadyDeclared of (string option * Names.Id.t) + +module Obls : sig + +type 'a obligation_body = DefinedObl of 'a | TermObl of constr + +module Obligation : sig + type t = private + { obl_name : Id.t + ; obl_type : types + ; obl_location : Evar_kinds.t Loc.located + ; obl_body : pconstant obligation_body option + ; obl_status : bool * Evar_kinds.obligation_definition_status + ; obl_deps : Int.Set.t + ; obl_tac : unit Proofview.tactic option } + + val set_type : typ:Constr.types -> t -> t + val set_body : body:pconstant obligation_body -> t -> t +end + +type obligations = {obls : Obligation.t array; remaining : int} +type fixpoint_kind = IsFixpoint of lident option list | IsCoFixpoint + +(* Information about a single [Program {Definition,Lemma,..}] declaration *) +module ProgramDecl : sig + type t = private + { prg_name : Id.t + ; prg_body : constr + ; prg_type : constr + ; prg_ctx : UState.t + ; prg_univdecl : UState.universe_decl + ; prg_obligations : obligations + ; prg_deps : Id.t list + ; prg_fixkind : fixpoint_kind option + ; prg_implicits : Impargs.manual_implicits + ; prg_notations : Vernacexpr.decl_notation list + ; prg_poly : bool + ; prg_scope : locality + ; prg_kind : Decls.definition_object_kind + ; prg_reduce : constr -> constr + ; prg_hook : Hook.t option + ; prg_opaque : bool } + + val make : + ?opaque:bool + -> ?hook:Hook.t + -> Names.Id.t + -> udecl:UState.universe_decl + -> uctx:UState.t + -> impargs:Impargs.manual_implicits + -> poly:bool + -> scope:locality + -> kind:Decls.definition_object_kind + -> Constr.constr option + -> Constr.types + -> Names.Id.t list + -> fixpoint_kind option + -> Vernacexpr.decl_notation list + -> RetrieveObl.obligation_info + -> (Constr.constr -> Constr.constr) + -> t + + val set_uctx : uctx:UState.t -> t -> t +end + +(** [declare_obligation prg obl ~uctx ~types ~body] Save an obligation + [obl] for program definition [prg] *) +val declare_obligation : + ProgramDecl.t + -> Obligation.t + -> uctx:UState.t + -> types:Constr.types option + -> body:Constr.types + -> bool * Obligation.t + +module State : sig + + val num_pending : unit -> int + val first_pending : unit -> ProgramDecl.t option + + (** Returns [Error duplicate_list] if not a single program is open *) + val get_unique_open_prog : + Id.t option -> (ProgramDecl.t, Id.t list) result + + (** Add a new obligation *) + val add : Id.t -> ProgramDecl.t -> unit + + val fold : f:(Id.t -> ProgramDecl.t -> 'a -> 'a) -> init:'a -> 'a + + val all : unit -> ProgramDecl.t list + + val find : Id.t -> ProgramDecl.t option + + (* Internal *) + type t + val prg_tag : t Summary.Dyn.tag +end + +val declare_definition : ProgramDecl.t -> Names.GlobRef.t + +(** Resolution status of a program *) +type progress = + | Remain of int (** n obligations remaining *) + | Dependent (** Dependent on other definitions *) + | Defined of GlobRef.t (** Defined as id *) + +type obligation_resolver = + Id.t option + -> Int.Set.t + -> unit Proofview.tactic option + -> progress + +type obligation_qed_info = {name : Id.t; num : int; auto : obligation_resolver} + +(** [update_obls prg obls n progress] What does this do? *) +val update_obls : + ProgramDecl.t -> Obligation.t array -> int -> progress + +(** Check obligations are properly solved before closing the + [what_for] section / module *) +val check_solved_obligations : what_for:Pp.t -> unit + +(** { 2 Util } *) + +val obl_substitution : + bool + -> Obligation.t array + -> Int.Set.t + -> (Id.t * (Constr.types * Constr.types)) list + +val dependencies : Obligation.t array -> int -> Int.Set.t + +(* This is a hack to make it possible for Obligations to craft a Qed + * behind the scenes. The fix_exn the Stm attaches to the Future proof + * is not available here, so we provide a side channel to get it *) +val stm_get_fix_exn : (unit -> Exninfo.iexn -> Exninfo.iexn) ref + +end + +(** Creating high-level proofs with an associated constant *) +module Proof_ending : sig + + type t = + | Regular + | End_obligation of Obls.obligation_qed_info + | End_derive of { f : Id.t; name : Id.t } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } + +end + +module Info : sig + type t + val make + : ?hook: Hook.t + (** Callback to be executed at the end of the proof *) + -> ?proof_ending : Proof_ending.t + (** Info for special constants *) + -> ?scope : locality + (** locality *) + -> ?kind:Decls.logical_kind + (** Theorem, etc... *) + -> ?compute_guard:lemma_possible_guards + -> ?thms:Recthm.t list + (** Both of those are internal, used by the upper layers but will + become handled natively here in the future *) + -> unit + -> t + + (* Internal; used to initialize non-mutual proofs *) + val add_first_thm : + info:t + -> name:Id.t + -> typ:EConstr.t + -> impargs:Impargs.manual_implicits + -> t +end + +val save_lemma_proved + : proof:Proof.t + -> info:Info.t + -> opaque:opacity_flag + -> idopt:Names.lident option + -> unit + +val save_lemma_admitted : + proof:Proof.t + -> info:Info.t + -> unit + +(** Special cases for delayed proofs, in this case we must provide the + proof information so the proof won't be forced. *) +val save_lemma_admitted_delayed : + proof:proof_object + -> info:Info.t + -> unit + +val save_lemma_proved_delayed + : proof:proof_object + -> info:Info.t + -> idopt:Names.lident option + -> unit diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml deleted file mode 100644 index 9ea54f5d8f..0000000000 --- a/vernac/declareObl.ml +++ /dev/null @@ -1,578 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Util -open Names -open Environ -open Context -open Constr -open Vars -open Entries - -type 'a obligation_body = DefinedObl of 'a | TermObl of constr - -module Obligation = struct - type t = - { obl_name : Id.t - ; obl_type : types - ; obl_location : Evar_kinds.t Loc.located - ; obl_body : pconstant obligation_body option - ; obl_status : bool * Evar_kinds.obligation_definition_status - ; obl_deps : Int.Set.t - ; obl_tac : unit Proofview.tactic option } - - let set_type ~typ obl = { obl with obl_type = typ } - let set_body ~body obl = { obl with obl_body = Some body } - -end - -type obligations = - { obls : Obligation.t array - ; remaining : int } - -type fixpoint_kind = - | IsFixpoint of lident option list - | IsCoFixpoint - -module ProgramDecl = struct - - type t = - { prg_name : Id.t - ; prg_body : constr - ; prg_type : constr - ; prg_ctx : UState.t - ; prg_univdecl : UState.universe_decl - ; prg_obligations : obligations - ; prg_deps : Id.t list - ; prg_fixkind : fixpoint_kind option - ; prg_implicits : Impargs.manual_implicits - ; prg_notations : Vernacexpr.decl_notation list - ; prg_poly : bool - ; prg_scope : Declare.locality - ; prg_kind : Decls.definition_object_kind - ; prg_reduce : constr -> constr - ; prg_hook : Declare.Hook.t option - ; prg_opaque : bool - } - - open Obligation - - let make ?(opaque = false) ?hook n ~udecl ~uctx ~impargs - ~poly ~scope ~kind b t deps fixkind notations obls reduce = - let obls', b = - match b with - | None -> - assert(Int.equal (Array.length obls) 0); - let n = Nameops.add_suffix n "_obligation" in - [| { obl_name = n; obl_body = None; - obl_location = Loc.tag Evar_kinds.InternalHole; obl_type = t; - obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty; - obl_tac = None } |], - mkVar n - | Some b -> - Array.mapi - (fun i (n, t, l, o, d, tac) -> - { obl_name = n ; obl_body = None; - obl_location = l; obl_type = t; obl_status = o; - obl_deps = d; obl_tac = tac }) - obls, b - in - let ctx = UState.make_flexible_nonalgebraic uctx in - { prg_name = n - ; prg_body = b - ; prg_type = reduce t - ; prg_ctx = ctx - ; prg_univdecl = udecl - ; prg_obligations = { obls = obls' ; remaining = Array.length obls' } - ; prg_deps = deps - ; prg_fixkind = fixkind - ; prg_notations = notations - ; prg_implicits = impargs - ; prg_poly = poly - ; prg_scope = scope - ; prg_kind = kind - ; prg_reduce = reduce - ; prg_hook = hook - ; prg_opaque = opaque - } - - let set_uctx ~uctx prg = {prg with prg_ctx = uctx} -end - -open Obligation -open ProgramDecl - -(* Saving an obligation *) - -(* XXX: Is this the right place for this? *) -let it_mkLambda_or_LetIn_or_clean t ctx = - let open Context.Rel.Declaration in - let fold t decl = - if is_local_assum decl then Term.mkLambda_or_LetIn decl t - else if noccurn 1 t then subst1 mkProp t - else Term.mkLambda_or_LetIn decl t - in - Context.Rel.fold_inside fold ctx ~init:t - -(* XXX: Is this the right place for this? *) -let decompose_lam_prod c ty = - let open Context.Rel.Declaration in - let rec aux ctx c ty = - match (Constr.kind c, Constr.kind ty) with - | LetIn (x, b, t, c), LetIn (x', b', t', ty) - when Constr.equal b b' && Constr.equal t t' -> - let ctx' = Context.Rel.add (LocalDef (x, b', t')) ctx in - aux ctx' c ty - | _, LetIn (x', b', t', ty) -> - let ctx' = Context.Rel.add (LocalDef (x', b', t')) ctx in - aux ctx' (lift 1 c) ty - | LetIn (x, b, t, c), _ -> - let ctx' = Context.Rel.add (LocalDef (x, b, t)) ctx in - aux ctx' c (lift 1 ty) - | Lambda (x, b, t), Prod (x', b', t') - (* By invariant, must be convertible *) -> - let ctx' = Context.Rel.add (LocalAssum (x, b')) ctx in - aux ctx' t t' - | Cast (c, _, _), _ -> aux ctx c ty - | _, _ -> (ctx, c, ty) - in - aux Context.Rel.empty c ty - -(* XXX: What's the relation of this with Abstract.shrink ? *) -let shrink_body c ty = - let ctx, b, ty = - match ty with - | None -> - let ctx, b = Term.decompose_lam_assum c in - (ctx, b, None) - | Some ty -> - let ctx, b, ty = decompose_lam_prod c ty in - (ctx, b, Some ty) - in - let b', ty', n, args = - List.fold_left - (fun (b, ty, i, args) decl -> - if noccurn 1 b && Option.cata (noccurn 1) true ty then - (subst1 mkProp b, Option.map (subst1 mkProp) ty, succ i, args) - else - let open Context.Rel.Declaration in - let args = if is_local_assum decl then mkRel i :: args else args in - ( Term.mkLambda_or_LetIn decl b - , Option.map (Term.mkProd_or_LetIn decl) ty - , succ i - , args ) ) - (b, ty, 1, []) ctx - in - (ctx, b', ty', Array.of_list args) - -(***********************************************************************) -(* Saving an obligation *) -(***********************************************************************) - -let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] - -let add_hint local prg cst = - let locality = if local then Goptions.OptLocal else Goptions.OptExport in - Hints.add_hints ~locality [Id.to_string prg.prg_name] (unfold_entry cst) - -(* true = hide obligations *) -let get_hide_obligations = - Goptions.declare_bool_option_and_ref - ~depr:true - ~key:["Hide"; "Obligations"] - ~value:false - -let declare_obligation prg obl body ty uctx = - let body = prg.prg_reduce body in - let ty = Option.map prg.prg_reduce ty in - match obl.obl_status with - | _, Evar_kinds.Expand -> (false, {obl with obl_body = Some (TermObl body)}) - | force, Evar_kinds.Define opaque -> - let opaque = (not force) && opaque in - let poly = prg.prg_poly in - let ctx, body, ty, args = - if not poly then shrink_body body ty - else ([], body, ty, [||]) - in - let ce = Declare.definition_entry ?types:ty ~opaque ~univs:uctx body in - - (* ppedrot: seems legit to have obligations as local *) - let constant = - Declare.declare_constant ~name:obl.obl_name - ~local:Declare.ImportNeedQualified ~kind:Decls.(IsProof Property) - (Declare.DefinitionEntry ce) - in - if not opaque then - add_hint (Locality.make_section_locality None) prg constant; - Declare.definition_message obl.obl_name; - let body = - match uctx with - | Polymorphic_entry (_, uctx) -> - Some (DefinedObl (constant, Univ.UContext.instance uctx)) - | Monomorphic_entry _ -> - Some - (TermObl - (it_mkLambda_or_LetIn_or_clean - (mkApp (mkConst constant, args)) - ctx)) - in - (true, {obl with obl_body = body}) - -(* Updating the obligation meta-info on close *) - -let not_transp_msg = - Pp.( - str "Obligation should be transparent but was declared opaque." - ++ spc () - ++ str "Use 'Defined' instead.") - -let pperror cmd = CErrors.user_err ~hdr:"Program" cmd -let err_not_transp () = pperror not_transp_msg - -module ProgMap = Id.Map - -let from_prg, program_tcc_summary_tag = - Summary.ref_tag ProgMap.empty ~name:"program-tcc-table" - -(* In all cases, the use of the map is read-only so we don't expose the ref *) -let get_prg_info_map () = !from_prg - -let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] - -let check_can_close sec = - if not (ProgMap.is_empty !from_prg) then - let keys = map_keys !from_prg in - CErrors.user_err ~hdr:"Program" - Pp.( - str "Unsolved obligations when closing " - ++ Id.print sec ++ str ":" ++ spc () - ++ prlist_with_sep spc (fun x -> Id.print x) keys - ++ ( str (if Int.equal (List.length keys) 1 then " has " else " have ") - ++ str "unsolved obligations" )) - -let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) -let prgmap_op f = from_prg := f !from_prg -let progmap_remove prg = prgmap_op (ProgMap.remove prg.prg_name) -let progmap_add n prg = prgmap_op (ProgMap.add n prg) -let progmap_replace prg = prgmap_op (map_replace prg.prg_name prg) - -let obligations_solved prg = Int.equal prg.prg_obligations.remaining 0 - -let obligations_message rem = - if rem > 0 then - if Int.equal rem 1 then - Flags.if_verbose Feedback.msg_info - Pp.(int rem ++ str " obligation remaining") - else - Flags.if_verbose Feedback.msg_info - Pp.(int rem ++ str " obligations remaining") - else - Flags.if_verbose Feedback.msg_info Pp.(str "No more obligations remaining") - -type progress = Remain of int | Dependent | Defined of GlobRef.t - -let get_obligation_body expand obl = - match obl.obl_body with - | None -> None - | Some c -> ( - if expand && snd obl.obl_status == Evar_kinds.Expand then - match c with - | DefinedObl pc -> Some (constant_value_in (Global.env ()) pc) - | TermObl c -> Some c - else - match c with DefinedObl pc -> Some (mkConstU pc) | TermObl c -> Some c ) - -let obl_substitution expand obls deps = - Int.Set.fold - (fun x acc -> - let xobl = obls.(x) in - match get_obligation_body expand xobl with - | None -> acc - | Some oblb -> (xobl.obl_name, (xobl.obl_type, oblb)) :: acc ) - deps [] - -let rec intset_to = function - | -1 -> Int.Set.empty - | n -> Int.Set.add n (intset_to (pred n)) - -let obligation_substitution expand prg = - let obls = prg.prg_obligations.obls in - let ints = intset_to (pred (Array.length obls)) in - obl_substitution expand obls ints - -let hide_obligation () = - Coqlib.check_required_library ["Coq"; "Program"; "Tactics"]; - UnivGen.constr_of_monomorphic_global - (Coqlib.lib_ref "program.tactics.obligation") - -(* XXX: Is this the right place? *) -let rec prod_app t n = - match - Constr.kind - (EConstr.Unsafe.to_constr - (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) - (* FIXME *) - with - | Prod (_, _, b) -> subst1 n b - | LetIn (_, b, t, b') -> prod_app (subst1 b b') n - | _ -> - CErrors.user_err ~hdr:"prod_app" - Pp.(str "Needed a product, but didn't find one" ++ fnl ()) - -(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) -let prod_applist t nL = List.fold_left prod_app t nL - -let replace_appvars subst = - let rec aux c = - let f, l = decompose_app c in - if isVar f then - try - let c' = List.map (Constr.map aux) l in - let t, b = Id.List.assoc (destVar f) subst in - mkApp - ( delayed_force hide_obligation - , [|prod_applist t c'; Term.applistc b c'|] ) - with Not_found -> Constr.map aux c - else Constr.map aux c - in - Constr.map aux - -let subst_prog subst prg = - if get_hide_obligations () then - ( replace_appvars subst prg.prg_body - , replace_appvars subst (* Termops.refresh_universes *) prg.prg_type ) - else - let subst' = List.map (fun (n, (_, b)) -> (n, b)) subst in - ( Vars.replace_vars subst' prg.prg_body - , Vars.replace_vars subst' (* Termops.refresh_universes *) prg.prg_type ) - -let get_fix_exn, stm_get_fix_exn = Hook.make () - -let declare_definition prg = - let varsubst = obligation_substitution true prg in - let sigma = Evd.from_ctx prg.prg_ctx in - let body, types = subst_prog varsubst prg in - let body, types = EConstr.(of_constr body, Some (of_constr types)) in - (* All these should be grouped into a struct a some point *) - let opaque, poly, udecl, hook = prg.prg_opaque, prg.prg_poly, prg.prg_univdecl, prg.prg_hook in - let name, scope, kind, impargs = prg.prg_name, prg.prg_scope, Decls.(IsDefinition prg.prg_kind), prg.prg_implicits in - let fix_exn = Hook.get get_fix_exn () in - let obls = List.map (fun (id, (_, c)) -> (id, c)) varsubst in - (* XXX: This is doing normalization twice *) - let () = progmap_remove prg in - let kn = - Declare.declare_definition ~name ~scope ~kind ~impargs ?hook ~obls - ~fix_exn ~opaque ~poly ~udecl ~types ~body sigma - in - kn - -let rec lam_index n t acc = - match Constr.kind t with - | Lambda ({binder_name=Name n'}, _, _) when Id.equal n n' -> acc - | Lambda (_, _, b) -> lam_index n b (succ acc) - | _ -> raise Not_found - -let compute_possible_guardness_evidences n fixbody fixtype = - match n with - | Some {CAst.loc; v = n} -> [lam_index n fixbody 0] - | None -> - (* If recursive argument was not given by user, we try all args. - An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual - fixpoints ?) *) - let m = - Termops.nb_prod Evd.empty (EConstr.of_constr fixtype) - (* FIXME *) - in - let ctx = fst (Term.decompose_prod_n_assum m fixtype) in - List.map_i (fun i _ -> i) 0 ctx - -let declare_mutual_definition l = - let len = List.length l in - let first = List.hd l in - let defobl x = - let oblsubst = obligation_substitution true x in - 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, r, x.prg_reduce typ, x.prg_implicits) in - let oblsubst = List.map (fun (id, (_, c)) -> (id, c)) oblsubst in - def, oblsubst - in - let defs, obls = - List.fold_right (fun x (defs, obls) -> - let xdef, xobls = defobl x in - (xdef :: defs, xobls @ obls)) l ([], []) - in - (* let fixdefs = List.map reduce_fix fixdefs in *) - let fixdefs, fixrs, fixtypes, fixitems = - List.fold_right2 (fun (d,r,typ,impargs) name (a1,a2,a3,a4) -> - d :: a1, r :: a2, typ :: a3, - Declare.Recthm.{ name; typ; impargs; args = [] } :: a4 - ) defs first.prg_deps ([],[],[],[]) - in - let fixkind = Option.get first.prg_fixkind in - let arrrec, recvec = (Array.of_list fixtypes, Array.of_list fixdefs) in - let rvec = Array.of_list fixrs in - let namevec = Array.of_list (List.map (fun x -> Name x.prg_name) l) in - let rec_declaration = (Array.map2 make_annot namevec rvec, arrrec, recvec) in - let possible_indexes = - match fixkind with - | IsFixpoint wfl -> - Some (List.map3 compute_possible_guardness_evidences wfl fixdefs fixtypes) - | IsCoFixpoint -> None - in - (* In the future we will pack all this in a proper record *) - let poly, scope, ntns, opaque = first.prg_poly, first.prg_scope, first.prg_notations, first.prg_opaque in - let kind = if fixkind != IsCoFixpoint then Decls.(IsDefinition Fixpoint) else Decls.(IsDefinition CoFixpoint) in - (* Declare the recursive definitions *) - let udecl = UState.default_univ_decl in - let kns = - Declare.declare_mutually_recursive ~scope ~opaque ~kind - ~udecl ~ntns ~uctx:first.prg_ctx ~rec_declaration ~possible_indexes ~poly - ~restrict_ucontext:false fixitems - in - (* Only for the first constant *) - let dref = List.hd kns in - Declare.Hook.(call ?hook:first.prg_hook { S.uctx = first.prg_ctx; obls; scope; dref }); - List.iter progmap_remove l; - dref - -let update_obls prg obls rem = - let prg_obligations = { obls; remaining = rem } in - let prg' = {prg with prg_obligations} in - progmap_replace prg'; - obligations_message rem; - if rem > 0 then Remain rem - else - match prg'.prg_deps with - | [] -> - let kn = declare_definition prg' in - progmap_remove prg'; - Defined kn - | l -> - let progs = - List.map - (fun x -> CEphemeron.get (ProgMap.find x !from_prg)) - prg'.prg_deps - in - if List.for_all (fun x -> obligations_solved x) progs then - let kn = declare_mutual_definition progs in - Defined kn - else Dependent - -let dependencies obls n = - let res = ref Int.Set.empty in - Array.iteri - (fun i obl -> - if (not (Int.equal i n)) && Int.Set.mem n obl.obl_deps then - res := Int.Set.add i !res ) - obls; - !res - -let update_program_decl_on_defined prg obls num obl ~uctx rem ~auto = - let obls = Array.copy obls in - let () = obls.(num) <- obl in - let prg = { prg with prg_ctx = uctx } in - let () = ignore (update_obls prg obls (pred rem)) in - if pred rem > 0 then begin - let deps = dependencies obls num in - if not (Int.Set.is_empty deps) then - ignore (auto (Some prg.prg_name) deps None) - end - -type obligation_qed_info = - { name : Id.t - ; num : int - ; auto : Id.t option -> Int.Set.t -> unit Proofview.tactic option -> progress - } - -let obligation_terminator entries uctx { name; num; auto } = - match entries with - | [entry] -> - let env = Global.env () in - let ty = entry.Declare.proof_entry_type in - let body, uctx = Declare.inline_private_constants ~uctx env entry in - let sigma = Evd.from_ctx uctx in - Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); - (* Declare the obligation ourselves and drop the hook *) - let prg = CEphemeron.get (ProgMap.find name !from_prg) in - let { obls; remaining=rem } = prg.prg_obligations in - let obl = obls.(num) in - let status = - match obl.obl_status, entry.Declare.proof_entry_opaque with - | (_, Evar_kinds.Expand), true -> err_not_transp () - | (true, _), true -> err_not_transp () - | (false, _), true -> Evar_kinds.Define true - | (_, Evar_kinds.Define true), false -> - Evar_kinds.Define false - | (_, status), false -> status - in - let obl = { obl with obl_status = false, status } in - let uctx = - if prg.prg_poly then uctx - else UState.union prg.prg_ctx uctx - in - let univs = UState.univ_entry ~poly:prg.prg_poly uctx in - let (defined, obl) = declare_obligation prg obl body ty univs in - let prg_ctx = - if prg.prg_poly then (* Polymorphic *) - (* We merge the new universes and constraints of the - polymorphic obligation with the existing ones *) - UState.union prg.prg_ctx uctx - else - (* The first obligation, if defined, - declares the univs of the constant, - each subsequent obligation declares its own additional - universes and constraints if any *) - if defined then UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) - else uctx - in - update_program_decl_on_defined prg obls num obl ~uctx:prg_ctx rem ~auto - | _ -> - CErrors.anomaly - Pp.( - str - "[obligation_terminator] close_proof returned more than one proof \ - term") - -(* Similar to the terminator but for interactive paths, as the - terminator is only called in interactive proof mode *) -let obligation_hook prg obl num auto { Declare.Hook.S.uctx = ctx'; dref; _ } = - let { obls; remaining=rem } = prg.prg_obligations in - let cst = match dref with GlobRef.ConstRef cst -> cst | _ -> assert false in - let transparent = evaluable_constant cst (Global.env ()) in - let () = match obl.obl_status with - (true, Evar_kinds.Expand) - | (true, Evar_kinds.Define true) -> - if not transparent then err_not_transp () - | _ -> () - in - let inst, ctx' = - if not prg.prg_poly (* Not polymorphic *) then - (* The universe context was declared globally, we continue - from the new global environment. *) - let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in - let ctx' = UState.merge_subst ctx (UState.subst ctx') in - Univ.Instance.empty, ctx' - else - (* We get the right order somehow, but surely it could be enforced in a clearer way. *) - let uctx = UState.context ctx' in - Univ.UContext.instance uctx, ctx' - in - let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in - let () = if transparent then add_hint true prg cst in - update_program_decl_on_defined prg obls num obl ~uctx:ctx' rem ~auto diff --git a/vernac/declareObl.mli b/vernac/declareObl.mli deleted file mode 100644 index 03f0a57bcb..0000000000 --- a/vernac/declareObl.mli +++ /dev/null @@ -1,164 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Names -open Constr - -type 'a obligation_body = DefinedObl of 'a | TermObl of constr - -module Obligation : sig - - type t = private - { obl_name : Id.t - ; obl_type : types - ; obl_location : Evar_kinds.t Loc.located - ; obl_body : pconstant obligation_body option - ; obl_status : bool * Evar_kinds.obligation_definition_status - ; obl_deps : Int.Set.t - ; obl_tac : unit Proofview.tactic option } - - val set_type : typ:Constr.types -> t -> t - val set_body : body:pconstant obligation_body -> t -> t - -end - -type obligations = - { obls : Obligation.t array - ; remaining : int } - -type fixpoint_kind = - | IsFixpoint of lident option list - | IsCoFixpoint - -(* Information about a single [Program {Definition,Lemma,..}] declaration *) -module ProgramDecl : sig - - type t = private - { prg_name : Id.t - ; prg_body : constr - ; prg_type : constr - ; prg_ctx : UState.t - ; prg_univdecl : UState.universe_decl - ; prg_obligations : obligations - ; prg_deps : Id.t list - ; prg_fixkind : fixpoint_kind option - ; prg_implicits : Impargs.manual_implicits - ; prg_notations : Vernacexpr.decl_notation list - ; prg_poly : bool - ; prg_scope : Declare.locality - ; prg_kind : Decls.definition_object_kind - ; prg_reduce : constr -> constr - ; prg_hook : Declare.Hook.t option - ; prg_opaque : bool - } - - val make : - ?opaque:bool - -> ?hook:Declare.Hook.t - -> Names.Id.t - -> udecl:UState.universe_decl - -> uctx:UState.t - -> impargs:Impargs.manual_implicits - -> poly:bool - -> scope:Declare.locality - -> kind:Decls.definition_object_kind - -> Constr.constr option - -> Constr.types - -> Names.Id.t list - -> fixpoint_kind option - -> Vernacexpr.decl_notation list - -> ( Names.Id.t - * Constr.types - * Evar_kinds.t Loc.located - * (bool * Evar_kinds.obligation_definition_status) - * Int.Set.t - * unit Proofview.tactic option ) - array - -> (Constr.constr -> Constr.constr) - -> t - - val set_uctx : uctx:UState.t -> t -> t -end - -val declare_obligation : - ProgramDecl.t - -> Obligation.t - -> Constr.types - -> Constr.types option - -> Entries.universes_entry - -> bool * Obligation.t -(** [declare_obligation] Save an obligation *) - -module ProgMap : CMap.ExtS with type key = Id.t and module Set := Id.Set - -val declare_definition : ProgramDecl.t -> Names.GlobRef.t - -(** Resolution status of a program *) -type progress = - | Remain of int - (** n obligations remaining *) - | Dependent - (** Dependent on other definitions *) - | Defined of GlobRef.t - (** Defined as id *) - -type obligation_qed_info = - { name : Id.t - ; num : int - ; auto : Id.t option -> Int.Set.t -> unit Proofview.tactic option -> progress - } - -val obligation_terminator - : Evd.side_effects Declare.proof_entry list - -> UState.t - -> obligation_qed_info -> unit -(** [obligation_terminator] part 2 of saving an obligation, proof mode *) - -val obligation_hook - : ProgramDecl.t - -> Obligation.t - -> Int.t - -> (Names.Id.t option -> Int.Set.t -> 'a option -> 'b) - -> Declare.Hook.S.t - -> unit -(** [obligation_hook] part 2 of saving an obligation, non-interactive mode *) - -val update_obls : - ProgramDecl.t - -> Obligation.t array - -> int - -> progress -(** [update_obls prg obls n progress] What does this do? *) - -(** { 2 Util } *) - -(** Check obligations are properly solved before closing a section *) -val check_can_close : Id.t -> unit - -val get_prg_info_map : unit -> ProgramDecl.t CEphemeron.key ProgMap.t - -val program_tcc_summary_tag : - ProgramDecl.t CEphemeron.key Id.Map.t Summary.Dyn.tag - -val obl_substitution : - bool - -> Obligation.t array - -> Int.Set.t - -> (ProgMap.key * (Constr.types * Constr.types)) list - -val dependencies : Obligation.t array -> int -> Int.Set.t - -val err_not_transp : unit -> unit -val progmap_add : ProgMap.key -> ProgramDecl.t CEphemeron.key -> unit - -(* This is a hack to make it possible for Obligations to craft a Qed - * behind the scenes. The fix_exn the Stm attaches to the Future proof - * is not available here, so we provide a side channel to get it *) -val stm_get_fix_exn : (unit -> Exninfo.iexn -> Exninfo.iexn) Hook.t diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 42259cee10..45bf61d79e 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -35,11 +35,16 @@ open Attributes let query_command = Entry.create "vernac:query_command" +let search_query = Entry.create "vernac:search_query" +let search_queries = Entry.create "vernac:search_queries" + let subprf = Entry.create "vernac:subprf" let quoted_attributes = Entry.create "vernac:quoted_attributes" let class_rawexpr = Entry.create "vernac:class_rawexpr" let thm_token = Entry.create "vernac:thm_token" +let def_token = Entry.create "vernac:def_token" +let assumption_token = Entry.create "vernac:assumption_token" let def_body = Entry.create "vernac:def_body" let decl_notations = Entry.create "vernac:decl_notations" let record_field = Entry.create "vernac:record_field" @@ -70,6 +75,13 @@ let test_hash_ident = to_entry "test_hash_ident" begin lk_kw "#" >> lk_ident >> check_no_space end + +let test_id_colon = + let open Pcoq.Lookahead in + to_entry "test_id_colon" begin + lk_ident >> lk_kw ":" + end + } GRAMMAR EXTEND Gram @@ -183,7 +195,7 @@ let name_of_ident_decl : ident_decl -> name_decl = (* Gallina declarations *) GRAMMAR EXTEND Gram - GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion + GLOBAL: gallina gallina_ext thm_token def_token assumption_token def_body of_type_with_opt_coercion record_field decl_notations rec_definition ident_decl univ_decl; gallina: @@ -810,7 +822,7 @@ GRAMMAR EXTEND Gram END GRAMMAR EXTEND Gram - GLOBAL: command query_command class_rawexpr gallina_ext; + GLOBAL: command query_command class_rawexpr gallina_ext search_query search_queries; gallina_ext: [ [ IDENT "Export"; "Set"; table = option_table; v = option_setting -> @@ -915,7 +927,7 @@ GRAMMAR EXTEND Gram { fun g -> VernacSearch (SearchPattern c,g, l) } | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules; "." -> { fun g -> VernacSearch (SearchRewrite c,g, l) } - | IDENT "Search"; s = searchabout_query; l = searchabout_queries; "." -> + | IDENT "Search"; s = search_query; l = search_queries; "." -> { let (sl,m) = l in fun g -> VernacSearch (Search (s::sl),g, m) } ] ] ; @@ -1012,16 +1024,50 @@ GRAMMAR EXTEND Gram positive_search_mark: [ [ "-" -> { false } | -> { true } ] ] ; - searchabout_query: - [ [ b = positive_search_mark; s = ne_string; sc = OPT scope_delimiter -> - { (b, SearchString (s,sc)) } - | b = positive_search_mark; p = constr_pattern -> - { (b, SearchSubPattern p) } + search_query: + [ [ b = positive_search_mark; s = search_item -> { (b, SearchLiteral s) } + | b = positive_search_mark; "["; l = LIST1 (LIST1 search_query) SEP "|"; "]" -> { (b, SearchDisjConj l) } + ] ] + ; + search_item: + [ [ test_id_colon; where = search_where; ":"; s = ne_string; sc = OPT scope_delimiter -> + { SearchString (where,s,sc) } + | IDENT "is"; ":"; kl = logical_kind -> + { SearchKind kl } + | s = ne_string; sc = OPT scope_delimiter -> + { SearchString ((Anywhere,false),s,sc) } + | test_id_colon; where = search_where; ":"; p = constr_pattern -> + { SearchSubPattern (where,p) } + | p = constr_pattern -> + { SearchSubPattern ((Anywhere,false),p) } ] ] ; - searchabout_queries: + logical_kind: + [ [ k = thm_token -> { IsProof k } + | k = assumption_token -> { IsAssumption (snd k) } + | k = IDENT "Context" -> { IsAssumption Context } + | k = extended_def_token -> { IsDefinition k } + | IDENT "Primitive" -> { IsPrimitive } ] ] + ; + extended_def_token: + [ [ k = def_token -> { snd k } + | IDENT "Coercion" -> { Coercion } + | IDENT "Instance" -> { Instance } + | IDENT "Scheme" -> { Scheme } + | IDENT "Canonical" -> { CanonicalStructure } + | IDENT "Field" -> { StructureComponent } + | IDENT "Method" -> { Method } ] ] + ; + search_where: + [ [ IDENT "head" -> { Anywhere, true } + | IDENT "hyp" -> { InHyp, false } + | IDENT "concl" -> { InConcl, false } + | IDENT "headhyp" -> { InHyp, true } + | IDENT "headconcl" -> { InConcl, true } ] ] + ; + search_queries: [ [ m = ne_in_or_out_modules -> { ([],m) } - | s = searchabout_query; l = searchabout_queries -> + | s = search_query; l = search_queries -> { let (sl,m) = l in (s::sl,m) } | -> { ([],SearchOutside []) } ] ] diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 838496c595..10d63ff2ff 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -12,7 +12,6 @@ file command.ml, Aug 2009 *) open Util -open Names module NamedDecl = Context.Named.Declaration @@ -21,44 +20,8 @@ module NamedDecl = Context.Named.Declaration type lemma_possible_guards = int list list -module Proof_ending = struct - - type t = - | Regular - | End_obligation of DeclareObl.obligation_qed_info - | End_derive of { f : Id.t; name : Id.t } - | End_equations of - { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; sigma : Evd.evar_map - } - -end - -module Info = struct - - type t = - { hook : Declare.Hook.t option - ; proof_ending : Proof_ending.t CEphemeron.key - (* This could be improved and the CEphemeron removed *) - ; scope : Declare.locality - ; kind : Decls.logical_kind - (* thms and compute guard are specific only to start_lemma_with_initialization + regular terminator *) - ; thms : Declare.Recthm.t list - ; compute_guard : lemma_possible_guards - } - - let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=Declare.Global Declare.ImportDefaultBehavior) - ?(kind=Decls.(IsProof Lemma)) () = - { hook - ; compute_guard = [] - ; proof_ending = CEphemeron.create proof_ending - ; thms = [] - ; scope - ; kind - } -end +module Proof_ending = Declare.Proof_ending +module Info = Declare.Info (* Proofs with a save constant function *) type t = @@ -96,15 +59,6 @@ let initialize_named_context_for_proof () = let d = if Decls.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 add_first_thm ~info ~name ~typ ~impargs = - let thms = - { Declare.Recthm.name - ; impargs - ; typ = EConstr.Unsafe.to_constr typ - ; args = [] } :: info.Info.thms - in - { info with Info.thms } - (* Starting a goal *) let start_lemma ~name ~poly ?(udecl=UState.default_univ_decl) @@ -114,7 +68,7 @@ let start_lemma ~name ~poly let sign = initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in let proof = Declare.start_proof sigma ~name ~udecl ~poly goals in - let info = add_first_thm ~info ~name ~typ:c ~impargs in + let info = Declare.Info.add_first_thm ~info ~name ~typ:c ~impargs in { proof; info } (* Note that proofs opened by start_dependent lemma cannot be closed @@ -162,276 +116,15 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua match thms with | [] -> CErrors.anomaly (Pp.str "No proof to start.") | { Declare.Recthm.name; typ; impargs; _} :: thms -> - let info = - Info.{ hook - ; compute_guard - ; proof_ending = CEphemeron.create Proof_ending.Regular - ; thms - ; scope - ; kind - } in + let info = Info.make ?hook ~scope ~kind ~compute_guard ~thms () in (* start_lemma has the responsibility to add (name, impargs, typ) to thms, once Info.t is more refined this won't be necessary *) let lemma = start_lemma ~name ~impargs ~poly ~udecl ~info sigma (EConstr.of_constr typ) in pf_map (Declare.Proof.map_proof (fun p -> pi1 @@ Proof.run_tactic Global.(env ()) init_tac p)) lemma -(************************************************************************) -(* Commom constant saving path, for both Qed and Admitted *) -(************************************************************************) - -(* Support for mutually proved theorems *) - -(* XXX: Most of this does belong to Declare, due to proof_entry manip *) -module MutualEntry : sig - - val declare_variable - : info:Info.t - -> uctx:UState.t - -> Entries.parameter_entry - -> Names.GlobRef.t list - - val declare_mutdef - (* Common to all recthms *) - : info:Info.t - -> uctx:UState.t - -> Evd.side_effects Declare.proof_entry - -> Names.GlobRef.t list - -end = struct - - (* XXX: Refactor this with the code in [Declare.declare_mutdef] *) - let guess_decreasing env possible_indexes ((body, ctx), eff) = - let open Constr in - match Constr.kind body with - | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> - let env = Safe_typing.push_private_constants env eff.Evd.seff_private in - let indexes = Pretyping.search_guard env possible_indexes fixdecls in - (mkFix ((indexes,0),fixdecls), ctx), eff - | _ -> (body, ctx), eff - - let select_body i t = - let open Constr in - match Constr.kind t with - | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) - | CoFix (0,decls) -> mkCoFix (i,decls) - | _ -> - CErrors.anomaly - Pp.(str "Not a proof by induction: " ++ - Termops.Internal.debug_print_constr (EConstr.of_constr t) ++ str ".") - - let declare_mutdef ~uctx ~info pe i Declare.Recthm.{ name; impargs; typ; _} = - let { Info.hook; scope; kind; compute_guard; _ } = info in - (* if i = 0 , we don't touch the type; this is for compat - but not clear it is the right thing to do. - *) - let pe, ubind = - if i > 0 && not (CList.is_empty compute_guard) - then Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ), UnivNames.empty_binders - else pe, UState.universe_binders uctx - in - (* We when compute_guard was [] in the previous step we should not - substitute the body *) - let pe = match compute_guard with - | [] -> pe - | _ -> - Declare.Internal.map_entry_body pe - ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) - in - Declare.declare_entry ~name ~scope ~kind ?hook ~impargs ~uctx pe - - let declare_mutdef ~info ~uctx const = - let pe = match info.Info.compute_guard with - | [] -> - (* Not a recursive statement *) - const - | possible_indexes -> - (* Try all combinations... not optimal *) - let env = Global.env() in - Declare.Internal.map_entry_body const - ~f:(guess_decreasing env possible_indexes) - in - List.map_i (declare_mutdef ~info ~uctx pe) 0 info.Info.thms - - let declare_variable ~info ~uctx pe = - let { Info.scope; hook } = info in - List.map_i ( - fun i { Declare.Recthm.name; typ; impargs } -> - Declare.declare_assumption ~name ~scope ~hook ~impargs ~uctx pe - ) 0 info.Info.thms - -end - -(************************************************************************) -(* Admitting a lemma-like constant *) -(************************************************************************) - -(* Admitted *) -let get_keep_admitted_vars = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Keep"; "Admitted"; "Variables"] - ~value:true - -let compute_proof_using_for_admitted proof typ pproofs = - if not (get_keep_admitted_vars ()) then None - else match Declare.Proof.get_used_variables proof, pproofs with - | Some _ as x, _ -> x - | None, pproof :: _ -> - let env = Global.env () in - let ids_typ = Environ.global_vars_set env typ in - (* [pproof] is evar-normalized by [partial_proof]. We don't - count variables appearing only in the type of evars. *) - let ids_def = Environ.global_vars_set env (EConstr.Unsafe.to_constr pproof) in - Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) - | _ -> None - -let finish_admitted ~info ~uctx pe = - let _r : Names.GlobRef.t list = MutualEntry.declare_variable ~info ~uctx pe in - () - -let save_lemma_admitted ~(lemma : t) : unit = - let udecl = Declare.Proof.get_universe_decl lemma.proof in - let Proof.{ poly; entry } = Proof.data (Declare.Proof.get_proof lemma.proof) in - let typ = match Proofview.initial_goals entry with - | [typ] -> snd typ - | _ -> CErrors.anomaly ~label:"Lemmas.save_lemma_admitted" (Pp.str "more than one statement.") - in - let typ = EConstr.Unsafe.to_constr typ in - let proof = Declare.Proof.get_proof lemma.proof in - let pproofs = Proof.partial_proof proof in - let sec_vars = compute_proof_using_for_admitted lemma.proof typ pproofs in - let uctx = Declare.Proof.get_initial_euctx lemma.proof in - let univs = UState.check_univ_decl ~poly uctx udecl in - finish_admitted ~info:lemma.info ~uctx (sec_vars, (typ, univs), None) - -(************************************************************************) -(* Saving a lemma-like constant *) -(************************************************************************) - -let finish_proved po info = - let open Declare in - match po with - | { entries=[const]; uctx } -> - let _r : Names.GlobRef.t list = MutualEntry.declare_mutdef ~info ~uctx const in - () - | _ -> - CErrors.anomaly ~label:"finish_proved" Pp.(str "close_proof returned more than one proof term") - -let finish_derived ~f ~name ~entries = - (* [f] and [name] correspond to the proof of [f] and of [suchthat], respectively. *) - - let f_def, lemma_def = - match entries with - | [_;f_def;lemma_def] -> - f_def, lemma_def - | _ -> assert false - in - (* The opacity of [f_def] is adjusted to be [false], as it - must. Then [f] is declared in the global environment. *) - let f_def = Declare.Internal.set_opacity ~opaque:false f_def in - let f_kind = Decls.(IsDefinition Definition) in - let f_def = Declare.DefinitionEntry f_def in - let f_kn = Declare.declare_constant ~name:f ~kind:f_kind f_def in - let f_kn_term = Constr.mkConst f_kn in - (* In the type and body of the proof of [suchthat] there can be - references to the variable [f]. It needs to be replaced by - references to the constant [f] declared above. This substitution - performs this precise action. *) - let substf c = Vars.replace_vars [f,f_kn_term] c in - (* Extracts the type of the proof of [suchthat]. *) - let lemma_pretype typ = - match typ with - | Some t -> Some (substf t) - | None -> assert false (* Declare always sets type here. *) - in - (* The references of [f] are subsituted appropriately. *) - let lemma_def = Declare.Internal.map_entry_type lemma_def ~f:lemma_pretype in - (* The same is done in the body of the proof. *) - let lemma_def = Declare.Internal.map_entry_body lemma_def ~f:(fun ((b,ctx),fx) -> (substf b, ctx), fx) in - let lemma_def = Declare.DefinitionEntry lemma_def in - let _ : Names.Constant.t = Declare.declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in - () - -let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = - - let obls = ref 1 in - let sigma, recobls = - CList.fold_left2_map (fun sigma (_evar_env, ev, _evi, local_context, _type) entry -> - let id = - match Evd.evar_ident ev sigma0 with - | Some id -> id - | None -> let n = !obls in incr obls; Nameops.add_suffix i ("_obligation_" ^ string_of_int n) - in - let entry, args = Declare.Internal.shrink_entry local_context entry in - let cst = Declare.declare_constant ~name:id ~kind (Declare.DefinitionEntry entry) in - let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in - let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in - sigma, cst) sigma0 - types proof_obj.Declare.entries - in - hook recobls sigma - -let finalize_proof proof_obj proof_info = - let open Declare in - let open Proof_ending in - match CEphemeron.default proof_info.Info.proof_ending Regular with - | Regular -> - finish_proved proof_obj proof_info - | End_obligation oinfo -> - DeclareObl.obligation_terminator proof_obj.entries proof_obj.uctx oinfo - | End_derive { f ; name } -> - finish_derived ~f ~name ~entries:proof_obj.entries - | End_equations { hook; i; types; sigma } -> - finish_proved_equations ~kind:proof_info.Info.kind ~hook i proof_obj types sigma - -let err_save_forbidden_in_place_of_qed () = - CErrors.user_err (Pp.str "Cannot use Save with more than one constant or in this proof mode") - -let process_idopt_for_save ~idopt info = - match idopt with - | None -> info - | Some { CAst.v = save_name } -> - (* Save foo was used; we override the info in the first theorem *) - let thms = - match info.Info.thms, CEphemeron.default info.Info.proof_ending Proof_ending.Regular with - | [ { Declare.Recthm.name; _} as decl ], Proof_ending.Regular -> - [ { decl with Declare.Recthm.name = save_name } ] - | _ -> - err_save_forbidden_in_place_of_qed () - in { info with Info.thms } +let save_lemma_admitted ~lemma = + Declare.save_lemma_admitted ~proof:lemma.proof ~info:lemma.info let save_lemma_proved ~lemma ~opaque ~idopt = - (* Env and sigma are just used for error printing in save_remaining_recthms *) - let proof_obj = Declare.close_proof ~opaque ~keep_body_ucst_separate:false lemma.proof in - let proof_info = process_idopt_for_save ~idopt lemma.info in - finalize_proof proof_obj proof_info - -(***********************************************************************) -(* Special case to close a lemma without forcing a proof *) -(***********************************************************************) -let save_lemma_admitted_delayed ~proof ~info = - let open Declare in - let { entries; uctx } = proof in - if List.length entries <> 1 then - CErrors.user_err Pp.(str "Admitted does not support multiple statements"); - let { Declare.proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in - let poly = match proof_entry_universes with - | Entries.Monomorphic_entry _ -> false - | Entries.Polymorphic_entry (_, _) -> true in - let typ = match proof_entry_type with - | None -> CErrors.user_err Pp.(str "Admitted requires an explicit statement"); - | Some typ -> typ in - let ctx = UState.univ_entry ~poly uctx in - let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in - finish_admitted ~uctx ~info (sec_vars, (typ, ctx), None) - -let save_lemma_proved_delayed ~proof ~info ~idopt = - (* vio2vo calls this but with invalid info, we have to workaround - that to add the name to the info structure *) - if CList.is_empty info.Info.thms then - let info = add_first_thm ~info ~name:proof.Declare.name ~typ:EConstr.mkSet ~impargs:[] in - finalize_proof proof info - else - let info = process_idopt_for_save ~idopt info in - finalize_proof proof info + Declare.save_lemma_proved ~proof:lemma.proof ~info:lemma.info ~opaque ~idopt diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index b1462f1ce5..4787a940da 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -28,39 +28,8 @@ val pf_fold : (Declare.Proof.t -> 'a) -> t -> 'a val by : unit Proofview.tactic -> t -> t * bool (** [by tac l] apply a tactic to [l] *) -(** Creating high-level proofs with an associated constant *) -module Proof_ending : sig - - type t = - | Regular - | End_obligation of DeclareObl.obligation_qed_info - | End_derive of { f : Id.t; name : Id.t } - | End_equations of - { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; sigma : Evd.evar_map - } - -end - -module Info : sig - - type t - - val make - : ?hook: Declare.Hook.t - (** Callback to be executed at the end of the proof *) - -> ?proof_ending : Proof_ending.t - (** Info for special constants *) - -> ?scope : Declare.locality - (** locality *) - -> ?kind:Decls.logical_kind - (** Theorem, etc... *) - -> unit - -> t - -end +module Proof_ending = Declare.Proof_ending +module Info = Declare.Info (** Starts the proof of a constant *) val start_lemma @@ -99,6 +68,7 @@ val start_lemma_with_initialization (** {4 Saving proofs} *) val save_lemma_admitted : lemma:t -> unit + val save_lemma_proved : lemma:t -> opaque:Declare.opacity_flag @@ -110,12 +80,3 @@ module Internal : sig val get_info : t -> Info.t (** Only needed due to the Declare compatibility layer. *) end - -(** Special cases for delayed proofs, in this case we must provide the - proof information so the proof won't be forced. *) -val save_lemma_admitted_delayed : proof:Declare.proof_object -> info:Info.t -> unit -val save_lemma_proved_delayed - : proof:Declare.proof_object - -> info:Info.t - -> idopt:Names.lident option - -> unit diff --git a/vernac/locality.ml b/vernac/locality.ml index f62eed5e41..3953e54f52 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -10,9 +10,12 @@ (** * Managing locality *) +type import_status = ImportDefaultBehavior | ImportNeedQualified +type locality = Discharge | Global of import_status + let importability_of_bool = function - | true -> Declare.ImportNeedQualified - | false -> Declare.ImportDefaultBehavior + | true -> ImportNeedQualified + | false -> ImportDefaultBehavior (** Positioning locality for commands supporting discharging and export outside of modules *) @@ -34,15 +37,14 @@ let warn_local_declaration = strbrk "available without qualification when imported.") let enforce_locality_exp locality_flag discharge = - let open Declare in let open Vernacexpr in match locality_flag, discharge with | Some b, NoDischarge -> Global (importability_of_bool b) - | None, NoDischarge -> Global Declare.ImportDefaultBehavior + | None, NoDischarge -> Global ImportDefaultBehavior | None, DoDischarge when not (Global.sections_are_opened ()) -> (* If a Let/Variable is defined outside a section, then we consider it as a local definition *) warn_local_declaration (); - Global Declare.ImportNeedQualified + Global ImportNeedQualified | None, DoDischarge -> Discharge | Some true, DoDischarge -> CErrors.user_err Pp.(str "Local not allowed in this case") | Some false, DoDischarge -> CErrors.user_err Pp.(str "Global not allowed in this case") diff --git a/vernac/locality.mli b/vernac/locality.mli index bf65579efd..81da895568 100644 --- a/vernac/locality.mli +++ b/vernac/locality.mli @@ -10,6 +10,9 @@ (** * Managing locality *) +type import_status = ImportDefaultBehavior | ImportNeedQualified +type locality = Discharge | Global of import_status + (** * Positioning locality for commands supporting discharging and export outside of modules *) @@ -20,7 +23,7 @@ val make_locality : bool option -> bool val make_non_locality : bool option -> bool -val enforce_locality_exp : bool option -> Vernacexpr.discharge -> Declare.locality +val enforce_locality_exp : bool option -> Vernacexpr.discharge -> locality val enforce_locality : bool option -> bool (** For commands whose default is to not discharge but to export: diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 5e746afc74..a8eac8fd2d 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -9,39 +9,56 @@ (************************************************************************) open Printf - open Names open Pp -open CErrors open Util (* For the records fields, opens should go away one these types are private *) -open DeclareObl -open DeclareObl.Obligation -open DeclareObl.ProgramDecl - -let pperror cmd = CErrors.user_err ~hdr:"Program" cmd -let error s = pperror (str s) +open Declare.Obls +open Declare.Obls.Obligation +open Declare.Obls.ProgramDecl let reduce c = let env = Global.env () in let sigma = Evd.from_env env in EConstr.Unsafe.to_constr (Reductionops.clos_norm_flags CClosure.betaiota env sigma (EConstr.of_constr c)) -exception NoObligations of Id.t option - let explain_no_obligations = function Some ident -> str "No obligations for program " ++ Id.print ident | None -> str "No obligations remaining" -let assumption_message = Declare.assumption_message +module Error = struct + + let no_obligations n = + CErrors.user_err (explain_no_obligations n) + + let ambiguous_program id ids = + CErrors.user_err + Pp.(str "More than one program with unsolved obligations: " ++ prlist Id.print ids + ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Id.print id ++ str "\"") + + let unknown_obligation num = + CErrors.user_err (Pp.str (sprintf "Unknown obligation number %i" (succ num))) + + let already_solved num = + CErrors.user_err + ( str "Obligation" ++ spc () ++ int num ++ str "already" ++ spc () + ++ str "solved." ) + + let depends num rem = + CErrors.user_err + ( str "Obligation " ++ int num + ++ str " depends on obligation(s) " + ++ pr_sequence (fun x -> int (succ x)) rem) + +end let default_tactic = ref (Proofview.tclUNIT ()) let evar_of_obligation o = Evd.make_evar (Global.named_context_val ()) (EConstr.of_constr o.obl_type) let subst_deps expand obls deps t = - let osubst = DeclareObl.obl_substitution expand obls deps in + let osubst = Declare.Obls.obl_substitution expand obls deps in (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) let subst_deps_obl obls obl = @@ -50,56 +67,6 @@ let subst_deps_obl obls obl = open Evd -let map_cardinal m = - let i = ref 0 in - ProgMap.iter (fun _ v -> - if (CEphemeron.get v).prg_obligations.remaining > 0 then incr i) m; - !i - -exception Found of ProgramDecl.t CEphemeron.key - -let map_first m = - try - ProgMap.iter (fun _ v -> - if (CEphemeron.get v).prg_obligations.remaining > 0 then - raise (Found v)) m; - assert(false) - with Found x -> x - -let get_prog name = - let prg_infos = get_prg_info_map () in - match name with - Some n -> - (try CEphemeron.get (ProgMap.find n prg_infos) - with Not_found -> raise (NoObligations (Some n))) - | None -> - (let n = map_cardinal prg_infos in - match n with - 0 -> raise (NoObligations None) - | 1 -> CEphemeron.get (map_first prg_infos) - | _ -> - let progs = Id.Set.elements (ProgMap.domain prg_infos) in - let prog = List.hd progs in - let progs = prlist_with_sep pr_comma Id.print progs in - user_err - (str "More than one program with unsolved obligations: " ++ progs - ++ str "; use the \"of\" clause to specify, as in \"Obligation 1 of " ++ Id.print prog ++ str "\"")) - -let get_any_prog () = - let prg_infos = get_prg_info_map () in - let n = map_cardinal prg_infos in - if n > 0 then CEphemeron.get (map_first prg_infos) - else raise (NoObligations None) - -let get_prog_err n = - try get_prog n with NoObligations id -> pperror (explain_no_obligations id) - -let get_any_prog_err () = - try get_any_prog () with NoObligations id -> pperror (explain_no_obligations id) - -let all_programs () = - ProgMap.fold (fun k p l -> p :: l) (get_prg_info_map ()) [] - let is_defined obls x = not (Option.is_empty obls.(x).obl_body) let deps_remaining obls deps = @@ -109,7 +76,6 @@ let deps_remaining obls deps = else x :: acc) deps [] - let goal_kind = Decls.(IsDefinition Definition) let goal_proof_kind = Decls.(IsProof Lemma) @@ -119,19 +85,19 @@ let kind_of_obligation o = | Evar_kinds.Expand -> goal_kind | _ -> goal_proof_kind -let rec string_of_list sep f = function - [] -> "" - | x :: [] -> f x - | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl - (* Solve an obligation using tactics, return the corresponding proof term *) -let warn_solve_errored = CWarnings.create ~name:"solve_obligation_error" ~category:"tactics" (fun err -> - Pp.seq [str "Solve Obligations tactic returned error: "; err; fnl (); - str "This will become an error in the future"]) +let warn_solve_errored = + CWarnings.create ~name:"solve_obligation_error" ~category:"tactics" + (fun err -> + Pp.seq + [ str "Solve Obligations tactic returned error: " + ; err + ; fnl () + ; str "This will become an error in the future" ]) let solve_by_tac ?loc name evi t poly uctx = + (* the status is dropped. *) try - (* the status is dropped. *) let env = Global.env () in let body, types, _univs, _, uctx = Declare.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in @@ -140,7 +106,7 @@ let solve_by_tac ?loc name evi t poly uctx = with | Refiner.FailError (_, s) as exn -> let _ = Exninfo.capture exn in - user_err ?loc ~hdr:"solve_obligation" (Lazy.force s) + CErrors.user_err ?loc ~hdr:"solve_obligation" (Lazy.force s) (* If the proof is open we absorb the error and leave the obligation open *) | Proof.OpenProof _ -> None @@ -149,17 +115,24 @@ let solve_by_tac ?loc name evi t poly uctx = warn_solve_errored ?loc err; None +let get_unique_prog prg = + match State.get_unique_open_prog prg with + | Ok prg -> prg + | Error [] -> + Error.no_obligations None + | Error ((id :: _) as ids) -> + Error.ambiguous_program id ids + let rec solve_obligation prg num tac = let user_num = succ num in let { obls; remaining=rem } = prg.prg_obligations in let obl = obls.(num) in let remaining = deps_remaining obls obl.obl_deps in let () = - if not (Option.is_empty obl.obl_body) then - pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved."); - if not (List.is_empty remaining) then - pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " - ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining)); + if not (Option.is_empty obl.obl_body) + then Error.already_solved user_num; + if not (List.is_empty remaining) + then Error.depends user_num remaining in let obl = subst_deps_obl obls obl in let scope = Declare.(Global Declare.ImportNeedQualified) in @@ -167,9 +140,11 @@ let rec solve_obligation prg num tac = let evd = Evd.from_ctx prg.prg_ctx in let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n oblset tac = auto_solve_obligations n ~oblset tac in - let proof_ending = Lemmas.Proof_ending.End_obligation (DeclareObl.{name = prg.prg_name; num; auto}) in - let hook = Declare.Hook.make (DeclareObl.obligation_hook prg obl num auto) in - let info = Lemmas.Info.make ~hook ~proof_ending ~scope ~kind () in + let proof_ending = + Declare.Proof_ending.End_obligation + {Declare.Obls.name = prg.prg_name; num; auto} + in + let info = Lemmas.Info.make ~proof_ending ~scope ~kind () in let poly = prg.prg_poly in let lemma = Lemmas.start_lemma ~name:obl.obl_name ~poly ~info evd (EConstr.of_constr obl.obl_type) in let lemma = fst @@ Lemmas.by !default_tactic lemma in @@ -178,15 +153,14 @@ let rec solve_obligation prg num tac = and obligation (user_num, name, typ) tac = let num = pred user_num in - let prg = get_prog_err name in + let prg = get_unique_prog name in let { obls; remaining } = prg.prg_obligations in - if num >= 0 && num < Array.length obls then - let obl = obls.(num) in - match obl.obl_body with - | None -> solve_obligation prg num tac - | Some r -> error "Obligation already solved" - else error (sprintf "Unknown obligation number %i" (succ num)) - + if num >= 0 && num < Array.length obls then + let obl = obls.(num) in + match obl.obl_body with + | None -> solve_obligation prg num tac + | Some r -> Error.already_solved num + else Error.unknown_obligation num and solve_obligation_by_tac prg obls i tac = let obl = obls.(i) in @@ -208,18 +182,16 @@ and solve_obligation_by_tac prg obls i tac = match solve_by_tac ?loc:(fst obl.obl_location) obl.obl_name (evar_of_obligation obl) tac prg.prg_poly (Evd.evar_universe_context evd) with | None -> None - | Some (t, ty, ctx) -> - let prg = ProgramDecl.set_uctx ~uctx:ctx prg in + | Some (t, ty, uctx) -> + let prg = ProgramDecl.set_uctx ~uctx prg in (* Why is uctx not used above? *) - let uctx = UState.univ_entry ~poly:prg.prg_poly ctx in - let def, obl' = declare_obligation prg obl t ty uctx in + let def, obl' = declare_obligation prg obl ~body:t ~types:ty ~uctx in obls.(i) <- obl'; if def && not prg.prg_poly then ( (* Declare the term constraints with the first obligation only *) - let evd = Evd.from_env (Global.env ()) in - let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in - let ctx' = Evd.evar_universe_context evd in - Some (ProgramDecl.set_uctx ~uctx:ctx' prg)) + let uctx_global = UState.from_env (Global.env ()) in + let uctx = UState.merge_subst uctx_global (UState.subst uctx) in + Some (ProgramDecl.set_uctx ~uctx prg)) else Some prg else None @@ -233,121 +205,163 @@ and solve_prg_obligations prg ?oblset tac = | Some s -> set := s; (fun i -> Int.Set.mem i !set) in - let prg = - Array.fold_left_i (fun i prg x -> - if p i then - match solve_obligation_by_tac prg obls' i tac with - | None -> prg - | Some prg -> - let deps = dependencies obls i in - set := Int.Set.union !set deps; - decr rem; - prg - else prg) - prg obls' + let (), prg = + Array.fold_left_i + (fun i ((), prg) x -> + if p i then ( + match solve_obligation_by_tac prg obls' i tac with + | None -> (), prg + | Some prg -> + let deps = dependencies obls i in + set := Int.Set.union !set deps; + decr rem; + (), prg) + else (), prg) + ((), prg) obls' in update_obls prg obls' !rem and solve_obligations n tac = - let prg = get_prog_err n in + let prg = get_unique_prog n in solve_prg_obligations prg tac and solve_all_obligations tac = - ProgMap.iter (fun k v -> ignore(solve_prg_obligations (CEphemeron.get v) tac)) (get_prg_info_map ()) + State.fold ~init:() ~f:(fun k v () -> + let _ = solve_prg_obligations v tac in ()) and try_solve_obligation n prg tac = - let prg = get_prog prg in + let prg = get_unique_prog prg in let {obls; remaining } = prg.prg_obligations in let obls' = Array.copy obls in - match solve_obligation_by_tac prg obls' n tac with - | Some prg' -> ignore(update_obls prg' obls' (pred remaining)) - | None -> () + match solve_obligation_by_tac prg obls' n tac with + | Some prg' -> + let _r = update_obls prg' obls' (pred remaining) in + () + | None -> () and try_solve_obligations n tac = - try ignore (solve_obligations n tac) with NoObligations _ -> () + let _ = solve_obligations n tac in + () and auto_solve_obligations n ?oblset tac : progress = - Flags.if_verbose Feedback.msg_info (str "Solving obligations automatically..."); - try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent + Flags.if_verbose Feedback.msg_info + (str "Solving obligations automatically..."); + let prg = get_unique_prog n in + solve_prg_obligations prg ?oblset tac open Pp -let show_obligations_of_prg ?(msg=true) prg = + +let show_single_obligation i n obls x = + let x = subst_deps_obl obls x in + let env = Global.env () in + let sigma = Evd.from_env env in + let msg = + str "Obligation" ++ spc () + ++ int (succ i) + ++ spc () ++ str "of" ++ spc () ++ Id.print n ++ str ":" ++ spc () + ++ hov 1 (Printer.pr_constr_env env sigma x.obl_type + ++ str "." ++ fnl ()) in + Feedback.msg_info msg + +let show_obligations_of_prg ?(msg = true) prg = let n = prg.prg_name in let {obls; remaining} = prg.prg_obligations in let showed = ref 5 in if msg then Feedback.msg_info (int remaining ++ str " obligation(s) remaining: "); - Array.iteri (fun i x -> - match x.obl_body with - | None -> - if !showed > 0 then ( - decr showed; - let x = subst_deps_obl obls x in - let env = Global.env () in - let sigma = Evd.from_env env in - Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ - str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++ - hov 1 (Printer.pr_constr_env env sigma x.obl_type ++ - str "." ++ fnl ()))) - | Some _ -> ()) + Array.iteri + (fun i x -> + match x.obl_body with + | None -> + if !showed > 0 then begin + decr showed; + show_single_obligation i n obls x + end + | Some _ -> ()) obls -let show_obligations ?(msg=true) n = - let progs = match n with - | None -> all_programs () +let show_obligations ?(msg = true) n = + let progs = + match n with + | None -> + State.all () | Some n -> - try [ProgMap.find n (get_prg_info_map ())] - with Not_found -> raise (NoObligations (Some n)) - in List.iter (fun x -> show_obligations_of_prg ~msg (CEphemeron.get x)) progs + (match State.find n with + | Some prg -> [prg] + | None -> Error.no_obligations (Some n)) + in + List.iter (fun x -> show_obligations_of_prg ~msg x) progs let show_term n = - let prg = get_prog_err n in + let prg = get_unique_prog n in let n = prg.prg_name in let env = Global.env () in let sigma = Evd.from_env env in - (Id.print n ++ spc () ++ str":" ++ spc () ++ - Printer.pr_constr_env env sigma prg.prg_type ++ spc () ++ str ":=" ++ fnl () - ++ Printer.pr_constr_env env sigma prg.prg_body) + Id.print n ++ spc () ++ str ":" ++ spc () + ++ Printer.pr_constr_env env sigma prg.prg_type + ++ spc () ++ str ":=" ++ fnl () + ++ Printer.pr_constr_env env sigma prg.prg_body -let add_definition ~name ?term t ~uctx ?(udecl=UState.default_univ_decl) - ?(impargs=[]) ~poly ?(scope=Declare.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?tactic - ?(reduce=reduce) ?hook ?(opaque = false) obls = +let msg_generating_obl name obls = + let len = Array.length obls in let info = Id.print name ++ str " has type-checked" in + Feedback.msg_info + (if len = 0 then info ++ str "." + else + info ++ str ", generating " ++ int len ++ + str (String.plural len " obligation")) + +let add_definition ~name ?term t ~uctx ?(udecl = UState.default_univ_decl) + ?(impargs = []) ~poly + ?(scope = Declare.Global Declare.ImportDefaultBehavior) + ?(kind = Decls.Definition) ?tactic ?(reduce = reduce) ?hook + ?(opaque = false) obls = let prg = ProgramDecl.make ~opaque name ~udecl term t ~uctx [] None [] obls ~impargs ~poly ~scope ~kind reduce ?hook in let {obls;_} = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( - Flags.if_verbose Feedback.msg_info (info ++ str "."); - let cst = DeclareObl.declare_definition prg in + Flags.if_verbose (msg_generating_obl name) obls; + let cst = Declare.Obls.declare_definition prg in Defined cst) - else ( - let len = Array.length obls in - let () = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str (String.plural len " obligation")) in - progmap_add name (CEphemeron.create prg); - let res = auto_solve_obligations (Some name) tactic in - match res with - | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some name)) (); res - | _ -> res) - -let add_mutual_definitions l ~uctx ?(udecl=UState.default_univ_decl) ?tactic - ~poly ?(scope=Declare.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?(reduce=reduce) - ?hook ?(opaque = false) notations fixkind = - let deps = List.map (fun ({ Declare.Recthm.name; _ }, _, _) -> name) l in - List.iter - (fun ({ Declare.Recthm.name; typ; impargs; _ }, b, obls) -> - let prg = ProgramDecl.make ~opaque name ~udecl (Some b) typ ~uctx deps (Some fixkind) - notations obls ~impargs ~poly ~scope ~kind reduce ?hook - in progmap_add name (CEphemeron.create prg)) l; - let _defined = - List.fold_left (fun finished x -> - if finished then finished + else + let () = Flags.if_verbose (msg_generating_obl name) obls in + let () = State.add name prg in + let res = auto_solve_obligations (Some name) tactic in + match res with + | Remain rem -> + Flags.if_verbose (show_obligations ~msg:false) (Some name); + res + | _ -> res + +let add_mutual_definitions l ~uctx ?(udecl = UState.default_univ_decl) + ?tactic ~poly ?(scope = Declare.Global Declare.ImportDefaultBehavior) + ?(kind = Decls.Definition) ?(reduce = reduce) ?hook ?(opaque = false) + notations fixkind = + let deps = List.map (fun ({Declare.Recthm.name; _}, _, _) -> name) l in + let pm = + List.fold_left + (fun () ({Declare.Recthm.name; typ; impargs; _}, b, obls) -> + let prg = + ProgramDecl.make ~opaque name ~udecl (Some b) typ ~uctx deps + (Some fixkind) notations obls ~impargs ~poly ~scope ~kind reduce + ?hook + in + State.add name prg) + () l + in + let pm, _defined = + List.fold_left + (fun (pm, finished) x -> + if finished then (pm, finished) else let res = auto_solve_obligations (Some x) tactic in - match res with - | Defined _ -> - (* If one definition is turned into a constant, - the whole block is defined. *) true - | _ -> false) - false deps - in () + match res with + | Defined _ -> + (* If one definition is turned into a constant, + the whole block is defined. *) + (pm, true) + | _ -> (pm, false)) + (pm, false) deps + in + pm let admit_prog prg = let {obls; remaining} = prg.prg_obligations in @@ -359,39 +373,41 @@ let admit_prog prg = let x = subst_deps_obl obls x in let ctx = UState.univ_entry ~poly:false prg.prg_ctx in let kn = Declare.declare_constant ~name:x.obl_name ~local:Declare.ImportNeedQualified - (Declare.ParameterEntry (None,(x.obl_type,ctx),None)) ~kind:Decls.(IsAssumption Conjectural) + (Declare.ParameterEntry (None, (x.obl_type, ctx), None)) ~kind:Decls.(IsAssumption Conjectural) in - assumption_message x.obl_name; + Declare.assumption_message x.obl_name; obls.(i) <- Obligation.set_body ~body:(DefinedObl (kn, Univ.Instance.empty)) x | Some _ -> ()) obls; - ignore(DeclareObl.update_obls prg obls 0) + Declare.Obls.update_obls prg obls 0 +(* get_any_prog *) let rec admit_all_obligations () = - let prg = try Some (get_any_prog ()) with NoObligations _ -> None in + let prg = State.first_pending () in match prg with | None -> () | Some prg -> - admit_prog prg; + let _prog = admit_prog prg in admit_all_obligations () let admit_obligations n = match n with | None -> admit_all_obligations () | Some _ -> - let prg = get_prog_err n in - admit_prog prg + let prg = get_unique_prog n in + let _ = admit_prog prg in + () let next_obligation n tac = let prg = match n with - | None -> get_any_prog_err () - | Some _ -> get_prog_err n + | None -> State.first_pending () |> Option.get + | Some _ -> get_unique_prog n in let {obls; remaining} = prg.prg_obligations in let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in let i = match Array.findi is_open obls with - | Some i -> i - | None -> anomaly (Pp.str "Could not find a solvable obligation.") + | Some i -> i + | None -> CErrors.anomaly (Pp.str "Could not find a solvable obligation.") in solve_obligation prg i tac diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 89ed4c3498..102a17b216 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -84,7 +84,7 @@ val add_definition : -> ?hook:Declare.Hook.t -> ?opaque:bool -> RetrieveObl.obligation_info - -> DeclareObl.progress + -> Declare.Obls.progress (* XXX: unify with MutualEntry *) @@ -102,7 +102,7 @@ val add_mutual_definitions : -> ?hook:Declare.Hook.t -> ?opaque:bool -> Vernacexpr.decl_notation list - -> DeclareObl.fixpoint_kind + -> Declare.Obls.fixpoint_kind -> unit (** Implementation of the [Obligation] command *) @@ -117,7 +117,7 @@ val next_obligation : (** Implementation of the [Solve Obligation] command *) val solve_obligations : - Names.Id.t option -> unit Proofview.tactic option -> DeclareObl.progress + Names.Id.t option -> unit Proofview.tactic option -> Declare.Obls.progress val solve_all_obligations : unit Proofview.tactic option -> unit @@ -132,7 +132,5 @@ val show_obligations : ?msg:bool -> Names.Id.t option -> unit val show_term : Names.Id.t option -> Pp.t val admit_obligations : Names.Id.t option -> unit -exception NoObligations of Names.Id.t option - val explain_no_obligations : Names.Id.t option -> Pp.t val check_program_libraries : unit -> unit diff --git a/vernac/pfedit.ml b/vernac/pfedit.ml index e6c66ee503..150311ffaa 100644 --- a/vernac/pfedit.ml +++ b/vernac/pfedit.ml @@ -15,5 +15,5 @@ let build_by_tactic ?side_eff env ~uctx ~poly ~typ tac = b, t, safe, uctx [@@ocaml.deprecated "Use [Proof.build_by_tactic]"] -let build_constant_by_tactic = Declare.build_constant_by_tactic +let build_constant_by_tactic = Declare.build_constant_by_tactic [@ocaml.warning "-3"] [@@ocaml.deprecated "Use [Proof.build_constant_by_tactic]"] diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index b97cdfa51c..2c52c605b5 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -108,6 +108,38 @@ open Pputils let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() + let string_of_theorem_kind = let open Decls in function + | Theorem -> "Theorem" + | Lemma -> "Lemma" + | Fact -> "Fact" + | Remark -> "Remark" + | Property -> "Property" + | Proposition -> "Proposition" + | Corollary -> "Corollary" + + let string_of_definition_object_kind = let open Decls in function + | Definition -> "Definition" + | Example -> "Example" + | Coercion -> "Coercion" + | SubClass -> "SubClass" + | CanonicalStructure -> "Canonical Structure" + | Instance -> "Instance" + | Let -> "Let" + | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> + CErrors.anomaly (Pp.str "Internal definition kind.") + + let string_of_assumption_kind = let open Decls in function + | Definitional -> "Parameter" + | Logical -> "Axiom" + | Conjectural -> "Conjecture" + | Context -> "Context" + + let string_of_logical_kind = let open Decls in function + | IsAssumption k -> string_of_assumption_kind k + | IsDefinition k -> string_of_definition_object_kind k + | IsProof k -> string_of_theorem_kind k + | IsPrimitive -> "Primitive" + let pr_notation_entry = function | InConstrEntry -> keyword "constr" | InCustomEntry s -> keyword "custom" ++ spc () ++ str s @@ -148,14 +180,28 @@ open Pputils | SearchOutside [] -> mt() | SearchOutside l -> spc() ++ keyword "outside" ++ spc() ++ prlist_with_sep sep pr_module l - let pr_search (b,c) = - (if b then str "-" else mt()) ++ - match c with - | SearchSubPattern p -> + let pr_search_where = function + | Anywhere, false -> mt () + | Anywhere, true -> str "head:" + | InHyp, true -> str "headhyp:" + | InHyp, false -> str "hyp:" + | InConcl, true -> str "headconcl:" + | InConcl, false -> str "concl:" + + let pr_search_item = function + | SearchSubPattern (where,p) -> let env = Global.env () in let sigma = Evd.from_env env in - pr_constr_pattern_expr env sigma p - | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + pr_search_where where ++ pr_constr_pattern_expr env sigma p + | SearchString (where,s,sc) -> pr_search_where where ++ qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + | SearchKind kind -> str "is:" ++ str (string_of_logical_kind kind) + + let rec pr_search_request = function + | SearchLiteral a -> pr_search_item a + | SearchDisjConj l -> str "[" ++ prlist_with_sep spc (prlist_with_sep pr_bar pr_search_default) l ++ str "]" + + and pr_search_default (b, s) = + (if b then mt() else str "-") ++ pr_search_request s let pr_search a gopt b pr_p = pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt @@ -165,7 +211,7 @@ open Pputils | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b | Search sl -> - keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search sl ++ pr_in_out_modules b + keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_default sl ++ pr_in_out_modules b let pr_option_ref_value = function | Goptions.QualidRefValue id -> pr_qualid id @@ -386,15 +432,6 @@ open Pputils prlist_with_sep pr_semicolon (pr_params pr_c) *) -let string_of_theorem_kind = let open Decls in function - | Theorem -> "Theorem" - | Lemma -> "Lemma" - | Fact -> "Fact" - | Remark -> "Remark" - | Property -> "Property" - | Proposition -> "Proposition" - | Corollary -> "Corollary" - let pr_thm_token k = keyword (string_of_theorem_kind k) let pr_syntax_modifier = let open Gramlib.Gramext in function @@ -611,18 +648,6 @@ let string_of_theorem_kind = let open Decls in function with Not_found -> hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")") - -let string_of_definition_object_kind = let open Decls in function - | Definition -> "Definition" - | Example -> "Example" - | Coercion -> "Coercion" - | SubClass -> "SubClass" - | CanonicalStructure -> "Canonical Structure" - | Instance -> "Instance" - | Let -> "Let" - | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> - CErrors.anomaly (Pp.str "Internal definition kind.") - let pr_vernac_expr v = let return = tag_vernac v in let env = Global.env () in diff --git a/vernac/proof_global.ml b/vernac/proof_global.ml index 54d1db44a4..0c5bc39020 100644 --- a/vernac/proof_global.ml +++ b/vernac/proof_global.ml @@ -10,3 +10,4 @@ let get_proof = Declare.Proof.get_proof type opacity_flag = Declare.opacity_flag = | Opaque [@ocaml.deprecated "Use [Declare.Opaque]"] | Transparent [@ocaml.deprecated "Use [Declare.Transparent]"] +[@@ocaml.deprecated "Use [Declare.opacity_flag]"] diff --git a/vernac/record.ml b/vernac/record.ml index 36254780cd..9d99036273 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -223,7 +223,7 @@ let warn_cannot_define_projection = (* If a projection is not definable, we throw an error if the user asked it to be a coercion. Otherwise, we just print an info message. The user might still want to name the field of the record. *) -let warning_or_error coe indsp err = +let warning_or_error ~info coe indsp err = let st = match err with | MissingProj (fi,projs) -> let s,have = if List.length projs > 1 then "s","were" else "","was" in @@ -246,7 +246,7 @@ let warning_or_error coe indsp err = | _ -> (Id.print fi ++ strbrk " cannot be defined because it is not typable.") in - if coe then user_err ~hdr:"structure" st; + if coe then user_err ~hdr:"structure" ~info st; warn_cannot_define_projection (hov 0 st) type field_status = @@ -352,8 +352,9 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let kind = Decls.IsDefinition kind in let kn = try declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) - with Type_errors.TypeError (ctx,te) when not primitive -> - raise (NotDefinable (BadTypedProj (fid,ctx,te))) + with Type_errors.TypeError (ctx,te) as exn when not primitive -> + let _, info = Exninfo.capture exn in + Exninfo.iraise (NotDefinable (BadTypedProj (fid,ctx,te)),info) in Declare.definition_message fid; let term = match p_opt with @@ -374,8 +375,9 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f end; let i = if is_local_assum decl then i+1 else i in (Some kn::sp_projs, i, Projection term::subst) - with NotDefinable why -> - warning_or_error flags.pf_subclass indsp why; + with NotDefinable why as exn -> + let _, info = Exninfo.capture exn in + warning_or_error ~info flags.pf_subclass indsp why; (None::sp_projs,i,NoProjection fi::subst) in (nfi - 1, i, { Recordops.pk_name = fi ; pk_true_proj = is_local_assum decl ; pk_canonical = flags.pf_canonical } :: kinds, sp_projs, subst)) diff --git a/vernac/search.ml b/vernac/search.ml index 8b54b696f2..2a21184c1e 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -17,11 +17,14 @@ open Libobject open Environ open Pattern open Libnames +open Vernacexpr module NamedDecl = Context.Named.Declaration -type filter_function = GlobRef.t -> env -> constr -> bool -type display_function = GlobRef.t -> env -> constr -> unit +type filter_function = + GlobRef.t -> Decls.logical_kind option -> env -> Evd.evar_map -> constr -> bool +type display_function = + GlobRef.t -> Decls.logical_kind option -> env -> constr -> unit (* This option restricts the output of [SearchPattern ...], etc. to the names of the symbols matching the @@ -29,9 +32,15 @@ query, separated by a newline. This type of output is useful for editors (like emacs), to generate a list of completion candidates without having to parse through the types of all symbols. *) -type glob_search_about_item = - | GlobSearchSubPattern of constr_pattern +type glob_search_item = + | GlobSearchSubPattern of glob_search_where * bool * constr_pattern | GlobSearchString of string + | GlobSearchKind of Decls.logical_kind + | GlobSearchFilter of (GlobRef.t -> bool) + +type glob_search_request = + | GlobSearchLiteral of glob_search_item + | GlobSearchDisjConj of (bool * glob_search_request) list list module SearchBlacklist = Goptions.MakeStringTable @@ -52,25 +61,9 @@ module SearchBlacklist = let iter_constructors indsp u fn env nconstr = for i = 1 to nconstr do let typ = Inductiveops.type_of_constructor env ((indsp, i), u) in - fn (GlobRef.ConstructRef (indsp, i)) env typ + fn (GlobRef.ConstructRef (indsp, i)) None env typ done -let iter_named_context_name_type f = - List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl)) - -let get_current_or_goal_context ?pstate glnum = - match pstate with - | None -> let env = Global.env () in Evd.(from_env env, env) - | Some p -> Declare.get_goal_context p glnum - -(* General search over hypothesis of a goal *) -let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = - let env = Global.env () in - let iter_hyp idh typ = fn (GlobRef.VarRef idh) env typ in - let evmap,e = get_current_or_goal_context ?pstate glnum in - let pfctxt = named_context e in - iter_named_context_name_type iter_hyp pfctxt - (* FIXME: this is a Libobject hack that should be replaced with a proper registration mechanism. *) module DynHandle = Libobject.Dyn.Map(struct type 'a t = 'a -> unit end) @@ -80,9 +73,8 @@ let handle h (Libobject.Dyn.Dyn (tag, o)) = match DynHandle.find tag h with | exception Not_found -> () (* General search over declarations *) -let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = - let env = Global.env () in - List.iter (fun d -> fn (GlobRef.VarRef (NamedDecl.get_id d)) env (NamedDecl.get_type d)) +let generic_search env (fn : GlobRef.t -> Decls.logical_kind option -> env -> constr -> unit) = + List.iter (fun d -> fn (GlobRef.VarRef (NamedDecl.get_id d)) None env (NamedDecl.get_type d)) (Environ.named_context env); let iter_obj (sp, kn) lobj = match lobj with | AtomicObject o -> @@ -91,7 +83,8 @@ let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = let cst = Global.constant_of_delta_kn kn in let gr = GlobRef.ConstRef cst in let (typ, _) = Typeops.type_of_global_in_context (Global.env ()) gr in - fn gr env typ + let kind = Dumpglob.constant_kind cst in + fn gr (Some kind) env typ end @@ DynHandle.add DeclareInd.Internal.objInductive begin fun _ -> let mind = Global.mind_of_delta_kn kn in @@ -101,7 +94,7 @@ let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let i = (ind, u) in let typ = Inductiveops.type_of_inductive env i in - let () = fn (GlobRef.IndRef ind) env typ in + let () = fn (GlobRef.IndRef ind) None env typ in let len = Array.length mip.mind_user_lc in iter_constructors ind u fn env len in @@ -115,12 +108,6 @@ let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = try Declaremods.iter_all_segments iter_obj with Not_found -> () -let generic_search ?pstate glnumopt fn = - (match glnumopt with - | None -> () - | Some glnum -> iter_hypothesis ?pstate glnum fn); - iter_declarations fn - (** This module defines a preference on constrs in the form of a [compare] function (preferred constr must be big for this functions, so preferences such as small constr must use a reversed @@ -132,7 +119,7 @@ module ConstrPriority = struct (* The priority is memoised here. Because of the very localised use of this module, it is not worth it making a convenient interface. *) - type t = GlobRef.t * Environ.env * Constr.t * priority + type t = GlobRef.t * Decls.logical_kind option * Environ.env * Constr.t * priority and priority = int module ConstrSet = CSet.Make(Constr) @@ -154,10 +141,10 @@ module ConstrPriority = struct let num_symbols t = ConstrSet.(cardinal (symbols empty t)) - let priority t : priority = + let priority gref t : priority = -(3*(num_symbols t) + size t) - let compare (_,_,_,p1) (_,_,_,p2) = + let compare (_,_,_,_,p1) (_,_,_,_,p2) = pervasives_compare p1 p2 end @@ -172,16 +159,16 @@ let rec iter_priority_queue q fn = with Heap.EmptyHeap -> None end in match next with - | Some (gref,env,t,_) -> - fn gref env t; + | Some (gref,kind,env,t,_) -> + fn gref kind env t; iter_priority_queue (PriorityQueue.remove q) fn | None -> () let prioritize_search seq fn = let acc = ref PriorityQueue.empty in - let iter gref env t = - let p = ConstrPriority.priority t in - acc := PriorityQueue.add (gref,env,t,p) !acc + let iter gref kind env t = + let p = ConstrPriority.priority gref t in + acc := PriorityQueue.add (gref,kind,env,t,p) !acc in let () = seq iter in iter_priority_queue !acc fn @@ -211,12 +198,12 @@ let full_name_of_reference ref = DirPath.to_string dir ^ "." ^ Id.to_string id (** Whether a reference is blacklisted *) -let blacklist_filter ref env typ = +let blacklist_filter ref kind env sigma typ = let name = full_name_of_reference ref in let is_not_bl str = not (String.string_contains ~where:name ~what:str) in CString.Set.for_all is_not_bl (SearchBlacklist.v ()) -let module_filter (mods, outside) ref env typ = +let module_filter (mods, outside) ref kind env sigma typ = let sp = Nametab.path_of_global ref in let sl = dirpath sp in let is_outside md = not (is_dirpath_prefix_of md sl) in @@ -226,25 +213,42 @@ let module_filter (mods, outside) ref env typ = let name_of_reference ref = Id.to_string (Nametab.basename_of_global ref) -let search_filter query gr env typ = match query with -| GlobSearchSubPattern pat -> - Constr_matching.is_matching_appsubterm ~closed:false env (Evd.from_env env) pat (EConstr.of_constr typ) +let search_filter query gr kind env sigma typ = match query with +| GlobSearchSubPattern (where,head,pat) -> + let open Context.Rel.Declaration in + let collect_hyps ctx = + List.fold_left (fun acc d -> match get_value d with + | None -> get_type d :: acc + | Some b -> b :: get_type d :: acc) [] ctx in + let typl= match where with + | InHyp -> collect_hyps (fst (Term.decompose_prod_assum typ)) + | InConcl -> [snd (Term.decompose_prod_assum typ)] + | Anywhere -> + if head then + let ctx, ccl = Term.decompose_prod_assum typ in ccl :: collect_hyps ctx + else [typ] in + List.exists (fun typ -> + let f = + if head then Constr_matching.is_matching_head + else Constr_matching.is_matching_appsubterm ~closed:false in + f env sigma pat (EConstr.of_constr typ)) typl | GlobSearchString s -> String.string_contains ~where:(name_of_reference gr) ~what:s - +| GlobSearchKind k -> (match kind with None -> false | Some k' -> k = k') +| GlobSearchFilter f -> f gr (** SearchPattern *) -let search_pattern ?pstate gopt pat mods pr_search = - let filter ref env typ = - module_filter mods ref env typ && - pattern_filter pat ref env (Evd.from_env env) (* FIXME *) (EConstr.of_constr typ) && - blacklist_filter ref env typ +let search_pattern env sigma pat mods pr_search = + let filter ref kind env typ = + module_filter mods ref kind env sigma typ && + pattern_filter pat ref env sigma (EConstr.of_constr typ) && + blacklist_filter ref kind env sigma typ in - let iter ref env typ = - if filter ref env typ then pr_search ref env typ + let iter ref kind env typ = + if filter ref kind env typ then pr_search ref kind env typ in - generic_search ?pstate gopt iter + generic_search env iter (** SearchRewrite *) @@ -256,47 +260,49 @@ let rewrite_pat1 pat = let rewrite_pat2 pat = PApp (PRef (eq ()), [| PMeta None; PMeta None; pat |]) -let search_rewrite ?pstate gopt pat mods pr_search = +let search_rewrite env sigma pat mods pr_search = let pat1 = rewrite_pat1 pat in let pat2 = rewrite_pat2 pat in - let filter ref env typ = - module_filter mods ref env typ && - (pattern_filter pat1 ref env (Evd.from_env env) (* FIXME *) (EConstr.of_constr typ) || - pattern_filter pat2 ref env (Evd.from_env env) (EConstr.of_constr typ)) && - blacklist_filter ref env typ + let filter ref kind env typ = + module_filter mods ref kind env sigma typ && + (pattern_filter pat1 ref env sigma (EConstr.of_constr typ) || + pattern_filter pat2 ref env sigma (EConstr.of_constr typ)) && + blacklist_filter ref kind env sigma typ in - let iter ref env typ = - if filter ref env typ then pr_search ref env typ + let iter ref kind env typ = + if filter ref kind env typ then pr_search ref kind env typ in - generic_search ?pstate gopt iter + generic_search env iter (** Search *) -let search_by_head ?pstate gopt pat mods pr_search = - let filter ref env typ = - module_filter mods ref env typ && - head_filter pat ref env (Evd.from_env env) (* FIXME *) (EConstr.of_constr typ) && - blacklist_filter ref env typ +let search_by_head env sigma pat mods pr_search = + let filter ref kind env typ = + module_filter mods ref kind env sigma typ && + head_filter pat ref env sigma (EConstr.of_constr typ) && + blacklist_filter ref kind env sigma typ in - let iter ref env typ = - if filter ref env typ then pr_search ref env typ + let iter ref kind env typ = + if filter ref kind env typ then pr_search ref kind env typ in - generic_search ?pstate gopt iter + generic_search env iter (** Search *) -let search ?pstate gopt items mods pr_search = - let filter ref env typ = +let search env sigma items mods pr_search = + let filter ref kind env typ = let eqb b1 b2 = if b1 then b2 else not b2 in - module_filter mods ref env typ && - List.for_all - (fun (b,i) -> eqb b (search_filter i ref env typ)) items && - blacklist_filter ref env typ + module_filter mods ref kind env sigma typ && + let rec aux = function + | GlobSearchLiteral i -> search_filter i ref kind env sigma typ + | GlobSearchDisjConj l -> List.exists (List.for_all aux') l + and aux' (b,s) = eqb b (aux s) in + List.for_all aux' items && blacklist_filter ref kind env sigma typ in - let iter ref env typ = - if filter ref env typ then pr_search ref env typ + let iter ref kind env typ = + if filter ref kind env typ then pr_search ref kind env typ in - generic_search ?pstate gopt iter + generic_search env iter type search_constraint = | Name_Pattern of Str.regexp @@ -311,7 +317,7 @@ type 'a coq_object = { coq_object_object : 'a; } -let interface_search ?pstate = +let interface_search env sigma = let rec extract_flags name tpe subtpe mods blacklist = function | [] -> (name, tpe, subtpe, mods, blacklist) | (Name_Pattern regexp, b) :: l -> @@ -325,7 +331,7 @@ let interface_search ?pstate = | (Include_Blacklist, b) :: l -> extract_flags name tpe subtpe mods b l in - fun ?glnum flags -> + fun flags -> let (name, tpe, subtpe, mods, blacklist) = extract_flags [] [] [] [] false flags in @@ -337,12 +343,12 @@ let interface_search ?pstate = toggle (Str.string_match regexp id 0) flag in let match_type (pat, flag) = - toggle (Constr_matching.is_matching env (Evd.from_env env) pat (EConstr.of_constr constr)) flag + toggle (Constr_matching.is_matching env sigma pat (EConstr.of_constr constr)) flag in let match_subtype (pat, flag) = toggle (Constr_matching.is_matching_appsubterm ~closed:false - env (Evd.from_env env) pat (EConstr.of_constr constr)) flag + env sigma pat (EConstr.of_constr constr)) flag in let match_module (mdl, flag) = toggle (Libnames.is_dirpath_prefix_of mdl path) flag @@ -351,7 +357,7 @@ let interface_search ?pstate = List.for_all match_type tpe && List.for_all match_subtype subtpe && List.for_all match_module mods && - (blacklist || blacklist_filter ref env constr) + (blacklist || blacklist_filter ref kind env sigma constr) in let ans = ref [] in let print_function ref env constr = @@ -377,8 +383,8 @@ let interface_search ?pstate = } in ans := answer :: !ans; in - let iter ref env typ = + let iter ref kind env typ = if filter_function ref env typ then print_function ref env typ in - let () = generic_search ?pstate glnum iter in + let () = generic_search env iter in !ans diff --git a/vernac/search.mli b/vernac/search.mli index d3b8444b5f..09847f4e03 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -12,15 +12,24 @@ open Names open Constr open Environ open Pattern +open Vernacexpr (** {6 Search facilities. } *) -type glob_search_about_item = - | GlobSearchSubPattern of constr_pattern +type glob_search_item = + | GlobSearchSubPattern of glob_search_where * bool * constr_pattern | GlobSearchString of string + | GlobSearchKind of Decls.logical_kind + | GlobSearchFilter of (GlobRef.t -> bool) -type filter_function = GlobRef.t -> env -> constr -> bool -type display_function = GlobRef.t -> env -> constr -> unit +type glob_search_request = + | GlobSearchLiteral of glob_search_item + | GlobSearchDisjConj of (bool * glob_search_request) list list + +type filter_function = + GlobRef.t -> Decls.logical_kind option -> env -> Evd.evar_map -> constr -> bool +type display_function = + GlobRef.t -> Decls.logical_kind option -> env -> constr -> unit (** {6 Generic filter functions} *) @@ -30,7 +39,7 @@ val blacklist_filter : filter_function val module_filter : DirPath.t list * bool -> filter_function (** Check whether a reference pertains or not to a set of modules *) -val search_filter : glob_search_about_item -> filter_function +val search_filter : glob_search_item -> filter_function (** {6 Specialized search functions} @@ -38,13 +47,13 @@ val search_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_by_head : env -> Evd.evar_map -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_rewrite : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_rewrite : env -> Evd.evar_map -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_pattern : ?pstate:Declare.Proof.t -> int option -> constr_pattern -> DirPath.t list * bool +val search_pattern : env -> Evd.evar_map -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search : ?pstate:Declare.Proof.t -> int option -> (bool * glob_search_about_item) list +val search : env -> Evd.evar_map -> (bool * glob_search_request) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = @@ -65,12 +74,11 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : ?pstate:Declare.Proof.t -> ?glnum:int -> (search_constraint * bool) list -> - constr coq_object list +val interface_search : env -> Evd.evar_map -> (search_constraint * bool) list -> constr coq_object list (** {6 Generic search function} *) -val generic_search : ?pstate:Declare.Proof.t -> int option -> display_function -> unit +val generic_search : env -> display_function -> unit (** This function iterates over all hypothesis of the goal numbered [glnum] (if present) and all known declarations. *) diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 2d8734ff7f..a28d8f605b 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -404,6 +404,7 @@ let with_output_to_file fname func input = let channel = open_out (String.concat "." [fname; "out"]) in let old_fmt = !std_ft, !err_ft, !deep_ft in let new_ft = Format.formatter_of_out_channel channel in + set_gp new_ft (get_gp !std_ft); std_ft := new_ft; err_ft := new_ft; deep_ft := new_ft; @@ -412,6 +413,7 @@ let with_output_to_file fname func input = std_ft := Util.pi1 old_fmt; err_ft := Util.pi2 old_fmt; deep_ft := Util.pi3 old_fmt; + Format.pp_print_flush new_ft (); close_out channel; output with reraise -> @@ -419,6 +421,7 @@ let with_output_to_file fname func input = std_ft := Util.pi1 old_fmt; err_ft := Util.pi2 old_fmt; deep_ft := Util.pi3 old_fmt; + Format.pp_print_flush new_ft (); close_out channel; Exninfo.iraise reraise diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 618a61f487..1cad052bce 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -16,7 +16,6 @@ Metasyntax DeclareUniv RetrieveObl Declare -DeclareObl ComHints Canonical RecLemmas @@ -32,6 +31,7 @@ ComPrimitive ComAssumption DeclareInd Search +ComSearch Prettyp ComInductive ComFixpoint diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 09201d727d..106fed124e 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -576,10 +576,14 @@ let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt let env = Global.env () in let sigma = Evd.from_env env in Some (snd (Hook.get f_interp_redexp env sigma r)) in - let do_definition = - ComDefinition.(if program_mode then do_definition_program else do_definition) in - do_definition ~name:name.v - ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook + if program_mode then + ComDefinition.do_definition_program ~name:name.v + ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook + else + let () = + ComDefinition.do_definition ~name:name.v + ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook in + () (* NB: pstate argument to use combinators easily *) let vernac_start_proof ~atts kind l = @@ -1054,10 +1058,21 @@ let vernac_end_section {CAst.loc; v} = let vernac_name_sec_hyp {v=id} set = Proof_using.name_set id set (* Dispatcher of the "End" command *) +let msg_of_subsection ss id = + let kind = + match ss with + | Lib.OpenedModule (false,_,_,_) -> "module" + | Lib.OpenedModule (true,_,_,_) -> "module type" + | Lib.OpenedSection _ -> "section" + | _ -> "unknown" + in + Pp.str kind ++ spc () ++ Id.print id let vernac_end_segment ({v=id} as lid) = - DeclareObl.check_can_close lid.v; - match Lib.find_opening_node id with + let ss = Lib.find_opening_node id in + let what_for = msg_of_subsection ss lid.v in + Declare.Obls.check_solved_obligations ~what_for; + match ss with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid | Lib.OpenedSection _ -> vernac_end_section lid @@ -1762,91 +1777,17 @@ let vernac_print ~pstate ~atts = | PrintStrategy r -> print_strategy r | PrintRegistered -> print_registered () -let global_module qid = - try Nametab.full_name_module qid - with Not_found -> - user_err ?loc:qid.CAst.loc ~hdr:"global_module" - (str "Module/section " ++ pr_qualid qid ++ str " not found.") - -let interp_search_restriction = function - | SearchOutside l -> (List.map global_module l, true) - | SearchInside l -> (List.map global_module l, false) - -open Search - -let interp_search_about_item env sigma = - function - | SearchSubPattern pat -> - let _,pat = Constrintern.intern_constr_pattern env sigma pat in - GlobSearchSubPattern pat - | SearchString (s,None) when Id.is_valid s -> - GlobSearchString s - | SearchString (s,sc) -> - try - let ref = - Notation.interp_notation_as_global_reference - ~head:false (fun _ -> true) s sc in - GlobSearchSubPattern (Pattern.PRef ref) - with UserError _ -> - user_err ~hdr:"interp_search_about_item" - (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component") - -(* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the - `search_output_name_only` option to avoid excessive printing when - searching. - - The motivation was to make search usable for IDE completion, - however, it is still too slow due to the non-indexed nature of the - underlying search mechanism. - - In the future we should deprecate the option and provide a fast, - indexed name-searching interface. -*) -let search_output_name_only = ref false - -let () = - declare_bool_option - { optdepr = false; - optkey = ["Search";"Output";"Name";"Only"]; - optread = (fun () -> !search_output_name_only); - optwrite = (:=) search_output_name_only } - let vernac_search ~pstate ~atts s gopt r = + let open ComSearch in let gopt = query_command_selector gopt in - let r = interp_search_restriction r in - let env,gopt = + let sigma, env = match gopt with | None -> (* 1st goal by default if it exists, otherwise no goal at all *) - (try snd (get_goal_or_global_context ~pstate 1) , Some 1 - with _ -> Global.env (),None) + (try get_goal_or_global_context ~pstate 1 + with _ -> let env = Global.env () in (Evd.from_env env, env)) (* if goal selector is given and wrong, then let exceptions be raised. *) - | Some g -> snd (get_goal_or_global_context ~pstate g) , Some g - in - let get_pattern c = snd (Constrintern.intern_constr_pattern env Evd.(from_env env) c) in - let pr_search ref env c = - let pr = pr_global ref in - let pp = if !search_output_name_only - then pr - else begin - let open Impargs in - let impargs = select_stronger_impargs (implicits_of_global ref) in - let impargs = List.map binding_kind_of_status impargs in - let pc = pr_ltype_env env Evd.(from_env env) ~impargs c in - hov 2 (pr ++ str":" ++ spc () ++ pc) - end - in Feedback.msg_notice pp - in - (match s with - | SearchPattern c -> - (Search.search_pattern ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchRewrite c -> - (Search.search_rewrite ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchHead c -> - (Search.search_by_head ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search - | Search sl -> - (Search.search ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> - Search.prioritize_search) pr_search); - Feedback.msg_notice (str "(use \"About\" for full details on implicit arguments)") + | Some g -> get_goal_or_global_context ~pstate g in + interp_search env sigma s r let vernac_locate ~pstate = let open Constrexpr in function | LocateAny {v=AN qid} -> Prettyp.print_located_qualid qid diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index b622fd9801..0fdf9e2a7b 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -61,15 +61,22 @@ type printable = | PrintStrategy of qualid or_by_notation option | PrintRegistered -type search_about_item = - | SearchSubPattern of constr_pattern_expr - | SearchString of string * scope_name option +type glob_search_where = InHyp | InConcl | Anywhere + +type search_item = + | SearchSubPattern of (glob_search_where * bool) * constr_pattern_expr + | SearchString of (glob_search_where * bool) * string * scope_name option + | SearchKind of Decls.logical_kind + +type search_request = + | SearchLiteral of search_item + | SearchDisjConj of (bool * search_request) list list type searchable = | SearchPattern of constr_pattern_expr | SearchRewrite of constr_pattern_expr | SearchHead of constr_pattern_expr - | Search of (bool * search_about_item) list + | Search of (bool * search_request) list type locatable = | LocateAny of qualid or_by_notation diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 19d41c4770..7d25e6b852 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -225,9 +225,9 @@ let interp_qed_delayed ~proof ~info ~st pe : Vernacstate.LemmaStack.t option = let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in let () = match pe with | Admitted -> - Lemmas.save_lemma_admitted_delayed ~proof ~info + Declare.save_lemma_admitted_delayed ~proof ~info | Proved (_,idopt) -> - Lemmas.save_lemma_proved_delayed ~proof ~info ~idopt in + Declare.save_lemma_proved_delayed ~proof ~info ~idopt in stack let interp_qed_delayed_control ~proof ~info ~st ~control { CAst.loc; v=pe } = |