diff options
156 files changed, 3516 insertions, 2498 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 468161ff73..e8ee0c537b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2020-03-13-V69" + CACHEKEY: "bionic_coq-V2020-05-06-V70" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -676,7 +676,7 @@ library:ci-color: library:ci-compcert: extends: .ci-template-flambda -library:ci-coq-tools: +library:ci-coq_tools: extends: .ci-template library:ci-coqprime: @@ -696,16 +696,16 @@ library:ci-coqprime: library:ci-coquelicot: extends: .ci-template -library:ci-cross-crypto: +library:ci-cross_crypto: extends: .ci-template -library:ci-fcsl-pcm: +library:ci-fcsl_pcm: extends: .ci-template # We cannot use flambda due to # https://github.com/ocaml/ocaml/issues/7842, see # https://github.com/coq/coq/pull/11916#issuecomment-609977375 -library:ci-fiat-crypto: +library:ci-fiat_crypto: extends: .ci-template stage: stage-4 needs: @@ -731,10 +731,10 @@ library:ci-corn: needs: - build:edge+flambda - plugin:ci-bignums - - library:ci-math-classes + - library:ci-math_classes dependencies: - build:edge+flambda - - library:ci-math-classes + - library:ci-math_classes library:ci-geocoq: extends: .ci-template-flambda @@ -742,10 +742,10 @@ library:ci-geocoq: library:ci-hott: extends: .ci-template -library:ci-iris-lambda-rust: +library:ci-lambda_rust: extends: .ci-template-flambda -library:ci-math-classes: +library:ci-math_classes: extends: .ci-template-flambda stage: stage-3 artifacts: @@ -759,7 +759,7 @@ library:ci-math-classes: - build:edge+flambda - plugin:ci-bignums -library:ci-math-comp: +library:ci-mathcomp: extends: .ci-template-flambda library:ci-sf: @@ -774,7 +774,7 @@ library:ci-tlc: library:ci-unimath: extends: .ci-template-flambda -library:ci-verdi-raft: +library:ci-verdi_raft: extends: .ci-template-flambda library:ci-vst: diff --git a/Makefile.build b/Makefile.build index b7a4dd655a..3140df4cee 100644 --- a/Makefile.build +++ b/Makefile.build @@ -249,8 +249,8 @@ MLINCLUDES=$(LOCALINCLUDES) USERCONTRIBINCLUDES=$(addprefix -I user-contrib/,$(USERCONTRIBDIRS)) -OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) -OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) +OCAMLC = $(TIMER) $(OCAMLFIND) ocamlc $(CAMLFLAGS) +OCAMLOPT = $(TIMER) $(OCAMLFIND) opt $(CAMLFLAGS) BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(FLAMBDA_FLAGS) diff --git a/Makefile.ci b/Makefile.ci index b545c9de45..af92d476ba 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -19,22 +19,22 @@ CI_TARGETS= \ ci-coq_dpdgraph \ ci-coquelicot \ ci-corn \ - ci-cross-crypto \ - ci-coq-tools \ + ci-cross_crypto \ + ci-coq_tools \ ci-coqprime \ ci-elpi \ - ci-ext-lib \ + ci-ext_lib \ ci-equations \ - ci-fcsl-pcm \ - ci-fiat-crypto \ + ci-fcsl_pcm \ + ci-fiat_crypto \ ci-fiat_parsers \ ci-flocq \ ci-geocoq \ ci-coqhammer \ ci-hott \ - ci-iris-lambda-rust \ - ci-math-classes \ - ci-math-comp \ + ci-lambda_rust \ + ci-math_classes \ + ci-mathcomp \ ci-metacoq \ ci-mtac2 \ ci-paramcoq \ @@ -44,12 +44,12 @@ CI_TARGETS= \ ci-relation_algebra \ ci-rewriter \ ci-sf \ - ci-simple-io \ + ci-simple_io \ ci-stdlib2 \ ci-tlc \ ci-unimath \ ci-unicoq \ - ci-verdi-raft \ + ci-verdi_raft \ ci-vst .PHONY: ci-all $(CI_TARGETS) @@ -64,16 +64,16 @@ ci-color: ci-bignums ci-coqprime: ci-bignums -ci-math-classes: ci-bignums +ci-math_classes: ci-bignums -ci-corn: ci-math-classes +ci-corn: ci-math_classes ci-mtac2: ci-unicoq -ci-fiat-crypto: ci-coqprime ci-rewriter +ci-fiat_crypto: ci-coqprime ci-rewriter -ci-simple-io: ci-ext-lib -ci-quickchick: ci-ext-lib ci-simple-io +ci-simple_io: ci-ext_lib +ci-quickchick: ci-ext_lib ci-simple_io ci-metacoq: ci-equations diff --git a/Makefile.dune b/Makefile.dune index b002c7709d..c2899dcaba 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -1,7 +1,7 @@ # -*- mode: makefile -*- # Dune Makefile for Coq -.PHONY: help states world watch check # Main developer targets +.PHONY: help help-install states world watch check # Main developer targets .PHONY: refman-html refman-pdf stdlib-html apidoc # Documentation targets .PHONY: test-suite .PHONY: fmt ocheck ireport clean # Maintenance targets @@ -11,6 +11,7 @@ # DUNEOPT=--display=short help: + @echo "" @echo "Welcome to Coq's Dune-based build system. Common developer targets are:" @echo "" @echo " - states: build a minimal functional coqtop" @@ -19,8 +20,15 @@ help: @echo " - check: build all ML files as fast as possible" @echo " - test-suite: run Coq's test suite" @echo "" - @echo " Note: these targets produce a developer build," - @echo " not suitable for distribution to end-users" + @echo " Note: running ./configure is not recommended," + @echo " see dev/doc/build-system.dune.md for more info" + @echo " Note: these targets produce a developer build, not suitable" + @echo " for distribution to end-users or install" + @echo "" + @echo " To run an \$$app \\in {coqc,coqtop,coqbyte,coqide}:" + @echo "" + @echo " - use 'dune exec -- dev/shim/\$$app-prelude args'" + @echo " Example: 'dune exec -- dev/shim/coqc-prelude file.v'" @echo "" @echo " Documentation targets:" @echo "" @@ -37,9 +45,14 @@ help: @echo " - clean: remove build directory and autogenerated files" @echo " - help: show this message" @echo "" - @echo " To run an app \\in {coqc,coqtop,coqbyte,coqide}:" + @echo " Type 'make help-install' for installation instructions" + +help-install: + @echo "" + @echo "The Dune-based Coq build is split in packages; see Dune and dev/doc" + @echo "documentation for more details. A quick install of Coq alone can done with" @echo "" - @echo " - use 'dune exec -- dev/shim/app-prelude args'" + @echo " ./configure -prefix <install_prefix> && dune build -p coq && dune install -p coq" @echo "" @echo " Provided opam/dune packages are:" @echo "" @@ -52,8 +65,16 @@ help: @echo " - 'dune build package.install' : build package in developer mode" @echo " - 'dune build -p package' : build package in release mode" @echo "" - @echo " Packages _must_ be installed using release mode, use: 'dune install -p package'" - @echo " See Dune documentation for more information." + @echo " Packages _must_ be installed using release mode, to install a package use: " + @echo "" + @echo " - 'dune install -p package'" + @echo "" + @echo " Example: " + @echo "" + @echo " - 'dune build -p coq,coqide-server,coqide && dune install -p coq coqide-server coqide'" + @echo "" + @echo " Note that building a package in release mode ignores other packages present in" + @echo " the worktree. See Dune documentation for more information." voboot: @echo "This target is empty and not needed anymore" diff --git a/configure.ml b/configure.ml index 0eff70999d..75c11dab5f 100644 --- a/configure.ml +++ b/configure.ml @@ -751,10 +751,10 @@ let check_coqide () = if !prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in if dir = "" - then set_ide No "LablGtk3 not found" + then set_ide No "LablGtk3 or LablGtkSourceView3 not found" else let (ok, version) = check_lablgtk_version () in - let found = sprintf "LablGtk3 found (%s)" version in + let found = sprintf "LablGtk3 and LablGtkSourceView3 found (%s)" version in if not ok then set_ide No (found^", but too old (required >= 3.0, found " ^ version ^ ")"); (* We're now sure to produce at least one kind of coqide *) lablgtkdir := shorten_camllib dir; diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 88d08a1724..d5c6096100 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -73,16 +73,31 @@ Moreover your PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) fil If you break external projects that are hosted on GitHub, you can use the `create_overlays.sh` script to automatically perform most of the -above steps. In order to do so, call the script as: -``` -./dev/tools/create_overlays.sh ejgallego 9873 aac_tactics elpi ltac -``` -replacing `ejgallego` by your GitHub nickname and `9873` by the actual PR -number. The script will: +above steps. In order to do so: -- checkout the contributions and prepare the branch/remote so you can - just commit the fixes and push, -- add the corresponding overlay file in `dev/ci/user-overlays`. +- determine the list of failing projects: +IDs can be found as ci-XXX1 ci-XXX2 ci-XXX3 in the list of GitLab CI failures; +- for each project XXXi, look in [ci-basic-overlay.sh](https://github.com/coq/coq/blob/master/dev/ci/ci-basic-overlay.sh) +to see if the corresponding `XXXi_CI_GITURL` is hosted on GitHub; +- log on GitHub and fork all the XXXi projects hosted there; +- call the script as: + + ``` + ./dev/tools/create_overlays.sh ejgallego 9873 XXX1 XXX2 XXX3 + ``` + + replacing `ejgallego` by your GitHub nickname, `9873` by the actual PR +number, and selecting the XXXi hosted on GitHub. The script will: + + + checkout the contributions and prepare the branch/remote so you can + just commit the fixes and push, + + add the corresponding overlay file in `dev/ci/user-overlays`; + +- go to `_build_ci/XXXi` to prepare your overlay +(you can test your modifications by using `make -C ../.. ci-XXXi`) +and push using `git push ejgallego` (replacing `ejgallego` by your GitHub nickname); +- finally push the `dev/ci/user-overlays/9873-elgallego-YYY.sh` file on your Coq fork +(replacing `9873` by the actual PR number, and `ejgallego` by your GitHub nickname). For problems related to ML-plugins, if you use `dune build` to build Coq, it will actually be aware of the broken contributions and perform @@ -124,7 +139,7 @@ Currently available artifacts are: - the Coq documentation, built in the `doc:*` jobs. When submitting a documentation PR, this can help reviewers checking the rendered result. **@coqbot** will automatically post links to these - artifacts in the PR checks section. Furthemore, these artifacts are + artifacts in the PR checks section. Furthermore, these artifacts are automatically deployed at: + Coq's Reference Manual [master branch]: diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index f7a8851af7..b87a9c0392 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -46,9 +46,9 @@ : "${math_classes_CI_GITURL:=https://github.com/coq-community/math-classes}" : "${math_classes_CI_ARCHIVEURL:=${math_classes_CI_GITURL}/archive}" -: "${Corn_CI_REF:=master}" -: "${Corn_CI_GITURL:=https://github.com/coq-community/corn}" -: "${Corn_CI_ARCHIVEURL:=${Corn_CI_GITURL}/archive}" +: "${corn_CI_REF:=master}" +: "${corn_CI_GITURL:=https://github.com/coq-community/corn}" +: "${corn_CI_ARCHIVEURL:=${corn_CI_GITURL}/archive}" ######################################################################## # Iris @@ -59,19 +59,19 @@ : "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/iris/stdpp}" : "${stdpp_CI_ARCHIVEURL:=${stdpp_CI_GITURL}/-/archive}" -: "${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/iris/iris}" -: "${Iris_CI_ARCHIVEURL:=${Iris_CI_GITURL}/-/archive}" +: "${iris_CI_GITURL:=https://gitlab.mpi-sws.org/iris/iris}" +: "${iris_CI_ARCHIVEURL:=${iris_CI_GITURL}/-/archive}" -: "${lambdaRust_CI_REF:=master}" -: "${lambdaRust_CI_GITURL:=https://gitlab.mpi-sws.org/iris/lambda-rust}" -: "${lambdaRust_CI_ARCHIVEURL:=${lambdaRust_CI_GITURL}/-/archive}" +: "${lambda_rust_CI_REF:=master}" +: "${lambda_rust_CI_GITURL:=https://gitlab.mpi-sws.org/iris/lambda-rust}" +: "${lambda_rust_CI_ARCHIVEURL:=${lambda_rust_CI_GITURL}/-/archive}" ######################################################################## # HoTT ######################################################################## -: "${HoTT_CI_REF:=master}" -: "${HoTT_CI_GITURL:=https://github.com/HoTT/HoTT}" -: "${HoTT_CI_ARCHIVEURL:=${HoTT_CI_GITURL}/archive}" +: "${hott_CI_REF:=master}" +: "${hott_CI_GITURL:=https://github.com/HoTT/HoTT}" +: "${hott_CI_ARCHIVEURL:=${hott_CI_GITURL}/archive}" ######################################################################## # CoqHammer @@ -83,16 +83,16 @@ ######################################################################## # GeoCoq ######################################################################## -: "${GeoCoq_CI_REF:=master}" -: "${GeoCoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq}" -: "${GeoCoq_CI_ARCHIVEURL:=${GeoCoq_CI_GITURL}/archive}" +: "${geocoq_CI_REF:=master}" +: "${geocoq_CI_GITURL:=https://github.com/GeoCoq/GeoCoq}" +: "${geocoq_CI_ARCHIVEURL:=${geocoq_CI_GITURL}/archive}" ######################################################################## # Flocq ######################################################################## -: "${Flocq_CI_REF:=master}" -: "${Flocq_CI_GITURL:=https://gitlab.inria.fr/flocq/flocq}" -: "${Flocq_CI_ARCHIVEURL:=${Flocq_CI_GITURL}/-/archive}" +: "${flocq_CI_REF:=master}" +: "${flocq_CI_GITURL:=https://gitlab.inria.fr/flocq/flocq}" +: "${flocq_CI_ARCHIVEURL:=${flocq_CI_GITURL}/-/archive}" ######################################################################## # coq-tools diff --git a/dev/ci/ci-coq-tools.sh b/dev/ci/ci-coq_tools.sh index 9c95c49c9f..9c95c49c9f 100755 --- a/dev/ci/ci-coq-tools.sh +++ b/dev/ci/ci-coq_tools.sh diff --git a/dev/ci/ci-corn.sh b/dev/ci/ci-corn.sh index a0c714884c..ac3978dc8d 100755 --- a/dev/ci/ci-corn.sh +++ b/dev/ci/ci-corn.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download Corn +git_download corn -( cd "${CI_BUILD_DIR}/Corn" && ./configure.sh && make && make install ) +( cd "${CI_BUILD_DIR}/corn" && ./configure.sh && make && make install ) diff --git a/dev/ci/ci-cross-crypto.sh b/dev/ci/ci-cross_crypto.sh index 900d12c1dd..900d12c1dd 100755 --- a/dev/ci/ci-cross-crypto.sh +++ b/dev/ci/ci-cross_crypto.sh diff --git a/dev/ci/ci-ext-lib.sh b/dev/ci/ci-ext_lib.sh index 5eb167d97d..5eb167d97d 100755 --- a/dev/ci/ci-ext-lib.sh +++ b/dev/ci/ci-ext_lib.sh diff --git a/dev/ci/ci-fcsl-pcm.sh b/dev/ci/ci-fcsl_pcm.sh index cb951630c8..cb951630c8 100755 --- a/dev/ci/ci-fcsl-pcm.sh +++ b/dev/ci/ci-fcsl_pcm.sh diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat_crypto.sh index 811fefda35..811fefda35 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat_crypto.sh diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index 7a9531216e..a3a704091b 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download Flocq +git_download flocq -( cd "${CI_BUILD_DIR}/Flocq" && autoconf && ./configure && ./remake "-j${NJOBS}" && ./remake install ) +( cd "${CI_BUILD_DIR}/flocq" && autoconf && ./configure && ./remake "-j${NJOBS}" && ./remake install ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index 8c57318477..e4fc983e68 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -5,6 +5,6 @@ ci_dir="$(dirname "$0")" install_ssralg -git_download GeoCoq +git_download geocoq -( cd "${CI_BUILD_DIR}/GeoCoq" && ./configure.sh && make ) +( cd "${CI_BUILD_DIR}/geocoq" && ./configure.sh && make ) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index c8e6fe690f..4b92c8cb4d 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download HoTT +git_download hott -( cd "${CI_BUILD_DIR}/HoTT" && ./autogen.sh -skip-submodules && ./configure && make && make validate ) +( cd "${CI_BUILD_DIR}/hott" && ./autogen.sh -skip-submodules && ./configure && make && make validate ) diff --git a/dev/ci/ci-iris-lambda-rust.sh b/dev/ci/ci-lambda_rust.sh index d99e140bce..1ef0c2cb8f 100755 --- a/dev/ci/ci-iris-lambda-rust.sh +++ b/dev/ci/ci-lambda_rust.sh @@ -5,17 +5,17 @@ ci_dir="$(dirname "$0")" install_ssreflect -# Setup lambdaRust first -git_download lambdaRust +# Setup lambda_rust first +git_download lambda_rust # Extract required version of Iris (avoiding "+" which does not work on MacOS :( *) -Iris_CI_REF=$(grep -F coq-iris < "${CI_BUILD_DIR}/lambdaRust/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') +iris_CI_REF=$(grep -F coq-iris < "${CI_BUILD_DIR}/lambda_rust/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') # Setup Iris -git_download Iris +git_download iris # Extract required version of std++ -stdpp_CI_REF=$(grep -F coq-stdpp < "${CI_BUILD_DIR}/Iris/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') +stdpp_CI_REF=$(grep -F coq-stdpp < "${CI_BUILD_DIR}/iris/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') # Setup std++ git_download stdpp @@ -24,7 +24,7 @@ git_download stdpp ( cd "${CI_BUILD_DIR}/stdpp" && make && make install ) # Build and validate Iris -( cd "${CI_BUILD_DIR}/Iris" && make && make validate && make install ) +( cd "${CI_BUILD_DIR}/iris" && make && make validate && make install ) -# Build lambdaRust -( cd "${CI_BUILD_DIR}/lambdaRust" && make && make install ) +# Build lambda_rust +( cd "${CI_BUILD_DIR}/lambda_rust" && make && make install ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math_classes.sh index ae31a8e7f8..ae31a8e7f8 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math_classes.sh diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-mathcomp.sh index cae127ee7b..cae127ee7b 100755 --- a/dev/ci/ci-math-comp.sh +++ b/dev/ci/ci-mathcomp.sh diff --git a/dev/ci/ci-simple-io.sh b/dev/ci/ci-simple_io.sh index e7bcd80de7..e7bcd80de7 100755 --- a/dev/ci/ci-simple-io.sh +++ b/dev/ci/ci-simple_io.sh diff --git a/dev/ci/ci-verdi-raft.sh b/dev/ci/ci-verdi_raft.sh index 3bcd52c464..3bcd52c464 100755 --- a/dev/ci/ci-verdi-raft.sh +++ b/dev/ci/ci-verdi_raft.sh diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index e240ea3ba1..9ee6496ee5 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-03-13-V69" +# CACHEKEY: "bionic_coq-V2020-05-06-V70" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -39,7 +39,7 @@ ENV COMPILER="4.05.0" # with the compiler version. ENV BASE_OPAM="num ocamlfind.1.8.1 ounit.2.2.2 odoc.1.5.0" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ - BASE_ONLY_OPAM="elpi.1.10.2" + BASE_ONLY_OPAM="elpi.1.11.0" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" diff --git a/dev/ci/user-overlays/12227-ppedrot-refiner-rm-v82.sh b/dev/ci/user-overlays/12227-ppedrot-refiner-rm-v82.sh new file mode 100644 index 0000000000..0f8daf418c --- /dev/null +++ b/dev/ci/user-overlays/12227-ppedrot-refiner-rm-v82.sh @@ -0,0 +1,6 @@ +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/12267-gares-elpi-1.11.sh b/dev/ci/user-overlays/12267-gares-elpi-1.11.sh new file mode 100644 index 0000000000..ceb7afe3d1 --- /dev/null +++ b/dev/ci/user-overlays/12267-gares-elpi-1.11.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12267" ] || [ "$CI_BRANCH" = "elpi-1.11" ]; then + + elpi_CI_REF="coq-master+elpi-1.11" + elpi_hb_CI_REF="coq-master+elpi.11" + +fi diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 58c2fcc68a..ceb390c02c 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -131,8 +131,12 @@ in time. the package managers can Cc `@erikmd` to request that he prepare the necessary configuration for the Docker release in [`coqorg/coq`](https://hub.docker.com/r/coqorg/coq) (namely, he'll need to make sure a `coq-bignums` opam package is available in [`extra-dev`](https://github.com/coq/opam-coq-archive/tree/master/extra-dev), respectively [`released`](https://github.com/coq/opam-coq-archive/tree/master/released), so the Docker image gathering `coq` and `coq-bignums` can be built). - [ ] Draft a release on GitHub. -- [ ] Get `@maximedenes` to sign the Windows and MacOS packages and - upload them on GitHub. +- [ ] Sign the Windows and MacOS packages and upload them on GitHub. + + The Windows packages must be signed by the Inria IT security service. They + should be sent as a link to the binary together with its SHA256 hash in a + signed e-mail, via our local contact (currently `@maximedenes`). + + The MacOS packages should be signed by our own certificate, by sending them + to `@maximedenes`. A detailed step-by-step guide can be found [on the wiki](https://github.com/coq/coq/wiki/SigningReleases). - [ ] Prepare a page of news on the website with the link to the GitHub release (see [coq/www#63](https://github.com/coq/www/pull/63)). - [ ] Upload the new version of the reference manual to the website. diff --git a/doc/changelog/02-specification-language/12121-master+fix11903-warn-non-truly-fixpoint.rst b/doc/changelog/02-specification-language/12121-master+fix11903-warn-non-truly-fixpoint.rst new file mode 100644 index 0000000000..d69a94205f --- /dev/null +++ b/doc/changelog/02-specification-language/12121-master+fix11903-warn-non-truly-fixpoint.rst @@ -0,0 +1,5 @@ +- **Added:** + New warning on using :cmd:`Fixpoint` or :cmd:`CoFixpoint` for + definitions which are not recursive + (`#12121 <https://github.com/coq/coq/pull/12121>`_, + by Hugo Herbelin) diff --git a/doc/changelog/04-tactics/12213-zify-Nat.rst b/doc/changelog/04-tactics/12213-zify-Nat.rst new file mode 100644 index 0000000000..8b744cd193 --- /dev/null +++ b/doc/changelog/04-tactics/12213-zify-Nat.rst @@ -0,0 +1,3 @@ +- **Added:** + The :tacn:`zify` tactic is now aware of `Nat.le`, `Nat.lt` and `Nat.eq` + (`#12213 <https://github.com/coq/coq/pull/12213>`_, by Frédéric Besson; fixes `#12210 <https://github.com/coq/coq/issues/12210>`_). diff --git a/doc/changelog/05-tactic-language/12197-ltacprof-multi-success.rst b/doc/changelog/05-tactic-language/12197-ltacprof-multi-success.rst new file mode 100644 index 0000000000..b90c8e7a1f --- /dev/null +++ b/doc/changelog/05-tactic-language/12197-ltacprof-multi-success.rst @@ -0,0 +1,8 @@ +- **Fixed:** + The :flag:`Ltac Profiling` machinery now correctly handles + backtracking into multi-success tactics. The call-counts of some + tactics are unfortunately inflated by 1, as some tactics are + implicitly implemented as :g:`tac + fail`, which has two + entry-points rather than one (Fixes `#12196 + <https://github.com/coq/coq/issues/12196>`_, `#12197 + <https://github.com/coq/coq/pull/12197>`_, by Jason Gross). diff --git a/doc/changelog/07-commands-and-options/11665-cumulative-attr.rst b/doc/changelog/07-commands-and-options/11665-cumulative-attr.rst index b6a034941d..7b690da68d 100644 --- a/doc/changelog/07-commands-and-options/11665-cumulative-attr.rst +++ b/doc/changelog/07-commands-and-options/11665-cumulative-attr.rst @@ -6,7 +6,6 @@ ``Private`` (`#11665 <https://github.com/coq/coq/pull/11665>`_, by Théo Zimmermann). -- **Changed:** - Legacy attributes can now be passed in any order. See - :ref:`gallina-attributes` (`#11665 - <https://github.com/coq/coq/pull/11665>`_, by Théo Zimmermann). +- **Changed:** :term:`Legacy attributes <attribute>` can now be passed + in any order (`#11665 <https://github.com/coq/coq/pull/11665>`_, by + Théo Zimmermann). diff --git a/doc/changelog/08-tools/12211-time-ocaml.rst b/doc/changelog/08-tools/12211-time-ocaml.rst new file mode 100644 index 0000000000..7ff68cc495 --- /dev/null +++ b/doc/changelog/08-tools/12211-time-ocaml.rst @@ -0,0 +1,5 @@ +- **Changed:** + When passing ``TIMED=1`` to ``make`` with either Coq's own makefile + or a ``coq_makefile``\-made makefile, timing information is now + printed for OCaml files as well (`#12211 + <https://github.com/coq/coq/pull/12211>`_, by Jason Gross). diff --git a/doc/changelog/09-coqide/12068-master+coqide-completion-no-matched.rst b/doc/changelog/09-coqide/12068-master+coqide-completion-no-matched.rst new file mode 100644 index 0000000000..dbb4bdecab --- /dev/null +++ b/doc/changelog/09-coqide/12068-master+coqide-completion-no-matched.rst @@ -0,0 +1,5 @@ +- **Fixed:** + New patch presumably fixing the random Coq 8.11 segfault issue with CoqIDE completion + (`#12068 <https://github.com/coq/coq/pull/12068>`_, + by Hugo Herbelin, presumably fixing + `#11943 <https://github.com/coq/coq/pull/11943>`_). diff --git a/doc/changelog/10-standard-library/12008-ollibs-bool.rst b/doc/changelog/10-standard-library/12008-ollibs-bool.rst new file mode 100644 index 0000000000..7c10d261a7 --- /dev/null +++ b/doc/changelog/10-standard-library/12008-ollibs-bool.rst @@ -0,0 +1,5 @@ +- **Added:** + Order relations ``ltb`` and ``compareb`` added in ``Bool.Bool``. + Order properties for ``bool`` added in ``Bool.BoolOrder`` as well as two modules ``Bool_as_OT`` and ``Bool_as_DT`` in ``Structures.OrdersEx`` + (`#12008 <https://github.com/coq/coq/pull/12008>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12018-master+implb-characterization.rst b/doc/changelog/10-standard-library/12018-master+implb-characterization.rst new file mode 100644 index 0000000000..4b0abdfa3b --- /dev/null +++ b/doc/changelog/10-standard-library/12018-master+implb-characterization.rst @@ -0,0 +1,19 @@ +- **Added:** + Added lemmas + :g:`orb_negb_l`, + :g:`andb_negb_l`, + :g:`implb_true_iff`, + :g:`implb_false_iff`, + :g:`implb_true_r`, + :g:`implb_false_r`, + :g:`implb_true_l`, + :g:`implb_false_l`, + :g:`implb_same`, + :g:`implb_contrapositive`, + :g:`implb_negb`, + :g:`implb_curry`, + :g:`implb_andb_distrib_r`, + :g:`implb_orb_distrib_r`, + :g:`implb_orb_distrib_l` in library :g:`Bool` + (`#12018 <https://github.com/coq/coq/pull/12018>`_,` + by Hugo Herbelin).` diff --git a/doc/changelog/10-standard-library/12121-master+fix11903-warn-non-truly-fixpoint.rst b/doc/changelog/10-standard-library/12121-master+fix11903-warn-non-truly-fixpoint.rst new file mode 100644 index 0000000000..f22fff0736 --- /dev/null +++ b/doc/changelog/10-standard-library/12121-master+fix11903-warn-non-truly-fixpoint.rst @@ -0,0 +1,5 @@ +- **Fixed:** + :cmd:`Fixpoint`\s of the standard library without a recursive call turned + into ordinary :cmd:`Definition`\s + (`#12121 <https://github.com/coq/coq/pull/12121>`_, + by Hugo Herbelin; fixes `#11903 <https://github.com/coq/coq/pull/11903>`_). diff --git a/doc/changelog/10-standard-library/12263-fix-haskell-extraction.rst b/doc/changelog/10-standard-library/12263-fix-haskell-extraction.rst new file mode 100644 index 0000000000..c80a070181 --- /dev/null +++ b/doc/changelog/10-standard-library/12263-fix-haskell-extraction.rst @@ -0,0 +1,9 @@ +- **Fixed:** + In Haskell extraction with ``ExtrHaskellString``, equality comparisons on + strings and characters are now guaranteed to be uniquely well-typed, even in + very polymorphic contexts under ``unsafeCoerce``; this is achieved by adding + type annotations to the extracted code, and by making ``ExtrHaskellString`` + export ``ExtrHaskellBasic`` (`#12263 + <https://github.com/coq/coq/pull/12263>`_, fixes `#12257 + <https://github.com/coq/coq/issues/12257>`_ and `#12258 + <https://github.com/coq/coq/issues/12258>`_, by Jason Gross). diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 315c9d4a80..759f630b85 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -529,7 +529,7 @@ pass additional arguments such as ``using relation``. setoid_symmetry {? in @ident} setoid_transitivity setoid_rewrite {? @orientation} @term {? at @occurrences} {? in @ident} - setoid_replace @term with @term {? using relation @term} {? in @ident} {? by @tactic} + setoid_replace @term with @term {? using relation @term} {? in @ident} {? by @ltac_expr3} :name: setoid_reflexivity; setoid_symmetry; setoid_transitivity; setoid_rewrite; setoid_replace The ``using relation`` arguments cannot be passed to the unprefixed form. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 5cffe9e435..52862dea47 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -290,7 +290,7 @@ optional identifier is used when multiple functions have unsolved obligations (e.g. when defining mutually recursive blocks). The optional tactic is replaced by the default one if not specified. -.. cmd:: {? {| Local | Global } } Obligation Tactic := @tactic +.. cmd:: {? {| Local | Global } } Obligation Tactic := @ltac_expr :name: Obligation Tactic Sets the default obligation solving tactic applied to all obligations @@ -314,11 +314,11 @@ optional tactic is replaced by the default one if not specified. Start the proof of the next unsolved obligation. -.. cmd:: Solve Obligations {? {? of @ident} with @tactic} +.. cmd:: Solve Obligations {? {? of @ident} with @ltac_expr} Tries to solve each obligation of ``ident`` using the given ``tactic`` or the default one. -.. cmd:: Solve All Obligations {? with @tactic} +.. cmd:: Solve All Obligations {? with @ltac_expr} Tries to solve each obligation of every program using the given tactic or the default one (useful for mutually recursive definitions). diff --git a/doc/sphinx/appendix/indexes/index.rst b/doc/sphinx/appendix/indexes/index.rst index c8b2cf46dc..7dd0f62a9f 100644 --- a/doc/sphinx/appendix/indexes/index.rst +++ b/doc/sphinx/appendix/indexes/index.rst @@ -11,17 +11,17 @@ find what you are looking for. .. toctree:: - ../../genindex + ../../std-glossindex ../../coq-cmdindex ../../coq-tacindex + ../../coq-attrindex ../../coq-optindex ../../coq-exnindex - ../../coq-attrindex - ../../std-glossindex + ../../genindex For reference, here are direct links to the documentation of: -- :ref:`flags, options and tables <flags-options-tables>`; +- :ref:`attributes` +- :ref:`flags-options-tables`; - controlling the display of warning messages with the :opt:`Warnings` option; -- :ref:`gallina-attributes`. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 88ca0e63d8..453b8597f9 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -1559,7 +1559,7 @@ changes: - Vernacular: - - Experimental support for :ref:`attributes <gallina-attributes>` on + - Experimental support for :term:`attributes <attribute>` on commands, by Vincent Laporte, as in ``#[local] Lemma foo : bar.`` Tactics and tactic notations now support the ``deprecated`` attribute. diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index db1340eacb..dbe582df95 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -186,6 +186,7 @@ nitpick_ignore = [ ('token', token) for token in [ 'binders', 'collection', 'modpath', + 'tactic', ]] # -- Options for HTML output ---------------------------------------------- diff --git a/doc/sphinx/coq-attrindex.rst b/doc/sphinx/coq-attrindex.rst index f2ace20374..a0c8bba90d 100644 --- a/doc/sphinx/coq-attrindex.rst +++ b/doc/sphinx/coq-attrindex.rst @@ -1,5 +1,9 @@ :orphan: +.. hack to get index in TOC + +.. _attribute_index: + --------------- Attribute index --------------- diff --git a/doc/sphinx/coq-optindex.rst b/doc/sphinx/coq-optindex.rst index 0961bea61f..e03b2abc32 100644 --- a/doc/sphinx/coq-optindex.rst +++ b/doc/sphinx/coq-optindex.rst @@ -2,6 +2,8 @@ .. hack to get index in TOC +.. _options_index: + ------------------------------- Flags, options and tables index ------------------------------- diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 09a3897a06..b125d21a3c 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -24,9 +24,9 @@ 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 *sorts*. Types and sorts are themselves terms +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, +syntactic language of terms which is described in Section :ref:`terms`. But first, we describe sorts. @@ -1108,6 +1108,75 @@ between universes for inductive types in the Type hierarchy. 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 diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst new file mode 100644 index 0000000000..9473cc5a15 --- /dev/null +++ b/doc/sphinx/language/core/basic.rst @@ -0,0 +1,520 @@ +============================= +Basic notions and conventions +============================= + +This section provides some essential notions and conventions for reading +the manual. + +We start by explaining the syntax and lexical conventions used in the +manual. Then, we present the essential vocabulary necessary to read +the rest of the manual. Other terms are defined throughout the manual. +The reader may refer to the :ref:`glossary index <glossary_index>` +for a complete list of defined terms. Finally, we describe the various types of +settings that |Coq| provides. + +Syntax and lexical conventions +------------------------------ + +Syntax conventions +~~~~~~~~~~~~~~~~~~ + +The syntax described in this documentation is equivalent to that +accepted by the |Coq| parser, but the grammar has been edited +to improve readability and presentation. + +In the grammar presented in this manual, the terminal symbols are +black (e.g. :n:`forall`), whereas the nonterminals are green, italic +and hyperlinked (e.g. :n:`@term`). Some syntax is represented +graphically using the following kinds of blocks: + +:n:`{? item }` + An optional item. + +:n:`{+ item }` + A list of one or more items. + +:n:`{* item }` + An optional list of items. + +:n:`{+s item}` + A list of one or more items separated by "s" (e.g. :n:`item__1 s item__2 s item__3`). + +:n:`{*s item}` + An optional list of items separated by "s". + +:n:`{| item__1 | item__2 | ... }` + Alternatives (either :n:`item__1` or :n:`item__2` or ...). + +`Precedence levels +<https://en.wikipedia.org/wiki/Order_of_operations>`_ that are +implemented in the |Coq| parser are shown in the documentation by +appending the level to the nonterminal name (as in :n:`@term100` or +:n:`@ltac_expr3`). + +.. note:: + + |Coq| uses an extensible parser. Plugins and the :ref:`notation + system <syntax-extensions-and-notation-scopes>` can extend the + syntax at run time. Some notations are defined in the prelude, + which is loaded by default. The documented grammar doesn't include + these notations. Precedence levels not used by the base grammar + are omitted from the documentation, even though they could still be + populated by notations or plugins. + + Furthermore, some parsing rules are only activated in certain + contexts (:ref:`interactive proof mode <proofhandling>`, + :ref:`custom entries <custom-entries>`...). + +.. warning:: + + Given the complexity of these parsing rules, it would be extremely + difficult to create an external program that can properly parse a + |Coq| document. Therefore, tool writers are advised to delegate + parsing to |Coq|, by communicating with it, for instance through + `SerAPI <https://github.com/ejgallego/coq-serapi>`_. + +.. seealso:: :cmd:`Print Grammar` + +.. _lexical-conventions: + +Lexical conventions +~~~~~~~~~~~~~~~~~~~ + +Blanks + Space, newline and horizontal tab are considered blanks. + Blanks are ignored but they separate tokens. + +Comments + Comments are enclosed between ``(*`` and ``*)``. They can be nested. + They can contain any character. However, embedded :n:`@string` literals must be + correctly closed. Comments are treated as blanks. + +Identifiers + Identifiers, written :n:`@ident`, are sequences of letters, digits, ``_`` and + ``'``, that do not start with a digit or ``'``. That is, they are + recognized by the following grammar (except that the string ``_`` is reserved; + it is not a valid identifier): + + .. insertprodn ident subsequent_letter + + .. prodn:: + ident ::= @first_letter {* @subsequent_letter } + first_letter ::= {| a .. z | A .. Z | _ | @unicode_letter } + subsequent_letter ::= {| @first_letter | @digit | ' | @unicode_id_part } + + All characters are meaningful. In particular, identifiers are case-sensitive. + :production:`unicode_letter` non-exhaustively includes Latin, + Greek, Gothic, Cyrillic, Arabic, Hebrew, Georgian, Hangul, Hiragana + and Katakana characters, CJK ideographs, mathematical letter-like + symbols and non-breaking space. :production:`unicode_id_part` + non-exhaustively includes symbols for prime letters and subscripts. + +Numerals + Numerals are sequences of digits with an optional fractional part + and exponent, optionally preceded by a minus sign. :n:`@int` is an integer; + a numeral without fractional or exponent parts. :n:`@num` is a non-negative + integer. Underscores embedded in the digits are ignored, for example + ``1_000_000`` is the same as ``1000000``. + + .. insertprodn numeral digit + + .. prodn:: + numeral ::= {+ @digit } {? . {+ @digit } } {? {| e | E } {? {| + | - } } {+ @digit } } + int ::= {? - } {+ @digit } + num ::= {+ @digit } + digit ::= 0 .. 9 + +Strings + Strings begin and end with ``"`` (double quote). Use ``""`` to represent + a double quote character within a string. In the grammar, strings are + identified with :production:`string`. + +Keywords + The following character sequences are reserved keywords that cannot be + used as identifiers:: + + _ Axiom CoFixpoint Definition Fixpoint Hypothesis Parameter Prop + SProp Set Theorem Type Variable as at cofix discriminated else end + fix for forall fun if in let match return then where with + + Note that notations and plugins may define additional keywords. + +Other tokens + The set of + tokens defined at any given time can vary because the :cmd:`Notation` + command can define new tokens. A :cmd:`Require` command may load more notation definitions, + while the end of a :cmd:`Section` may remove notations. Some notations + are defined in the standard library (see :ref:`thecoqlibrary`) and are generally + loaded automatically at startup time. + + Here are the character sequences that |Coq| directly defines as tokens + without using :cmd:`Notation`:: + + ! #[ % & ' ( () (bfs) (dfs) ) * ** + , - -> + . .( .. ... / : ::= := :> :>> ; < <+ <- <: + <<: <= = => > >-> >= ? @ @{ [ [= ] _ + `( `{ { {| | |- || } + + When multiple tokens match the beginning of a sequence of characters, + the longest matching token is used. + Occasionally you may need to insert spaces to separate tokens. For example, + if ``~`` and ``~~`` are both defined as tokens, the inputs ``~ ~`` and + ``~~`` generate different tokens, whereas if `~~` is not defined, then the + two inputs are equivalent. + +Essential vocabulary +-------------------- + +This section presents the most essential notions to understand the +rest of the |Coq| manual: :term:`terms <term>` and :term:`types +<type>` on the one hand, :term:`commands <command>` and :term:`tactics +<tactic>` on the other hand. + +.. glossary:: + + term + + Terms are the basic expressions of |Coq|. Terms can represent + mathematical expressions, propositions and proofs, but also + executable programs and program types. + + Here is the top-level syntax of terms. Each of the listed + constructs is presented in a dedicated section. Some of these + constructs (like :n:`@term_forall_or_fun`) are part of the core + language that the kernel of |Coq| understands and are therefore + described in :ref:`this chapter <core-language>`, while + others (like :n:`@term_if`) are language extensions that are + presented in :ref:`the next chapter <extensions>`. + + .. insertprodn term qualid_annotated + + .. prodn:: + term ::= @term_forall_or_fun + | @term_let + | @term_if + | @term_fix + | @term_cofix + | @term100 + term100 ::= @term_cast + | @term10 + term10 ::= @term_application + | @one_term + one_term ::= @term_explicit + | @term1 + term1 ::= @term_projection + | @term_scope + | @term0 + term0 ::= @qualid_annotated + | @sort + | @primitive_notations + | @term_evar + | @term_match + | @term_record + | @term_generalizing + | @term_ltac + | ( @term ) + qualid_annotated ::= @qualid {? @univ_annot } + + .. note:: + + Many :term:`commands <command>` and :term:`tactics <tactic>` + use :n:`@one_term` (in the syntax of their arguments) rather + than :n:`@term`. The former need to be enclosed in + parentheses unless they're very simple, such as a single + identifier. This avoids confusing a space-separated list of + terms or identifiers with a :n:`@term_application`. + + type + + To be valid and accepted by the |Coq| kernel, a term needs an + associated type. We express this relationship by “:math:`x` *of + type* :math:`T`”, which we write as “:math:`x:T`”. Informally, + “:math:`x:T`” can be thought as “:math:`x` *belongs to* + :math:`T`”. + + The |Coq| kernel is a type checker: it verifies that a term has + the expected type by applying a set of typing rules (see + :ref:`Typing-rules`). If that's indeed the case, we say that the + term is :gdef:`well-typed`. + + A special feature of the |Coq| language is that types can depend + on terms (we say that the language is `dependently-typed + <https://en.wikipedia.org/wiki/Dependent_type>`_). Because of + this, types and terms share a common syntax. All types are terms, + but not all terms are types: + + .. insertprodn type type + + .. prodn:: + type ::= @term + + 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 + whether a type is inhabited is `undecidable + <https://en.wikipedia.org/wiki/Undecidable_problem>`_. + + Formally, types can be used to construct logical foundations for + mathematics alternative to the standard `"set theory" + <https://en.wikipedia.org/wiki/Set_theory>`_: we call such + logical foundations `"type theories" + <https://en.wikipedia.org/wiki/Type_theory>`_. |Coq| is based on + the Calculus of Inductive Constructions, which is a particular + instance of type theory. + + sentence + + |Coq| documents are made of a series of sentences that contain + :term:`commands <command>` or :term:`tactics <tactic>`, generally + terminated with a period and optionally decorated with + :term:`attributes <attribute>`. + + .. insertprodn document sentence + + .. prodn:: + document ::= {* @sentence } + sentence ::= {? @attributes } @command . + | {? @attributes } {? @num : } @query_command . + | {? @attributes } {? @toplevel_selector } @ltac_expr {| . | ... } + | @control_command + + :n:`@ltac_expr` syntax supports both simple and compound + :term:`tactics <tactic>`. For example: ``split`` is a simple + tactic while ``split; auto`` combines two simple tactics. + + command + + A :production:`command` can be used to modify the state of a |Coq| + document, for instance by declaring a new object, or to get + information about the current state. + + By convention, command names begin with uppercase letters. + Commands appear in the HTML documentation in blue or gray boxes + after the label "Command". In the pdf, they appear after the + boldface label "Command:". Commands are listed in the + :ref:`command_index`. Example: + + .. cmd:: Comments {* @string } + + This command prints "Comments ok" and does not change anything + to the state of the document. + + tactic + + Tactics specify how to transform the current proof state as a + step in creating a proof. They are syntactically valid only when + |Coq| is in proof mode, such as after a :cmd:`Theorem` command + and before any subsequent proof-terminating command such as + :cmd:`Qed`. See :ref:`proofhandling` for more on proof mode. + + By convention, tactic names begin with lowercase letters. Tactic + appear in the HTML documentation in blue or gray boxes after the + label "Tactic". In the pdf, they appear after the boldface label + "Tactic:". Tactics are listed in the :ref:`tactic_index`. + +Settings +-------- + +There are several mechanisms for changing the behavior of |Coq|. The +:term:`attribute` mechanism is used to modify the behavior of a single +:term:`sentence`. The :term:`flag`, :term:`option` and :term:`table` +mechanisms are used to modify the behavior of |Coq| more globally in a +document or project. + +.. _attributes: + +Attributes +~~~~~~~~~~ + +An :gdef:`attribute` modifies the behavior of a single sentence. +Syntactically, most commands and tactics can be decorated with +attributes (cf. :n:`@sentence`), but attributes not supported by the +command or tactic will trigger :warn:`This command does not support +this attribute`. + +.. insertprodn attributes legacy_attr + +.. prodn:: + attributes ::= {* #[ {*, @attribute } ] } {* @legacy_attr } + attribute ::= @ident {? @attr_value } + attr_value ::= = @string + | ( {*, @attribute } ) + legacy_attr ::= {| Local | Global } + | {| Polymorphic | Monomorphic } + | {| Cumulative | NonCumulative } + | Private + | Program + +The order of top-level attributes doesn't affect their meaning. ``#[foo,bar]``, ``#[bar,foo]``, +``#[foo]#[bar]`` and ``#[bar]#[foo]`` are equivalent. + +The legacy attributes (:n:`@legacy_attr`) provide an older, alternate syntax +for certain attributes. They are equivalent to new attributes as follows: + +================ ================================ +Legacy attribute New attribute +================ ================================ +`Local` :attr:`local` +`Global` :attr:`global` +`Polymorphic` :attr:`universes(polymorphic)` +`Monomorphic` :attr:`universes(monomorphic)` +`Cumulative` :attr:`universes(cumulative)` +`NonCumulative` :attr:`universes(noncumulative)` +`Private` :attr:`private(matching)` +`Program` :attr:`program` +================ ================================ + +Attributes appear in the HTML documentation in blue or gray boxes +after the label "Attribute". In the pdf, they appear after the +boldface label "Attribute:". Attributes are listed in the +:ref:`attribute_index`. + +.. warn:: This command does not support this attribute: @ident. + :name: This command does not support this attribute + + This warning is configured to behave as an error by default. You + may turn it into a normal warning by using the :opt:`Warnings` option: + + .. coqtop:: none + + Set Silent. + + .. coqtop:: all warn + + Set Warnings "unsupported-attributes". + #[ foo ] Comments. + +.. _flags-options-tables: + +Flags, Options and Tables +~~~~~~~~~~~~~~~~~~~~~~~~~ + +The following types of settings can be used to change the behavior of |Coq| in +subsequent commands and tactics (see :ref:`set_unset_scope_qualifiers` for a +more precise description of the scope of these settings): + +* A :gdef:`flag` has a boolean value, such as :flag:`Universe Polymorphism`. +* An :gdef:`option` generally has a numeric or string value, such as :opt:`Firstorder Depth`. +* A :gdef:`table` contains a set of :token:`string`\s or :token:`qualid`\s. +* In addition, some commands provide settings, such as :cmd:`Extraction Language`. + +.. FIXME Convert "Extraction Language" to an option. + +Flags, options and tables are identified by a series of identifiers, each with an initial +capital letter. + +Flags, options and tables appear in the HTML documentation in blue or +gray boxes after the labels "Flag", "Option" and "Table". In the pdf, +they appear after a boldface label. They are listed in the +:ref:`options_index`. + +.. cmd:: Set @setting_name {? {| @int | @string } } + :name: Set + + .. insertprodn setting_name setting_name + + .. prodn:: + setting_name ::= {+ @ident } + + If :n:`@setting_name` is a flag, no value may be provided; the flag + is set to on. + If :n:`@setting_name` is an option, a value of the appropriate type + must be provided; the option is set to the specified value. + + This command supports the :attr:`local`, :attr:`global` and :attr:`export` attributes. + They are described :ref:`here <set_unset_scope_qualifiers>`. + + .. warn:: There is no flag or option with this name: "@setting_name". + + This warning message can be raised by :cmd:`Set` and + :cmd:`Unset` when :n:`@setting_name` is unknown. It is a + warning rather than an error because this helps library authors + produce |Coq| code that is compatible with several |Coq| versions. + To preserve the same behavior, they may need to set some + compatibility flags or options that did not exist in previous + |Coq| versions. + +.. cmd:: Unset @setting_name + :name: Unset + + If :n:`@setting_name` is a flag, it is set to off. If :n:`@setting_name` is an option, it is + set to its default value. + + This command supports the :attr:`local`, :attr:`global` and :attr:`export` attributes. + They are described :ref:`here <set_unset_scope_qualifiers>`. + +.. cmd:: Add @setting_name {+ {| @qualid | @string } } + + Adds the specified values to the table :n:`@setting_name`. + +.. cmd:: Remove @setting_name {+ {| @qualid | @string } } + + Removes the specified value from the table :n:`@setting_name`. + +.. cmd:: Test @setting_name {? for {+ {| @qualid | @string } } } + + If :n:`@setting_name` is a flag or option, prints its current value. + If :n:`@setting_name` is a table: if the `for` clause is specified, reports + whether the table contains each specified value, otherwise this is equivalent to + :cmd:`Print Table`. The `for` clause is not valid for flags and options. + + .. exn:: There is no flag, option or table with this name: "@setting_name". + + This error message is raised when calling the :cmd:`Test` + command (without the `for` clause), or the :cmd:`Print Table` + command, for an unknown :n:`@setting_name`. + + .. exn:: There is no qualid-valued table with this name: "@setting_name". + There is no string-valued table with this name: "@setting_name". + + These error messages are raised when calling the :cmd:`Add` or + :cmd:`Remove` commands, or the :cmd:`Test` command with the + `for` clause, if :n:`@setting_name` is unknown or does not have + the right type. + +.. cmd:: Print Options + + Prints the current value of all flags and options, and the names of all tables. + +.. cmd:: Print Table @setting_name + + Prints the values in the table :n:`@setting_name`. + +.. cmd:: Print Tables + + A synonym for :cmd:`Print Options`. + +.. _set_unset_scope_qualifiers: + +Locality attributes supported by :cmd:`Set` and :cmd:`Unset` +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +The :cmd:`Set` and :cmd:`Unset` commands support the :attr:`local`, +:attr:`global` and :attr:`export` locality attributes: + +* no attribute: the original setting is *not* restored at the end of + the current module or section. +* :attr:`local` (or alternatively, the ``Local`` prefix): the setting + is applied within the current module or section. The original value + of the setting is restored at the end of the current module or + section. +* :attr:`export` (or alternatively, the ``Export`` prefix): similar to + :attr:`local`, the original value of the setting is restored at the + end of the current module or section. In addition, if the value is + set in a module, then :cmd:`Import`\-ing the module sets the option + or flag. +* :attr:`global` (or alternatively, the ``Global`` prefix): the + original setting is *not* restored at the end of the current module + or section. In addition, if the value is set in a file, then + :cmd:`Require`\-ing the file sets the option. + +Newly opened modules and sections inherit the current settings. + +.. note:: + + We discourage using the :attr:`global` attribute with the :cmd:`Set` and + :cmd:`Unset` commands. If your goal is to define + project-wide settings, you should rather use the command-line + arguments ``-set`` and ``-unset`` for setting flags and options + (cf. :ref:`command-line-options`). diff --git a/doc/sphinx/language/core/index.rst b/doc/sphinx/language/core/index.rst index 5ee960d99b..5e83672463 100644 --- a/doc/sphinx/language/core/index.rst +++ b/doc/sphinx/language/core/index.rst @@ -6,23 +6,26 @@ Core language At the heart of the Coq proof assistant is the Coq kernel. While users have access to a language with many convenient features such as -notations, implicit arguments, etc. (that are presented in the -:ref:`next chapter <extensions>`), such complex terms get translated -down to a core language (the Calculus of Inductive Constructions) that -the kernel understands, and which we present here. Furthermore, while -users can build proofs interactively using tactics (see Chapter +:ref:`notations <syntax-extensions-and-notation-scopes>`, +:ref:`implicit arguments <ImplicitArguments>`, etc. (presented in the +:ref:`next chapter <extensions>`), those features are translated into +the core language (the Calculus of Inductive Constructions) that the +kernel understands, which we present here. Furthermore, while users +can build proofs interactively using tactics (see Chapter :ref:`writing-proofs`), the role of these tactics is to incrementally build a "proof term" which the kernel will verify. More precisely, a -proof term is a term of the Calculus of Inductive Constructions whose -type corresponds to a theorem statement. The kernel is a type checker -which verifies that terms have their expected type. +proof term is a :term:`term` of the Calculus of Inductive +Constructions whose :term:`type` corresponds to a theorem statement. +The kernel is a type checker which verifies that terms have their +expected types. -This separation between the kernel on the one hand and the elaboration -engine and tactics on the other hand follows what is known as the "de -Bruijn criterion" (keeping a small and well delimited trusted code +This separation between the kernel on one hand and the +:ref:`elaboration engine <extensions>` and :ref:`tactics +<writing-proofs>` on the other follows what is known as the :gdef:`de +Bruijn criterion` (keeping a small and well delimited trusted code base within a proof assistant which can be much more complex). This -separation makes it possible to reduce the trust in the whole system -to trusting a smaller, critical component: the kernel. In particular, +separation makes it necessary to trust only a smaller, critical +component (the kernel) instead of the entire system. In particular, users may rely on external plugins that provide advanced and complex tactics without fear of these tactics being buggy, because the kernel will have to check their output. @@ -30,6 +33,7 @@ will have to check their output. .. toctree:: :maxdepth: 1 + basic ../gallina-specification-language ../cic records diff --git a/doc/sphinx/language/core/records.rst b/doc/sphinx/language/core/records.rst index 928378f55e..0080f1d052 100644 --- a/doc/sphinx/language/core/records.rst +++ b/doc/sphinx/language/core/records.rst @@ -15,14 +15,17 @@ expressions. In this sense, the :cmd:`Record` construction allows defining .. cmd:: {| Record | Structure } @record_definition {* with @record_definition } :name: Record; Structure - .. insertprodn record_definition field_body + .. insertprodn record_definition field_def .. prodn:: record_definition ::= {? > } @ident_decl {* @binder } {? : @type } {? @ident } %{ {*; @record_field } %} {? @decl_notations } - record_field ::= {* #[ {*, @attr } ] } @name {? @field_body } {? %| @num } {? @decl_notations } + record_field ::= {* #[ {*, @attribute } ] } @name {? @field_body } {? %| @num } {? @decl_notations } field_body ::= {* @binder } @of_type | {* @binder } @of_type := @term | {* @binder } := @term + term_record ::= %{%| {* @field_def } %|%} + field_def ::= @qualid {* @binder } := @term + Each :n:`@record_definition` defines a record named by :n:`@ident_decl`. The constructor name is given by :n:`@ident`. diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index d93dc00e24..73b1b65097 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -351,7 +351,7 @@ application. Use the :n:`(@ident := @term)` form of :token:`arg` to do so, where :token:`ident` is the name of the implicit argument and :token:`term` is its corresponding explicit term. Alternatively, one can deactivate the hiding of implicit arguments for a single function application using the -:n:`@ @qualid {? @univ_annot } {* @term1 }` form of :token:`term10`. +:n:`@@qualid_annotated {+ @term1 }` form of :token:`term_application`. .. example:: Syntax for explicitly giving implicit arguments (continued) @@ -420,6 +420,30 @@ but succeeds in Deactivation of implicit arguments for parsing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +.. insertprodn term_explicit term_explicit + +.. prodn:: + term_explicit ::= @ @qualid_annotated + +This syntax can be used to disable implicit arguments for a single +function. + +.. example:: + + The function `id` has one implicit argument and one explicit + argument. + + .. coqtop:: all reset + + Check (id 0). + Definition id' := @id. + + The function `id'` has no implicit argument. + + .. coqtop:: all + + Check (id' nat 0). + .. flag:: Parsing Explicit Turning this flag on (it is off by default) deactivates the use of implicit arguments. @@ -429,6 +453,19 @@ Deactivation of implicit arguments for parsing to be given as if no arguments were implicit. By symmetry, this also affects printing. +.. example:: + + We can reproduce the example above using the :flag:`Parsing + Explicit` flag: + + .. coqtop:: all reset + + Set Parsing Explicit. + Definition id' := id. + Unset Parsing Explicit. + Check (id 1). + Check (id' nat 1). + .. _canonical-structure-declaration: Canonical structures @@ -606,7 +643,7 @@ Implicit generalization .. index:: `[! ] .. index:: `(! ) -.. insertprodn generalizing_binder typeclass_constraint +.. insertprodn generalizing_binder term_generalizing .. prodn:: generalizing_binder ::= `( {+, @typeclass_constraint } ) @@ -615,7 +652,8 @@ Implicit generalization typeclass_constraint ::= {? ! } @term | %{ @name %} : {? ! } @term | @name : {? ! } @term - + term_generalizing ::= `%{ @term %} + | `( @term ) Implicit generalization is an automatic elaboration of a statement with free variables into a closed statement where these variables are diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 51dc169def..5b78280edc 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -30,6 +30,11 @@ under its expanded form (see :flag:`Printing Matching`). 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 @@ -852,7 +857,7 @@ Printing constructions in full .. flag:: Printing All Coercions, implicit arguments, the type of pattern matching, but also - notations (see :ref:`syntaxextensionsandnotationscopes`) can obfuscate the behavior of some + 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, @@ -913,7 +918,8 @@ Existential variables .. insertprodn term_evar term_evar .. prodn:: - term_evar ::= ?[ @ident ] + term_evar ::= _ + | ?[ @ident ] | ?[ ?@ident ] | ?@ident {? @%{ {+; @ident := @term } %} } diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 186a23897d..353bed1b3d 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -7,197 +7,13 @@ 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. The syntax of logical -objects involved in theories is described in Section :ref:`term`. The -language of commands, called *The Vernacular* is described in Section -:ref:`vernacular`. - -In Coq, logical objects are typed to ensure their logical correctness. The -rules implemented by the typing algorithm are described in Chapter :ref:`calculusofinductiveconstructions`. - - -.. About the grammars in the manual - ================================ - - Grammars are presented in Backus-Naur form (BNF). Terminal symbols are - set in black ``typewriter font``. In addition, there are special notations for - regular expressions. - - An expression enclosed in square brackets ``[…]`` means at most one - occurrence of this expression (this corresponds to an optional - component). - - The notation “``entry sep … sep entry``” stands for a non empty sequence - of expressions parsed by entry and separated by the literal “``sep``” [1]_. - - Similarly, the notation “``entry … entry``” stands for a non empty - sequence of expressions parsed by the “``entry``” entry, without any - separator between. - - At the end, the notation “``[entry sep … sep entry]``” stands for a - possibly empty sequence of expressions parsed by the “``entry``” entry, - separated by the literal “``sep``”. - -.. _lexical-conventions: - -Lexical conventions -=================== - -Blanks - Space, newline and horizontal tab are considered blanks. - Blanks are ignored but they separate tokens. - -Comments - Comments are enclosed between ``(*`` and ``*)``. They can be nested. - They can contain any character. However, embedded :n:`@string` literals must be - correctly closed. Comments are treated as blanks. - -Identifiers - Identifiers, written :n:`@ident`, are sequences of letters, digits, ``_`` and - ``'``, that do not start with a digit or ``'``. That is, they are - recognized by the following grammar (except that the string ``_`` is reserved; - it is not a valid identifier): - - .. insertprodn ident subsequent_letter - - .. prodn:: - ident ::= @first_letter {* @subsequent_letter } - first_letter ::= {| a .. z | A .. Z | _ | @unicode_letter } - subsequent_letter ::= {| @first_letter | @digit | ' | @unicode_id_part } - - All characters are meaningful. In particular, identifiers are case-sensitive. - :production:`unicode_letter` non-exhaustively includes Latin, - Greek, Gothic, Cyrillic, Arabic, Hebrew, Georgian, Hangul, Hiragana - and Katakana characters, CJK ideographs, mathematical letter-like - symbols and non-breaking space. :production:`unicode_id_part` - non-exhaustively includes symbols for prime letters and subscripts. - -Numerals - Numerals are sequences of digits with an optional fractional part - and exponent, optionally preceded by a minus sign. :n:`@int` is an integer; - a numeral without fractional or exponent parts. :n:`@num` is a non-negative - integer. Underscores embedded in the digits are ignored, for example - ``1_000_000`` is the same as ``1000000``. - - .. insertprodn numeral digit - - .. prodn:: - numeral ::= {+ @digit } {? . {+ @digit } } {? {| e | E } {? {| + | - } } {+ @digit } } - int ::= {? - } {+ @digit } - num ::= {+ @digit } - digit ::= 0 .. 9 - -Strings - Strings begin and end with ``"`` (double quote). Use ``""`` to represent - a double quote character within a string. In the grammar, strings are - identified with :production:`string`. - -Keywords - The following character sequences are reserved keywords that cannot be - used as identifiers:: - - _ Axiom CoFixpoint Definition Fixpoint Hypothesis IF Parameter Prop - SProp Set Theorem Type Variable as at by cofix discriminated else - end exists exists2 fix for forall fun if in lazymatch let match - multimatch return then using where with - - Note that plugins may define additional keywords when they are loaded. - -Other tokens - The set of - tokens defined at any given time can vary because the :cmd:`Notation` - command can define new tokens. A :cmd:`Require` command may load more notation definitions, - while the end of a :cmd:`Section` may remove notations. Some notations - are defined in the basic library (see :ref:`thecoqlibrary`) and are normally - loaded automatically at startup time. - - Here are the character sequences that Coq directly defines as tokens - without using :cmd:`Notation` (omitting 25 specialized tokens that begin with - ``#int63_``):: - - ! #[ % & ' ( () (bfs) (dfs) ) * ** + , - -> - . .( .. ... / : ::= := :> :>> ; < <+ <- <: - <<: <= = => > >-> >= ? @ @{ [ [= ] _ - `( `{ { {| | |- || } - - When multiple tokens match the beginning of a sequence of characters, - the longest matching token is used. - Occasionally you may need to insert spaces to separate tokens. For example, - if ``~`` and ``~~`` are both defined as tokens, the inputs ``~ ~`` and - ``~~`` generate different tokens, whereas if `~~` is not defined, then the - two inputs are equivalent. +definitions of constants, functions, predicates and sets. .. _term: Terms ===== -Syntax of terms ---------------- - -The following grammars describe the basic syntax of the terms of the -*Calculus of Inductive Constructions* (also called Cic). The formal -presentation of Cic is given in Chapter :ref:`calculusofinductiveconstructions`. Extensions of this syntax -are given in Chapter :ref:`extensionsofgallina`. How to customize the syntax -is described in Chapter :ref:`syntaxextensionsandnotationscopes`. - -.. insertprodn term field_def - -.. prodn:: - term ::= forall @open_binders , @term - | fun @open_binders => @term - | @term_let - | if @term {? {? as @name } return @term100 } then @term else @term - | @term_fix - | @term_cofix - | @term100 - term100 ::= @term_cast - | @term10 - term10 ::= @term1 {+ @arg } - | @ @qualid {? @univ_annot } {* @term1 } - | @term1 - arg ::= ( @ident := @term ) - | @term1 - one_term ::= @term1 - | @ @qualid {? @univ_annot } - term1 ::= @term_projection - | @term0 % @scope_key - | @term0 - term0 ::= @qualid {? @univ_annot } - | @sort - | @numeral - | @string - | _ - | @term_evar - | @term_match - | ( @term ) - | %{%| {* @field_def } %|%} - | `%{ @term %} - | `( @term ) - | ltac : ( @ltac_expr ) - field_def ::= @qualid {* @binder } := @term - -.. note:: - - Many commands and tactics use :n:`@one_term` rather than :n:`@term`. - The former need to be enclosed in parentheses unless they're very - simple, such as a single identifier. This avoids confusing a space-separated - list of terms with a :n:`@term1` applied to a list of arguments. - -.. _types: - -Types ------ - -.. prodn:: - type ::= @term - -:n:`@type`\s are a subset of :n:`@term`\s; not every :n:`@term` is a :n:`@type`. -Every term has an associated type, which -can be determined by applying the :ref:`typing-rules`. Distinct terms -may share the same type, for example 0 and 1 are both of type `nat`, the -natural numbers. - .. _gallina-identifiers: Qualified identifiers and simple identifiers @@ -223,9 +39,15 @@ Field identifiers, written :n:`@field_ident`, are identifiers prefixed by 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:`syntaxextensionsandnotationscopes` for details). +(see Chapter :ref:`syntax-extensions-and-notation-scopes` for details). Initially, numerals are bound to Peano’s representation of natural numbers (see :ref:`datatypes`). @@ -352,6 +174,12 @@ Section :ref:`let-in`). 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 @@ -373,6 +201,14 @@ 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 @@ -634,34 +470,6 @@ co-recursion. It is the local counterpart of the :cmd:`CoFixpoint` command. When The Vernacular ============== -.. insertprodn vernacular sentence - -.. prodn:: - vernacular ::= {* @sentence } - sentence ::= {? @all_attrs } @command . - | {? @all_attrs } {? @num : } @query_command . - | {? @all_attrs } {? @toplevel_selector } @ltac_expr {| . | ... } - | @control_command - -The top-level input to |Coq| is a series of :n:`@sentence`\s, -which are :production:`tactic`\s or :production:`command`\s, -generally terminated with a period -and optionally decorated with :ref:`gallina-attributes`. :n:`@ltac_expr` syntax supports both simple -and compound tactics. For example: ``split`` is a simple tactic while ``split; auto`` combines two -simple tactics. - -Tactics specify how to transform the current proof state as a step in creating a proof. They -are syntactically valid only when |Coq| is in proof mode, such as after a :cmd:`Theorem` command -and before any subsequent proof-terminating command such as :cmd:`Qed`. See :ref:`proofhandling` for more -on proof mode. - -By convention, command names begin with uppercase letters, while -tactic names begin with lowercase letters. Commands appear in the -HTML documentation in blue boxes after the label "Command". In the pdf, they appear -after the boldface label "Command:". Commands are listed in the :ref:`command_index`. - -Similarly, tactics appear after the label "Tactic". Tactics are listed in the :ref:`tactic_index`. - .. _gallina-assumptions: Assumptions @@ -697,7 +505,7 @@ has type :n:`@type`. 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` attribute (see :ref:`gallina-attributes`), + 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. @@ -764,7 +572,7 @@ Section :ref:`typing-rules`. | {* @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` attribute (see :ref:`gallina-attributes`), + 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 @@ -1639,82 +1447,6 @@ the proof and adds it to the environment. #. 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. -.. _gallina-attributes: - -Attributes ------------ - -.. insertprodn all_attrs legacy_attr - -.. prodn:: - all_attrs ::= {* #[ {*, @attr } ] } {* @legacy_attr } - attr ::= @ident {? @attr_value } - attr_value ::= = @string - | ( {*, @attr } ) - legacy_attr ::= {| Local | Global } - | {| Polymorphic | Monomorphic } - | {| Cumulative | NonCumulative } - | Private - | Program - -Attributes modify the behavior of a command or tactic. -Syntactically, most commands and tactics can be decorated with attributes, but -attributes not supported by the command or tactic will be flagged as errors. - -The order of top-level attributes doesn't affect their meaning. ``#[foo,bar]``, ``#[bar,foo]``, -``#[foo]#[bar]`` and ``#[bar]#[foo]`` are equivalent. - -The legacy attributes (:n:`@legacy_attr`) provide an older, alternate syntax -for certain attributes. They are equivalent to new attributes as follows: - -================ ================================ -Legacy attribute New attribute -================ ================================ -`Local` :attr:`local` -`Global` :attr:`global` -`Polymorphic` :attr:`universes(polymorphic)` -`Monomorphic` :attr:`universes(monomorphic)` -`Cumulative` :attr:`universes(cumulative)` -`NonCumulative` :attr:`universes(noncumulative)` -`Private` :attr:`private(matching)` -`Program` :attr:`program` -================ ================================ - -.. attr:: deprecated ( {? since = @string , } {? note = @string } ) - :name: deprecated - - At least one of :n:`since` or :n:`note` must be present. If both are present, - either one may appear first and they must be separated by a comma. - - This attribute is supported by the following commands: :cmd:`Ltac`, - :cmd:`Tactic Notation`, :cmd:`Notation`, :cmd:`Infix`. - - It can trigger the following warnings: - - .. warn:: Tactic @qualid is deprecated since @string__since. @string__note. - Tactic Notation @qualid is deprecated since @string__since. @string__note. - Notation @string is deprecated since @string__since. @string__note. - - :n:`@qualid` or :n:`@string` is the notation, :n:`@string__since` is the version number, - :n:`@string__note` is the note (usually explains the replacement). - - .. example:: - - .. coqtop:: all reset warn - - #[deprecated(since="8.9.0", note="Use idtac instead.")] - Ltac foo := idtac. - - Goal True. - Proof. - now foo. - Abort. - -.. warn:: Unsupported attribute - - This warning is an error by default. It is caused by using a - command with some attribute it does not understand. - .. [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/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 4e8a2b0879..42e752841d 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -206,7 +206,7 @@ Displaying Unicode symbols ~~~~~~~~~~~~~~~~~~~~~~~~~~ You just need to define suitable notations as described in the chapter -:ref:`syntaxextensionsandnotationscopes`. For example, to use the +:ref:`syntax-extensions-and-notation-scopes`. For example, to use the mathematical symbols ∀ and ∃, you may define: .. coqtop:: in diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index c1eb1f974c..b184311bef 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -174,6 +174,14 @@ mode but it can also be used in toplevel definitions as shown below. ltac_def : `ident` [`ident` ... `ident`] := `ltac_expr` : `qualid` [`ident` ... `ident`] ::= `ltac_expr` +Tactics in terms +~~~~~~~~~~~~~~~~ + +.. insertprodn term_ltac term_ltac + +.. prodn:: + term_ltac ::= ltac : ( @ltac_expr ) + .. _ltac-semantics: Semantics @@ -1778,16 +1786,22 @@ performance issue. and allow displaying and resetting the profile from tactic scripts for benchmarking purposes. +.. warn:: Ltac Profiler encountered an invalid stack (no \ + self node). This can happen if you reset the profile during \ + tactic execution + + Currently, :tacn:`reset ltac profile` is not very well-supported, + as it clears all profiling information about all tactics, including + ones above the current tactic. As a result, the profiler has + trouble understanding where it is in tactic execution. This mixes + especially poorly with backtracking into multi-success tactics. In + general, non-top-level calls to :tacn:`reset ltac profile` should + be avoided. + You can also pass the ``-profile-ltac`` command line option to ``coqc``, which turns the :flag:`Ltac Profiling` flag on at the beginning of each document, and performs a :cmd:`Show Ltac Profile` at the end. -.. warning:: - - Note that the profiler currently does not handle backtracking into - multi-success tactics, and issues a warning to this effect in many cases - when such backtracking occurs. - Run-time optimization tactic ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 3b5233502d..cf4d432f64 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -90,9 +90,7 @@ list of assertion commands is given in :ref:`Assertions`. The command .. cmd:: Save @ident :name: Save - Forces the name of the original goal to be :token:`ident`. This - command can only be used if the original goal - was opened using the :cmd:`Goal` command. + Forces the name of the original goal to be :token:`ident`. .. cmd:: Admitted @@ -821,7 +819,7 @@ in compacted hypotheses: .. .. image:: ../_static/diffs-coqide-compacted.png - :alt: coqide with Set Diffs on with compacted hyptotheses + :alt: coqide with Set Diffs on with compacted hypotheses Controlling the effect of proof editing commands ------------------------------------------------ diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 28c5359a04..4be18ccda9 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -286,7 +286,7 @@ example, the null and all list function(al)s can be defined as follows: .. coqtop:: all Variable d: Set. - Fixpoint null (s : list d) := + Definition null (s : list d) := if s is nil then true else false. Variable a : d -> bool. Fixpoint all (s : list d) : bool := diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 3d69126b2d..1759264e87 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -56,135 +56,6 @@ Displaying .. todo: "A.B" is permitted but unnecessary for modules/sections. should the command just take an @ident? - -.. _flags-options-tables: - -Flags, Options and Tables ------------------------------ - -Coq has many settings to control its behavior. Setting types include flags, options -and tables: - -* A *flag* has a boolean value, such as :flag:`Asymmetric Patterns`. -* An *option* generally has a numeric or string value, such as :opt:`Firstorder Depth`. -* A *table* contains a set of strings or qualids. -* In addition, some commands provide settings, such as :cmd:`Extraction Language`. - -.. FIXME Convert "Extraction Language" to an option. - -Flags, options and tables are identified by a series of identifiers, each with an initial -capital letter. - -.. cmd:: Set @setting_name {? {| @int | @string } } - :name: Set - - .. insertprodn setting_name setting_name - - .. prodn:: - setting_name ::= {+ @ident } - - If :n:`@setting_name` is a flag, no value may be provided; the flag - is set to on. - If :n:`@setting_name` is an option, a value of the appropriate type - must be provided; the option is set to the specified value. - - This command supports the :attr:`local`, :attr:`global` and :attr:`export` attributes. - They are described :ref:`here <set_unset_scope_qualifiers>`. - - .. warn:: There is no flag or option with this name: "@setting_name". - - This warning message can be raised by :cmd:`Set` and - :cmd:`Unset` when :n:`@setting_name` is unknown. It is a - warning rather than an error because this helps library authors - produce Coq code that is compatible with several Coq versions. - To preserve the same behavior, they may need to set some - compatibility flags or options that did not exist in previous - Coq versions. - -.. cmd:: Unset @setting_name - :name: Unset - - If :n:`@setting_name` is a flag, it is set to off. If :n:`@setting_name` is an option, it is - set to its default value. - - This command supports the :attr:`local`, :attr:`global` and :attr:`export` attributes. - They are described :ref:`here <set_unset_scope_qualifiers>`. - -.. cmd:: Add @setting_name {+ {| @qualid | @string } } - - Adds the specified values to the table :n:`@setting_name`. - -.. cmd:: Remove @setting_name {+ {| @qualid | @string } } - - Removes the specified value from the table :n:`@setting_name`. - -.. cmd:: Test @setting_name {? for {+ {| @qualid | @string } } } - - If :n:`@setting_name` is a flag or option, prints its current value. - If :n:`@setting_name` is a table: if the `for` clause is specified, reports - whether the table contains each specified value, otherise this is equivalent to - :cmd:`Print Table`. The `for` clause is not valid for flags and options. - - .. exn:: There is no flag, option or table with this name: "@setting_name". - - This error message is raised when calling the :cmd:`Test` - command (without the `for` clause), or the :cmd:`Print Table` - command, for an unknown :n:`@setting_name`. - - .. exn:: There is no qualid-valued table with this name: "@setting_name". - There is no string-valued table with this name: "@setting_name". - - These error messages are raised when calling the :cmd:`Add` or - :cmd:`Remove` commands, or the :cmd:`Test` command with the - `for` clause, if :n:`@setting_name` is unknown or does not have - the right type. - -.. cmd:: Print Options - - Prints the current value of all flags and options, and the names of all tables. - -.. cmd:: Print Table @setting_name - - Prints the values in the table :n:`@setting_name`. - -.. cmd:: Print Tables - - A synonym for :cmd:`Print Options`. - -.. _set_unset_scope_qualifiers: - -Locality attributes supported by :cmd:`Set` and :cmd:`Unset` -```````````````````````````````````````````````````````````` - -The :cmd:`Set` and :cmd:`Unset` commands support the :attr:`local`, -:attr:`global` and :attr:`export` locality attributes: - -* no attribute: the original setting is *not* restored at the end of - the current module or section. -* :attr:`local` (an alternative syntax is to use the ``Local`` - prefix): the setting is applied within the current module or - section. The original value of the setting is restored at the end - of the current module or section. -* :attr:`export` (an alternative syntax is to use the ``Export`` - prefix): similar to :attr:`local`, the original value of the setting - is restored at the end of the current module or section. In - addition, if the value is set in a module, then :cmd:`Import`\-ing - the module sets the option or flag. -* :attr:`global` (an alternative syntax is to use the ``Global`` - prefix): the original setting is *not* restored at the end of the - current module or section. In addition, if the value is set in a - file, then :cmd:`Require`\-ing the file sets the option. - -Newly opened modules and sections inherit the current settings. - -.. note:: - - The use of the :attr:`global` attribute with the :cmd:`Set` and - :cmd:`Unset` commands is discouraged. If your goal is to define - project-wide settings, you should rather use the command-line - arguments ``-set`` and ``-unset`` for setting flags and options - (cf. :ref:`command-line-options`). - Query commands -------------- diff --git a/doc/sphinx/std-glossindex.rst b/doc/sphinx/std-glossindex.rst index 3f085ca737..91e9da20fe 100644 --- a/doc/sphinx/std-glossindex.rst +++ b/doc/sphinx/std-glossindex.rst @@ -2,6 +2,8 @@ .. hack to get index in TOC +.. _glossary_index: + -------------- Glossary index -------------- diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 93d2439412..d72409e0d9 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1,4 +1,4 @@ -.. _syntaxextensionsandnotationscopes: +.. _syntax-extensions-and-notation-scopes: Syntax extensions and notation scopes ===================================== @@ -433,9 +433,7 @@ Displaying information about notations [ IDENT "try"; SELF Note that the productions printed by this command are represented in the form used by - |Coq|'s parser (coqpp), which differs from how productions are shown in the documentation. The grammar - described in this documentation is equivalent to the grammar of the |Coq| parser, but has been - heavily edited to improve readability and presentation. + |Coq|'s parser (coqpp), which differs from how productions are shown in the documentation. .. _locating-notations: @@ -1088,12 +1086,17 @@ ways to change the interpretation of subterms are available. Opening a notation scope locally ++++++++++++++++++++++++++++++++ +.. insertprodn term_scope term_scope + +.. prodn:: + term_scope ::= @term0 % @scope_key + The notation scope stack can be locally extended within a :token:`term` with the syntax -:n:`(@term)%@scope_key` (or simply :n:`@term%@scope_key` for atomic terms). +:n:`(@term)%@scope_key` (or simply :n:`@term0%@scope_key` for atomic terms). In this case, :n:`@term` is -interpreted in the scope stack extended with the scope bound to :token:`ident`. +interpreted in the scope stack extended with the scope bound to :n:`@scope_key`. .. cmd:: Delimit Scope @scope_name with @scope_key diff --git a/doc/sphinx/using/libraries/index.rst b/doc/sphinx/using/libraries/index.rst index ad10869439..0bd3054788 100644 --- a/doc/sphinx/using/libraries/index.rst +++ b/doc/sphinx/using/libraries/index.rst @@ -23,3 +23,4 @@ installed with the `opam package manager ../../addendum/extraction ../../addendum/miscellaneous-extensions funind + writing diff --git a/doc/sphinx/using/libraries/writing.rst b/doc/sphinx/using/libraries/writing.rst new file mode 100644 index 0000000000..325ea2af60 --- /dev/null +++ b/doc/sphinx/using/libraries/writing.rst @@ -0,0 +1,71 @@ +Writing Coq libraries and plugins +================================= + +This section presents the part of the Coq language that is useful only +to library and plugin authors. A tutorial for writing Coq plugins is +available in the Coq repository in `doc/plugin_tutorial +<https://github.com/coq/coq/tree/master/doc/plugin_tutorial>`_. + +Deprecating library objects or tactics +-------------------------------------- + +You may use the following :term:`attribute` to deprecate a notation or +tactic. When renaming a definition or theorem, you can introduce a +deprecated compatibility alias using :cmd:`Notation (abbreviation)` +(see :ref:`the example below <compatibility-alias>`). + +.. attr:: deprecated ( {? since = @string , } {? note = @string } ) + :name: deprecated + + At least one of :n:`since` or :n:`note` must be present. If both + are present, either one may appear first and they must be separated + by a comma. + + This attribute is supported by the following commands: :cmd:`Ltac`, + :cmd:`Tactic Notation`, :cmd:`Notation`, :cmd:`Infix`. + + It can trigger the following warnings: + + .. warn:: Tactic @qualid is deprecated since @string__since. @string__note. + Tactic Notation @qualid is deprecated since @string__since. @string__note. + Notation @string is deprecated since @string__since. @string__note. + + :n:`@qualid` or :n:`@string` is the notation, + :n:`@string__since` is the version number, :n:`@string__note` is + the note (usually explains the replacement). + +.. example:: Deprecating a tactic. + + .. coqtop:: all abort warn + + #[deprecated(since="0.9", note="Use idtac instead.")] + Ltac foo := idtac. + Goal True. + Proof. + now foo. + +.. _compatibility-alias: + +.. example:: Introducing a compatibility alias + + Let's say your library initially contained: + + .. coqtop:: in + + Definition foo x := S x. + + and you want to rename `foo` into `bar`, but you want to avoid breaking + your users' code without advanced notice. To do so, replace the previous + code by the following: + + .. coqtop:: in reset + + Definition bar x := S x. + #[deprecated(since="1.2", note="Use bar instead.")] + Notation foo := bar (only parsing). + + Then, the following code still works, but emits a warning: + + .. coqtop:: all warn + + Check (foo 0). diff --git a/doc/stdlib/Library.tex b/doc/stdlib/Library.tex index 44a0b1d361..1a9d4d738f 100644 --- a/doc/stdlib/Library.tex +++ b/doc/stdlib/Library.tex @@ -5,6 +5,7 @@ \usepackage[T1]{fontenc} \usepackage{fullpage} \usepackage{amsfonts} +\usepackage{amssymb} \usepackage{url} \usepackage[color]{../../coqdoc} diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index b2c9c936c9..4a62888552 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -99,6 +99,7 @@ through the <tt>Require Import</tt> command.</p> <dd> theories/Bool/Bool.v theories/Bool/BoolEq.v + theories/Bool/BoolOrder.v theories/Bool/DecBool.v theories/Bool/IfProp.v theories/Bool/Sumbool.v diff --git a/doc/tools/coqrst/coqdoc/main.py b/doc/tools/coqrst/coqdoc/main.py index a3fc069e6c..de0d912c03 100644 --- a/doc/tools/coqrst/coqdoc/main.py +++ b/doc/tools/coqrst/coqdoc/main.py @@ -48,28 +48,22 @@ def coqdoc(coq_code, coqdoc_bin=None): finally: os.remove(filename) -def is_whitespace_string(elem): - return isinstance(elem, NavigableString) and elem.strip() == "" - -def strip_soup(soup, pred): - """Strip elements matching pred from front and tail of soup.""" - while soup.contents and pred(soup.contents[-1]): - soup.contents.pop() - - skip = 0 - for elem in soup.contents: - if not pred(elem): - break - skip += 1 - - soup.contents[:] = soup.contents[skip:] +def first_string_node(node): + """Return the first string node, or None if does not exist""" + while node.children: + node = next(node.children) + if isinstance(node, NavigableString): + return node def lex(source): """Convert source into a stream of (css_classes, token_string).""" coqdoc_output = coqdoc(source) soup = BeautifulSoup(coqdoc_output, "html.parser") root = soup.find(class_='code') - strip_soup(root, is_whitespace_string) + # strip the leading '\n' + first = first_string_node(root) + if first and first.string[0] == '\n': + first.string.replace_with(first.string[1:]) for elem in root.children: if isinstance(elem, NavigableString): yield [], elem diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 9d51d2198a..df11960403 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -905,9 +905,13 @@ class CoqtopBlocksTransform(Transform): return isinstance(node, nodes.Element) and 'coqtop_options' in node @staticmethod - def split_sentences(source): - """Split Coq sentences in source. Could be improved.""" - return re.split(r"(?<=(?<!\.)\.)\s+", source) + def split_lines(source): + """Split Coq input in chunks + + A chunk is a minimal sequence of consecutive lines of the input that + ends with a '.' + """ + return re.split(r"(?<=(?<!\.)\.)\s+\n", source) @staticmethod def parse_options(node): @@ -986,7 +990,7 @@ class CoqtopBlocksTransform(Transform): repl.sendone('Unset Coqtop Exit On Error.') if options['warn']: repl.sendone('Set Warnings "default".') - for sentence in self.split_sentences(node.rawsource): + for sentence in self.split_lines(node.rawsource): pairs.append((sentence, repl.sendone(sentence))) if options['abort']: repl.sendone('Abort All.') diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 6111eaa160..c7e3ee18ad 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -179,7 +179,10 @@ case_item: [ ] binder_constr: [ +| MOVETO term_forall_or_fun "forall" open_binders "," operconstr200 +| MOVETO term_forall_or_fun "fun" open_binders "=>" operconstr200 | MOVETO term_let "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 +| MOVETO term_if "if" operconstr200 as_return_type "then" operconstr200 "else" operconstr200 | MOVETO term_fix "let" "fix" fix_decl "in" operconstr200 | MOVETO term_cofix "let" "cofix" cofix_decl "in" operconstr200 | MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" operconstr200 "in" operconstr200 @@ -203,8 +206,10 @@ term_let: [ ] atomic_constr: [ -(* @Zimmi48: "string" used only for notations, but keep to be consistent with patterns *) -(* | DELETE string *) +| MOVETO qualid_annotated global univ_instance +| MOVETO primitive_notations NUMERAL +| MOVETO primitive_notations string +| MOVETO term_evar "_" | REPLACE "?" "[" ident "]" | WITH "?[" ident "]" | MOVETO term_evar "?[" ident "]" @@ -243,7 +248,21 @@ operconstr100: [ | MOVETO term_cast operconstr99 ":>" ] +constr: [ +| REPLACE "@" global univ_instance +| WITH "@" qualid_annotated +| MOVETO term_explicit "@" qualid_annotated +] + operconstr10: [ +(* Separate this LIST0 in the nonempty and the empty case *) +(* The empty case is covered by constr *) +| REPLACE "@" global univ_instance LIST0 operconstr9 +| WITH "@" qualid_annotated LIST1 operconstr9 +| REPLACE operconstr9 +| WITH constr +| MOVETO term_application operconstr9 LIST1 appl_arg +| MOVETO term_application "@" qualid_annotated LIST1 operconstr9 (* fixme: add in as a prodn somewhere *) | MOVETO dangling_pattern_extension_rule "@" pattern_identref LIST1 identref | DELETE dangling_pattern_extension_rule @@ -259,6 +278,7 @@ operconstr1: [ | WITH operconstr0 ".(" global LIST0 appl_arg ")" (* huh? *) | REPLACE operconstr0 "%" IDENT | WITH operconstr0 "%" scope_key +| MOVETO term_scope operconstr0 "%" scope_key | MOVETO term_projection operconstr0 ".(" global LIST0 appl_arg ")" | MOVETO term_projection operconstr0 ".(" "@" global LIST0 ( operconstr9 ) ")" ] @@ -268,6 +288,10 @@ operconstr0: [ | DELETE "{" binder_constr "}" | REPLACE "{|" record_declaration bar_cbrace | WITH "{|" LIST0 field_def bar_cbrace +| MOVETO term_record "{|" LIST0 field_def bar_cbrace +| MOVETO term_generalizing "`{" operconstr200 "}" +| MOVETO term_generalizing "`(" operconstr200 ")" +| MOVETO term_ltac "ltac" ":" "(" tactic_expr5 ")" ] fix_decls: [ @@ -1132,7 +1156,7 @@ assumption_token: [ | WITH [ "Variable" | "Variables" ] ] -all_attrs: [ +attributes: [ | LIST0 ( "#[" LIST0 attribute SEP "," "]" ) LIST0 legacy_attr ] @@ -1696,7 +1720,6 @@ RENAME: [ | univ_instance univ_annot | simple_assum_coe assumpt | of_type_with_opt_coercion of_type -| attribute attr | attribute_value attr_value | constructor_list_or_record_decl constructors_or_record | record_binder_body field_body @@ -1807,12 +1830,12 @@ control_command: [ ] query_command: [ ] (* re-add since previously spliced *) sentence: [ -| OPT all_attrs command "." -| OPT all_attrs OPT ( num ":" ) query_command "." -| OPT all_attrs OPT toplevel_selector ltac_expr [ "." | "..." ] +| OPT attributes command "." +| OPT attributes OPT ( num ":" ) query_command "." +| OPT attributes OPT toplevel_selector ltac_expr [ "." | "..." ] | control_command ] -vernacular: [ +document: [ | LIST0 sentence ] diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 98f826cd29..6d4c33f7be 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -50,7 +50,7 @@ let default_args = { verify = false; } -let start_symbols = ["vernacular"] +let start_symbols = ["document"] let tokens = [ "bullet"; "string"; "unicode_id_part"; "unicode_letter" ] (* translated symbols *) diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 2a30c03dd2..df4e5a22e3 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -15,10 +15,9 @@ ltac_use_default: [ ] term: [ -| "forall" open_binders "," term -| "fun" open_binders "=>" term +| term_forall_or_fun | term_let -| "if" term OPT [ OPT [ "as" name ] "return" term100 ] "then" term "else" term +| term_if | term_fix | term_cofix | term100 @@ -30,44 +29,39 @@ term100: [ ] term10: [ -| term1 LIST1 arg -| "@" qualid OPT univ_annot LIST0 term1 -| term1 -] - -arg: [ -| "(" ident ":=" term ")" -| term1 +| term_application +| one_term ] one_term: [ +| term_explicit | term1 -| "@" qualid OPT univ_annot ] term1: [ | term_projection -| term0 "%" scope_key +| term_scope | term0 ] term0: [ -| qualid OPT univ_annot +| qualid_annotated | sort -| numeral -| string -| "_" +| primitive_notations | term_evar | term_match +| term_record +| term_generalizing +| term_ltac | "(" term ")" -| "{|" LIST0 field_def "|}" -| "`{" term "}" -| "`(" term ")" -| "ltac" ":" "(" ltac_expr ")" ] -field_def: [ -| qualid LIST0 binder ":=" term +qualid_annotated: [ +| qualid OPT univ_annot +] + +term_ltac: [ +| "ltac" ":" "(" ltac_expr ")" ] term_projection: [ @@ -75,7 +69,12 @@ term_projection: [ | term0 ".(" "@" qualid LIST0 ( term1 ) ")" ] +term_scope: [ +| term0 "%" scope_key +] + term_evar: [ +| "_" | "?[" ident "]" | "?[" "?" ident "]" | "?" ident OPT ( "@{" LIST1 ( ident ":=" term ) SEP ";" "}" ) @@ -85,6 +84,25 @@ dangling_pattern_extension_rule: [ | "@" "?" ident LIST1 ident ] +term_application: [ +| term1 LIST1 arg +| "@" qualid_annotated LIST1 term1 +] + +arg: [ +| "(" ident ":=" term ")" +| term1 +] + +term_explicit: [ +| "@" qualid_annotated +] + +primitive_notations: [ +| numeral +| string +] + assumption_token: [ | [ "Axiom" | "Axioms" ] | [ "Conjecture" | "Conjectures" ] @@ -158,14 +176,14 @@ where: [ | "before" ident ] -vernacular: [ +document: [ | LIST0 sentence ] sentence: [ -| OPT all_attrs command "." -| OPT all_attrs OPT ( num ":" ) query_command "." -| OPT all_attrs OPT toplevel_selector ltac_expr [ "." | "..." ] +| OPT attributes command "." +| OPT attributes OPT ( num ":" ) query_command "." +| OPT attributes OPT toplevel_selector ltac_expr [ "." | "..." ] | control_command ] @@ -178,17 +196,17 @@ query_command: [ tacticals: [ ] -all_attrs: [ -| LIST0 ( "#[" LIST0 attr SEP "," "]" ) LIST0 legacy_attr +attributes: [ +| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) LIST0 legacy_attr ] -attr: [ +attribute: [ | ident OPT attr_value ] attr_value: [ | "=" string -| "(" LIST0 attr SEP "," ")" +| "(" LIST0 attribute SEP "," ")" ] legacy_attr: [ @@ -267,6 +285,10 @@ cofix_body: [ | ident LIST0 binder OPT ( ":" type ) ":=" term ] +term_if: [ +| "if" term OPT [ OPT [ "as" name ] "return" term100 ] "then" term "else" term +] + term_let: [ | "let" name OPT ( ":" type ) ":=" term "in" term | "let" name LIST1 binder OPT ( ":" type ) ":=" term "in" term @@ -275,6 +297,11 @@ term_let: [ | "let" "'" pattern "in" pattern ":=" term "return" term100 "in" term ] +term_forall_or_fun: [ +| "forall" open_binders "," term +| "fun" open_binders "=>" term +] + open_binders: [ | LIST1 name ":" term | LIST1 binder @@ -312,6 +339,11 @@ typeclass_constraint: [ | name ":" OPT "!" term ] +term_generalizing: [ +| "`{" term "}" +| "`(" term ")" +] + term_cast: [ | term10 "<:" term | term10 "<<:" term @@ -467,7 +499,7 @@ record_definition: [ ] record_field: [ -| LIST0 ( "#[" LIST0 attr SEP "," "]" ) name OPT field_body OPT [ "|" num ] OPT decl_notations +| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) name OPT field_body OPT [ "|" num ] OPT decl_notations ] field_body: [ @@ -476,6 +508,14 @@ field_body: [ | LIST0 binder ":=" term ] +term_record: [ +| "{|" LIST0 field_def "|}" +] + +field_def: [ +| qualid LIST0 binder ":=" term +] + inductive_definition: [ | OPT ">" ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations ] diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml index dcb71d96a1..cc24e71386 100644 --- a/ide/wg_Completion.ml +++ b/ide/wg_Completion.ml @@ -69,7 +69,7 @@ let is_substring s1 s2 = if !break then len2 - len1 else -1 -class completion_provider coqtop = +class completion_provider buffer coqtop = let self_provider = ref None in let active = ref true in let provider = object (self) @@ -97,9 +97,13 @@ class completion_provider coqtop = ctx#add_proposals (Option.get !self_provider) props true method populate ctx = - let iter = ctx#iter in + let iter = buffer#get_iter_at_mark `INSERT in + let () = insert_offset <- iter#offset in + let () = Minilib.log (Printf.sprintf "Completion at offset: %i" insert_offset) in let buffer = new GText.buffer iter#buffer in + if not (Gtk_parsing.ends_word iter#backward_char) then self#add_proposals ctx Proposals.empty else let start = Gtk_parsing.find_word_start iter in + if iter#offset - start#offset < auto_complete_length then self#add_proposals ctx Proposals.empty else let w = start#get_text ~stop:iter in let () = Minilib.log ("Completion of prefix: '" ^ w ^ "'") in let (off, prefix, props) = cache in @@ -127,17 +131,7 @@ class completion_provider coqtop = let occupied () = update synt in Coq.try_grab coqtop query occupied - method matched ctx = - if !active then - let iter = ctx#iter in - let () = insert_offset <- iter#offset in - let log = Printf.sprintf "Completion at offset: %i" insert_offset in - let () = Minilib.log log in - if Gtk_parsing.ends_word iter#backward_char then - let start = Gtk_parsing.find_word_start iter in - iter#offset - start#offset >= auto_complete_length - else false - else false + method matched ctx = !active method activation = [`INTERACTIVE; `USER_REQUESTED] diff --git a/ide/wg_Completion.mli b/ide/wg_Completion.mli index 93c4cbb602..8bb34fbbca 100644 --- a/ide/wg_Completion.mli +++ b/ide/wg_Completion.mli @@ -10,7 +10,7 @@ module Proposals : sig type t end -class completion_provider : Coq.coqtop -> +class completion_provider : GText.buffer -> Coq.coqtop -> object inherit GSourceView3.source_completion_provider method active : bool diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index f2d9f33d7d..62d58a5f23 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -287,7 +287,7 @@ end class script_view (tv : source_view) (ct : Coq.coqtop) = let view = new GSourceView3.source_view (Gobject.unsafe_cast tv) in -let provider = new Wg_Completion.completion_provider ct in +let provider = new Wg_Completion.completion_provider view#buffer ct in object (self) inherit GSourceView3.source_view (Gobject.unsafe_cast tv) diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index 3fa376a037..c4036e9677 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -52,6 +52,51 @@ type t = | Float64next_up | Float64next_down +let parse = function + | "int63_head0" -> Int63head0 + | "int63_tail0" -> Int63tail0 + | "int63_add" -> Int63add + | "int63_sub" -> Int63sub + | "int63_mul" -> Int63mul + | "int63_div" -> Int63div + | "int63_mod" -> Int63mod + | "int63_lsr" -> Int63lsr + | "int63_lsl" -> Int63lsl + | "int63_land" -> Int63land + | "int63_lor" -> Int63lor + | "int63_lxor" -> Int63lxor + | "int63_addc" -> Int63addc + | "int63_subc" -> Int63subc + | "int63_addcarryc" -> Int63addCarryC + | "int63_subcarryc" -> Int63subCarryC + | "int63_mulc" -> Int63mulc + | "int63_diveucl" -> Int63diveucl + | "int63_div21" -> Int63div21 + | "int63_addmuldiv" -> Int63addMulDiv + | "int63_eq" -> Int63eq + | "int63_lt" -> Int63lt + | "int63_le" -> Int63le + | "int63_compare" -> Int63compare + | "float64_opp" -> Float64opp + | "float64_abs" -> Float64abs + | "float64_eq" -> Float64eq + | "float64_lt" -> Float64lt + | "float64_le" -> Float64le + | "float64_compare" -> Float64compare + | "float64_classify" -> Float64classify + | "float64_add" -> Float64add + | "float64_sub" -> Float64sub + | "float64_mul" -> Float64mul + | "float64_div" -> Float64div + | "float64_sqrt" -> Float64sqrt + | "float64_of_int63" -> Float64ofInt63 + | "float64_normfr_mantissa" -> Float64normfr_mantissa + | "float64_frshiftexp" -> Float64frshiftexp + | "float64_ldshiftexp" -> Float64ldshiftexp + | "float64_next_up" -> Float64next_up + | "float64_next_down" -> Float64next_down + | _ -> raise Not_found + let equal (p1 : t) (p2 : t) = p1 == p2 @@ -229,3 +274,17 @@ let prim_type_to_string = function let op_or_type_to_string = function | OT_op op -> to_string op | OT_type t -> prim_type_to_string t + +let prim_type_of_string = function + | "int63_type" -> PT_int63 + | "float64_type" -> PT_float64 + | _ -> raise Not_found + +let op_or_type_of_string s = + try OT_type (prim_type_of_string s) + with Not_found -> OT_op (parse s) + +let parse_op_or_type ?loc s = + try op_or_type_of_string s + with Not_found -> + CErrors.user_err ?loc Pp.(str ("Built-in #"^s^" does not exist.")) diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index 2a0399f1f7..a5db51111f 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -52,6 +52,10 @@ type t = | Float64next_up | Float64next_down +(** Can raise [Not_found]. + Beware that this is not exactly the reverse of [to_string] below. *) +val parse : string -> t + val equal : t -> t -> bool type arg_kind = @@ -75,6 +79,10 @@ type prim_type = | PT_int63 | PT_float64 +(** Can raise [Not_found] *) +val prim_type_of_string : string -> prim_type +val prim_type_to_string : prim_type -> string + type 'a prim_ind = | PIT_bool : unit prim_ind | PIT_carry : prim_type prim_ind @@ -90,8 +98,13 @@ type op_or_type = | OT_type of prim_type val prim_ind_to_string : 'a prim_ind -> string + +(** Can raise [Not_found] *) +val op_or_type_of_string : string -> op_or_type val op_or_type_to_string : op_or_type -> string +val parse_op_or_type : ?loc:Loc.t -> string -> op_or_type + type ind_or_type = | PITT_ind : 'a prim_ind * 'a -> ind_or_type | PITT_type : prim_type -> ind_or_type diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 020ab9307d..52c6c5d0f9 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -164,14 +164,17 @@ module Btauto = struct let reify env t = lapp eval [|convert_env env; convert t|] - let print_counterexample p penv gl = + let print_counterexample p penv = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let var = lapp witness [|p|] in let var = EConstr.of_constr var in (* Compute an assignment that dissatisfies the goal *) - let redfun, _ = Redexpr.reduction_of_red_expr (Refiner.pf_env gl) Genredexpr.(CbvVm None) in - let _, var = redfun Refiner.(pf_env gl) Refiner.(project gl) var in + let redfun, _ = Redexpr.reduction_of_red_expr env Genredexpr.(CbvVm None) in + let _, var = redfun env sigma var in let var = EConstr.Unsafe.to_constr var in - let rec to_list l = match decomp_term (Tacmach.project gl) l with + let rec to_list l = match decomp_term sigma l with | App (c, _) when c === (Lazy.force CoqList._nil) -> [] | App (c, [|_; h; t|]) @@ -196,7 +199,6 @@ module Btauto = struct let assign = List.combine penv var in let map_msg (key, v) = let b = if v then str "true" else str "false" in - let sigma, env = Tacmach.project gl, Tacmach.pf_env gl in let term = Printer.pr_constr_env env sigma key in term ++ spc () ++ str ":=" ++ spc () ++ b in @@ -205,7 +207,8 @@ module Btauto = struct str "Not a tautology:" ++ spc () ++ l with e when CErrors.noncritical e -> (str "Not a tautology") in - Tacticals.tclFAIL 0 msg gl + Tacticals.New.tclFAIL 0 msg + end let try_unification env = Proofview.Goal.enter begin fun gl -> @@ -216,7 +219,7 @@ module Btauto = struct match t with | App (c, [|typ; p; _|]) when c === eq -> (* should be an equality [@eq poly ?p (Cst false)] *) - let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (Proofview.V82.tactic (print_counterexample p env)) in + let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (print_counterexample p env) in tac | _ -> let msg = str "Btauto: Internal error" in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 7b2ce671a3..f4200854c2 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -41,7 +41,10 @@ let observe_tac s = observe_tac (fun _ _ -> Pp.str s) let finish_proof dynamic_infos g = observe_tac "finish" (Proofview.V82.of_tactic assumption) g -let refine c = Refiner.refiner ~check:true EConstr.Unsafe.(to_constr c) +let refine c = + Proofview.V82.of_tactic + (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr c)) + let thin l = Proofview.V82.of_tactic (Tactics.clear l) let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 55e659d487..c53dcc7edd 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -159,7 +159,7 @@ let recompute_binder_list fixpoint_exprl = fixpoint_exprl in let (_, _, _, typel), _, ctx, _ = - ComFixpoint.interp_fixpoint ~cofix:false fixl + ComFixpoint.interp_fixpoint ~check_recursivity:false ~cofix:false fixl in let constr_expr_typel = with_full_print @@ -191,61 +191,35 @@ let prepare_body {Vernacexpr.binders} rt = let fun_args, rt' = chop_rlambda_n n rt in (fun_args, rt') -let build_functional_principle ?(opaque = Declare.Transparent) - (evd : Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = +let build_functional_principle (sigma : Evd.evar_map) old_princ_type sorts funs + _i proof_tac hook = (* First we get the type of the old graph principle *) let mutr_nparams = - (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)) + (Tactics.compute_elim_sig sigma (EConstr.of_constr old_princ_type)) .Tactics.nparams in - (* let time1 = System.get_time () in *) let new_principle_type = Functional_principles_types.compute_new_princ_type_from_rel (Array.map Constr.mkConstU funs) sorts old_princ_type in - (* let time2 = System.get_time () in *) - (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) - let new_princ_name = - Namegen.next_ident_away_in_goal - (Id.of_string "___________princ_________") - Id.Set.empty - in let sigma, _ = - Typing.type_of ~refresh:true (Global.env ()) !evd - (EConstr.of_constr new_principle_type) - in - evd := sigma; - let hook = DeclareDef.Hook.make (hook new_principle_type) in - let lemma = - Lemmas.start_lemma ~name:new_princ_name ~poly:false !evd + Typing.type_of ~refresh:true (Global.env ()) sigma (EConstr.of_constr new_principle_type) in - (* let _tim1 = System.get_time () in *) let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let lemma, _ = - Lemmas.by - (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) - lemma + let ftac = + Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams) in - (* let _tim2 = System.get_time () in *) - (* begin *) - (* let dur1 = System.time_difference tim1 tim2 in *) - (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) - (* end; *) - let {Declare.entries} = - Lemmas.pf_fold - (Declare.close_proof ~opaque ~keep_body_ucst_separate:false) - lemma + let env = Global.env () in + let uctx = Evd.evar_universe_context sigma in + let typ = EConstr.of_constr new_principle_type in + let body, typ, univs, _safe, _uctx = + Declare.build_by_tactic env ~uctx ~poly:false ~typ ftac in - match entries with - | [entry] -> (entry, hook) - | _ -> - CErrors.anomaly - Pp.( - str - "[build_functional_principle] close_proof returned more than one \ - proof term") + (* uctx was ignored before *) + let hook = DeclareDef.Hook.make (hook new_principle_type) in + (body, typ, univs, hook, sigma) let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in @@ -333,14 +307,16 @@ let generate_functional_principle (evd : Evd.evar_map ref) old_princ_type sorts register_with_sort Sorts.InProp; register_with_sort Sorts.InSet ) in - let entry, hook = - build_functional_principle evd old_princ_type new_sorts funs i proof_tac + let body, types, univs, hook, sigma0 = + build_functional_principle !evd old_princ_type new_sorts funs i proof_tac hook in + evd := sigma0; (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in + let entry = Declare.definition_entry ~univs ?types body in let (_ : Names.GlobRef.t) = DeclareDef.declare_entry ~name:new_princ_name ~hook ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) @@ -1334,8 +1310,7 @@ let get_funs_constant mp = in l_const -let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : - Evd.side_effects Declare.proof_entry list = +let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : _ list = let exception Found_type of int in let env = Global.env () in let funs = List.map fst fas in @@ -1402,18 +1377,19 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : if Declareops.is_opaque (Global.lookup_constant equation) then Opaque else Transparent in - let entry, _hook = + let body, typ, univs, _hook, sigma0 = try - build_functional_principle ~opaque evd first_type (Array.of_list sorts) + build_functional_principle !evd first_type (Array.of_list sorts) this_block_funs 0 (Functional_principles_proofs.prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) (fun _ _ -> ()) with e when CErrors.noncritical e -> raise (Defining_principle e) in + evd := sigma0; incr i; (* The others are just deduced *) - if List.is_empty other_princ_types then [entry] + if List.is_empty other_princ_types then [(body, typ, univs, opaque)] else let other_fun_princ_types = let funs = Array.map Constr.mkConstU this_block_funs in @@ -1422,10 +1398,8 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types in - let first_princ_body = entry.Declare.proof_entry_body in - let ctxt, fix = - Term.decompose_lam_assum (fst (fst (Future.force first_princ_body))) - in + let first_princ_body = body in + let ctxt, fix = Term.decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*) let (idxs, _), ((_, ta, _) as decl) = Constr.destFix fix in let other_result = @@ -1457,8 +1431,8 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) - let entry, _hook = - build_functional_principle evd + let body, typ, univs, _hook, sigma0 = + build_functional_principle !evd (List.nth other_princ_types (!i - 1)) (Array.of_list sorts) this_block_funs !i (Functional_principles_proofs.prove_princ_for_struct evd false @@ -1466,15 +1440,16 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : (Array.of_list (List.map fst funs))) (fun _ _ -> ()) in - entry + evd := sigma0; + (body, typ, univs, opaque) with Found_type i -> let princ_body = Termops.it_mkLambda_or_LetIn (Constr.mkFix ((idxs, i), decl)) ctxt in - Declare.definition_entry ~types:scheme_type princ_body) + (princ_body, Some scheme_type, univs, opaque)) other_fun_princ_types in - entry :: other_result + (body, typ, univs, opaque) :: other_result (* [derive_correctness funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] @@ -1527,11 +1502,8 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) with Not_found -> Array.of_list (List.map - (fun entry -> - ( EConstr.of_constr - (fst (fst (Future.force entry.Declare.proof_entry_body))) - , EConstr.of_constr (Option.get entry.Declare.proof_entry_type) - )) + (fun (body, typ, _opaque, _univs) -> + (EConstr.of_constr body, EConstr.of_constr (Option.get typ))) (make_scheme evd (Array.map_to_list (fun const -> (const, Sorts.InType)) funs))) in @@ -2225,11 +2197,14 @@ let build_scheme fas = in let bodies_types = make_scheme evd pconstants in List.iter2 - (fun (princ_id, _, _) def_entry -> - ignore - (Declare.declare_constant ~name:princ_id - ~kind:Decls.(IsProof Theorem) - (Declare.DefinitionEntry def_entry)); + (fun (princ_id, _, _) (body, types, univs, opaque) -> + let (_ : Constant.t) = + let opaque = if opaque = Declare.Opaque then true else false in + let def_entry = Declare.definition_entry ~univs ~opaque ?types body in + Declare.declare_constant ~name:princ_id + ~kind:Decls.(IsProof Theorem) + (Declare.DefinitionEntry def_entry) + in Declare.definition_message princ_id) fas bodies_types diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 14fab251d0..0dbf16a821 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -25,27 +25,20 @@ let is_profiling = Flags.profile_ltac let set_profiling b = is_profiling := b let get_profiling () = !is_profiling -(** LtacProf cannot yet handle backtracking into multi-success tactics. - To properly support this, we'd have to somehow recreate our location in the - call-stack, and stop/restart the intervening timers. This is tricky and - possibly expensive, so instead we currently just emit a warning that - profiling results will be off. *) -let encountered_multi_success_backtracking = ref false - -let warn_profile_backtracking = - CWarnings.create ~name:"profile-backtracking" ~category:"ltac" - (fun () -> strbrk "Ltac Profiler cannot yet handle backtracking \ - into multi-success tactics; profiling results may be wildly inaccurate.") - -let warn_encountered_multi_success_backtracking () = - if !encountered_multi_success_backtracking then - warn_profile_backtracking () - -let encounter_multi_success_backtracking () = - if not !encountered_multi_success_backtracking +let encountered_invalid_stack_no_self = ref false + +let warn_invalid_stack_no_self = + CWarnings.create ~name:"profile-invalid-stack-no-self" ~category:"ltac" + (fun () -> strbrk + "Ltac Profiler encountered an invalid stack (no self \ + node). This can happen if you reset the profile during \ + tactic execution.") + +let encounter_invalid_stack_no_self () = + if not !encountered_invalid_stack_no_self then begin - encountered_multi_success_backtracking := true; - warn_encountered_multi_success_backtracking () + encountered_invalid_stack_no_self := true; + warn_invalid_stack_no_self () end @@ -76,8 +69,7 @@ module Local = Summary.Local let stack = Local.ref ~name:"LtacProf-stack" [empty_treenode root] let reset_profile_tmp () = - Local.(stack := [empty_treenode root]); - encountered_multi_success_backtracking := false + Local.(stack := [empty_treenode root]) (* ************** XML Serialization ********************* *) @@ -218,7 +210,6 @@ let to_string ~filter ?(cutoff=0.0) node = cumulate tree; !global in - warn_encountered_multi_success_backtracking (); let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in let msg = h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ @@ -296,13 +287,15 @@ let exit_tactic ~count_call start_time c = match Local.(!stack) with | [] | [_] -> (* oops, our stack is invalid *) - encounter_multi_success_backtracking (); + encounter_invalid_stack_no_self (); reset_profile_tmp () | node :: (parent :: rest as full_stack) -> let name = string_of_call c in if not (String.equal name node.name) then (* oops, our stack is invalid *) - encounter_multi_success_backtracking (); + CErrors.anomaly + (Pp.strbrk "Ltac Profiler encountered an invalid stack (wrong self node) \ + likely due to backtracking into multi-success tactics."); let node = { node with total = node.total +. diff; local = node.local +. diff; @@ -332,38 +325,56 @@ let exit_tactic ~count_call start_time c = (* Calls are over, we reset the stack and send back data *) if rest == [] && get_profiling () then begin assert(String.equal root parent.name); + encountered_invalid_stack_no_self := false; reset_profile_tmp (); feedback_results parent end -let tclFINALLY tac (finally : unit Proofview.tactic) = +(** [tclWRAPFINALLY before tac finally] runs [before] before each + entry-point of [tac] and passes the result of [before] to + [finally], which is then run at each exit-point of [tac], + regardless of whether it succeeds or fails. Said another way, if + [tac] succeeds, then it behaves as [before >>= fun v -> tac >>= fun + ret -> finally v <*> tclUNIT ret]; otherwise, if [tac] fails with + [e], it behaves as [before >>= fun v -> finally v <*> tclZERO + e]. *) +let rec tclWRAPFINALLY before tac finally = + let open Proofview in let open Proofview.Notations in - Proofview.tclIFCATCH - tac - (fun v -> finally <*> Proofview.tclUNIT v) - (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) + before >>= fun v -> tclCASE tac >>= function + | Fail (e, info) -> finally v >>= fun () -> tclZERO ~info e + | Next (ret, tac') -> tclOR + (finally v >>= fun () -> tclUNIT ret) + (fun e -> tclWRAPFINALLY before (tac' e) finally) let do_profile s call_trace ?(count_call=true) tac = let open Proofview.Notations in - Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> - if !is_profiling then - match call_trace, Local.(!stack) with - | (_, c) :: _, parent :: rest -> - let name = string_of_call c in - let node = get_child name parent in - Local.(stack := node :: parent :: rest); - Some (time ()) - | _ :: _, [] -> assert false - | _ -> None - else None)) >>= function - | Some start_time -> - tclFINALLY - tac + (* We do an early check to [is_profiling] so that we save the + overhead of [tclWRAPFINALLY] when profiling is not set + *) + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> !is_profiling)) >>= function + | false -> tac + | true -> + tclWRAPFINALLY (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> - (match call_trace with - | (_, c) :: _ -> exit_tactic ~count_call start_time c - | [] -> ())))) - | None -> tac + if !is_profiling then + match call_trace, Local.(!stack) with + | (_, c) :: _, parent :: rest -> + let name = string_of_call c in + let node = get_child name parent in + Local.(stack := node :: parent :: rest); + Some (time ()) + | _ :: _, [] -> assert false + | _ -> None + else None))) + tac + (function + | Some start_time -> + (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + (match call_trace with + | (_, c) :: _ -> exit_tactic ~count_call start_time c + | [] -> ())))) + | None -> Proofview.tclUNIT ()) (* ************** Accumulation of data from workers ************************* *) @@ -396,6 +407,7 @@ let _ = | _ -> ())) let reset_profile () = + encountered_invalid_stack_no_self := false; reset_profile_tmp (); data := SM.empty diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 7e4c4ce5c6..ee2c87d19a 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -128,249 +128,142 @@ let selecti s m = *) module M = struct (** - * Location of the Coq libraries. - *) - - let logic_dir = ["Coq"; "Logic"; "Decidable"] - - let mic_modules = - [ ["Coq"; "Lists"; "List"] - ; ["Coq"; "micromega"; "ZMicromega"] - ; ["Coq"; "micromega"; "Tauto"] - ; ["Coq"; "micromega"; "DeclConstant"] - ; ["Coq"; "micromega"; "RingMicromega"] - ; ["Coq"; "micromega"; "EnvRing"] - ; ["Coq"; "micromega"; "ZMicromega"] - ; ["Coq"; "micromega"; "RMicromega"] - ; ["Coq"; "micromega"; "Tauto"] - ; ["Coq"; "micromega"; "RingMicromega"] - ; ["Coq"; "micromega"; "EnvRing"] - ; ["Coq"; "QArith"; "QArith_base"] - ; ["Coq"; "Reals"; "Rdefinitions"] - ; ["Coq"; "Reals"; "Rpow_def"] - ; ["LRing_normalise"] ] - - [@@@ocaml.warning "-3"] - - let coq_modules = - Coqlib.( - init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules - @ mic_modules) - - let bin_module = [["Coq"; "Numbers"; "BinNums"]] - - let r_modules = - [ ["Coq"; "Reals"; "Rdefinitions"] - ; ["Coq"; "Reals"; "Rpow_def"] - ; ["Coq"; "Reals"; "Raxioms"] - ; ["Coq"; "QArith"; "Qreals"] ] - - let z_modules = [["Coq"; "ZArith"; "BinInt"]] - - (** * Initialization : a large amount of Caml symbols are derived from * ZMicromega.v *) - let gen_constant_in_modules s m n = + let constr_of_ref str = EConstr.of_constr - ( UnivGen.constr_of_monomorphic_global - @@ Coqlib.gen_reference_in_modules s m n ) - - let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules - - [@@@ocaml.warning "+3"] - - let constant = gen_constant_in_modules "ZMicromega" coq_modules - let bin_constant = gen_constant_in_modules "ZMicromega" bin_module - let r_constant = gen_constant_in_modules "ZMicromega" r_modules - let z_constant = gen_constant_in_modules "ZMicromega" z_modules - let m_constant = gen_constant_in_modules "ZMicromega" mic_modules - let coq_and = lazy (init_constant "and") - let coq_or = lazy (init_constant "or") - let coq_not = lazy (init_constant "not") - let coq_iff = lazy (init_constant "iff") - let coq_True = lazy (init_constant "True") - let coq_False = lazy (init_constant "False") - let coq_cons = lazy (constant "cons") - let coq_nil = lazy (constant "nil") - let coq_list = lazy (constant "list") - let coq_O = lazy (init_constant "O") - let coq_S = lazy (init_constant "S") - let coq_nat = lazy (init_constant "nat") - let coq_unit = lazy (init_constant "unit") + (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref str)) + + let coq_and = lazy (constr_of_ref "core.and.type") + let coq_or = lazy (constr_of_ref "core.or.type") + let coq_not = lazy (constr_of_ref "core.not.type") + let coq_iff = lazy (constr_of_ref "core.iff.type") + let coq_True = lazy (constr_of_ref "core.True.type") + let coq_False = lazy (constr_of_ref "core.False.type") + let coq_cons = lazy (constr_of_ref "core.list.cons") + let coq_nil = lazy (constr_of_ref "core.list.nil") + let coq_list = lazy (constr_of_ref "core.list.type") + let coq_O = lazy (constr_of_ref "num.nat.O") + let coq_S = lazy (constr_of_ref "num.nat.S") + let coq_nat = lazy (constr_of_ref "num.nat.type") + let coq_unit = lazy (constr_of_ref "core.unit.type") (* let coq_option = lazy (init_constant "option")*) - let coq_None = lazy (init_constant "None") - let coq_tt = lazy (init_constant "tt") - let coq_Inl = lazy (init_constant "inl") - let coq_Inr = lazy (init_constant "inr") - let coq_N0 = lazy (bin_constant "N0") - let coq_Npos = lazy (bin_constant "Npos") - let coq_xH = lazy (bin_constant "xH") - let coq_xO = lazy (bin_constant "xO") - let coq_xI = lazy (bin_constant "xI") - let coq_Z = lazy (bin_constant "Z") - let coq_ZERO = lazy (bin_constant "Z0") - let coq_POS = lazy (bin_constant "Zpos") - let coq_NEG = lazy (bin_constant "Zneg") - let coq_Q = lazy (constant "Q") - let coq_R = lazy (constant "R") - let coq_Qmake = lazy (constant "Qmake") - let coq_Rcst = lazy (constant "Rcst") - let coq_C0 = lazy (m_constant "C0") - let coq_C1 = lazy (m_constant "C1") - let coq_CQ = lazy (m_constant "CQ") - let coq_CZ = lazy (m_constant "CZ") - let coq_CPlus = lazy (m_constant "CPlus") - let coq_CMinus = lazy (m_constant "CMinus") - let coq_CMult = lazy (m_constant "CMult") - let coq_CPow = lazy (m_constant "CPow") - let coq_CInv = lazy (m_constant "CInv") - let coq_COpp = lazy (m_constant "COpp") - let coq_R0 = lazy (constant "R0") - let coq_R1 = lazy (constant "R1") - let coq_proofTerm = lazy (constant "ZArithProof") - let coq_doneProof = lazy (constant "DoneProof") - let coq_ratProof = lazy (constant "RatProof") - let coq_cutProof = lazy (constant "CutProof") - let coq_enumProof = lazy (constant "EnumProof") - let coq_ExProof = lazy (constant "ExProof") - let coq_Zgt = lazy (z_constant "Z.gt") - let coq_Zge = lazy (z_constant "Z.ge") - let coq_Zle = lazy (z_constant "Z.le") - let coq_Zlt = lazy (z_constant "Z.lt") - let coq_Eq = lazy (init_constant "eq") - let coq_Zplus = lazy (z_constant "Z.add") - let coq_Zminus = lazy (z_constant "Z.sub") - let coq_Zopp = lazy (z_constant "Z.opp") - let coq_Zmult = lazy (z_constant "Z.mul") - let coq_Zpower = lazy (z_constant "Z.pow") - let coq_Qle = lazy (constant "Qle") - let coq_Qlt = lazy (constant "Qlt") - let coq_Qeq = lazy (constant "Qeq") - let coq_Qplus = lazy (constant "Qplus") - let coq_Qminus = lazy (constant "Qminus") - let coq_Qopp = lazy (constant "Qopp") - let coq_Qmult = lazy (constant "Qmult") - let coq_Qpower = lazy (constant "Qpower") - let coq_Rgt = lazy (r_constant "Rgt") - let coq_Rge = lazy (r_constant "Rge") - let coq_Rle = lazy (r_constant "Rle") - let coq_Rlt = lazy (r_constant "Rlt") - let coq_Rplus = lazy (r_constant "Rplus") - let coq_Rminus = lazy (r_constant "Rminus") - let coq_Ropp = lazy (r_constant "Ropp") - let coq_Rmult = lazy (r_constant "Rmult") - let coq_Rinv = lazy (r_constant "Rinv") - let coq_Rpower = lazy (r_constant "pow") - let coq_powerZR = lazy (r_constant "powerRZ") - let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (r_constant "Q2R") - let coq_PEX = lazy (constant "PEX") - let coq_PEc = lazy (constant "PEc") - let coq_PEadd = lazy (constant "PEadd") - let coq_PEopp = lazy (constant "PEopp") - let coq_PEmul = lazy (constant "PEmul") - let coq_PEsub = lazy (constant "PEsub") - let coq_PEpow = lazy (constant "PEpow") - let coq_PX = lazy (constant "PX") - let coq_Pc = lazy (constant "Pc") - let coq_Pinj = lazy (constant "Pinj") - let coq_OpEq = lazy (constant "OpEq") - let coq_OpNEq = lazy (constant "OpNEq") - let coq_OpLe = lazy (constant "OpLe") - let coq_OpLt = lazy (constant "OpLt") - let coq_OpGe = lazy (constant "OpGe") - let coq_OpGt = lazy (constant "OpGt") - let coq_PsatzIn = lazy (constant "PsatzIn") - let coq_PsatzSquare = lazy (constant "PsatzSquare") - let coq_PsatzMulE = lazy (constant "PsatzMulE") - let coq_PsatzMultC = lazy (constant "PsatzMulC") - let coq_PsatzAdd = lazy (constant "PsatzAdd") - let coq_PsatzC = lazy (constant "PsatzC") - let coq_PsatzZ = lazy (constant "PsatzZ") + let coq_None = lazy (constr_of_ref "core.option.None") + let coq_tt = lazy (constr_of_ref "core.unit.tt") + let coq_Inl = lazy (constr_of_ref "core.sum.inl") + let coq_Inr = lazy (constr_of_ref "core.sum.inr") + let coq_N0 = lazy (constr_of_ref "num.N.N0") + let coq_Npos = lazy (constr_of_ref "num.N.Npos") + let coq_xH = lazy (constr_of_ref "num.pos.xH") + let coq_xO = lazy (constr_of_ref "num.pos.xO") + let coq_xI = lazy (constr_of_ref "num.pos.xI") + let coq_Z = lazy (constr_of_ref "num.Z.type") + let coq_ZERO = lazy (constr_of_ref "num.Z.Z0") + let coq_POS = lazy (constr_of_ref "num.Z.Zpos") + let coq_NEG = lazy (constr_of_ref "num.Z.Zneg") + let coq_Q = lazy (constr_of_ref "rat.Q.type") + let coq_Qmake = lazy (constr_of_ref "rat.Q.Qmake") + let coq_R = lazy (constr_of_ref "reals.R.type") + let coq_Rcst = lazy (constr_of_ref "micromega.Rcst.type") + let coq_C0 = lazy (constr_of_ref "micromega.Rcst.C0") + let coq_C1 = lazy (constr_of_ref "micromega.Rcst.C1") + let coq_CQ = lazy (constr_of_ref "micromega.Rcst.CQ") + let coq_CZ = lazy (constr_of_ref "micromega.Rcst.CZ") + let coq_CPlus = lazy (constr_of_ref "micromega.Rcst.CPlus") + let coq_CMinus = lazy (constr_of_ref "micromega.Rcst.CMinus") + let coq_CMult = lazy (constr_of_ref "micromega.Rcst.CMult") + let coq_CPow = lazy (constr_of_ref "micromega.Rcst.CPow") + let coq_CInv = lazy (constr_of_ref "micromega.Rcst.CInv") + let coq_COpp = lazy (constr_of_ref "micromega.Rcst.COpp") + let coq_R0 = lazy (constr_of_ref "reals.R.R0") + let coq_R1 = lazy (constr_of_ref "reals.R.R1") + let coq_proofTerm = lazy (constr_of_ref "micromega.ZArithProof.type") + let coq_doneProof = lazy (constr_of_ref "micromega.ZArithProof.DoneProof") + let coq_ratProof = lazy (constr_of_ref "micromega.ZArithProof.RatProof") + let coq_cutProof = lazy (constr_of_ref "micromega.ZArithProof.CutProof") + let coq_enumProof = lazy (constr_of_ref "micromega.ZArithProof.EnumProof") + let coq_ExProof = lazy (constr_of_ref "micromega.ZArithProof.ExProof") + let coq_Zgt = lazy (constr_of_ref "num.Z.gt") + let coq_Zge = lazy (constr_of_ref "num.Z.ge") + let coq_Zle = lazy (constr_of_ref "num.Z.le") + let coq_Zlt = lazy (constr_of_ref "num.Z.lt") + let coq_Eq = lazy (constr_of_ref "core.eq.type") + let coq_Zplus = lazy (constr_of_ref "num.Z.add") + let coq_Zminus = lazy (constr_of_ref "num.Z.sub") + let coq_Zopp = lazy (constr_of_ref "num.Z.opp") + let coq_Zmult = lazy (constr_of_ref "num.Z.mul") + let coq_Zpower = lazy (constr_of_ref "num.Z.pow") + let coq_Qle = lazy (constr_of_ref "rat.Q.Qle") + let coq_Qlt = lazy (constr_of_ref "rat.Q.Qlt") + let coq_Qeq = lazy (constr_of_ref "rat.Q.Qeq") + let coq_Qplus = lazy (constr_of_ref "rat.Q.Qplus") + let coq_Qminus = lazy (constr_of_ref "rat.Q.Qminus") + let coq_Qopp = lazy (constr_of_ref "rat.Q.Qopp") + let coq_Qmult = lazy (constr_of_ref "rat.Q.Qmult") + let coq_Qpower = lazy (constr_of_ref "rat.Q.Qpower") + let coq_Rgt = lazy (constr_of_ref "reals.R.Rgt") + let coq_Rge = lazy (constr_of_ref "reals.R.Rge") + let coq_Rle = lazy (constr_of_ref "reals.R.Rle") + let coq_Rlt = lazy (constr_of_ref "reals.R.Rlt") + let coq_Rplus = lazy (constr_of_ref "reals.R.Rplus") + let coq_Rminus = lazy (constr_of_ref "reals.R.Rminus") + let coq_Ropp = lazy (constr_of_ref "reals.R.Ropp") + let coq_Rmult = lazy (constr_of_ref "reals.R.Rmult") + let coq_Rinv = lazy (constr_of_ref "reals.R.Rinv") + let coq_Rpower = lazy (constr_of_ref "reals.R.pow") + let coq_powerZR = lazy (constr_of_ref "reals.R.powerRZ") + let coq_IZR = lazy (constr_of_ref "reals.R.IZR") + let coq_IQR = lazy (constr_of_ref "reals.R.Q2R") + let coq_PEX = lazy (constr_of_ref "micromega.PExpr.PEX") + let coq_PEc = lazy (constr_of_ref "micromega.PExpr.PEc") + let coq_PEadd = lazy (constr_of_ref "micromega.PExpr.PEadd") + let coq_PEopp = lazy (constr_of_ref "micromega.PExpr.PEopp") + let coq_PEmul = lazy (constr_of_ref "micromega.PExpr.PEmul") + let coq_PEsub = lazy (constr_of_ref "micromega.PExpr.PEsub") + let coq_PEpow = lazy (constr_of_ref "micromega.PExpr.PEpow") + let coq_PX = lazy (constr_of_ref "micromega.Pol.PX") + let coq_Pc = lazy (constr_of_ref "micromega.Pol.Pc") + let coq_Pinj = lazy (constr_of_ref "micromega.Pol.Pinj") + let coq_OpEq = lazy (constr_of_ref "micromega.Op2.OpEq") + let coq_OpNEq = lazy (constr_of_ref "micromega.Op2.OpNEq") + let coq_OpLe = lazy (constr_of_ref "micromega.Op2.OpLe") + let coq_OpLt = lazy (constr_of_ref "micromega.Op2.OpLt") + let coq_OpGe = lazy (constr_of_ref "micromega.Op2.OpGe") + let coq_OpGt = lazy (constr_of_ref "micromega.Op2.OpGt") + let coq_PsatzIn = lazy (constr_of_ref "micromega.Psatz.PsatzIn") + let coq_PsatzSquare = lazy (constr_of_ref "micromega.Psatz.PsatzSquare") + let coq_PsatzMulE = lazy (constr_of_ref "micromega.Psatz.PsatzMulE") + let coq_PsatzMultC = lazy (constr_of_ref "micromega.Psatz.PsatzMulC") + let coq_PsatzAdd = lazy (constr_of_ref "micromega.Psatz.PsatzAdd") + let coq_PsatzC = lazy (constr_of_ref "micromega.Psatz.PsatzC") + let coq_PsatzZ = lazy (constr_of_ref "micromega.Psatz.PsatzZ") (* let coq_GT = lazy (m_constant "GT")*) - let coq_DeclaredConstant = lazy (m_constant "DeclaredConstant") - - let coq_TT = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "TT") - - let coq_FF = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "FF") - - let coq_And = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "Cj") + let coq_DeclaredConstant = + lazy (constr_of_ref "micromega.DeclaredConstant.type") - let coq_Or = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "D") - - let coq_Neg = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "N") - - let coq_Atom = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "A") - - let coq_X = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "X") - - let coq_Impl = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "I") - - let coq_Formula = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "BFormula") + let coq_TT = lazy (constr_of_ref "micromega.GFormula.TT") + let coq_FF = lazy (constr_of_ref "micromega.GFormula.FF") + let coq_And = lazy (constr_of_ref "micromega.GFormula.Cj") + let coq_Or = lazy (constr_of_ref "micromega.GFormula.D") + let coq_Neg = lazy (constr_of_ref "micromega.GFormula.N") + let coq_Atom = lazy (constr_of_ref "micromega.GFormula.A") + let coq_X = lazy (constr_of_ref "micromega.GFormula.X") + let coq_Impl = lazy (constr_of_ref "micromega.GFormula.I") + let coq_Formula = lazy (constr_of_ref "micromega.BFormula.type") (** * Initialization : a few Caml symbols are derived from other libraries; * QMicromega, ZArithRing, RingMicromega. *) - let coq_QWitness = - lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "QMicromega"]] - "QWitness") - - let coq_Build = - lazy - (gen_constant_in_modules "RingMicromega" - [["Coq"; "micromega"; "RingMicromega"]; ["RingMicromega"]] - "Build_Formula") - - let coq_Cstr = - lazy - (gen_constant_in_modules "RingMicromega" - [["Coq"; "micromega"; "RingMicromega"]; ["RingMicromega"]] - "Formula") + let coq_QWitness = lazy (constr_of_ref "micromega.QWitness.type") + let coq_Build = lazy (constr_of_ref "micromega.Formula.Build_Formula") + let coq_Cstr = lazy (constr_of_ref "micromega.Formula.type") (** * Parsing and dumping : transformation functions between Caml and Coq @@ -1318,29 +1211,10 @@ end open M -let coq_Branch = - lazy - (gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "Branch") - -let coq_Elt = - lazy - (gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "Elt") - -let coq_Empty = - lazy - (gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "Empty") - -let coq_VarMap = - lazy - (gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "t") +let coq_Branch = lazy (constr_of_ref "micromega.VarMap.Branch") +let coq_Elt = lazy (constr_of_ref "micromega.VarMap.Elt") +let coq_Empty = lazy (constr_of_ref "micromega.VarMap.Empty") +let coq_VarMap = lazy (constr_of_ref "micromega.VarMap.type") let rec dump_varmap typ m = match m with @@ -1900,13 +1774,7 @@ let micromega_order_changer cert env ff = [ ( "__ff" , ff , EConstr.mkApp (Lazy.force coq_Formula, [|formula_typ|]) ) - ; ( "__varmap" - , vm - , EConstr.mkApp - ( gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "t" - , [|typ|] ) ) + ; ("__varmap", vm, EConstr.mkApp (Lazy.force coq_VarMap, [|typ|])) ; ("__wit", cert, cert_typ) ] (Tacmach.New.pf_concl gl)) (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 6a9a0657a3..42b9248979 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -55,18 +55,18 @@ let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) let interp_nbargs ist gl rc = try let rc6 = mkRApp rc (mkRHoles 6) in - let sigma, t = interp_open_constr ist gl (rc6, None) in + let sigma, t = interp_open_constr (pf_env gl) (project gl) ist (rc6, None) in let si = sig_it gl in let gl = re_sig si sigma in - 6 + Ssrcommon.nbargs_open_constr gl t + 6 + Ssrcommon.nbargs_open_constr (pf_env gl) t with _ -> 5 let interp_view_nbimps ist gl rc = try - let sigma, t = interp_open_constr ist gl (rc, None) in + let sigma, t = interp_open_constr (pf_env gl) (project gl) ist (rc, None) in let si = sig_it gl in let gl = re_sig si sigma in - let pl, c = splay_open_constr gl t in + let pl, c = splay_open_constr (pf_env gl) t in if Ssrcommon.isAppInd (pf_env gl) (project gl) c then List.length pl else (-(List.length pl)) with _ -> 0 @@ -88,7 +88,7 @@ let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) let apply_rconstr ?ist t gl = (* ppdebug(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) let n = match ist, DAst.get t with - | None, (GVar id | GRef (Names.GlobRef.VarRef id,_)) -> pf_nbargs gl (EConstr.mkVar id) + | None, (GVar id | GRef (Names.GlobRef.VarRef id,_)) -> pf_nbargs (pf_env gl) (project gl) (EConstr.mkVar id) | Some ist, _ -> interp_nbargs ist gl t | _ -> anomaly "apply_rconstr without ist and not RVar" in let mkRlemma i = mkRApp t (mkRHoles i) in @@ -97,7 +97,7 @@ let apply_rconstr ?ist t gl = if i > n then errorstrm Pp.(str"Cannot apply lemma "++pf_pr_glob_constr gl t) else try pf_match gl (mkRlemma i) (OfType cl) with _ -> loop (i + 1) in - refine_with (loop 0) gl + Proofview.V82.of_tactic (refine_with (loop 0)) gl let mkRAppView ist gl rv gv = let nb_view_imps = interp_view_nbimps ist gl rv in @@ -112,18 +112,20 @@ let refine_interp_apply_view dbl ist gl gv = interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in let rec loop = function | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) - | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in + | h :: hs -> (try Proofview.V82.of_tactic (refine_with (snd (interp_with h))) gl with _ -> loop hs) in loop (pair dbl (Ssrview.AdaptorDb.get dbl) @ if dbl = Ssrview.AdaptorDb.Equivalence then pair Ssrview.AdaptorDb.Backward (Ssrview.AdaptorDb.(get Backward)) else []) let apply_top_tac = - Tacticals.tclTHENLIST [ + Proofview.Goal.enter begin fun _ -> + Tacticals.New.tclTHENLIST [ introid top_id; - apply_rconstr (mkRVar top_id); - old_cleartac [SsrHyp(None,top_id)] + Proofview.V82.tactic (apply_rconstr (mkRVar top_id)); + cleartac [SsrHyp(None,top_id)] ] + end let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars:false (fun gl -> let _, clr = interp_hyps ist gl gclr in @@ -131,7 +133,7 @@ let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars: let ggenl, tclGENTAC = if gviews <> [] && ggenl <> [] then let ggenl= List.map (fun (x,g) -> x, cpattern_of_term g ist) (List.hd ggenl) in - [], Tacticals.tclTHEN (genstac (ggenl,[])) + [], Tacticals.tclTHEN (Proofview.V82.of_tactic (genstac (ggenl,[]))) else ggenl, Tacticals.tclTHEN Tacticals.tclIDTAC in tclGENTAC (fun gl -> match gviews, ggenl with @@ -148,9 +150,9 @@ let inner_ssrapplytac gviews (ggenl, gclr) ist = Proofview.V82.tactic ~nf_evars: | [], [agens] -> let clr', (sigma, lemma) = interp_agens ist gl agens in let gl = pf_merge_uc_of sigma gl in - Tacticals.tclTHENLIST [old_cleartac clr; refine_with ~beta:true lemma; old_cleartac clr'] gl + Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [cleartac clr; refine_with ~beta:true lemma; cleartac clr']) gl | _, _ -> - Tacticals.tclTHENLIST [apply_top_tac; old_cleartac clr] gl) gl + Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [apply_top_tac; cleartac clr]) gl) gl ) -let apply_top_tac = Proofview.V82.tactic ~nf_evars:false apply_top_tac +let apply_top_tac = apply_top_tac diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 134a9e4b36..e05c4c26dd 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -221,8 +221,8 @@ let intern_term ist env (_, c) = glob_constr ist env c (* FUNCLASS, which is probably just as well since these can *) (* lead to infinite arities. *) -let splay_open_constr gl (sigma, c) = - let env = pf_env gl in let t = Retyping.get_type_of env sigma c in +let splay_open_constr env (sigma, c) = + let t = Retyping.get_type_of env sigma c in Reductionops.splay_prod env sigma t let isAppInd env sigma c = @@ -253,11 +253,11 @@ let interp_refine ist gl rc = (sigma, (sigma, c)) -let interp_open_constr ist gl gc = - let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, Tactypes.NoBindings) in - (project gl, (sigma, c)) +let interp_open_constr env sigma0 ist gc = + let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist env sigma0 (gc, Tactypes.NoBindings) in + (sigma0, (sigma, c)) -let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) +let interp_term env sigma ist (_, c) = snd (interp_open_constr env sigma ist c) let of_ftactic ftac gl = let r = ref None in @@ -322,10 +322,10 @@ let ssrdgens_of_parsed_dgens = function | _ -> assert false -let nbargs_open_constr gl oc = - let pl, _ = splay_open_constr gl oc in List.length pl +let nbargs_open_constr env oc = + let pl, _ = splay_open_constr env oc in List.length pl -let pf_nbargs gl c = nbargs_open_constr gl (project gl, c) +let pf_nbargs env sigma c = nbargs_open_constr env (sigma, c) let internal_names = ref [] let add_internal_name pt = internal_names := pt :: !internal_names @@ -521,10 +521,10 @@ let resolve_typeclasses ~where ~fail env sigma = let nf_evar sigma t = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr t)) -let pf_abs_evars2 gl rigid (sigma, c0) = +let abs_evars2 env sigma0 rigid (sigma, c0) = let c0 = EConstr.to_constr ~abort_on_undefined_evars:false sigma c0 in - let sigma0, ucst = project gl, Evd.evar_universe_context sigma in - let nenv = env_size (pf_env gl) in + let sigma0, ucst = sigma0, Evd.evar_universe_context sigma in + let nenv = env_size env in let abs_evar n k = let evi = Evd.find sigma k in let concl = EConstr.Unsafe.to_constr evi.evar_concl in @@ -558,6 +558,11 @@ let pf_abs_evars2 gl rigid (sigma, c0) = | [] -> c in List.length evlist, EConstr.of_constr (loop (get 1 c0) 1 evlist), List.map fst evlist, ucst +let pf_abs_evars2 gl rigid c = + abs_evars2 (pf_env gl) (project gl) rigid c + +let abs_evars env sigma t = abs_evars2 env sigma [] t + let pf_abs_evars gl t = pf_abs_evars2 gl [] t @@ -569,7 +574,7 @@ let pf_abs_evars gl t = pf_abs_evars2 gl [] t * the corresponding lambda looks like (fun evar_i : T(c)) where c is * the solution found by ssrautoprop. *) -let ssrautoprop_tac = ref (fun gl -> assert false) +let ssrautoprop_tac = ref (Proofview.Goal.enter (fun gl -> assert false)) (* Thanks to Arnaud Spiwack for this snippet *) let call_on_evar tac e s = @@ -581,12 +586,11 @@ open Pp let pp _ = () (* FIXME *) module Intset = Evar.Set -let pf_abs_evars_pirrel gl (sigma, c0) = +let abs_evars_pirrel env sigma0 (sigma, c0) = pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); - pp(lazy(str"c0= " ++ Printer.pr_constr_env (pf_env gl) sigma c0)); - let sigma0 = project gl in + pp(lazy(str"c0= " ++ Printer.pr_constr_env env sigma c0)); let c0 = nf_evar sigma0 (nf_evar sigma c0) in - let nenv = env_size (pf_env gl) in + let nenv = env_size env in let abs_evar n k = let evi = Evd.find sigma k in let concl = EConstr.Unsafe.to_constr evi.evar_concl in @@ -602,13 +606,13 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let n = max 0 (List.length a - nenv) in let k_ty = Retyping.get_sort_family_of - (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in + env sigma (Evd.evar_concl (Evd.find sigma k)) in let is_prop = k_ty = InProp in let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t | _ -> Constr.fold put evlist c in let evlist = put [] c0 in if evlist = [] then 0, c0 else - let pr_constr t = Printer.pr_econstr_env (pf_env gl) sigma (Reductionops.nf_beta (pf_env gl) (project gl) (EConstr.of_constr t)) in + let pr_constr t = Printer.pr_econstr_env env sigma (Reductionops.nf_beta env sigma0 (EConstr.of_constr t)) in pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") (fun (k,_) -> Evar.print k) evlist)); let evplist = @@ -620,7 +624,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = if evplist = [] then evlist, [], sigma else List.fold_left (fun (ev, evp, sigma) (i, (_,t,_) as p) -> try - let ng, sigma = call_on_evar !ssrautoprop_tac i sigma in + let ng, sigma = call_on_evar (Proofview.V82.of_tactic !ssrautoprop_tac) i sigma in if (ng <> []) then errorstrm (str "Should we tell the user?"); List.filter (fun (j,_) -> j <> i) ev, evp, sigma with _ -> ev, p::evp, sigma) (evlist, [], sigma) (List.rev evplist) in @@ -667,6 +671,9 @@ let pf_abs_evars_pirrel gl (sigma, c0) = pp(lazy(str"res= " ++ pr_constr res)); List.length evlist, res +let pf_abs_evars_pirrel gl c = + abs_evars_pirrel (pf_env gl) (project gl) c + (* Strip all non-essential dependencies from an abstracted term, generating *) (* standard names for the abstracted holes. *) @@ -678,7 +685,8 @@ let nb_evar_deps = function (try int_of_string (String.sub s m (String.length s - 1 - m)) with _ -> 0) | _ -> 0 -let pf_type_id gl t = Id.of_string (Namegen.hdchar (pf_env gl) (project gl) t) +let type_id env sigma t = Id.of_string (Namegen.hdchar env sigma t) +let pf_type_id gl t = type_id (pf_env gl) (project gl) t let pfe_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty @@ -693,7 +701,7 @@ let pf_type_of gl t = let sigma, ty = pf_type_of gl (EConstr.of_constr t) in re_sig (sig_it gl) sigma, EConstr.Unsafe.to_constr ty -let pf_abs_cterm gl n c0 = +let abs_cterm env sigma n c0 = if n <= 0 then c0 else let c0 = EConstr.Unsafe.to_constr c0 in let noargs = [|0|] in @@ -725,13 +733,15 @@ let pf_abs_cterm gl n c0 = let na' = List.length dl in eva.(i) <- Array.of_list (na - na' :: dl); let x' = - if na' = 0 then Name (pf_type_id gl (EConstr.of_constr t2)) else mk_evar_name na' in + if na' = 0 then Name (type_id env sigma (EConstr.of_constr t2)) else mk_evar_name na' in mkLambda ({x with binder_name=x'}, t2, strip_evars (i + 1) c1) (* if noccurn 1 c2 then lift (-1) c2 else mkLambda (Name (pf_type_id gl t2), t2, c2) *) | _ -> strip i c in EConstr.of_constr (strip_evars 0 c0) +let pf_abs_cterm gl n c0 = abs_cterm (pf_env gl) (project gl) n c0 + (* }}} *) let pf_merge_uc uc gl = @@ -835,7 +845,7 @@ open Locus let rewritetac ?(under=false) dir c = (* Due to the new optional arg ?tac, application shouldn't be too partial *) let open Proofview.Notations in - Proofview.V82.of_tactic begin + Proofview.Goal.enter begin fun _ -> Equality.general_rewrite (dir = L2R) AllOccurrences true false c <*> if under then Proofview.cycle 1 else Proofview.tclUNIT () end @@ -845,7 +855,7 @@ let rewritetac ?(under=false) dir c = type name_hint = (int * EConstr.types array) option ref let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = - let sigma, ct as t = interp_term ist gl t in + let sigma, ct as t = interp_term (pf_env gl) (project gl) ist t in let sigma, _ as t = let env = pf_env gl in if not resolve_typeclasses then t @@ -857,7 +867,8 @@ let pf_abs_ssrterm ?(resolve_typeclasses=false) ist gl t = let top_id = mk_internal_id "top assumption" -let ssr_n_tac seed n gl = +let ssr_n_tac seed n = + Proofview.Goal.enter begin fun gl -> let name = if n = -1 then seed else ("ssr" ^ seed ^ string_of_int n) in let fail msg = CErrors.user_err (Pp.str msg) in let tacname = @@ -867,9 +878,10 @@ let ssr_n_tac seed n gl = if n = -1 then fail "The ssreflect library was not loaded" else fail ("The tactic "^name^" was not found") in let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in - Proofview.V82.of_tactic (Tacinterp.eval_tactic (Tacexpr.TacArg tacexpr)) gl + Tacinterp.eval_tactic (Tacexpr.TacArg tacexpr) + end -let donetac n gl = ssr_n_tac "done" n gl +let donetac n = ssr_n_tac "done" n open Constrexpr open Util @@ -890,7 +902,7 @@ let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, CastConv ty) let rec isCHoles = function { CAst.v = CHole _ } :: cl -> isCHoles cl | cl -> cl = [] let rec isCxHoles = function ({ CAst.v = CHole _ }, None) :: ch -> isCxHoles ch | _ -> false -let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = +let pf_interp_ty ?(resolve_typeclasses=false) env sigma0 ist ty = let n_binders = ref 0 in let ty = match ty with | a, (t, None) -> @@ -915,15 +927,14 @@ let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = | LetInType(n,v,ty,t) -> decr n_binders; mkLetIn (n, v, ty, aux t) | _ -> anomaly "pf_interp_ty: ssr Type cast deleted by typecheck" in sigma, aux t in - let sigma, cty as ty = strip_cast (interp_term ist gl ty) in + let sigma, cty as ty = strip_cast (interp_term env sigma0 ist ty) in let ty = - let env = pf_env gl in if not resolve_typeclasses then ty else let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in sigma, Evarutil.nf_evar sigma cty in - let n, c, _, ucst = pf_abs_evars gl ty in - let lam_c = pf_abs_cterm gl n c in + let n, c, _, ucst = abs_evars env sigma0 ty in + let lam_c = abs_cterm env sigma0 n c in let ctx, c = EConstr.decompose_lam_n_assum sigma n lam_c in n, EConstr.it_mkProd_or_LetIn c ctx, lam_c, ucst ;; @@ -981,7 +992,8 @@ let dependent_apply_error = * * Refiner.refiner that does not handle metas with a non ground type but works * with dependently typed higher order metas. *) -let applyn ~with_evars ?beta ?(with_shelve=false) ?(first_goes_last=false) n t gl = +let applyn ~with_evars ?beta ?(with_shelve=false) ?(first_goes_last=false) n t = + Proofview.V82.tactic begin fun gl -> if with_evars then let refine gl = let t, ty, args, gl = pf_saturate ?beta ~bi_types:true gl t n in @@ -1014,16 +1026,22 @@ let applyn ~with_evars ?beta ?(with_shelve=false) ?(first_goes_last=false) n t g pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); Proofview.(V82.of_tactic (Tacticals.New.tclTHENLIST [ - V82.tactic (Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t)); + Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t); (if first_goes_last then cycle 1 else tclUNIT ()) ])) gl + end -let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = +let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let uct = Evd.evar_universe_context (fst oc) in - let n, oc = pf_abs_evars_pirrel gl (fst oc, EConstr.to_constr ~abort_on_undefined_evars:false (fst oc) (snd oc)) in - let gl = pf_unsafe_merge_uc uct gl in - try applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc) gl - with e when CErrors.noncritical e -> raise dependent_apply_error + let n, oc = abs_evars_pirrel env sigma (fst oc, EConstr.to_constr ~abort_on_undefined_evars:false (fst oc) (snd oc)) in + Proofview.Unsafe.tclEVARS (Evd.set_universe_context sigma uct) <*> + Proofview.tclOR (applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc)) + (fun _ -> Proofview.tclZERO dependent_apply_error) + end (* We wipe out all the keywords generated by the grammar rules we defined. *) (* The user is supposed to Require Import ssreflect or Require ssreflect *) @@ -1041,23 +1059,24 @@ let rec fst_prod red tac = Proofview.Goal.enter begin fun gl -> else Tacticals.New.tclTHEN Tactics.hnf_in_concl (fst_prod true tac) end -let introid ?(orig=ref Anonymous) name = tclTHEN (fun gl -> - let g, env = Tacmach.pf_concl gl, pf_env gl in - let sigma = project gl in +let introid ?(orig=ref Anonymous) name = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let g = Proofview.Goal.concl gl in match EConstr.kind sigma g with | App (hd, _) when EConstr.isLambda sigma hd -> - Proofview.V82.of_tactic (convert_concl_no_check (Reductionops.whd_beta sigma g)) gl - | _ -> tclIDTAC gl) - (Proofview.V82.of_tactic - (fst_prod false (fun id -> orig := id; Tactics.intro_mustbe_force name))) -;; + convert_concl_no_check (Reductionops.whd_beta sigma g) + | _ -> Tacticals.New.tclIDTAC + end <*> + (fst_prod false (fun id -> orig := id; Tactics.intro_mustbe_force name)) let anontac decl gl = let id = match RelDecl.get_name decl with | Name id -> if is_discharged_id id then id else mk_anon_id (Id.to_string id) (Tacmach.pf_ids_of_hyps gl) | _ -> mk_anon_id ssr_anon_hyp (Tacmach.pf_ids_of_hyps gl) in - introid id gl + Proofview.V82.of_tactic (introid id) gl let rec intro_anon gl = try anontac (List.hd (fst (EConstr.decompose_prod_n_assum (project gl) 1 (Tacmach.pf_concl gl)))) gl @@ -1085,16 +1104,17 @@ let interp_clr sigma = function let tclID tac = tac let tclDOTRY n tac = + let open Tacticals.New in if n <= 0 then tclIDTAC else - let rec loop i gl = - if i = n then tclTRY tac gl else - tclTRY (tclTHEN tac (loop (i + 1))) gl in + let rec loop i = + if i = n then tclTRY tac else + tclTRY (tclTHEN tac (loop (i + 1))) in loop 1 let tclDO n tac = let prefix i = str"At iteration " ++ int i ++ str": " in let tac_err_at i gl = - try tac gl + try Proofview.V82.of_tactic tac gl with | CErrors.UserError (l, s) as e -> let _, info = Exninfo.capture e in @@ -1105,11 +1125,15 @@ let tclDO n tac = let rec loop i gl = if i = n then tac_err_at i gl else (tclTHEN (tac_err_at i) (loop (i + 1))) gl in - loop 1 + Proofview.V82.tactic ~nf_evars:false (loop 1) + +let tclAT_LEAST_ONCE t = + let open Tacticals.New in + tclTHEN t (tclREPEAT t) let tclMULT = function - | 0, May -> tclREPEAT - | 1, May -> tclTRY + | 0, May -> Tacticals.New.tclREPEAT + | 1, May -> Tacticals.New.tclTRY | n, May -> tclDOTRY n | 0, Must -> tclAT_LEAST_ONCE | n, Must when n > 1 -> tclDO n @@ -1124,7 +1148,7 @@ let cleartac clr = check_hyps_uniq [] clr; Tactics.clear (hyps_ids clr) (* XXX the k of the redex should percolate out *) let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = - let pat = interp_cpattern gl t None in (* UGLY API *) + let pat = interp_cpattern (pf_env gl) (project gl) t None in (* UGLY API *) let gl = pf_merge_uc_of (fst pat) gl in let cl, env, sigma = Tacmach.pf_concl gl, pf_env gl, project gl in let (c, ucst), cl = @@ -1171,7 +1195,8 @@ let genclrtac cl cs clr = gl)) (old_cleartac clr) -let gentac gen gl = +let gentac gen = + Proofview.V82.tactic begin fun gl -> (* ppdebug(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux gl false gen in ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); @@ -1179,9 +1204,10 @@ let gentac gen gl = if conv then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl else genclrtac cl [c] clr gl + end let genstac (gens, clr) = - tclTHENLIST (old_cleartac clr :: List.rev_map gentac gens) + Tacticals.New.tclTHENLIST (cleartac clr :: List.rev_map gentac gens) let gen_tmp_ids ?(ist=Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty })) gl @@ -1191,7 +1217,7 @@ let gen_tmp_ids (tclTHENLIST (List.map (fun (id,orig_ref) -> tclTHEN - (gentac ((None,Some(false,[])),cpattern_of_id id)) + (Proofview.V82.of_tactic (gentac ((None,Some(false,[])),cpattern_of_id id))) (rename_hd_prod orig_ref)) ctx.tmp_ids) gl) ;; @@ -1214,24 +1240,6 @@ let pfLIFT f = Proofview.tclUNIT x ;; -(* TASSI: This version of unprotects inlines the unfold tactic definition, - * since we don't want to wipe out let-ins, and it seems there is no flag - * to change that behaviour in the standard unfold code *) -let unprotecttac gl = - let c, gl = pf_mkSsrConst "protect_term" gl in - let prot, _ = EConstr.destConst (project gl) c in - Tacticals.onClause (fun idopt -> - let hyploc = Option.map (fun id -> id, InHyp) idopt in - Proofview.V82.of_tactic (Tactics.reduct_option ~check:false - (Reductionops.clos_norm_flags - (CClosure.RedFlags.mkflags - [CClosure.RedFlags.fBETA; - CClosure.RedFlags.fCONST prot; - CClosure.RedFlags.fMATCH; - CClosure.RedFlags.fFIX; - CClosure.RedFlags.fCOFIX]), DEFAULTcast) hyploc)) - allHypsAndConcl gl - let is_protect hd env sigma = let _, protectC = mkSsrConst "protect_term" env sigma in EConstr.eq_constr_nounivs sigma hd protectC @@ -1259,7 +1267,7 @@ let abs_wgen keep_let f gen (gl,args,c) = gl, EConstr.mkVar x :: args, prod | _, Some ((x, "@"), Some p) -> let x = hoi_id x in - let cp = interp_cpattern gl p None in + let cp = interp_cpattern (pf_env gl) (project gl) p None in let gl = pf_merge_uc_of (fst cp) gl in let (t, ucst), c = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 @@ -1272,7 +1280,7 @@ let abs_wgen keep_let f gen (gl,args,c) = pf_merge_uc ucst gl, args, EConstr.mkLetIn(make_annot (Name (f x)) r, ut, ty, c) | _, Some ((x, _), Some p) -> let x = hoi_id x in - let cp = interp_cpattern gl p None in + let cp = interp_cpattern (pf_env gl) (project gl) p None in let gl = pf_merge_uc_of (fst cp) gl in let (t, ucst), c = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 @@ -1287,8 +1295,8 @@ let abs_wgen keep_let f gen (gl,args,c) = let clr_of_wgen gen clrs = match gen with | clr, Some ((x, _), None) -> let x = hoi_id x in - old_cleartac clr :: old_cleartac [SsrHyp(Loc.tag x)] :: clrs - | clr, _ -> old_cleartac clr :: clrs + cleartac clr :: cleartac [SsrHyp(Loc.tag x)] :: clrs + | clr, _ -> cleartac clr :: clrs let reduct_in_concl ~check t = Tactics.reduct_in_concl ~check (t, DEFAULTcast) @@ -1321,7 +1329,8 @@ end let tacREDUCE_TO_QUANTIFIED_IND ty = tacSIGMA >>= fun gl -> - tclUNIT (Tacmach.pf_reduce_to_quantified_ind gl ty) + try tclUNIT (Tacmach.pf_reduce_to_quantified_ind gl ty) + with e -> tclZERO e let tacTYPEOF c = Goal.enter_one ~__LOC__ (fun g -> let sigma, env = Goal.sigma g, Goal.env g in @@ -1460,7 +1469,7 @@ end let tacINTERP_CPATTERN cp = tacSIGMA >>= begin fun gl -> - tclUNIT (Ssrmatching.interp_cpattern gl cp None) + tclUNIT (Ssrmatching.interp_cpattern (pf_env gl) (project gl) cp None) end let tacUNIFY a b = @@ -1488,12 +1497,38 @@ let tclWITHTOP tac = Goal.enter begin fun gl -> Tactics.clear [top] end -let tacMK_SSR_CONST name = Goal.enter_one ~__LOC__ begin fun g -> - let sigma, env = Goal.(sigma g, env g) in - let sigma, c = mkSsrConst name env sigma in - Unsafe.tclEVARS sigma <*> - tclUNIT c -end +let tacMK_SSR_CONST name = + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + match mkSsrConst name env sigma with + | sigma, c -> Unsafe.tclEVARS sigma <*> tclUNIT c + | exception e when CErrors.noncritical e -> + tclLIFT (Proofview.NonLogical.raise (e, Exninfo.null)) + +let tacDEST_CONST c = + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.destConst sigma c with + | c, _ -> tclUNIT c + | exception e when CErrors.noncritical e -> + tclLIFT (Proofview.NonLogical.raise (e, Exninfo.null)) + +(* TASSI: This version of unprotects inlines the unfold tactic definition, + * since we don't want to wipe out let-ins, and it seems there is no flag + * to change that behaviour in the standard unfold code *) +let unprotecttac = + tacMK_SSR_CONST "protect_term" >>= tacDEST_CONST >>= fun prot -> + Tacticals.New.onClause (fun idopt -> + let hyploc = Option.map (fun id -> id, InHyp) idopt in + Tactics.reduct_option ~check:false + (Reductionops.clos_norm_flags + (CClosure.RedFlags.mkflags + [CClosure.RedFlags.fBETA; + CClosure.RedFlags.fCONST prot; + CClosure.RedFlags.fMATCH; + CClosure.RedFlags.fFIX; + CClosure.RedFlags.fCOFIX]), DEFAULTcast) hyploc) + allHypsAndConcl + module type StateType = sig type state diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 3f92eab0bd..d1ad24496e 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -131,7 +131,8 @@ val pf_intern_term : ssrterm -> Glob_term.glob_constr val interp_term : - Tacinterp.interp_sign -> Goal.goal Evd.sigma -> + Environ.env -> Evd.evar_map -> + Tacinterp.interp_sign -> ssrterm -> evar_map * EConstr.t val interp_wit : @@ -145,7 +146,8 @@ val interp_refine : Glob_term.glob_constr -> evar_map * (evar_map * EConstr.constr) val interp_open_constr : - Tacinterp.interp_sign -> Goal.goal Evd.sigma -> + Environ.env -> Evd.evar_map -> + Tacinterp.interp_sign -> Genintern.glob_constr_and_expr -> evar_map * (evar_map * EConstr.t) val pf_e_type_of : @@ -153,7 +155,7 @@ val pf_e_type_of : EConstr.constr -> Goal.goal Evd.sigma * EConstr.types val splay_open_constr : - Goal.goal Evd.sigma -> + Environ.env -> evar_map * EConstr.t -> (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t val isAppInd : Environ.env -> Evd.evar_map -> EConstr.types -> bool @@ -179,8 +181,23 @@ val mk_internal_id : string -> Id.t val mk_tagged_id : string -> int -> Id.t val mk_evar_name : int -> Name.t val ssr_anon_hyp : string +val type_id : Environ.env -> Evd.evar_map -> EConstr.types -> Id.t val pf_type_id : Goal.goal Evd.sigma -> EConstr.types -> Id.t +val abs_evars : + Environ.env -> Evd.evar_map -> + evar_map * EConstr.t -> + int * EConstr.t * Evar.t list * + UState.t +val abs_evars2 : (* ssr2 *) + Environ.env -> Evd.evar_map -> Evar.t list -> + evar_map * EConstr.t -> + int * EConstr.t * Evar.t list * + UState.t +val abs_cterm : + Environ.env -> Evd.evar_map -> int -> EConstr.t -> EConstr.t + + val pf_abs_evars : Goal.goal Evd.sigma -> evar_map * EConstr.t -> @@ -216,15 +233,8 @@ val pf_abs_prod : EConstr.t -> Goal.goal Evd.sigma * EConstr.types val mkSsrRRef : string -> Glob_term.glob_constr * 'a option -val mkSsrConst : - string -> - env -> evar_map -> evar_map * EConstr.t -val pf_mkSsrConst : - string -> - Goal.goal Evd.sigma -> - EConstr.t * Goal.goal Evd.sigma -val new_wild_id : tac_ctx -> Names.Id.t * tac_ctx +val new_wild_id : tac_ctx -> Names.Id.t * tac_ctx val pf_fresh_global : GlobRef.t -> @@ -239,11 +249,14 @@ val ssrqid : string -> Libnames.qualid val new_tmp_id : tac_ctx -> (Names.Id.t * Name.t ref) * tac_ctx val mk_anon_id : string -> Id.t list -> Id.t +val abs_evars_pirrel : + Environ.env -> Evd.evar_map -> + evar_map * Constr.constr -> int * Constr.constr val pf_abs_evars_pirrel : Goal.goal Evd.sigma -> evar_map * Constr.constr -> int * Constr.constr -val nbargs_open_constr : Goal.goal Evd.sigma -> Evd.evar_map * EConstr.t -> int -val pf_nbargs : Goal.goal Evd.sigma -> EConstr.t -> int +val nbargs_open_constr : Environ.env -> Evd.evar_map * EConstr.t -> int +val pf_nbargs : Environ.env -> Evd.evar_map -> EConstr.t -> int val gen_tmp_ids : ?ist:Geninterp.interp_sign -> (Goal.goal * tac_ctx) Evd.sigma -> @@ -263,7 +276,7 @@ val red_product_skip_id : env -> evar_map -> EConstr.t -> EConstr.t val ssrautoprop_tac : - (Evar.t Evd.sigma -> Evar.t list Evd.sigma) ref + unit Proofview.tactic ref val mkProt : EConstr.t -> @@ -300,14 +313,15 @@ val pf_abs_ssrterm : val pf_interp_ty : ?resolve_typeclasses:bool -> + Environ.env -> + Evd.evar_map -> Tacinterp.interp_sign -> - Goal.goal Evd.sigma -> Ssrast.ssrtermkind * (Glob_term.glob_constr * Constrexpr.constr_expr option) -> int * EConstr.t * EConstr.t * UState.t -val ssr_n_tac : string -> int -> v82tac -val donetac : int -> v82tac +val ssr_n_tac : string -> int -> unit Proofview.tactic +val donetac : int -> unit Proofview.tactic val applyn : with_evars:bool -> @@ -315,7 +329,7 @@ val applyn : ?with_shelve:bool -> ?first_goes_last:bool -> int -> - EConstr.t -> v82tac + EConstr.t -> unit Proofview.tactic exception NotEnoughProducts val pf_saturate : ?beta:bool -> @@ -339,7 +353,7 @@ val refine_with : ?first_goes_last:bool -> ?beta:bool -> ?with_evars:bool -> - evar_map * EConstr.t -> v82tac + evar_map * EConstr.t -> unit Proofview.tactic val pf_resolve_typeclasses : where:EConstr.t -> @@ -350,18 +364,18 @@ val resolve_typeclasses : (*********************** Wrapped Coq tactics *****************************) -val rewritetac : ?under:bool -> ssrdir -> EConstr.t -> tactic +val rewritetac : ?under:bool -> ssrdir -> EConstr.t -> unit Proofview.tactic type name_hint = (int * EConstr.types array) option ref val gentac : - Ssrast.ssrdocc * Ssrmatching.cpattern -> v82tac + Ssrast.ssrdocc * Ssrmatching.cpattern -> unit Proofview.tactic val genstac : ((Ssrast.ssrhyp list option * Ssrmatching.occ) * Ssrmatching.cpattern) list * Ssrast.ssrhyp list -> - Tacmach.tactic + unit Proofview.tactic val pf_interp_gen : bool -> @@ -378,7 +392,7 @@ val pfLIFT (** Basic tactics *) -val introid : ?orig:Name.t ref -> Id.t -> v82tac +val introid : ?orig:Name.t ref -> Id.t -> unit Proofview.tactic val intro_anon : v82tac val interp_clr : @@ -390,9 +404,9 @@ val genclrtac : val old_cleartac : ssrhyps -> v82tac val cleartac : ssrhyps -> unit Proofview.tactic -val tclMULT : int * ssrmmod -> Tacmach.tactic -> Tacmach.tactic +val tclMULT : int * ssrmmod -> unit Proofview.tactic -> unit Proofview.tactic -val unprotecttac : Goal.goal Evd.sigma -> Goal.goal list Evd.sigma +val unprotecttac : unit Proofview.tactic val is_protect : EConstr.t -> Environ.env -> Evd.evar_map -> bool val abs_wgen : @@ -407,7 +421,7 @@ val abs_wgen : val clr_of_wgen : ssrhyps * ((ssrhyp_or_id * 'a) * 'b option) option -> - Proofview.V82.tac list -> Proofview.V82.tac list + unit Proofview.tactic list -> unit Proofview.tactic list val unfold : EConstr.t list -> unit Proofview.tactic diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index b44600a8cf..8e75ba7a2b 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -183,7 +183,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = else let c = Option.get oc in let gl, c_ty = pfe_type_of gl c in let pc = match c_gen with - | Some p -> interp_cpattern orig_gl p None + | Some p -> interp_cpattern (pf_env orig_gl) (project orig_gl) p None | _ -> mkTpat gl c in Some(c, c_ty, pc), gl in seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl @@ -233,7 +233,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in let pred = List.assoc pred_id elim_args in let pc = match n_c_args, c_gen with - | 0, Some p -> interp_cpattern orig_gl p None + | 0, Some p -> interp_cpattern (pf_env orig_gl) (project orig_gl) p None | _ -> mkTpat gl c in let cty = Some (c, c_ty, pc) in let elimty = Reductionops.whd_all env (project gl) elimty in @@ -312,7 +312,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let rec loop patterns clr i = function | [],[] -> patterns, clr, gl | ((oclr, occ), t):: deps, inf_t :: inf_deps -> - let p = interp_cpattern orig_gl t None in + let p = interp_cpattern (pf_env orig_gl) (project orig_gl) t None in let clr_t = interp_clr (project gl) (oclr,(tag_of_cpattern t,EConstr.of_constr (fst (redex_of_pattern env p)))) in (* if we are the index for the equation we do not clear *) @@ -392,10 +392,15 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let erefl = fire_subst gl erefl in let erefl_ty = Retyping.get_type_of (pf_env gl) (project gl) erefl in let eq_ty = Retyping.get_type_of (pf_env gl) (project gl) erefl_ty in - let gen_eq_tac s = + let gen_eq_tac = + let open Proofview.Notations in + Proofview.Goal.enter begin fun s -> + let sigma = Proofview.Goal.sigma s in let open Evd in - let sigma = merge_universe_context s.sigma (evar_universe_context (project gl)) in - apply_type new_concl [erefl] { s with sigma } + let sigma = merge_universe_context sigma (evar_universe_context (project gl)) in + Proofview.Unsafe.tclEVARS sigma <*> + Tactics.apply_type ~typecheck:true new_concl [erefl] + end in gen_eq_tac, eq_ty, gl in let rel = k + if c_is_head_p then 1 else 0 in @@ -403,7 +408,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let concl = EConstr.mkArrow src Sorts.Relevant (EConstr.Vars.lift 1 concl) in let clr = if deps <> [] then clr else [] in concl, gen_eq_tac, clr, gl - | _ -> concl, Tacticals.tclIDTAC, clr, gl in + | _ -> concl, Tacticals.New.tclIDTAC, clr, gl in let mk_lam t r = EConstr.mkLambda_or_LetIn r t in let concl = List.fold_left mk_lam concl pred_rctx in let gl, concl = @@ -453,9 +458,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elim_tac = Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (refine_with ~with_evars:false elim); + refine_with ~with_evars:false elim; cleartac clr] in - let gen_eq_tac = Proofview.V82.tactic gen_eq_tac in Tacticals.New.tclTHENLIST [gen_eq_tac; elim_intro_tac ?seed:(Some seed) what eqid elim_tac is_rec clr] ;; @@ -467,19 +471,22 @@ let casetac x k = let k ?seed _what _eqid elim_tac _is_rec _clr = k ?seed elim_tac in ssrelim ~is_case:true [] (`EConstr ([],None,x)) None k -let pf_nb_prod gl = nb_prod (project gl) (pf_concl gl) - let rev_id = mk_internal_id "rev concl" let injecteq_id = mk_internal_id "injection equation" -let revtoptac n0 gl = - let n = pf_nb_prod gl - n0 in - let dc, cl = EConstr.decompose_prod_n_assum (project gl) n (pf_concl gl) in +let revtoptac n0 = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let n = nb_prod sigma concl - n0 in + let dc, cl = EConstr.decompose_prod_n_assum sigma n concl in let dc' = dc @ [Context.Rel.Declaration.LocalAssum(make_annot (Name rev_id) Sorts.Relevant, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in - Refiner.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) gl + Refiner.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) + end -let equality_inj l b id c gl = +let equality_inj l b id c = + Proofview.V82.tactic begin fun gl -> let msg = ref "" in try Proofview.V82.of_tactic (Equality.inj None l b None c) gl with @@ -490,37 +497,53 @@ let equality_inj l b id c gl = !msg = "Nothing to inject." -> Feedback.msg_warning (Pp.str !msg); discharge_hyp (id, (id, "")) gl + end -let injectidl2rtac id c gl = - Tacticals.tclTHEN (equality_inj None true id c) (revtoptac (pf_nb_prod gl)) gl +let injectidl2rtac id c = + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + Tacticals.New.tclTHEN (equality_inj None true id c) (revtoptac (nb_prod sigma concl)) + end let injectl2rtac sigma c = match EConstr.kind sigma c with | Var id -> injectidl2rtac id (EConstr.mkVar id, NoBindings) | _ -> let id = injecteq_id in - let xhavetac id c = Proofview.V82.of_tactic (Tactics.pose_proof (Name id) c) in - Tacticals.tclTHENLIST [xhavetac id c; injectidl2rtac id (EConstr.mkVar id, NoBindings); Proofview.V82.of_tactic (Tactics.clear [id])] + let xhavetac id c = Tactics.pose_proof (Name id) c in + Tacticals.New.tclTHENLIST [xhavetac id c; injectidl2rtac id (EConstr.mkVar id, NoBindings); Tactics.clear [id]] -let is_injection_case c gl = - let gl, cty = pfe_type_of gl c in - let (mind,_), _ = pf_reduce_to_quantified_ind gl cty in +let is_injection_case env sigma c = + let sigma, cty = Typing.type_of env sigma c in + let (mind,_), _ = Tacred.reduce_to_quantified_ind env sigma cty in Coqlib.check_ind_ref "core.eq.type" mind -let perform_injection c gl = - let gl, cty = pfe_type_of gl c in - let mind, t = pf_reduce_to_quantified_ind gl cty in - let dc, eqt = EConstr.decompose_prod (project gl) t in - if dc = [] then injectl2rtac (project gl) c gl else - if not (EConstr.Vars.closed0 (project gl) eqt) then +let perform_injection c = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, cty = Typing.type_of env sigma c in + let mind, t = Tacred.reduce_to_quantified_ind env sigma cty in + let dc, eqt = EConstr.decompose_prod sigma t in + if dc = [] then injectl2rtac sigma c else + if not (EConstr.Vars.closed0 sigma eqt) then CErrors.user_err (Pp.str "can't decompose a quantified equality") else - let cl = pf_concl gl in let n = List.length dc in + let cl = Proofview.Goal.concl gl in + let n = List.length dc in let c_eq = mkEtaApp c n 2 in let cl1 = EConstr.mkLambda EConstr.(make_annot Anonymous Sorts.Relevant, mkArrow eqt Sorts.Relevant cl, mkApp (mkRel 1, [|c_eq|])) in let id = injecteq_id in let id_with_ebind = (EConstr.mkVar id, NoBindings) in - let injtac = Tacticals.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in - Tacticals.tclTHENLAST (Proofview.V82.of_tactic (Tactics.apply (EConstr.compose_lam dc cl1))) injtac gl + let injtac = Tacticals.New.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in + Proofview.Unsafe.tclEVARS sigma <*> + Tacticals.New.tclTHENLAST (Tactics.apply (EConstr.compose_lam dc cl1)) injtac + end -let ssrscase_or_inj_tac c = Proofview.V82.tactic ~nf_evars:false (fun gl -> - if is_injection_case c gl then perform_injection c gl - else Proofview.V82.of_tactic (casetac c (fun ?seed:_ k -> k)) gl) +let ssrscase_or_inj_tac c = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + if is_injection_case env sigma c then perform_injection c + else casetac c (fun ?seed:_ k -> k) + end diff --git a/plugins/ssr/ssrelim.mli b/plugins/ssr/ssrelim.mli index 7b9cfed5ba..7f74fc78a2 100644 --- a/plugins/ssr/ssrelim.mli +++ b/plugins/ssr/ssrelim.mli @@ -41,10 +41,10 @@ val casetac : (?seed:Names.Name.t list array -> unit Proofview.tactic -> unit Proofview.tactic) -> unit Proofview.tactic -val is_injection_case : EConstr.t -> Goal.goal Evd.sigma -> bool +val is_injection_case : Environ.env -> Evd.evar_map -> EConstr.t -> bool val perform_injection : EConstr.constr -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic val ssrscase_or_inj_tac : EConstr.constr -> diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index d4303e9e8b..ab07dd5be9 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -42,29 +42,36 @@ let () = (* We must avoid zeta-converting any "let"s created by the "in" tactical. *) -let tacred_simpl gl = +let tacred_simpl env = let simpl_expr = Genredexpr.( Simpl(Redops.make_red_flag[FBeta;FMatch;FZeta;FDeltaBut []],None)) in - let esimpl, _ = Redexpr.reduction_of_red_expr (pf_env gl) simpl_expr in + let esimpl, _ = Redexpr.reduction_of_red_expr env simpl_expr in let esimpl e sigma c = let (_,t) = esimpl e sigma c in t in let simpl env sigma c = (esimpl env sigma c) in simpl -let safe_simpltac n gl = +let safe_simpltac n = if n = ~-1 then - let cl= red_safe (tacred_simpl gl) (pf_env gl) (project gl) (pf_concl gl) in - Proofview.V82.of_tactic (convert_concl_no_check cl) gl + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let cl = red_safe (tacred_simpl env) env sigma concl in + convert_concl_no_check cl + end else - ssr_n_tac "simpl" n gl + ssr_n_tac "simpl" n let simpltac = function | Simpl n -> safe_simpltac n - | Cut n -> tclTRY (donetac n) - | SimplCut (n,m) -> tclTHEN (safe_simpltac m) (tclTRY (donetac n)) - | Nop -> tclIDTAC + | Cut n -> Tacticals.New.tclTRY (donetac n) + | SimplCut (n,m) -> Tacticals.New.tclTHEN (safe_simpltac m) (Tacticals.New.tclTRY (donetac n)) + | Nop -> Tacticals.New.tclIDTAC + +let simpltac s = Proofview.Goal.enter (fun _ -> simpltac s) (** The "congr" tactic *) @@ -87,13 +94,13 @@ let pattern_id = mk_internal_id "pattern value" let congrtac ((n, t), ty) ist gl = ppdebug(lazy (Pp.str"===congr===")); ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); - let sigma, _ as it = interp_term ist gl t in + let sigma, _ as it = interp_term (pf_env gl) (project gl) ist t in let gl = pf_merge_uc_of sigma gl in let _, f, _, _ucst = pf_abs_evars gl it in let ist' = {ist with lfun = Id.Map.add pattern_id (Tacinterp.Value.of_constr f) Id.Map.empty } in let rf = mkRltacVar pattern_id in - let m = pf_nbargs gl f in + let m = pf_nbargs (pf_env gl) (project gl) f in let _, cf = if n > 0 then match interp_congrarg_at ist' gl n rf ty m with | Some cf -> cf @@ -105,14 +112,18 @@ let congrtac ((n, t), ty) ist gl = | Some cf -> cf | None -> loop (i + 1) in loop 1 in - tclTHEN (refine_with cf) (tclTRY (Proofview.V82.of_tactic Tactics.reflexivity)) gl + Proofview.V82.of_tactic Tacticals.New.(tclTHEN (refine_with cf) (tclTRY Tactics.reflexivity)) gl let pf_typecheck t gl = let it = sig_it gl in let sigma,_ = pf_type_of gl t in re_sig [it] sigma -let newssrcongrtac arg ist gl = +let newssrcongrtac arg ist = + let open Proofview.Notations in + Proofview.Goal.enter_one ~__LOC__ begin fun _g -> + (Ssrcommon.tacMK_SSR_CONST "ssr_congr_arrow") end >>= fun arr -> + Proofview.V82.tactic begin fun gl -> ppdebug(lazy Pp.(str"===newcongr===")); ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); (* utils *) @@ -129,7 +140,6 @@ let newssrcongrtac arg ist gl = let sigma = Evd.create_evar_defs sigma in let (sigma, x) = Evarutil.new_evar env sigma ty in x, re_sig si sigma in - let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in let ssr_congr lr = EConstr.mkApp (arr, lr) in let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in (* here the two cases: simple equality or arrow *) @@ -150,6 +160,7 @@ let newssrcongrtac arg ist gl = ; congrtac (arg, mkRType) ist ]) (fun _ _ -> errorstrm Pp.(str"Conclusion is not an equality nor an arrow"))) gl + end (** 7. Rewriting tactics (rewrite, unlock) *) @@ -188,24 +199,28 @@ let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) : ssrrwarg = let norwmult = L2R, nomult let norwocc = noclr, None -let simplintac occ rdx sim gl = - let simptac m gl = +let simplintac occ rdx sim = + let simptac m = + Proofview.Goal.enter begin fun gl -> if m <> ~-1 then begin if rdx <> None then CErrors.user_err (Pp.str "Custom simpl tactic does not support patterns"); if occ <> None then CErrors.user_err (Pp.str "Custom simpl tactic does not support occurrence numbers"); - simpltac (Simpl m) gl + simpltac (Simpl m) end else - let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let sigma0, concl0, env0 = Proofview.Goal.(sigma gl, concl gl, env gl) in let simp env c _ _ = EConstr.Unsafe.to_constr (red_safe Tacred.simpl env sigma0 (EConstr.of_constr c)) in - Proofview.V82.of_tactic - (convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.Unsafe.to_constr concl0) rdx occ simp))) - gl in + convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.to_constr ~abort_on_undefined_evars:false sigma0 concl0) rdx occ simp)) + end + in + let open Tacticals.New in + Proofview.Goal.enter begin fun _ -> match sim with - | Simpl m -> simptac m gl - | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) gl - | _ -> simpltac sim gl + | Simpl m -> simptac m + | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) + | _ -> simpltac sim + end let rec get_evalref env sigma c = match EConstr.kind sigma c with | Var id -> EvalVarRef id @@ -233,7 +248,8 @@ let all_ok _ _ = true let fake_pmatcher_end () = mkProp, L2R, (Evd.empty, UState.empty, mkProp) -let unfoldintac occ rdx t (kt,_) gl = +let unfoldintac occ rdx t (kt,_) = + Proofview.V82.tactic begin fun gl -> let fs sigma x = Reductionops.nf_evar sigma x in let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let (sigma, t), const = strip_unfold_term env0 t kt in @@ -286,9 +302,10 @@ let unfoldintac occ rdx t (kt,_) gl = with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in Proofview.V82.of_tactic (convert_concl ~check:true concl) gl -;; + end -let foldtac occ rdx ft gl = +let foldtac occ rdx ft = + Proofview.V82.tactic begin fun gl -> let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let sigma, t = ft in let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in @@ -313,7 +330,7 @@ let foldtac occ rdx ft gl = let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in let _ = conclude () in Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.of_constr concl)) gl -;; + end let converse_dir = function L2R -> R2L | R2L -> L2R @@ -337,7 +354,8 @@ exception PRtype_error of (Environ.env * Evd.evar_map * Pretype_errors.pretype_e let id_map_redex _ sigma ~before:_ ~after = sigma, after -let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = +let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_rdx dir (sigma, c) c_ty = + Proofview.V82.tactic begin fun gl -> (* ppdebug(lazy(str"sigma@pirrel_rewrite=" ++ pr_evar_map None sigma)); *) let env = pf_env gl in let beta = Reductionops.clos_norm_flags CClosure.beta env sigma in @@ -369,8 +387,8 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ in ppdebug(lazy Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); ppdebug(lazy Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); - try refine_with - ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof) gl + try Proofview.V82.of_tactic (refine_with + ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof)) gl with _ -> (* we generate a msg like: "Unable to find an instance for the variable" *) let hd_ty, miss = match EConstr.kind sigma c with @@ -393,62 +411,73 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ | _ -> anomaly "rewrite rule not an application" in errorstrm Pp.(Himsg.explain_refiner_error env sigma (Logic.UnresolvedBindings miss)++ (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_econstr_env env sigma hd_ty)) -;; + end + +let pf_merge_uc_of s sigma = + Evd.merge_universe_context sigma (Evd.evar_universe_context s) -let rwcltac ?under ?map_redex cl rdx dir sr gl = +let rwcltac ?under ?map_redex cl rdx dir sr = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma0 = Proofview.Goal.sigma gl in let sr = let sigma, r = sr in - let sigma = resolve_typeclasses ~where:r ~fail:false (pf_env gl) sigma in + let sigma = resolve_typeclasses ~where:r ~fail:false env sigma in sigma, r in - let n, r_n,_, ucst = pf_abs_evars gl sr in - let r_n' = pf_abs_cterm gl n r_n in + let n, r_n,_, ucst = abs_evars env sigma0 sr in + let r_n' = abs_cterm env sigma0 n r_n in let r' = EConstr.Vars.subst_var pattern_id r_n' in - let gl = pf_unsafe_merge_uc ucst gl in - let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in + let sigma0 = Evd.set_universe_context sigma0 ucst in + let rdxt = Retyping.get_type_of env (fst sr) rdx in (* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) - ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env (pf_env gl) (project gl) (snd sr))); - let cvtac, rwtac, gl = - if EConstr.Vars.closed0 (project gl) r' then - let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in + ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env env sigma0 (snd sr))); + let cvtac, rwtac, sigma0 = + if EConstr.Vars.closed0 sigma0 r' then + let sigma, c, c_eq = fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); let open EConstr in match kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with | AtomicType(e, a) when Ssrcommon.is_ind_ref sigma e c_eq -> let new_rdx = if dir = L2R then a.(2) else a.(1) in - pirrel_rewrite ?under ?map_redex cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl + pirrel_rewrite ?under ?map_redex cl rdx rdxt new_rdx dir (sigma,c) c_ty, Tacticals.New.tclIDTAC, sigma0 | _ -> let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl, [|rdx|]) in let sigma, _ = Typing.type_of env sigma cl' in - let gl = pf_merge_uc_of sigma gl in - Proofview.V82.of_tactic (convert_concl ~check:true cl'), rewritetac ?under dir r', gl + let sigma0 = pf_merge_uc_of sigma sigma0 in + convert_concl ~check:true cl', rewritetac ?under dir r', sigma0 else - let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in + let dc, r2 = EConstr.decompose_lam_n_assum sigma0 n r' in let r3, _, r3t = - try EConstr.destCast (project gl) r2 with _ -> - errorstrm Pp.(str "no cast from " ++ pr_econstr_pat (pf_env gl) (project gl) (snd sr) - ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in + try EConstr.destCast sigma0 r2 with _ -> + errorstrm Pp.(str "no cast from " ++ pr_econstr_pat env sigma0 (snd sr) + ++ str " to " ++ pr_econstr_env env sigma0 r2) in let cl' = EConstr.mkNamedProd (make_annot rule_id Sorts.Relevant) (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in let cl'' = EConstr.mkNamedProd (make_annot pattern_id Sorts.Relevant) rdxt cl' in let itacs = [introid pattern_id; introid rule_id] in - let cltac = Proofview.V82.of_tactic (Tactics.clear [pattern_id; rule_id]) in + let cltac = Tactics.clear [pattern_id; rule_id] in let rwtacs = [rewritetac ?under dir (EConstr.mkVar rule_id); cltac] in - apply_type cl'' [rdx; EConstr.it_mkLambda_or_LetIn r3 dc], tclTHENLIST (itacs @ rwtacs), gl + Tactics.apply_type ~typecheck:true cl'' [rdx; EConstr.it_mkLambda_or_LetIn r3 dc], Tacticals.New.tclTHENLIST (itacs @ rwtacs), sigma0 in - let cvtac' _ = - try cvtac gl with - | PRtype_error e -> + let cvtac' = + Proofview.tclOR cvtac begin function + | (PRtype_error e, _) -> let error = Option.cata (fun (env, sigma, te) -> Pp.(fnl () ++ str "Type error was: " ++ Himsg.explain_pretype_error env sigma te)) (Pp.mt ()) e in - if occur_existential (project gl) (Tacmach.pf_concl gl) - then errorstrm Pp.(str "Rewriting impacts evars" ++ error) - else errorstrm Pp.(str "Dependent type error in rewrite of " - ++ pr_econstr_env (pf_env gl) (project gl) + if occur_existential sigma0 (Tacmach.New.pf_concl gl) + then Tacticals.New.tclZEROMSG Pp.(str "Rewriting impacts evars" ++ error) + else Tacticals.New.tclZEROMSG Pp.(str "Dependent type error in rewrite of " + ++ pr_econstr_env env sigma0 (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl) ++ error) + | (e, info) -> Proofview.tclZERO ~info e + end in - tclTHEN cvtac' rwtac gl + Proofview.Unsafe.tclEVARS sigma0 <*> + Tacticals.New.tclTHEN cvtac' rwtac + end [@@@ocaml.warning "-3"] let lz_coq_prod = @@ -474,14 +503,13 @@ let ssr_is_setoid env = Rewrite.is_applied_rewrite_relation env sigma [] (EConstr.mkApp (r, args)) <> None -let closed0_check cl p gl = +let closed0_check env sigma cl p = if closed0 cl then - errorstrm Pp.(str"No occurrence of redex "++ pr_constr_env (pf_env gl) (project gl) p) + errorstrm Pp.(str"No occurrence of redex "++ pr_constr_env env sigma p) let dir_org = function L2R -> 1 | R2L -> 2 -let rwprocess_rule dir rule gl = - let env = pf_env gl in +let rwprocess_rule env dir rule = let coq_prod = lz_coq_prod () in let is_setoid = ssr_is_setoid env in let r_sigma, rules = @@ -558,15 +586,17 @@ let rwprocess_rule dir rule gl = in r_sigma, rules -let rwrxtac ?under ?map_redex occ rdx_pat dir rule gl = - let env = pf_env gl in - let r_sigma, rules = rwprocess_rule dir rule gl in +let rwrxtac ?under ?map_redex occ rdx_pat dir rule = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma0 = Proofview.Goal.sigma gl in + let r_sigma, rules = rwprocess_rule env dir rule in let find_rule rdx = let rec rwtac = function | [] -> - errorstrm Pp.(str "pattern " ++ pr_econstr_pat env (project gl) rdx ++ + errorstrm Pp.(str "pattern " ++ pr_econstr_pat env sigma0 rdx ++ str " does not match " ++ pr_dir_side dir ++ - str " of " ++ pr_econstr_pat env (project gl) (snd rule)) + str " of " ++ pr_econstr_pat env sigma0 (snd rule)) | (d, r, lhs, rhs) :: rs -> try let ise = unify_HO env (Evd.create_evar_defs r_sigma) lhs rdx in @@ -574,7 +604,8 @@ let rwrxtac ?under ?map_redex occ rdx_pat dir rule gl = d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) with _ -> rwtac rs in rwtac rules in - let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in + let env0 = env in + let concl0 = Proofview.Goal.concl gl in let find_R, conclude = match rdx_pat with | Some (_, (In_T _ | In_X_In_T _)) | None -> let upats_origin = dir, EConstr.Unsafe.to_constr (snd rule) in @@ -586,23 +617,26 @@ let rwrxtac ?under ?map_redex occ rdx_pat dir rule gl = let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in (fun e c _ i -> find_R ~k:(fun _ _ _ h -> mkRel h) e c i), - fun cl -> let rdx,d,r = end_R () in closed0_check cl rdx gl; (d,r),rdx + fun cl -> let rdx,d,r = end_R () in closed0_check env0 sigma0 cl rdx; (d,r),rdx | Some(_, (T e | X_In_T (_,e) | E_As_X_In_T (e,_,_) | E_In_X_In_T (e,_,_))) -> let r = ref None in (fun env c _ h -> do_once r (fun () -> find_rule (EConstr.of_constr c), c); mkRel h), - (fun concl -> closed0_check concl e gl; + (fun concl -> closed0_check env0 sigma0 concl e; let (d,(ev,ctx,c)) , x = assert_done r in (d,(ev,ctx, EConstr.to_constr ~abort_on_undefined_evars:false ev c)) , x) in - let concl0 = EConstr.Unsafe.to_constr concl0 in + let concl0 = EConstr.to_constr ~abort_on_undefined_evars:false sigma0 concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in let (d, r), rdx = conclude concl in let r = Evd.merge_universe_context (pi1 r) (pi2 r), EConstr.of_constr (pi3 r) in - rwcltac ?under ?map_redex (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl -;; - -let ssrinstancesofrule ist dir arg gl = - let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in - let rule = interp_term ist gl arg in - let r_sigma, rules = rwprocess_rule dir rule gl in + rwcltac ?under ?map_redex (EConstr.of_constr concl) (EConstr.of_constr rdx) d r + end + +let ssrinstancesofrule ist dir arg = + Proofview.Goal.enter begin fun gl -> + let env0 = Proofview.Goal.env gl in + let sigma0 = Proofview.Goal.sigma gl in + let concl0 = Proofview.Goal.concl gl in + let rule = interp_term env0 sigma0 ist arg in + let r_sigma, rules = rwprocess_rule env0 dir rule in let find, conclude = let upats_origin = dir, EConstr.Unsafe.to_constr (snd rule) in let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = @@ -619,33 +653,47 @@ let ssrinstancesofrule ist dir arg gl = Feedback.msg_info Pp.(str"BEGIN INSTANCES"); try while true do - ignore(find env0 (EConstr.Unsafe.to_constr concl0) 1 ~k:print) + ignore(find env0 (EConstr.to_constr ~abort_on_undefined_evars:false sigma0 concl0) 1 ~k:print) done; raise NoMatch - with NoMatch -> Feedback.msg_info Pp.(str"END INSTANCES"); tclIDTAC gl - -let ipat_rewrite occ dir c gl = rwrxtac occ None dir (project gl, c) gl - -let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) gl = + with NoMatch -> Feedback.msg_info Pp.(str"END INSTANCES"); Tacticals.New.tclIDTAC + end + +let ipat_rewrite occ dir c = Proofview.Goal.enter begin fun gl -> + rwrxtac occ None dir (Proofview.Goal.sigma gl, c) +end + +let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt))) = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let fail = ref false in - let interp_rpattern gl gc = - try interp_rpattern gl gc - with _ when snd mult = May -> fail := true; project gl, T mkProp in - let interp gc gl = - try interp_term ist gl gc - with _ when snd mult = May -> fail := true; (project gl, EConstr.mkProp) in - let rwtac gl = - let rx = Option.map (interp_rpattern gl) grx in - let gl = match rx with - | None -> gl - | Some (s,_) -> pf_merge_uc_of s gl in - let t = interp gt gl in - let gl = pf_merge_uc_of (fst t) gl in + let interp_rpattern env sigma gc = + try interp_rpattern env sigma gc + with _ when snd mult = May -> fail := true; sigma, T mkProp in + let interp env sigma gc = + try interp_term env sigma ist gc + with _ when snd mult = May -> fail := true; (sigma, EConstr.mkProp) in + let rwtac = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let rx = Option.map (interp_rpattern env sigma) grx in + let sigma = match rx with + | None -> sigma + | Some (s,_) -> pf_merge_uc_of s sigma in + let t = interp env sigma gt in + let sigma = pf_merge_uc_of (fst t) sigma in + Proofview.Unsafe.tclEVARS sigma <*> (match kind with | RWred sim -> simplintac occ rx sim | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt - | RWeq -> rwrxtac ?under ?map_redex occ rx dir t) gl in - let ctac = old_cleartac (interp_clr (project gl) (oclr, (fst gt, snd (interp gt gl)))) in - if !fail then ctac gl else tclTHEN (tclMULT mult rwtac) ctac gl + | RWeq -> rwrxtac ?under ?map_redex occ rx dir t) + end + in + let ctac = cleartac (interp_clr sigma (oclr, (fst gt, snd (interp env sigma gt)))) in + if !fail then ctac else Tacticals.New.tclTHEN (tclMULT mult rwtac) ctac + end (** Rewrite argument sequence *) @@ -654,24 +702,37 @@ let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt) (** The "rewrite" tactic *) let ssrrewritetac ?under ?map_redex ist rwargs = - tclTHENLIST (List.map (rwargtac ?under ?map_redex ist) rwargs) + Proofview.Goal.enter begin fun _ -> + Tacticals.New.tclTHENLIST (List.map (rwargtac ?under ?map_redex ist) rwargs) + end (** The "unlock" tactic *) -let unfoldtac occ ko t kt gl = - let env = pf_env gl in - let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term env t kt)) in - let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref env (project gl) c] gl c) cl in +let unfoldtac occ ko t kt = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let concl = Evarutil.nf_evar sigma concl in + let cl, c = fill_occ_term env sigma concl occ (fst (strip_unfold_term env t kt)) in + let cl' = EConstr.Vars.subst1 (Tacred.unfoldn [OnlyOccurrences [1], get_evalref env sigma c] env sigma c) cl in let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in - Proofview.V82.of_tactic - (convert_concl ~check:true (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl - -let unlocktac ist args gl = - let utac (occ, gt) gl = - unfoldtac occ occ (interp_term ist gl gt) (fst gt) gl in - let locked, gl = pf_mkSsrConst "locked" gl in - let key, gl = pf_mkSsrConst "master_key" gl in + convert_concl ~check:true (Reductionops.clos_norm_flags f env sigma cl') + end + +let unlocktac ist args = + let open Proofview.Notations in + let utac (occ, gt) = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + unfoldtac occ occ (interp_term env sigma ist gt) (fst gt) + end + in + Ssrcommon.tacMK_SSR_CONST "locked" >>= fun locked -> + Ssrcommon.tacMK_SSR_CONST "master_key" >>= fun key -> let ktacs = [ - (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); - Proofview.V82.of_tactic (Ssrelim.casetac key (fun ?seed:_ k -> k)) ] in - tclTHENLIST (List.map utac args @ ktacs) gl + (Proofview.tclEVARMAP >>= fun sigma -> unfoldtac None None (sigma, locked) xInParens); + Ssrelim.casetac key (fun ?seed:_ k -> k) + ] in + Tacticals.New.tclTHENLIST (List.map utac args @ ktacs) diff --git a/plugins/ssr/ssrequality.mli b/plugins/ssr/ssrequality.mli index 0bb67c99db..1c3b1bb018 100644 --- a/plugins/ssr/ssrequality.mli +++ b/plugins/ssr/ssrequality.mli @@ -26,12 +26,12 @@ val mkclr : ssrclear -> ssrdocc val nodocc : ssrdocc val noclr : ssrdocc -val simpltac : Ssrast.ssrsimpl -> Tacmach.tactic +val simpltac : Ssrast.ssrsimpl -> unit Proofview.tactic val newssrcongrtac : int * Ssrast.ssrterm -> Ltac_plugin.Tacinterp.interp_sign -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic val mk_rwarg : @@ -49,7 +49,7 @@ val ssrinstancesofrule : Ltac_plugin.Tacinterp.interp_sign -> Ssrast.ssrdir -> Ssrast.ssrterm -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic (* map_redex (by default the identity on after) is called on the * redex (before) and its replacement (after). It is used to @@ -59,11 +59,11 @@ val ssrrewritetac : ?map_redex:(Environ.env -> Evd.evar_map -> before:EConstr.t -> after:EConstr.t -> Evd.evar_map * EConstr.t) -> Ltac_plugin.Tacinterp.interp_sign -> - ssrrwarg list -> Tacmach.tactic + ssrrwarg list -> unit Proofview.tactic -val ipat_rewrite : ssrocc -> ssrdir -> EConstr.t -> Tacmach.tactic +val ipat_rewrite : ssrocc -> ssrdir -> EConstr.t -> unit Proofview.tactic val unlocktac : Ltac_plugin.Tacinterp.interp_sign -> (Ssrmatching.occ * Ssrast.ssrterm) list -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 43b527c32b..4961138190 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -28,19 +28,22 @@ module RelDecl = Context.Rel.Declaration let posetac id cl = Proofview.V82.of_tactic (Tactics.pose_tac (Name id) cl) -let ssrposetac (id, (_, t)) gl = +let ssrposetac (id, (_, t)) = + Proofview.V82.tactic begin fun gl -> let ist, t = match t.Ssrast.interp_env with | Some ist -> ist, Ssrcommon.ssrterm_of_ast_closure_term t | None -> assert false in let sigma, t, ucst, _ = pf_abs_ssrterm ist gl t in posetac id t (pf_merge_uc ucst gl) + end -let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = +let ssrsettac id ((_, (pat, pty)), (_, occ)) = + Proofview.V82.tactic begin fun gl -> let pty = Option.map (fun { Ssrast.body; interp_env } -> let ist = Option.get interp_env in (mkRHole, Some body), ist) pty in - let pat = interp_cpattern gl pat pty in + let pat = interp_cpattern (pf_env gl) (project gl) pat pty in let cl, sigma, env = pf_concl gl, project gl, pf_env gl in let (c, ucst), cl = let cl = EConstr.Unsafe.to_constr cl in @@ -56,7 +59,8 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) | _ -> c, pfe_type_of gl c in let cl' = EConstr.mkLetIn (make_annot (Name id) Sorts.Relevant, c, cty, cl) in - Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl')) (introid id) gl + Proofview.V82.of_tactic (Tacticals.New.tclTHEN (convert_concl ~check:true cl') (introid id)) gl + end open Util @@ -85,18 +89,30 @@ let combineCG t1 t2 f g = match t1, t2 with | _, (_, (_, None)) -> anomaly "have: mixed C-G constr" | _ -> anomaly "have: mixed G-C constr" -let basecuttac name c gl = - let hd, gl = pf_mkSsrConst name gl in - let t = EConstr.mkApp (hd, [|c|]) in - let gl, _ = pf_e_type_of gl t in - Proofview.V82.of_tactic (Tactics.apply t) gl +let basecuttac name t = + let open Proofview.Notations in + Ssrcommon.tacMK_SSR_CONST name >>= fun hd -> + let t = EConstr.mkApp (hd, [|t|]) in + Ssrcommon.tacTYPEOF t >>= fun _ty -> + Tactics.apply t -let introstac ipats = Proofview.V82.of_tactic (tclIPAT ipats) +let evarcuttac name cs = + let open Proofview.Notations in + Ssrcommon.tacMK_SSR_CONST name >>= fun hd -> + let t = EConstr.mkApp (hd, cs) in + Ssrcommon.tacTYPEOF t >>= fun _ty -> + applyn ~with_evars:true ~with_shelve:false (Array.length cs) t + +let introstac ipats = tclIPAT ipats let havetac ist (transp,((((clr, orig_pats), binders), simpl), (((fk, _), t), hint))) - suff namefst gl + suff namefst = + let open Proofview.Notations in + Ssrcommon.tacMK_SSR_CONST "abstract_key" >>= fun abstract_key -> + Ssrcommon.tacMK_SSR_CONST "abstract" >>= fun abstract -> + Proofview.V82.tactic begin fun gl -> let concl = pf_concl gl in let pats = tclCompileIPats orig_pats in let binders = tclCompileIPats binders in @@ -108,34 +124,30 @@ let havetac ist match clr with | None -> introstac pats, [] | Some clr -> introstac (tclCompileIPats (IPatClear clr :: orig_pats)), clr in - let itac, id, clr = introstac pats, Tacticals.tclIDTAC, old_cleartac clr in + let itac, id, clr = introstac pats, Tacticals.New.tclIDTAC, cleartac clr in let binderstac n = let rec aux = function 0 -> [] | n -> IOpInaccessible None :: aux (n-1) in - Tacticals.tclTHEN (if binders <> [] then introstac (aux n) else Tacticals.tclIDTAC) + Tacticals.New.tclTHEN (if binders <> [] then introstac (aux n) else Tacticals.New.tclIDTAC) (introstac binders) in let simpltac = introstac simpl in let fixtc = not !ssrhaveNOtcresolution && match fk with FwdHint(_,true) -> false | _ -> true in let hint = hinttac ist true hint in - let cuttac t gl = - if transp then - let have_let, gl = pf_mkSsrConst "ssr_have_let" gl in - let step = EConstr.mkApp (have_let, [|concl;t|]) in - let gl, _ = pf_e_type_of gl step in - applyn ~with_evars:true ~with_shelve:false 2 step gl - else basecuttac "ssr_have" t gl in + let cuttac t = Proofview.Goal.enter begin fun gl -> + if transp then evarcuttac "ssr_have_let" [|concl;t|] + else basecuttac "ssr_have" t + end in (* Introduce now abstract constants, so that everything sees them *) - let abstract_key, gl = pf_mkSsrConst "abstract_key" gl in let unlock_abs (idty,args_id) gl = let gl, _ = pf_e_type_of gl idty in pf_unify_HO gl args_id.(2) abstract_key in - Tacticals.tclTHENFIRST itac_mkabs (fun gl -> + Tacticals.tclTHENFIRST (Proofview.V82.of_tactic itac_mkabs) (fun gl -> let mkt t = mk_term xNoFlag t in let mkl t = (xNoFlag, (t, None)) in let interp gl rtc t = pf_abs_ssrterm ~resolve_typeclasses:rtc ist gl t in let interp_ty gl rtc t = - let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc ist gl t in a,b,u in + let a,b,_,u = pf_interp_ty ~resolve_typeclasses:rtc (pf_env gl) (project gl) ist t in a,b,u in let open CAst in let ct, cty, hole, loc = match Ssrcommon.ssrterm_of_ast_closure_term t with | _, (_, Some { loc; v = CCast (ct, CastConv cty)}) -> @@ -163,7 +175,7 @@ let havetac ist try Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) Sorts.Relevant concl)) in - gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c + gl, ty, Tacticals.New.tclTHEN (Proofview.V82.tactic assert_is_conv) (Tactics.apply t), id, itac_c | FwdHave, false, false -> let skols = List.flatten (List.map (function | IOpAbstractVars ids -> ids @@ -181,13 +193,12 @@ let havetac ist let gs = List.map (fun (_,a) -> Ssripats.Internal.pf_find_abstract_proof false gl (EConstr.Unsafe.to_constr a.(1))) skols_args in - let tacopen_skols gl = re_sig (gs @ [gl.Evd.it]) gl.Evd.sigma in + let tacopen_skols = Proofview.V82.tactic (fun gl -> re_sig (gs @ [gl.Evd.it]) gl.Evd.sigma) in let gl, ty = pf_e_type_of gl t in - gl, ty, Proofview.V82.of_tactic (Tactics.apply t), id, - Tacticals.tclTHEN (Tacticals.tclTHEN itac_c simpltac) - (Tacticals.tclTHEN tacopen_skols (fun gl -> - let abstract, gl = pf_mkSsrConst "abstract" gl in - Proofview.V82.of_tactic (unfold [abstract; abstract_key]) gl)) + gl, ty, Tactics.apply t, id, + Tacticals.New.tclTHEN (Tacticals.New.tclTHEN itac_c simpltac) + (Tacticals.New.tclTHEN tacopen_skols (Proofview.V82.tactic (fun gl -> + Proofview.V82.of_tactic (unfold [abstract; abstract_key]) gl))) | _,true,true -> let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in gl, EConstr.mkArrow ty Sorts.Relevant concl, hint, itac, clr @@ -196,11 +207,11 @@ let havetac ist gl, EConstr.mkArrow ty Sorts.Relevant concl, hint, id, itac_c | _, false, false -> let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in - gl, cty, Tacticals.tclTHEN (binderstac n) hint, id, Tacticals.tclTHEN itac_c simpltac + gl, cty, Tacticals.New.tclTHEN (binderstac n) hint, id, Tacticals.New.tclTHEN itac_c simpltac | _, true, false -> assert false in - Tacticals.tclTHENS (cuttac cut) [ Tacticals.tclTHEN sol itac1; itac2 ] gl) + Proofview.V82.of_tactic (Tacticals.New.tclTHENS (cuttac cut) [ Tacticals.New.tclTHEN sol itac1; itac2 ]) gl) gl -;; +end let destProd_or_LetIn sigma c = match EConstr.kind sigma c with @@ -208,7 +219,8 @@ let destProd_or_LetIn sigma c = | LetIn (n,bo,ty,c) -> RelDecl.LocalDef (n, bo, ty), c | _ -> raise DestKO -let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = +let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave = + Proofview.V82.tactic begin fun gl -> let clr0 = Option.default [] clr0 in let pats = tclCompileIPats pats in let mkabs gen = abs_wgen false (fun x -> x) gen in @@ -243,7 +255,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let (sigma, ev) = Evarutil.new_evar env sigma EConstr.mkProp in let k, _ = EConstr.destEvar sigma ev in let fake_gl = {Evd.it = k; Evd.sigma = sigma} in - let _, ct, _, uc = pf_interp_ty ist fake_gl ct in + let _, ct, _, uc = pf_interp_ty (pf_env fake_gl) sigma ist ct in let rec var2rel c g s = match EConstr.kind sigma c, g with | Prod({binder_name=Anonymous} as x,_,c), [] -> EConstr.mkProd(x, EConstr.Vars.subst_vars s ct, c) | Sort _, [] -> EConstr.Vars.subst_vars s ct @@ -260,39 +272,40 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = c, args, pired c args, pf_merge_uc uc gl in let tacipat pats = introstac pats in let tacigens = - Tacticals.tclTHEN - (Tacticals.tclTHENLIST(List.rev(List.fold_right mkclr gens [old_cleartac clr0]))) + Tacticals.New.tclTHEN + (Tacticals.New.tclTHENLIST(List.rev(List.fold_right mkclr gens [cleartac clr0]))) (introstac (List.fold_right mkpats gens [])) in let hinttac = hinttac ist true hint in let cut_kind, fst_goal_tac, snd_goal_tac = match suff, ghave with - | true, `NoGen -> "ssr_wlog", Tacticals.tclTHEN hinttac (tacipat pats), tacigens - | false, `NoGen -> "ssr_wlog", hinttac, Tacticals.tclTHEN tacigens (tacipat pats) + | true, `NoGen -> "ssr_wlog", Tacticals.New.tclTHEN hinttac (tacipat pats), tacigens + | false, `NoGen -> "ssr_wlog", hinttac, Tacticals.New.tclTHEN tacigens (tacipat pats) | true, `Gen _ -> assert false | false, `Gen id -> if gens = [] then errorstrm(str"gen have requires some generalizations"); - let clear0 = old_cleartac clr0 in + let clear0 = cleartac clr0 in let id, name_general_hyp, cleanup, pats = match id, pats with | None, (IOpId id as ip)::pats -> Some id, tacipat [ip], clear0, pats - | None, _ -> None, Tacticals.tclIDTAC, clear0, pats + | None, _ -> None, Tacticals.New.tclIDTAC, clear0, pats | Some (Some id),_ -> Some id, introid id, clear0, pats | Some _,_ -> let id = mk_anon_id "tmp" (Tacmach.pf_ids_of_hyps gl) in - Some id, introid id, Tacticals.tclTHEN clear0 (Proofview.V82.of_tactic (Tactics.clear [id])), pats in + Some id, introid id, Tacticals.New.tclTHEN clear0 (Tactics.clear [id]), pats in let tac_specialize = match id with - | None -> Tacticals.tclIDTAC + | None -> Tacticals.New.tclIDTAC | Some id -> - if pats = [] then Tacticals.tclIDTAC else + if pats = [] then Tacticals.New.tclIDTAC else let args = Array.of_list args in ppdebug(lazy(str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args)))); ppdebug(lazy(str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct)); - Tacticals.tclTHENS (basecuttac "ssr_have" ct) - [Proofview.V82.of_tactic (Tactics.apply EConstr.(mkApp (mkVar id,args))); Tacticals.tclIDTAC] in + Tacticals.New.tclTHENS (basecuttac "ssr_have" ct) + [Tactics.apply EConstr.(mkApp (mkVar id,args)); Tacticals.New.tclIDTAC] in "ssr_have", (if hint = nohint then tacigens else hinttac), - Tacticals.tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] + Tacticals.New.tclTHENLIST [name_general_hyp; tac_specialize; tacipat pats; cleanup] in - Tacticals.tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac] gl + Proofview.V82.of_tactic (Tacticals.New.tclTHENS (basecuttac cut_kind c) [fst_goal_tac; snd_goal_tac]) gl + end (** The "suffice" tactic *) @@ -301,7 +314,7 @@ let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = let pats = tclCompileIPats pats in let binders = tclCompileIPats binders in let simpl = tclCompileIPats simpl in - let htac = Tacticals.tclTHEN (introstac pats) (hinttac ist true hint) in + let htac = Tacticals.New.tclTHEN (introstac pats) (hinttac ist true hint) in let c = match Ssrcommon.ssrterm_of_ast_closure_term c with | (a, (b, Some ct)) -> begin match ct.CAst.v with @@ -314,10 +327,12 @@ let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = | _ -> anomaly "suff: ssr cast hole deleted by typecheck" end in - let ctac gl = - let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in - basecuttac "ssr_suff" ty gl in - Tacticals.tclTHENS ctac [htac; Tacticals.tclTHEN (old_cleartac clr) (introstac (binders@simpl))] + let ctac = + Proofview.V82.tactic begin fun gl -> + let _,ty,_,uc = pf_interp_ty (pf_env gl) (project gl) ist c in let gl = pf_merge_uc uc gl in + Proofview.V82.of_tactic (basecuttac "ssr_suff" ty) gl + end in + Tacticals.New.tclTHENS ctac [htac; Tacticals.New.tclTHEN (cleartac clr) (introstac (binders@simpl))] open Proofview.Notations @@ -340,16 +355,14 @@ let intro_lock ipats = Proofview.tclDISPATCH (ncons (ng - 1) ssrsmovetac @ [Proofview.tclUNIT ()]) in let protect_subgoal env sigma hd args = + Ssrcommon.tacMK_SSR_CONST "Under_rel" >>= fun under_rel -> + Ssrcommon.tacMK_SSR_CONST "Under_rel_from_rel" >>= fun under_from_rel -> Tactics.New.refine ~typecheck:true (fun sigma -> let lm2 = Array.length args - 2 in let sigma, carrier = Typing.type_of env sigma args.(lm2) in let rel = EConstr.mkApp (hd, Array.sub args 0 lm2) in let rel_args = Array.sub args lm2 2 in - let sigma, under_rel = - Ssrcommon.mkSsrConst "Under_rel" env sigma in - let sigma, under_from_rel = - Ssrcommon.mkSsrConst "Under_rel_from_rel" env sigma in let under_rel_args = Array.append [|carrier; rel|] rel_args in let ty = EConstr.mkApp (under_rel, under_rel_args) in let sigma, t = Evarutil.new_evar env sigma ty in @@ -408,7 +421,7 @@ let pretty_rename evar_map term varnames = in aux term varnames -let overtac = Proofview.V82.tactic (ssr_n_tac "over" ~-1) +let overtac = ssr_n_tac "over" ~-1 let check_numgoals ?(minus = 0) nh = Proofview.numgoals >>= fun ng -> @@ -492,7 +505,6 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = @ [betaiota]) in let rew = - Proofview.V82.tactic - (Ssrequality.ssrrewritetac ~under:true ~map_redex ist [rule]) + Ssrequality.ssrrewritetac ~under:true ~map_redex ist [rule] in rew <*> intro_lock ipats <*> undertacs diff --git a/plugins/ssr/ssrfwd.mli b/plugins/ssr/ssrfwd.mli index 8aacae39af..33bf56cfa9 100644 --- a/plugins/ssr/ssrfwd.mli +++ b/plugins/ssr/ssrfwd.mli @@ -16,9 +16,9 @@ open Ltac_plugin open Ssrast -val ssrsettac : Id.t -> ((ssrfwdfmt * (Ssrmatching_plugin.Ssrmatching.cpattern * ast_closure_term option)) * ssrdocc) -> v82tac +val ssrsettac : Id.t -> ((ssrfwdfmt * (Ssrmatching_plugin.Ssrmatching.cpattern * ast_closure_term option)) * ssrdocc) -> unit Proofview.tactic -val ssrposetac : Id.t * (ssrfwdfmt * ast_closure_term) -> v82tac +val ssrposetac : Id.t * (ssrfwdfmt * ast_closure_term) -> unit Proofview.tactic val havetac : ist -> bool * @@ -27,11 +27,9 @@ val havetac : ist -> (((Ssrast.ssrfwdkind * 'a) * ast_closure_term) * (bool * Tacinterp.Value.t option list))) -> bool -> - bool -> v82tac + bool -> unit Proofview.tactic -val basecuttac : - string -> - EConstr.t -> Goal.goal Evd.sigma -> Evar.t list Evd.sigma +val basecuttac : string -> EConstr.t -> unit Proofview.tactic val wlogtac : Ltac_plugin.Tacinterp.interp_sign -> @@ -46,7 +44,7 @@ val wlogtac : Ltac_plugin.Tacinterp.Value.t Ssrast.ssrhint -> bool -> [< `Gen of Names.Id.t option option | `NoGen > `NoGen ] -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic val sufftac : Ssrast.ist -> @@ -55,7 +53,7 @@ val sufftac : (('a * ast_closure_term) * (bool * Tacinterp.Value.t option list)) -> - Tacmach.tactic + unit Proofview.tactic (* pad_intro (by default false) indicates whether the intro-pattern "=> i..." must be turned into "=> [i...|i...|i...|]" (n+1 branches, diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 1edec8e8a0..46f90a7ee1 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -191,7 +191,7 @@ let isGEN_PUSH dg = (* generalize `id` as `new_name` *) let gen_astac id new_name = let gen = ((None,Some(false,[])),Ssrmatching.cpattern_of_id id) in - V82.tactic (Ssrcommon.gentac gen) + Ssrcommon.gentac gen <*> Ssrcommon.tclRENAME_HD_PROD new_name (* performs and resets all delayed generalizations *) @@ -337,7 +337,7 @@ let tac_case t = Ssrcommon.tacTYPEOF t >>= fun ty -> Ssrcommon.tacIS_INJECTION_CASE ~ty t >>= fun is_inj -> if is_inj then - V82.tactic ~nf_evars:false (Ssrelim.perform_injection t) + Ssrelim.perform_injection t else Goal.enter begin fun g -> (Ssrelim.casetac t (fun ?seed k -> @@ -384,13 +384,11 @@ end let tclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let env, concl = Goal.(env gl, concl gl) in - let step = begin fun sigma -> + let step ablock abstract = begin fun sigma -> let (sigma, (abstract_proof, abstract_ty)) = let (sigma, (ty, _)) = Evarutil.new_type_evar env sigma Evd.univ_flexible_alg in - let (sigma, ablock) = Ssrcommon.mkSsrConst "abstract_lock" env sigma in let (sigma, lock) = Evarutil.new_evar env sigma ablock in - let (sigma, abstract) = Ssrcommon.mkSsrConst "abstract" env sigma in let (sigma, abstract_id) = mk_abstract_id env sigma in let abstract_ty = EConstr.mkApp(abstract, [|ty; abstract_id; lock|]) in let sigma, m = Evarutil.new_evar env sigma abstract_ty in @@ -405,7 +403,9 @@ let tclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let sigma, _ = Typing.type_of env sigma term in sigma, term end in - Tactics.New.refine ~typecheck:false step <*> + Ssrcommon.tacMK_SSR_CONST "abstract_lock" >>= fun ablock -> + Ssrcommon.tacMK_SSR_CONST "abstract" >>= fun abstract -> + Tactics.New.refine ~typecheck:false (step ablock abstract) <*> tclFOCUS 1 3 Proofview.shelve end @@ -477,7 +477,7 @@ let rec ipat_tac1 ipat : bool tactic = | IOpInj ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP - (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) + (fun t -> Ssrelim.perform_injection t)) ipatss <*> notTAC @@ -494,11 +494,11 @@ let rec ipat_tac1 ipat : bool tactic = notTAC | IOpSimpl x -> - V82.tactic ~nf_evars:false (Ssrequality.simpltac x) <*> notTAC + Ssrequality.simpltac x <*> notTAC | IOpRewrite (occ,dir) -> Ssrcommon.tclWITHTOP - (fun x -> V82.tactic ~nf_evars:false (Ssrequality.ipat_rewrite occ dir x)) <*> notTAC + (fun x -> Ssrequality.ipat_rewrite occ dir x) <*> notTAC | IOpAbstractVars ids -> tclMK_ABSTRACT_VARS ids <*> notTAC @@ -622,7 +622,7 @@ end let with_dgens { dgens; gens; clr } maintac = match gens with | [] -> with_defective maintac dgens clr | gen :: gens -> - V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, clr)) <*> maintac dgens gen + Ssrcommon.genstac (gens, clr) <*> maintac dgens gen let mkCoqEq env sigma = let eq = Coqlib.((build_coq_eq_data ()).eq) in @@ -647,7 +647,7 @@ let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = | ProdType (_, src, tgt) -> begin match kind_of_type sigma src with | AtomicType (hd, _) when Ssrcommon.is_protect hd env sigma -> - V82.tactic ~nf_evars:false Ssrcommon.unprotecttac <*> + Ssrcommon.unprotecttac <*> Ssrcommon.tclINTRO_ID ipat | _ -> Ssrcommon.tclINTRO_ANON () <*> intro_eq () end @@ -700,7 +700,7 @@ let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = | _ -> tclUNIT () in let unprotect = if eqid <> None && is_rec - then V82.tactic ~nf_evars:false Ssrcommon.unprotecttac else tclUNIT () in + then Ssrcommon.unprotecttac else tclUNIT () in begin match seed with | None -> ssrelim | Some s -> IpatMachine.tclSEED_SUBGOALS s ssrelim end <*> @@ -727,7 +727,7 @@ let mkEq dir cl c t n env sigma = let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin Ssrcommon.tacSIGMA >>= fun sigma0 -> Goal.enter_one begin fun g -> - let pat = Ssrmatching.interp_cpattern sigma0 t None in + let pat = Ssrmatching.interp_cpattern (Tacmach.pf_env sigma0) (Tacmach.project sigma0) t None in let cl0, env, sigma, hyps = Goal.(concl g, env g, sigma g, hyps g) in let cl = EConstr.to_constr ~abort_on_undefined_evars:false sigma cl0 in let (c, ucst), cl = @@ -816,7 +816,7 @@ let ssrcasetac (view, (eqid, (dgens, ipats))) = Ssrcommon.tacIS_INJECTION_CASE vc >>= fun inj -> let simple = (eqid = None && deps = [] && occ = None) in if simple && inj then - V82.tactic ~nf_evars:false (Ssrelim.perform_injection vc) <*> + Ssrelim.perform_injection vc <*> Tactics.clear (List.map Ssrcommon.hyp_id clear) <*> tclIPATssr ipats else @@ -870,7 +870,7 @@ let tclIPAT ip = let ssrmovetac = function | _::_ as view, (_, ({ gens = lastgen :: gens; clr }, ipats)) -> - let gentac = V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, [])) in + let gentac = Ssrcommon.genstac (gens, []) in let conclusion _ t clear ccl = Tactics.apply_type ~typecheck:true ccl [t] <*> Tactics.clear (List.map Ssrcommon.hyp_id clear) in @@ -884,7 +884,7 @@ let ssrmovetac = function let dgentac = with_dgens dgens eqmovetac in dgentac <*> tclIPAT (eqmoveipats (IpatMachine.tclCompileIPats [pat]) (IpatMachine.tclCompileIPats ipats)) | _, (_, ({ gens = (_ :: _ as gens); dgens = []; clr}, ipats)) -> - let gentac = V82.tactic ~nf_evars:false (Ssrcommon.genstac (gens, clr)) in + let gentac = Ssrcommon.genstac (gens, clr) in gentac <*> tclIPAT (IpatMachine.tclCompileIPats ipats) | _, (_, ({ clr }, ipats)) -> Tacticals.New.tclTHENLIST [ssrsmovetac; Tactics.clear (List.map Ssrcommon.hyp_id clr); tclIPAT (IpatMachine.tclCompileIPats ipats)] @@ -985,7 +985,7 @@ let ssrabstract dgens = Ssrcommon.tacSIGMA >>= fun gl0 -> let open Ssrmatching in let ipats = List.map (fun (_,cp) -> - match id_of_pattern (interp_cpattern gl0 cp None) with + match id_of_pattern (interp_cpattern (Tacmach.pf_env gl0) (Tacmach.project gl0) cp None) with | None -> IPatAnon (One None) | Some id -> IPatId id) (List.tl gens) in diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 9c83f9fa4e..60af804c1b 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -1611,17 +1611,6 @@ let tactic_expr = Pltac.tactic_expr (** 1. Utilities *) -(** Tactic-level diagnosis *) - -(* debug *) - -{ - -(* Let's play with the new proof engine API *) -let old_tac = V82.tactic - -} - (** Name generation *) (* Since Coq now does repeated internal checks of its external lexical *) @@ -1731,18 +1720,20 @@ END { -let ssrautoprop gl = +let ssrautoprop = + Proofview.Goal.enter begin fun gl -> try let tacname = try Tacenv.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) with Not_found -> Tacenv.locate_tactic (ssrqid "ssrautoprop") in let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in - V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl - with Not_found -> V82.of_tactic (Auto.full_trivial []) gl + eval_tactic (Tacexpr.TacArg tacexpr) + with Not_found -> Auto.full_trivial [] + end let () = ssrautoprop_tac := ssrautoprop -let tclBY tac = Tacticals.tclTHEN tac (donetac ~-1) +let tclBY tac = Tacticals.New.tclTHEN tac (donetac ~-1) (** Tactical arguments. *) @@ -1760,7 +1751,7 @@ open Ssrfwd } TACTIC EXTEND ssrtclby -| [ "by" ssrhintarg(tac) ] -> { V82.tactic (hinttac ist true tac) } +| [ "by" ssrhintarg(tac) ] -> { hinttac ist true tac } END (* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) @@ -1778,7 +1769,7 @@ END let () = register_ssrtac "tcldo" begin fun args ist -> match args with | [arg] -> let arg = cast_arg wit_ssrdoarg arg in - V82.tactic (ssrdotac ist arg) + ssrdotac ist arg | _ -> assert false end @@ -1827,7 +1818,7 @@ let () = register_ssrtac "tclseq" begin fun args ist -> match args with let tac = cast_arg wit_ssrtclarg tac in let dir = cast_arg wit_ssrseqdir dir in let arg = cast_arg wit_ssrseqarg arg in - V82.tactic (tclSEQAT ist tac dir arg) + tclSEQAT ist tac dir arg | _ -> assert false end @@ -2191,9 +2182,9 @@ let vmexacttac pf = TACTIC EXTEND ssrexact | [ "exact" ssrexactarg(arg) ] -> { let views, (gens_clr, _) = arg in - V82.tactic (tclBY (V82.of_tactic (inner_ssrapplytac views gens_clr ist))) } + tclBY (inner_ssrapplytac views gens_clr ist) } | [ "exact" ] -> { - V82.tactic (Tacticals.tclORELSE (donetac ~-1) (tclBY (V82.of_tactic apply_top_tac))) } + Tacticals.New.tclORELSE (donetac ~-1) (tclBY apply_top_tac) } | [ "exact" "<:" lconstr(pf) ] -> { vmexacttac pf } END @@ -2220,9 +2211,9 @@ END TACTIC EXTEND ssrcongr | [ "congr" ssrcongrarg(arg) ] -> { let arg, dgens = arg in - V82.tactic begin + Proofview.Goal.enter begin fun _ -> match dgens with - | [gens], clr -> Tacticals.tclTHEN (genstac (gens,clr)) (newssrcongrtac arg ist) + | [gens], clr -> Tacticals.New.tclTHEN (genstac (gens,clr)) (newssrcongrtac arg ist) | _ -> errorstrm (str"Dependent family abstractions not allowed in congr") end } END @@ -2342,10 +2333,10 @@ ARGUMENT EXTEND ssrrwarg END TACTIC EXTEND ssrinstofruleL2R -| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> { V82.tactic (ssrinstancesofrule ist L2R arg) } +| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> { ssrinstancesofrule ist L2R arg } END TACTIC EXTEND ssrinstofruleR2L -| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> { V82.tactic (ssrinstancesofrule ist R2L arg) } +| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> { ssrinstancesofrule ist R2L arg } END (** Rewrite argument sequence *) @@ -2395,7 +2386,7 @@ END TACTIC EXTEND ssrrewrite | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> - { tclCLAUSES (old_tac (ssrrewritetac ist args)) clauses } + { tclCLAUSES (ssrrewritetac ist args) clauses } END (** The "unlock" tactic *) @@ -2426,16 +2417,16 @@ END TACTIC EXTEND ssrunlock | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> - { tclCLAUSES (old_tac (unlocktac ist args)) clauses } + { tclCLAUSES (unlocktac ist args) clauses } END (** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) TACTIC EXTEND ssrpose -| [ "pose" ssrfixfwd(ffwd) ] -> { V82.tactic (ssrposetac ffwd) } -| [ "pose" ssrcofixfwd(ffwd) ] -> { V82.tactic (ssrposetac ffwd) } -| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> { V82.tactic (ssrposetac (id, fwd)) } +| [ "pose" ssrfixfwd(ffwd) ] -> { ssrposetac ffwd } +| [ "pose" ssrcofixfwd(ffwd) ] -> { ssrposetac ffwd } +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> { ssrposetac (id, fwd) } END (** The "set" tactic *) @@ -2444,7 +2435,7 @@ END TACTIC EXTEND ssrset | [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> - { tclCLAUSES (old_tac (ssrsettac id fwd)) clauses } + { tclCLAUSES (ssrsettac id fwd) clauses } END (** The "have" tactic *) @@ -2471,27 +2462,27 @@ END TACTIC EXTEND ssrhave | [ "have" ssrhavefwdwbinders(fwd) ] -> - { V82.tactic (havetac ist fwd false false) } + { havetac ist fwd false false } END TACTIC EXTEND ssrhavesuff | [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - { V82.tactic (havetac ist (false,(pats,fwd)) true false) } + { havetac ist (false,(pats,fwd)) true false } END TACTIC EXTEND ssrhavesuffices | [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - { V82.tactic (havetac ist (false,(pats,fwd)) true false) } + { havetac ist (false,(pats,fwd)) true false } END TACTIC EXTEND ssrsuffhave | [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - { V82.tactic (havetac ist (false,(pats,fwd)) true true) } + { havetac ist (false,(pats,fwd)) true true } END TACTIC EXTEND ssrsufficeshave | [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - { V82.tactic (havetac ist (false,(pats,fwd)) true true) } + { havetac ist (false,(pats,fwd)) true true } END (** The "suffice" tactic *) @@ -2515,11 +2506,11 @@ END TACTIC EXTEND ssrsuff -| [ "suff" ssrsufffwd(fwd) ] -> { V82.tactic (sufftac ist fwd) } +| [ "suff" ssrsufffwd(fwd) ] -> { sufftac ist fwd } END TACTIC EXTEND ssrsuffices -| [ "suffices" ssrsufffwd(fwd) ] -> { V82.tactic (sufftac ist fwd) } +| [ "suffices" ssrsufffwd(fwd) ] -> { sufftac ist fwd } END (** The "wlog" (Without Loss Of Generality) tactic *) @@ -2541,34 +2532,34 @@ END TACTIC EXTEND ssrwlog | [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - { V82.tactic (wlogtac ist pats fwd hint false `NoGen) } + { wlogtac ist pats fwd hint false `NoGen } END TACTIC EXTEND ssrwlogs | [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } + { wlogtac ist pats fwd hint true `NoGen } END TACTIC EXTEND ssrwlogss | [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> - { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } + { wlogtac ist pats fwd hint true `NoGen } END TACTIC EXTEND ssrwithoutloss | [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - { V82.tactic (wlogtac ist pats fwd hint false `NoGen) } + { wlogtac ist pats fwd hint false `NoGen } END TACTIC EXTEND ssrwithoutlosss | [ "without" "loss" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } + { wlogtac ist pats fwd hint true `NoGen } END TACTIC EXTEND ssrwithoutlossss | [ "without" "loss" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> - { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } + { wlogtac ist pats fwd hint true `NoGen } END { @@ -2617,14 +2608,14 @@ TACTIC EXTEND ssrgenhave | [ "gen" "have" ssrclear(clr) ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> { let pats = augment_preclr clr pats in - V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) } + wlogtac ist pats fwd hint false (`Gen id) } END TACTIC EXTEND ssrgenhave2 | [ "generally" "have" ssrclear(clr) ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> { let pats = augment_preclr clr pats in - V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) } + wlogtac ist pats fwd hint false (`Gen id) } END { diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 00d1296291..cbc352126e 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -30,10 +30,12 @@ let get_index = function Locus.ArgArg i -> i | _ -> (** The "first" and "last" tacticals. *) -let tclPERM perm tac gls = - let subgls = tac gls in +let tclPERM perm tac = + Proofview.V82.tactic begin fun gls -> + let subgls = Proofview.V82.of_tactic tac gls in let subgll' = perm subgls.Evd.it in re_sig subgll' subgls.Evd.sigma + end let rot_hyps dir i hyps = let n = List.length hyps in @@ -46,17 +48,17 @@ let rot_hyps dir i hyps = let tclSEQAT ist atac1 dir (ivar, ((_, atacs2), atac3)) = let i = get_index ivar in - let evtac t = Proofview.V82.of_tactic (ssrevaltac ist t) in + let evtac t = ssrevaltac ist t in let tac1 = evtac atac1 in if atacs2 = [] && atac3 <> None then tclPERM (rot_hyps dir i) tac1 else - let evotac = function Some atac -> evtac atac | _ -> Tacticals.tclIDTAC in + let evotac = function Some atac -> evtac atac | _ -> Tacticals.New.tclIDTAC in let tac3 = evotac atac3 in let rec mk_pad n = if n > 0 then tac3 :: mk_pad (n - 1) else [] in match dir, mk_pad (i - 1), List.map evotac atacs2 with - | L2R, [], [tac2] when atac3 = None -> Tacticals.tclTHENFIRST tac1 tac2 - | L2R, [], [tac2] when atac3 = None -> Tacticals.tclTHENLAST tac1 tac2 - | L2R, pad, tacs2 -> Tacticals.tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 - | R2L, pad, tacs2 -> Tacticals.tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) + | L2R, [], [tac2] when atac3 = None -> Tacticals.New.tclTHENFIRST tac1 tac2 + | L2R, [], [tac2] when atac3 = None -> Tacticals.New.tclTHENLAST tac1 tac2 + | L2R, pad, tacs2 -> Tacticals.New.tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3 + | R2L, pad, tacs2 -> Tacticals.New.tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad)) (** The "in" pseudo-tactical *)(* {{{ **********************************************) @@ -74,7 +76,7 @@ let check_wgen_uniq gens = | [] -> () in check [] ids -let pf_clauseids gl gens clseq = +let pf_clauseids gens clseq = let keep_clears = List.map (fun (x, _) -> x, None) in if gens <> [] then (check_wgen_uniq gens; gens) else if clseq <> InAll && clseq <> InAllHyps then keep_clears gens else @@ -82,14 +84,15 @@ let pf_clauseids gl gens clseq = let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false -let posetac id cl = Proofview.V82.of_tactic (Tactics.pose_tac (Name id) cl) +let posetac id cl = Tactics.pose_tac (Name id) cl let hidetacs clseq idhide cl0 = if not (hidden_clseq clseq) then [] else [posetac idhide cl0; - Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkVar idhide))] + convert_concl_no_check (EConstr.mkVar idhide)] -let endclausestac id_map clseq gl_id cl0 gl = +let endclausestac id_map clseq gl_id cl0 = + Proofview.V82.tactic begin fun gl -> let not_hyp' id = not (List.mem_assoc id id_map) in let orig_id id = try List.assoc id id_map with Not_found -> id in let dc, c = EConstr.decompose_prod_assum (project gl) (pf_concl gl) in @@ -124,40 +127,45 @@ let endclausestac id_map clseq gl_id cl0 gl = let all_ids = ids_of_rel_context dc @ pf_ids_of_hyps gl in if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else errorstrm Pp.(str "tampering with discharged assumptions of \"in\" tactical") - -let tclCLAUSES tac (gens, clseq) gl = - if clseq = InGoal || clseq = InSeqGoal then tac gl else - let clr_gens = pf_clauseids gl gens clseq in - let clear = Tacticals.tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in - let gl_id = mk_anon_id hidden_goal_tag (Tacmach.pf_ids_of_hyps gl) in - let cl0 = pf_concl gl in - let dtac gl = + end + +let tclCLAUSES tac (gens, clseq) = + Proofview.Goal.enter begin fun gl -> + if clseq = InGoal || clseq = InSeqGoal then tac else + let clr_gens = pf_clauseids gens clseq in + let clear = Tacticals.New.tclTHENLIST (List.rev(List.fold_right clr_of_wgen clr_gens [])) in + let gl_id = mk_anon_id hidden_goal_tag (Tacmach.New.pf_ids_of_hyps gl) in + let cl0 = Proofview.Goal.concl gl in + let dtac = + Proofview.V82.tactic begin fun gl -> let c = pf_concl gl in let gl, args, c = List.fold_right (abs_wgen true mk_discharged_id) gens (gl,[], c) in - apply_type c args gl in + apply_type c args gl + end + in let endtac = let id_map = CList.map_filter (function | _, Some ((x,_),_) -> let id = hoi_id x in Some (mk_discharged_id id, id) | _, None -> None) gens in endclausestac id_map clseq gl_id cl0 in - Tacticals.tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) gl + Tacticals.New.tclTHENLIST (hidetacs clseq gl_id cl0 @ [dtac; clear; tac; endtac]) + end (** The "do" tactical. ********************************************************) let hinttac ist is_by (is_or, atacs) = - let dtac = if is_by then donetac ~-1 else Tacticals.tclIDTAC in + Proofview.Goal.enter begin fun _ -> + let dtac = if is_by then donetac ~-1 else Tacticals.New.tclIDTAC in let mktac = function - | Some atac -> Tacticals.tclTHEN (Proofview.V82.of_tactic (ssrevaltac ist atac)) dtac + | Some atac -> Tacticals.New.tclTHEN (ssrevaltac ist atac) dtac | _ -> dtac in match List.map mktac atacs with - | [] -> if is_or then dtac else Tacticals.tclIDTAC + | [] -> if is_or then dtac else Tacticals.New.tclIDTAC | [tac] -> tac - | tacs -> Tacticals.tclFIRST tacs + | tacs -> Tacticals.New.tclFIRST tacs + end let ssrdotac ist (((n, m), tac), clauses) = let mul = get_index n, m in tclCLAUSES (tclMULT mul (hinttac ist false tac)) clauses - -let tclCLAUSES tac g_c = - Proofview.V82.(tactic (tclCLAUSES (of_tactic tac) g_c)) diff --git a/plugins/ssr/ssrtacticals.mli b/plugins/ssr/ssrtacticals.mli index c5b0deb752..f907ac3801 100644 --- a/plugins/ssr/ssrtacticals.mli +++ b/plugins/ssr/ssrtacticals.mli @@ -20,7 +20,7 @@ val tclSEQAT : int Locus.or_var * (('a * Tacinterp.Value.t option list) * Tacinterp.Value.t option) -> - Tacmach.tactic + unit Proofview.tactic val tclCLAUSES : unit Proofview.tactic -> @@ -33,7 +33,7 @@ val tclCLAUSES : val hinttac : Tacinterp.interp_sign -> - bool -> bool * Tacinterp.Value.t option list -> Ssrast.v82tac + bool -> bool * Tacinterp.Value.t option list -> unit Proofview.tactic val ssrdotac : Tacinterp.interp_sign -> @@ -44,5 +44,5 @@ val ssrdotac : Ssrmatching.cpattern option) option) list * Ssrast.ssrclseq) -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index 33e523a4a4..2252435658 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -107,7 +107,7 @@ ARGUMENT EXTEND ssrpatternarg TYPED AS rpattern PRINTED BY { pr_rpattern } END TACTIC EXTEND ssrinstoftpat -| [ "ssrinstancesoftpat" cpattern(arg) ] -> { Proofview.V82.tactic (ssrinstancesof arg) } +| [ "ssrinstancesoftpat" cpattern(arg) ] -> { ssrinstancesof arg } END { diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index d5a781e472..adaf7c8cc1 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -14,7 +14,6 @@ open Ltac_plugin open Names open Pp open Genarg -open Stdarg open Term open Context module CoqConstr = Constr @@ -22,7 +21,6 @@ open CoqConstr open Vars open Libnames open Tactics -open Tacticals open Termops open Recordops open Tacmach @@ -173,8 +171,6 @@ let loc_ofCG = function let mk_term k c ist = k, (mkRHole, Some c), ist let mk_lterm = mk_term ' ' -let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty - let nf_evar sigma c = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr c)) @@ -932,31 +928,15 @@ let id_of_Cterm t = match id_of_cpattern t with | Some x -> x | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here" -let of_ftactic ftac gl = - let r = ref None in - let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in - let tac = Proofview.V82.of_tactic tac in - let { sigma = sigma } = tac gl in - let ans = match !r with - | None -> assert false (* If the tactic failed we should not reach this point *) - | Some ans -> ans - in - (sigma, ans) - -let interp_wit wit ist gl x = - let globarg = in_gen (glbwit wit) x in - let arg = interp_genarg ist globarg in - let (sigma, arg) = of_ftactic arg gl in - sigma, Value.cast (topwit wit) arg -let interp_open_constr ist gl gc = - interp_wit wit_open_constr ist gl gc -let pf_intern_term gl (_, c, ist) = glob_constr ist (pf_env gl) (project gl) c +let interp_open_constr ist env sigma gc = + Tacinterp.interp_open_constr ist env sigma gc +let pf_intern_term env sigma (_, c, ist) = glob_constr ist env sigma c let interp_ssrterm ist gl t = Tacmach.project gl, interp_ssrterm ist t -let interp_term gl = function +let interp_term env sigma = function | (_, c, Some ist) -> - on_snd EConstr.Unsafe.to_constr (interp_open_constr ist gl c) + on_snd EConstr.Unsafe.to_constr (interp_open_constr ist env sigma c) | _ -> errorstrm (str"interpreting a term with no ist") let thin id sigma goal = @@ -982,7 +962,7 @@ let pr_ist { lfun= lfun } = pr_id id ++ str":" ++ Geninterp.Val.pr ty) (Id.Map.bindings lfun) *) -let interp_pattern ?wit_ssrpatternarg gl red redty = +let interp_pattern ?wit_ssrpatternarg env sigma0 red redty = pp(lazy(str"interpreting: " ++ pr_pattern red)); let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in @@ -990,7 +970,7 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = let mkG ?(k=' ') x ist = k,(x,None), ist in let ist_of (_,_,ist) = ist in let decode (_,_,ist as t) ?reccall f g = - try match DAst.get (pf_intern_term gl t) with + try match DAst.get (pf_intern_term env sigma0 t) with | GCast(t,CastConv c) when isGHole t && isGLambda c-> let (x, c) = destGLambda c in f x (' ',(c,None),ist) @@ -1008,7 +988,7 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = let cleanup_XinE h x rp sigma = let h_k = match kind h with Evar (k,_) -> k | _ -> assert false in let to_clean, update = (* handle rename if x is already used *) - let ctx = pf_hyps gl in + let ctx = Environ.named_context env in let len = Context.Named.length ctx in let name = ref None in try ignore(Context.Named.lookup x ctx); (name, fun k -> @@ -1019,7 +999,6 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = name := Some (Context.Named.Declaration.get_id (List.nth nctx (nlen - len - 1))) end) with Not_found -> ref (Some x), fun _ -> () in - let sigma0 = project gl in let new_evars = let rec aux acc t = match kind t with | Evar (k,_) -> @@ -1072,13 +1051,13 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = match red with | T t -> T (combineCG t ty (mkCCast ?loc:(loc_ofCG t)) mkRCast) | X_In_T (x,t) -> - let gty = pf_intern_term gl ty in + let gty = pf_intern_term env sigma0 ty in E_As_X_In_T (mkG (mkRCast mkRHole gty) (ist_of ty), x, t) | E_In_X_In_T (e,x,t) -> - let ty = mkG (pf_intern_term gl ty) (ist_of ty) in + let ty = mkG (pf_intern_term env sigma0 ty) (ist_of ty) in E_In_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) | E_As_X_In_T (e,x,t) -> - let ty = mkG (pf_intern_term gl ty) (ist_of ty) in + let ty = mkG (pf_intern_term env sigma0 ty) (ist_of ty) in E_As_X_In_T (combineCG e ty (mkCCast ?loc:(loc_ofCG t)) mkRCast, x, t) | red -> red in pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); @@ -1086,12 +1065,12 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = | Some b -> a,(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)), ist | None -> a,(DAst.make ?loc @@ GLetIn (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None), ist in match red with - | T t -> let sigma, t = interp_term gl t in sigma, T t - | In_T t -> let sigma, t = interp_term gl t in sigma, In_T t + | T t -> let sigma, t = interp_term env sigma0 t in sigma, T t + | In_T t -> let sigma, t = interp_term env sigma0 t in sigma, In_T t | X_In_T (x, rp) | In_X_In_T (x, rp) -> let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in let rp = mkXLetIn (Name x) rp in - let sigma, rp = interp_term gl rp in + let sigma, rp = interp_term env sigma0 rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in let rp = subst1 h (nf_evar sigma rp) in @@ -1100,15 +1079,15 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = let mk e x p = match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in let rp = mkXLetIn (Name x) rp in - let sigma, rp = interp_term gl rp in + let sigma, rp = interp_term env sigma0 rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in let rp = subst1 h (nf_evar sigma rp) in - let sigma, e = interp_term (re_sig (sig_it gl) sigma) e in + let sigma, e = interp_term env sigma e in sigma, mk e h rp ;; -let interp_cpattern gl red redty = interp_pattern gl (T red) redty;; -let interp_rpattern ~wit_ssrpatternarg gl red = interp_pattern ~wit_ssrpatternarg gl red None;; +let interp_cpattern env sigma red redty = interp_pattern env sigma (T red) redty;; +let interp_rpattern ~wit_ssrpatternarg env sigma red = interp_pattern ~wit_ssrpatternarg env sigma red None;; let id_of_pattern = function | _, T t -> (match kind t with Var id -> Some id | _ -> None) @@ -1245,23 +1224,23 @@ let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = let rdx, _, (sigma, uc, p) = end_U () in sigma, uc, EConstr.of_constr p, EConstr.of_constr concl, EConstr.of_constr rdx -let fill_occ_term env cl occ sigma0 (sigma, t) = +let fill_occ_term env sigma0 cl occ (sigma, t) = try let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in if sigma' != sigma0 then CErrors.user_err Pp.(str "matching impacts evars") - else cl, (Evd.merge_universe_context sigma' uc, t') + else cl, t' with NoMatch -> try let sigma', uc, t' = unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in if sigma' != sigma0 then raise NoMatch - else cl, (Evd.merge_universe_context sigma' uc, t') + else cl, t' with _ -> errorstrm (str "partial term " ++ pr_econstr_pat env sigma t ++ str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in - let cl,(_,t) = fill_occ_term env concl occ sigma0 t in + let cl, t = fill_occ_term env sigma0 concl occ t in cl, t let cpattern_of_id id = @@ -1286,18 +1265,23 @@ let wit_ssrpatternarg = wit_rpatternty let interp_rpattern = interp_rpattern ~wit_ssrpatternarg -let ssrpatterntac _ist arg gl = - let pat = interp_rpattern gl arg in - let sigma0 = project gl in - let concl0 = pf_concl gl in +let ssrpatterntac _ist arg = + let open Proofview.Notations in + Proofview.Goal.enter begin fun gl -> + let sigma0 = Proofview.Goal.sigma gl in + let concl0 = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let pat = interp_rpattern env sigma0 arg in let concl0 = EConstr.Unsafe.to_constr concl0 in let (t, uc), concl_x = - fill_occ_pattern (pf_env gl) sigma0 concl0 pat noindex 1 in + fill_occ_pattern env sigma0 concl0 pat noindex 1 in let t = EConstr.of_constr t in let concl_x = EConstr.of_constr concl_x in - let gl, tty = pf_type_of gl t in + let sigma, tty = Typing.type_of env sigma0 t in let concl = EConstr.mkLetIn (make_annot (Name (Id.of_string "selected")) Sorts.Relevant, t, tty, concl_x) in - Proofview.V82.of_tactic (convert_concl ~check:true concl DEFAULTcast) gl + Proofview.Unsafe.tclEVARS sigma <*> + convert_concl ~check:true concl DEFAULTcast + end (* Register "ssrpattern" tactic *) let () = @@ -1305,7 +1289,7 @@ let () = let arg = let v = Id.Map.find (Names.Id.of_string "pattern") ist.lfun in Value.cast (topwit wit_ssrpatternarg) v in - Proofview.V82.tactic (ssrpatterntac ist arg) in + ssrpatterntac ist arg in let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = @@ -1315,25 +1299,29 @@ let () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in Mltop.declare_cache_obj obj "ssrmatching_plugin" -let ssrinstancesof arg gl = +let ssrinstancesof arg = + Proofview.Goal.enter begin fun gl -> let ok rhs lhs ise = true in (* not (equal lhs (Evarutil.nf_evar ise rhs)) in *) - let env, sigma, concl = pf_env gl, project gl, pf_concl gl in - let concl = EConstr.Unsafe.to_constr concl in - let sigma0, cpat = interp_cpattern gl arg None in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let concl = EConstr.to_constr ~abort_on_undefined_evars:false sigma concl in + let sigma0, cpat = interp_cpattern env sigma arg None in let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in let find, conclude = mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma None (etpat,[tpat]) in - let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) p ++ spc() - ++ str "matches:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) c)); c in + let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr_env env (Proofview.Goal.sigma gl) p ++ spc() + ++ str "matches:" ++ spc() ++ pr_constr_env env (Proofview.Goal.sigma gl) c)); c in ppnl (str"BEGIN INSTANCES"); try while true do ignore(find env concl 1 ~k:print) done; raise NoMatch - with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl + with NoMatch -> ppnl (str"END INSTANCES"); Tacticals.New.tclIDTAC + end module Internal = struct diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 31b414cc42..17b47227cb 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -57,7 +57,7 @@ val redex_of_pattern : (** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat] in the current [Ltac] interpretation signature [ise] and tactic input [gl]*) val interp_rpattern : - goal sigma -> + Environ.env -> Evd.evar_map -> rpattern -> pattern @@ -65,7 +65,7 @@ val interp_rpattern : in the current [Ltac] interpretation signature [ise] and tactic input [gl]. [ty] is an optional type for the redex of [cpat] *) val interp_cpattern : - goal sigma -> + Environ.env -> Evd.evar_map -> cpattern -> (glob_constr_and_expr * Geninterp.interp_sign) option -> pattern @@ -191,6 +191,8 @@ val mk_tpattern_matcher : * by [Rel 1] and the instance of [t] *) val pf_fill_occ_term : goal sigma -> occ -> evar_map * EConstr.t -> EConstr.t * EConstr.t +val fill_occ_term : Environ.env -> Evd.evar_map -> EConstr.t -> occ -> evar_map * EConstr.t -> EConstr.t * EConstr.t + (* It may be handy to inject a simple term into the first form of cpattern *) val cpattern_of_term : char * glob_constr_and_expr -> Geninterp.interp_sign -> cpattern @@ -230,7 +232,7 @@ val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma (* One can also "Set SsrMatchingDebug" from a .v *) val debug : bool -> unit -val ssrinstancesof : cpattern -> Tacmach.tactic +val ssrinstancesof : cpattern -> unit Proofview.tactic (** Functions used for grammar extensions. Do not use. *) diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 767f93787d..695e103082 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -61,10 +61,7 @@ let clenv_pose_dependent_evars ?(with_evars=false) clenv = clenv_pose_metas_as_evars clenv dep_mvs let clenv_refine ?(with_evars=false) ?(with_classes=true) clenv = - (* ppedrot: a Goal.enter here breaks things, because the tactic below may - solve goals by side effects, while the compatibility layer keeps those - useless goals. That deserves a FIXME. *) - Proofview.V82.tactic begin fun gl -> + Proofview.Goal.enter begin fun gl -> let clenv, evars = clenv_pose_dependent_evars ~with_evars clenv in let evd' = if with_classes then @@ -78,9 +75,9 @@ let clenv_refine ?(with_evars=false) ?(with_classes=true) clenv = else clenv.evd in let clenv = { clenv with evd = evd' } in - tclTHEN - (tclEVARS (Evd.clear_metas evd')) - (refiner ~check:false EConstr.Unsafe.(to_constr (clenv_cast_meta clenv (clenv_value clenv)))) gl + Proofview.tclTHEN + (Proofview.Unsafe.tclEVARS (Evd.clear_metas evd')) + (refiner ~check:false EConstr.Unsafe.(to_constr (clenv_cast_meta clenv (clenv_value clenv)))) end let clenv_pose_dependent_evars ?(with_evars=false) clenv = diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 75c3436cf4..29a47c5acd 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -37,6 +37,8 @@ let refiner ~check = CProfile.profile2 refiner_key (refiner ~check) else refiner ~check +let refiner ~check c = Proofview.V82.tactic ~nf_evars:false (refiner ~check c) + (*********************) (* Tacticals *) (*********************) @@ -269,5 +271,3 @@ let tclAT_LEAST_ONCE t = (tclTHEN t (tclREPEAT t)) (* Change evars *) let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} -let tclPUSHEVARUNIVCONTEXT ctx gl = - tclEVARS (Evd.merge_universe_context (project gl) ctx) gl diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 66eae1db81..3471f38e9e 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -22,7 +22,7 @@ val project : 'a sigma -> evar_map val pf_env : Goal.goal sigma -> Environ.env val pf_hyps : Goal.goal sigma -> named_context -val refiner : check:bool -> Constr.t -> tactic +val refiner : check:bool -> Constr.t -> unit Proofview.tactic (** {6 Tacticals. } *) @@ -32,7 +32,6 @@ val tclIDTAC_MESSAGE : Pp.t -> tactic (** [tclEVARS sigma] changes the current evar map *) val tclEVARS : evar_map -> tactic -val tclPUSHEVARUNIVCONTEXT : UState.t -> tactic (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies diff --git a/stm/stm.ml b/stm/stm.ml index f3768e9b99..5790bfc07e 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2023,12 +2023,16 @@ end = struct (* {{{ *) match Future.join f with | Some (pt, uc) -> let sigma, env = PG_compat.get_current_context () in + let push_state ctx = + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.Unsafe.tclEVARS (Evd.merge_universe_context sigma ctx) + in stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ str"t=" ++ (Printer.pr_constr_env env sigma pt) ++ spc () ++ str"uc=" ++ Termops.pr_evar_universe_context uc)); (if abstract then Abstract.tclABSTRACT None else (fun x -> x)) - (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*> + (push_state uc <*> Tactics.exact_no_check (EConstr.of_constr pt)) | None -> if solve then Tacticals.New.tclSOLVE [] else tclUNIT () diff --git a/tactics/equality.ml b/tactics/equality.ml index f3073acb0a..e1d34af13e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1043,7 +1043,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in tclTHENS (assert_after Anonymous false_0) - [onLastHypId gen_absurdity; (Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf)))] + [onLastHypId gen_absurdity; (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf))] let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in @@ -1360,8 +1360,8 @@ let inject_if_homogenous_dependent_pair ty = tclTHENS (cut (mkApp (ceq,new_eq_args))) [clear [destVar sigma hyp]; Tacticals.New.pf_constr_of_global inj2 >>= fun inj2 -> - Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr - (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))) + Refiner.refiner ~check:true EConstr.Unsafe.(to_constr + (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) ])] with Exit -> Proofview.tclUNIT () @@ -1406,7 +1406,7 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [inject_if_homogenous_dependent_pair ty; - Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf))]) + Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf)]) (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 8f6844079b..07f9def2c8 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -368,6 +368,9 @@ module New = struct Proofview.Unsafe.tclNEWGOALS tl <*> Proofview.tclUNIT ans + let tclTHENSLASTn t1 repeat l = + tclTHENS3PARTS t1 [||] repeat l + let tclTHENLASTn t1 l = tclTHENS3PARTS t1 [||] (tclUNIT()) l let tclTHENLAST t1 t2 = tclTHENLASTn t1 [|t2|] diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 9ec558f1ad..01565169ca 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -180,6 +180,7 @@ module New : sig middle. Raises an error if the number of resulting subgoals is strictly less than [n+m] *) val tclTHENS3PARTS : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic + val tclTHENSLASTn : unit tactic -> unit tactic -> unit tactic array -> unit tactic val tclTHENSFIRSTn : unit tactic -> unit tactic array -> unit tactic -> unit tactic val tclTHENFIRSTn : unit tactic -> unit tactic array -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0df4f5b207..e4809332c5 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1368,7 +1368,7 @@ let clenv_refine_in with_evars targetid id sigma0 clenv tac = if not with_evars && occur_meta clenv.evd new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in - let exact_tac = Proofview.V82.tactic (Refiner.refiner ~check:false EConstr.Unsafe.(to_constr new_hyp_prf)) in + let exact_tac = Refiner.refiner ~check:false EConstr.Unsafe.(to_constr new_hyp_prf) in let naming = NamingMustBe (CAst.make targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN @@ -1670,7 +1670,7 @@ let descend_in_conjunctions avoid tac (err, info) c = | Some (p,pt) -> Tacticals.New.tclTHENS (assert_before_gen false (NamingAvoid avoid) pt) - [Proofview.V82.tactic (refiner ~check:true EConstr.Unsafe.(to_constr p)); + [refiner ~check:true EConstr.Unsafe.(to_constr p); (* Might be ill-typed due to forbidden elimination. *) Tacticals.New.onLastHypId (tac (not isrec))] end))) diff --git a/test-suite/bugs/closed/bug_12196.v b/test-suite/bugs/closed/bug_12196.v new file mode 100644 index 0000000000..c0851b3204 --- /dev/null +++ b/test-suite/bugs/closed/bug_12196.v @@ -0,0 +1,46 @@ +(** TODO: Figure out how to test "sanity" for the ltac profiler output *) +Fixpoint fact (n : nat) := match n with 0 => 1 | S n' => n * fact n' end. +Fixpoint walk (n : nat) := match n with 0 => tt | S n => walk n end. +Ltac slow := idtac + (do 2 (let x := eval lazy in (walk (fact 9)) in idtac)). +Ltac slow2 := idtac + (do 2 (let x := eval lazy in (walk (fact 9)) in idtac)). +Ltac multi := idtac + slow + slow2. +Set Ltac Profiling. +Goal True. + Time try (multi; fail). + (* Warning: Ltac Profiler cannot yet handle backtracking into multi-success + tactics; profiling results may be wildly inaccurate. + [profile-backtracking,ltac] *) + Show Ltac Profile. + (* Used to be: +total time: 0.000s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─multi --------------------------------- 47.1% 47.1% 1 0.000s +─slow ---------------------------------- 35.3% 35.3% 1 0.000s +─slow2 --------------------------------- 17.6% 17.6% 1 0.000s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─multi --------------------------------- 47.1% 47.1% 1 0.000s +─slow ---------------------------------- 35.3% 35.3% 1 0.000s +─slow2 --------------------------------- 17.6% 17.6% 1 0.000s + + *) + (* Now: +total time: 2.074s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─multi --------------------------------- 0.0% 100.0% 6 1.119s +─slow ---------------------------------- 54.0% 54.0% 3 1.119s +─slow2 --------------------------------- 46.0% 46.0% 3 0.955s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─multi --------------------------------- 0.0% 100.0% 6 1.119s + ├─slow -------------------------------- 54.0% 54.0% 3 1.119s + └─slow2 ------------------------------- 46.0% 46.0% 3 0.955s + +*) +Abort. diff --git a/test-suite/bugs/closed/bug_12257.v b/test-suite/bugs/closed/bug_12257.v new file mode 100644 index 0000000000..4962048a42 --- /dev/null +++ b/test-suite/bugs/closed/bug_12257.v @@ -0,0 +1,3 @@ +(* Test that ExtrHaskellString transitively requires ExtrHaskellBasic *) +Require Coq.extraction.ExtrHaskellString. +Import Coq.extraction.ExtrHaskellBasic. diff --git a/test-suite/bugs/closed/bug_6378.v b/test-suite/bugs/closed/bug_6378.v index 68ae7961dd..453924d587 100644 --- a/test-suite/bugs/closed/bug_6378.v +++ b/test-suite/bugs/closed/bug_6378.v @@ -7,11 +7,20 @@ Ltac profile_constr tac := Ltac slow _ := eval vm_compute in (Z.div_eucl, Z.div_eucl, Z.div_eucl, Z.div_eucl, Z.div_eucl). +Ltac manipulate_ltac_prof := + start ltac profiling; + reset ltac profile; + try ((idtac + reset ltac profile + idtac); fail); + try ((idtac + start ltac profiling + idtac); fail); + try ((idtac + stop ltac profiling + idtac); fail). + Goal True. start ltac profiling. reset ltac profile. + manipulate_ltac_prof. reset ltac profile. stop ltac profiling. + Set Warnings Append "+profile-invalid-stack-no-self". time profile_constr slow. show ltac profile cutoff 0. show ltac profile "slow". diff --git a/test-suite/complexity/ConstructiveCauchyRealsPerformance.v b/test-suite/complexity/ConstructiveCauchyRealsPerformance.v index c901334da9..f3bc1767da 100644 --- a/test-suite/complexity/ConstructiveCauchyRealsPerformance.v +++ b/test-suite/complexity/ConstructiveCauchyRealsPerformance.v @@ -105,7 +105,7 @@ Proof. Qed. Lemma approx_sqrt_Q_cauchy : - forall q:Q, QCauchySeq (approx_sqrt_Q q) id. + forall q:Q, QCauchySeq (approx_sqrt_Q q). Proof. intro q. destruct q as [k j]. destruct k. - intros n a b H H0. reflexivity. diff --git a/test-suite/micromega/bug_12210.v b/test-suite/micromega/bug_12210.v new file mode 100644 index 0000000000..ca011def09 --- /dev/null +++ b/test-suite/micromega/bug_12210.v @@ -0,0 +1,19 @@ +Require Import PeanoNat Lia. + +Goal forall x, Nat.le x x. +Proof. +intros. +lia. +Qed. + +Goal forall x, Nat.lt x x -> False. +Proof. +intros. +lia. +Qed. + +Goal forall x, Nat.eq x x. +Proof. +intros. +lia. +Qed. diff --git a/test-suite/output/Extraction_Haskell_String_12258.out b/test-suite/output/Extraction_Haskell_String_12258.out new file mode 100644 index 0000000000..615abaa3e8 --- /dev/null +++ b/test-suite/output/Extraction_Haskell_String_12258.out @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -cpp -XMagicHash #-} +{- For Hugs, use the option -F"cpp -P -traditional" -} + +{- IMPORTANT: If you change this file, make sure that running [cp + Extraction_Haskell_String_12258.out Extraction_Haskell_String_12258.hs && + ghc -o test Extraction_Haskell_String_12258.hs] succeeds -} + +module Main where + +import qualified Prelude + +#ifdef __GLASGOW_HASKELL__ +import qualified GHC.Base +#else +-- HUGS +import qualified IOExts +#endif + +#ifdef __GLASGOW_HASKELL__ +unsafeCoerce :: a -> b +unsafeCoerce = GHC.Base.unsafeCoerce# +#else +-- HUGS +unsafeCoerce :: a -> b +unsafeCoerce = IOExts.unsafeCoerce +#endif + +#ifdef __GLASGOW_HASKELL__ +type Any = GHC.Base.Any +#else +-- HUGS +type Any = () +#endif + +data Output_type_code = + Ascii_dec + | Ascii_eqb + | String_dec + | String_eqb + | Byte_eqb + | Byte_eq_dec + +type Output_type = Any + +output :: Output_type_code -> Output_type +output c = + case c of { + Ascii_dec -> + unsafeCoerce + ((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool); + Ascii_eqb -> + unsafeCoerce + ((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool); + String_dec -> + unsafeCoerce + ((Prelude.==) :: Prelude.String -> Prelude.String -> Prelude.Bool); + String_eqb -> + unsafeCoerce + ((Prelude.==) :: Prelude.String -> Prelude.String -> Prelude.Bool); + Byte_eqb -> + unsafeCoerce + ((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool); + Byte_eq_dec -> + unsafeCoerce + ((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)} + +type Coq__IO a = GHC.Base.IO a + +main :: GHC.Base.IO () +main = + ((Prelude.>>=) (GHC.Base.return output) (\_ -> GHC.Base.return ())) + + diff --git a/test-suite/output/Extraction_Haskell_String_12258.v b/test-suite/output/Extraction_Haskell_String_12258.v new file mode 100644 index 0000000000..063ff64337 --- /dev/null +++ b/test-suite/output/Extraction_Haskell_String_12258.v @@ -0,0 +1,52 @@ +Require Import Coq.extraction.Extraction. +Require Import Coq.extraction.ExtrHaskellString. +Extraction Language Haskell. +Set Extraction File Comment "IMPORTANT: If you change this file, make sure that running [cp Extraction_Haskell_String_12258.out Extraction_Haskell_String_12258.hs && ghc -o test Extraction_Haskell_String_12258.hs] succeeds". +Inductive output_type_code := +| ascii_dec +| ascii_eqb +| string_dec +| string_eqb +| byte_eqb +| byte_eq_dec +. + +Definition output_type_sig (c : output_type_code) : { T : Type & T } + := existT (fun T => T) + _ + match c return match c with ascii_dec => _ | _ => _ end with + | ascii_dec => Ascii.ascii_dec + | ascii_eqb => Ascii.eqb + | string_dec => String.string_dec + | string_eqb => String.eqb + | byte_eqb => Byte.eqb + | byte_eq_dec => Byte.byte_eq_dec + end. + +Definition output_type (c : output_type_code) + := Eval cbv [output_type_sig projT1 projT2] in + projT1 (output_type_sig c). +Definition output (c : output_type_code) : output_type c + := Eval cbv [output_type_sig projT1 projT2] in + match c return output_type c with + | ascii_dec as c + | _ as c + => projT2 (output_type_sig c) + end. + +Axiom IO_unit : Set. +Axiom _IO : Set -> Set. +Axiom _IO_bind : forall {A B}, _IO A -> (A -> _IO B) -> _IO B. +Axiom _IO_return : forall {A : Set}, A -> _IO A. +Axiom cast_io : _IO unit -> IO_unit. +Extract Constant _IO "a" => "GHC.Base.IO a". +Extract Inlined Constant _IO_bind => "(Prelude.>>=)". +Extract Inlined Constant _IO_return => "GHC.Base.return". +Extract Inlined Constant IO_unit => "GHC.Base.IO ()". +Extract Inlined Constant cast_io => "". + +Definition main : IO_unit + := cast_io (_IO_bind (_IO_return output) + (fun _ => _IO_return tt)). + +Recursive Extraction main. diff --git a/test-suite/output/Fixpoint.out b/test-suite/output/Fixpoint.out index 60bc9cbf55..ff7918b4e6 100644 --- a/test-suite/output/Fixpoint.out +++ b/test-suite/output/Fixpoint.out @@ -12,3 +12,27 @@ let fix f (m : nat) : nat := match m with Ltac f id1 id2 := fix id1 2 with (id2 (n:_) (H:odd n) {struct H} : n >= 1) = cofix inf : Inf := {| projS := inf |} : Inf +File "stdin", line 57, characters 0-51: +Warning: Not a truly recursive fixpoint. [non-recursive,fixpoints] +File "stdin", line 60, characters 0-103: +Warning: Not a fully mutually defined fixpoint +(k1 depends on k2 but not conversely). +Well-foundedness check may fail unexpectedly. + [non-full-mutual,fixpoints] +File "stdin", line 62, characters 0-106: +Warning: Not a fully mutually defined fixpoint +(l2 and l1 are not mutually dependent). +Well-foundedness check may fail unexpectedly. + [non-full-mutual,fixpoints] +File "stdin", line 64, characters 0-103: +Warning: Not a fully mutually defined fixpoint +(m2 and m1 are not mutually dependent). +Well-foundedness check may fail unexpectedly. + [non-full-mutual,fixpoints] +File "stdin", line 72, characters 0-25: +Warning: Not a truly recursive fixpoint. [non-recursive,fixpoints] +File "stdin", line 75, characters 0-48: +Warning: Not a fully mutually defined fixpoint +(a2 and a1 are not mutually dependent). +Well-foundedness check may fail unexpectedly. + [non-full-mutual,fixpoints] diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index 398528de72..26c276b68b 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -44,7 +44,39 @@ fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). lia. Qed. -CoInductive Inf := S { projS : Inf }. -Definition expand_Inf (x : Inf) := S (projS x). -CoFixpoint inf := S inf. +CoInductive Inf := IS { projS : Inf }. +Definition expand_Inf (x : Inf) := IS (projS x). +CoFixpoint inf := IS inf. Eval compute in inf. + +Module Recursivity. + +Open Scope nat_scope. + +Fixpoint f n := match n with 0 => 0 | S n => f n end. +Fixpoint g n := match n with 0 => 0 | S n => n end. +Fixpoint h1 n := match n with 0 => 0 | S n => h2 n end +with h2 n := match n with 0 => 0 | S n => h1 n end. +Fixpoint k1 n := match n with 0 => 0 | S n => k2 n end +with k2 n := match n with 0 => 0 | S n => n end. +Fixpoint l1 n := match n with 0 => 0 | S n => l1 n end +with l2 n := match n with 0 => 0 | S n => l2 n end. +Fixpoint m1 n := match n with 0 => 0 | S n => m1 n end +with m2 n := match n with 0 => 0 | S n => n end. +(* Why not to allow this definition ? +Fixpoint h1' n := match n with 0 => 0 | S n => h2' n end +with h2' n := h1' n. +*) +CoInductive S := cons : nat -> S -> S. +CoFixpoint c := cons 0 c. +CoFixpoint d := cons 0 c. +CoFixpoint e1 := cons 0 e2 +with e2 := cons 1 e1. +CoFixpoint a1 := cons 0 a1 +with a2 := cons 1 a2. +(* Why not to allow this definition ? +CoFixpoint b1 := cons 0 b2 +with b2 := b1. +*) + +End Recursivity. diff --git a/test-suite/ssr/simpl_done.v b/test-suite/ssr/simpl_done.v new file mode 100644 index 0000000000..f5c766209a --- /dev/null +++ b/test-suite/ssr/simpl_done.v @@ -0,0 +1,28 @@ +Require Import ssreflect. + +Inductive lit : Set := +| LitP : lit +| LitL : lit +. + +Inductive val : Set := +| Val : lit -> val. + +Definition tyref := +fun (vl : list val) => +match vl with +| cons (Val LitL) (cons (Val LitP) _) => False +| _ => False +end. + +(** Check that simplification and resolution are performed in the right order + by "//=" when several goals are under focus. *) +Goal exists vl1 : list val, + cons (Val LitL) (cons (Val LitL) nil) = vl1 /\ + (tyref vl1) +. +Proof. +eexists (cons _ (cons _ _)). +split =>//=. +Fail progress simpl. +Abort. diff --git a/test-suite/ssr/try_case.v b/test-suite/ssr/try_case.v new file mode 100644 index 0000000000..114bf2cecf --- /dev/null +++ b/test-suite/ssr/try_case.v @@ -0,0 +1,11 @@ +From Coq Require Import ssreflect. + +Axiom T : Type. +Axiom R : T -> T -> Type. + +(** Check that internal exceptions are correctly caught in the monad *) +Goal forall (a b : T) (Hab : R a b), True. +Proof. +intros. +try (case: Hab). +Abort. diff --git a/test-suite/success/ltacprof.v b/test-suite/success/ltacprof.v index d5552695c4..f40f40c2bb 100644 --- a/test-suite/success/ltacprof.v +++ b/test-suite/success/ltacprof.v @@ -6,3 +6,20 @@ Goal True. try (multi; fail). (* Used to result in: Anomaly: Uncaught exception Failure("hd"). Please report. *) Admitted. Show Ltac Profile. + +(* backtracking across profiler manipulation *) +Unset Ltac Profiling. +Reset Ltac Profile. + +Fixpoint slow (n : nat) : unit + := match n with + | 0 => tt + | S n => fst (slow n, slow n) + end. + +Ltac slow := idtac; let v := eval cbv in (slow 16) in idtac. +Ltac multi2 := + try (((idtac; slow) + (start ltac profiling; slow) + (idtac; slow) + (slow; stop ltac profiling; slow) + slow + (start ltac profiling; (idtac + slow); ((stop ltac profiling + idtac); fail))); slow; fail); slow; show ltac profile. +Goal True. + multi2. +Admitted. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 1d5e3e54ff..57cc8c4e90 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -9,9 +9,12 @@ (************************************************************************) (** The type [bool] is defined in the prelude as - [Inductive bool : Set := true : bool | false : bool] *) +[[ +Inductive bool : Set := true : bool | false : bool +]] + *) -(** Most of the lemmas in this file are trivial after breaking all booleans *) +(** Most of the lemmas in this file are trivial by case analysis *) Ltac destr_bool := intros; destruct_all bool; simpl in *; trivial; try discriminate. @@ -75,9 +78,9 @@ Proof. destr_bool; intuition. Qed. -(**********************) +(************************) (** * Order on booleans *) -(**********************) +(************************) Definition leb (b1 b2:bool) := match b1 with @@ -91,11 +94,28 @@ Proof. destr_bool; intuition. Qed. -(* Infix "<=" := leb : bool_scope. *) +Definition ltb (b1 b2:bool) := + match b1 with + | true => False + | false => b2 = true + end. +Hint Unfold ltb: bool. + +Definition compareb (b1 b2 : bool) := + match b1, b2 with + | false, true => Lt + | true, false => Gt + | _, _ => Eq + end. + +Lemma compareb_spec : forall b1 b2, + CompareSpec (b1 = b2) (ltb b1 b2) (ltb b2 b1) (compareb b1 b2). +Proof. destr_bool; auto. Qed. + -(*************) +(***************) (** * Equality *) -(*************) +(***************) Definition eqb (b1 b2:bool) : bool := match b1, b2 with @@ -131,9 +151,9 @@ Proof. destr_bool; intuition. Qed. -(************************) +(**********************************) (** * A synonym of [if] on [bool] *) -(************************) +(**********************************) Definition ifb (b1 b2 b3:bool) : bool := match b1 with @@ -143,9 +163,9 @@ Definition ifb (b1 b2 b3:bool) : bool := Open Scope bool_scope. -(****************************) -(** * De Morgan laws *) -(****************************) +(*********************) +(** * De Morgan laws *) +(*********************) Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2. Proof. @@ -157,9 +177,9 @@ Proof. destr_bool. Qed. -(********************************) -(** * Properties of [negb] *) -(********************************) +(***************************) +(** * Properties of [negb] *) +(***************************) Lemma negb_involutive : forall b:bool, negb (negb b) = b. Proof. @@ -212,9 +232,9 @@ Proof. Qed. -(********************************) -(** * Properties of [orb] *) -(********************************) +(**************************) +(** * Properties of [orb] *) +(**************************) Lemma orb_true_iff : forall b1 b2, b1 || b2 = true <-> b1 = true \/ b2 = true. @@ -305,6 +325,11 @@ Proof. Qed. Hint Resolve orb_negb_r: bool. +Lemma orb_negb_l : forall b:bool, negb b || b = true. +Proof. + destr_bool. +Qed. + Notation orb_neg_b := orb_negb_r (only parsing). (** Commutativity *) @@ -322,9 +347,9 @@ Proof. Qed. Hint Resolve orb_comm orb_assoc: bool. -(*******************************) -(** * Properties of [andb] *) -(*******************************) +(***************************) +(** * Properties of [andb] *) +(***************************) Lemma andb_true_iff : forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true. @@ -404,6 +429,11 @@ Proof. Qed. Hint Resolve andb_negb_r: bool. +Lemma andb_negb_l : forall b:bool, negb b && b = false. +Proof. + destr_bool. +Qed. + Notation andb_neg_b := andb_negb_r (only parsing). (** Commutativity *) @@ -422,9 +452,9 @@ Qed. Hint Resolve andb_comm andb_assoc: bool. -(*******************************************) +(*****************************************) (** * Properties mixing [andb] and [orb] *) -(*******************************************) +(*****************************************) (** Distributivity *) @@ -476,9 +506,88 @@ Notation absoption_andb := absorption_andb (only parsing). Notation absoption_orb := absorption_orb (only parsing). (* end hide *) -(*********************************) -(** * Properties of [xorb] *) -(*********************************) +(****************************) +(** * Properties of [implb] *) +(****************************) + +Lemma implb_true_iff : forall b1 b2:bool, implb b1 b2 = true <-> (b1 = true -> b2 = true). +Proof. + destr_bool; intuition. +Qed. + +Lemma implb_false_iff : forall b1 b2:bool, implb b1 b2 = false <-> (b1 = true /\ b2 = false). +Proof. + destr_bool; intuition. +Qed. + +Lemma implb_orb : forall b1 b2:bool, implb b1 b2 = negb b1 || b2. +Proof. + destr_bool. +Qed. + +Lemma implb_negb_orb : forall b1 b2:bool, implb (negb b1) b2 = b1 || b2. +Proof. + destr_bool. +Qed. + +Lemma implb_true_r : forall b:bool, implb b true = true. +Proof. + destr_bool. +Qed. + +Lemma implb_false_r : forall b:bool, implb b false = negb b. +Proof. + destr_bool. +Qed. + +Lemma implb_true_l : forall b:bool, implb true b = b. +Proof. + destr_bool. +Qed. + +Lemma implb_false_l : forall b:bool, implb false b = true. +Proof. + destr_bool. +Qed. + +Lemma implb_same : forall b:bool, implb b b = true. +Proof. + destr_bool. +Qed. + +Lemma implb_contrapositive : forall b1 b2:bool, implb (negb b1) (negb b2) = implb b2 b1. +Proof. + destr_bool. +Qed. + +Lemma implb_negb : forall b1 b2:bool, implb (negb b1) b2 = implb (negb b2) b1. +Proof. + destr_bool. +Qed. + +Lemma implb_curry : forall b1 b2 b3:bool, implb (b1 && b2) b3 = implb b1 (implb b2 b3). +Proof. + destr_bool. +Qed. + +Lemma implb_andb_distrib_r : forall b1 b2 b3:bool, implb b1 (b2 && b3) = implb b1 b2 && implb b1 b3. +Proof. + destr_bool. +Qed. + +Lemma implb_orb_distrib_r : forall b1 b2 b3:bool, implb b1 (b2 || b3) = implb b1 b2 || implb b1 b3. +Proof. + destr_bool. +Qed. + +Lemma implb_orb_distrib_l : forall b1 b2 b3:bool, implb (b1 || b2) b3 = implb b1 b3 && implb b2 b3. +Proof. + destr_bool. +Qed. + +(***************************) +(** * Properties of [xorb] *) +(***************************) (** [false] is neutral for [xorb] *) @@ -632,9 +741,9 @@ Proof. Qed. Hint Resolve trans_eq_bool : core. -(*****************************************) +(***************************************) (** * Reflection of [bool] into [Prop] *) -(*****************************************) +(***************************************) (** [Is_true] and equality *) @@ -752,10 +861,10 @@ Proof. destr_bool. Qed. -(*****************************************) +(***********************************************) (** * Alternative versions of [andb] and [orb] - with lazy behavior (for vm_compute) *) -(*****************************************) + with lazy behavior (for vm_compute) *) +(***********************************************) Declare Scope lazy_bool_scope. @@ -776,11 +885,11 @@ Proof. reflexivity. Qed. -(*****************************************) +(************************************************) (** * Reflect: a specialized inductive type for relating propositions and booleans, - as popularized by the Ssreflect library. *) -(*****************************************) + as popularized by the Ssreflect library. *) +(************************************************) Inductive reflect (P : Prop) : bool -> Set := | ReflectT : P -> reflect P true @@ -823,3 +932,11 @@ Lemma eqb_spec (b b' : bool) : reflect (b = b') (eqb b b'). Proof. destruct b, b'; now constructor. Defined. + +(** Notations *) +Module BoolNotations. +Infix "<=" := leb : bool_scope. +Infix "<" := ltb : bool_scope. +Infix "?=" := compareb (at level 70) : bool_scope. +Infix "=?" := eqb (at level 70) : bool_scope. +End BoolNotations. diff --git a/theories/Bool/BoolOrder.v b/theories/Bool/BoolOrder.v new file mode 100644 index 0000000000..61aab607a9 --- /dev/null +++ b/theories/Bool/BoolOrder.v @@ -0,0 +1,105 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** The order relations [le] [lt] and [compare] are defined in [Bool.v] *) + +(** Order properties of [bool] *) + +Require Export Bool. +Require Import Orders. + +Local Notation le := Bool.leb. +Local Notation lt := Bool.ltb. +Local Notation compare := Bool.compareb. +Local Notation compare_spec := Bool.compareb_spec. + +(** * Order [le] *) + +Lemma le_refl : forall b, le b b. +Proof. destr_bool. Qed. + +Lemma le_trans : forall b1 b2 b3, + le b1 b2 -> le b2 b3 -> le b1 b3. +Proof. destr_bool. Qed. + +Lemma le_true : forall b, le b true. +Proof. destr_bool. Qed. + +Lemma false_le : forall b, le false b. +Proof. intros; constructor. Qed. + +Instance le_compat : Proper (eq ==> eq ==> iff) le. +Proof. intuition. Qed. + +(** * Strict order [lt] *) + +Lemma lt_irrefl : forall b, ~ lt b b. +Proof. destr_bool; auto. Qed. + +Lemma lt_trans : forall b1 b2 b3, + lt b1 b2 -> lt b2 b3 -> lt b1 b3. +Proof. destr_bool; auto. Qed. + +Instance lt_compat : Proper (eq ==> eq ==> iff) lt. +Proof. intuition. Qed. + +Lemma lt_trichotomy : forall b1 b2, { lt b1 b2 } + { b1 = b2 } + { lt b2 b1 }. +Proof. destr_bool; auto. Qed. + +Lemma lt_total : forall b1 b2, lt b1 b2 \/ b1 = b2 \/ lt b2 b1. +Proof. destr_bool; auto. Qed. + +Lemma lt_le_incl : forall b1 b2, lt b1 b2 -> le b1 b2. +Proof. destr_bool; auto. Qed. + +Lemma le_lteq_dec : forall b1 b2, le b1 b2 -> { lt b1 b2 } + { b1 = b2 }. +Proof. destr_bool; auto. Qed. + +Lemma le_lteq : forall b1 b2, le b1 b2 <-> lt b1 b2 \/ b1 = b2. +Proof. destr_bool; intuition. Qed. + + +(** * Order structures *) + +(* Class structure *) +Instance le_preorder : PreOrder le. +Proof. +split. +- intros b; apply le_refl. +- intros b1 b2 b3; apply le_trans. +Qed. + +Instance lt_strorder : StrictOrder lt. +Proof. +split. +- intros b; apply lt_irrefl. +- intros b1 b2 b3; apply lt_trans. +Qed. + +(* Module structure *) +Module BoolOrd <: UsualDecidableTypeFull <: OrderedTypeFull <: TotalOrder. + Definition t := bool. + Definition eq := @eq bool. + Definition eq_equiv := @eq_equivalence bool. + Definition lt := lt. + Definition lt_strorder := lt_strorder. + Definition lt_compat := lt_compat. + Definition le := le. + Definition le_lteq := le_lteq. + Definition lt_total := lt_total. + Definition compare := compare. + Definition compare_spec := compare_spec. + Definition eq_dec := bool_dec. + Definition eq_refl := @eq_Reflexive bool. + Definition eq_sym := @eq_Symmetric bool. + Definition eq_trans := @eq_Transitive bool. + Definition eqb := eqb. + Definition eqb_eq := eqb_true_iff. +End BoolOrd. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index f78c0ecc1e..ad0124db6d 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -123,7 +123,7 @@ Definition create l x e r := Definition assert_false := create. -Fixpoint bal l x d r := +Definition bal l x d r := let hl := height l in let hr := height r in if gt_le_dec hl (hr+2) then @@ -191,7 +191,7 @@ Fixpoint remove_min l x d r : t*(key*elt) := [|height t1 - height t2| <= 2]. *) -Fixpoint merge s1 s2 := match s1,s2 with +Definition merge s1 s2 := match s1,s2 with | Leaf, _ => s2 | _, Leaf => s1 | _, Node l2 x2 d2 r2 h2 => diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 0f2717beef..9f77221d5a 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -26,6 +26,8 @@ Inductive Empty_set : Set :=. Inductive unit : Set := tt : unit. +Register unit as core.unit.type. +Register tt as core.unit.tt. (********************************************************************) (** * The boolean datatype *) @@ -198,6 +200,10 @@ Notation "x + y" := (sum x y) : type_scope. Arguments inl {A B} _ , [A] B _. Arguments inr {A B} _ , A [B] _. +Register sum as core.sum.type. +Register inl as core.sum.inl. +Register inr as core.sum.inr. + (** [prod A B], written [A * B], is the product of [A] and [B]; the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *) diff --git a/theories/Init/Decimal.v b/theories/Init/Decimal.v index 855db8bc3f..2a84456500 100644 --- a/theories/Init/Decimal.v +++ b/theories/Init/Decimal.v @@ -179,7 +179,7 @@ Definition del_head_int n d := (** [del_tail n d] removes [n] digits at end of [d] or returns [zero] if [d] has less than [n] digits. *) -Fixpoint del_tail n d := rev (del_head n (rev d)). +Definition del_tail n d := rev (del_head n (rev d)). Definition del_tail_int n d := match d with diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 5d5f74db44..638e8e8308 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1141,7 +1141,7 @@ Section Map. Qed. Lemma map_eq_cons : forall l l' b, - map l = b :: l' -> exists a tl, l = a :: tl /\ b = f a /\ l' = map tl. + map l = b :: l' -> exists a tl, l = a :: tl /\ f a = b /\ map tl = l'. Proof. intros l l' b Heq. destruct l; inversion_clear Heq. @@ -1149,7 +1149,7 @@ Section Map. Qed. Lemma map_eq_app : forall l l1 l2, - map l = l1 ++ l2 -> exists l1' l2', l = l1' ++ l2' /\ l1 = map l1' /\ l2 = map l2'. + map l = l1 ++ l2 -> exists l1' l2', l = l1' ++ l2' /\ map l1' = l1 /\ map l2' = l2. Proof. induction l; simpl; intros l1 l2 Heq. - symmetry in Heq; apply app_eq_nil in Heq; destruct Heq; subst. diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index ea53618acb..04685cc3eb 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -126,7 +126,7 @@ Infix "?=" := compare (at level 70, no associativity) : N_scope. (** Boolean equality and comparison *) -Fixpoint eqb n m := +Definition eqb n m := match n, m with | 0, 0 => true | pos p, pos q => Pos.eqb p q @@ -313,7 +313,7 @@ Definition land n m := (** Logical [diff] *) -Fixpoint ldiff n m := +Definition ldiff n m := match n, m with | 0, _ => 0 | _, 0 => n diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index bacc4a7650..2c112c3469 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -135,29 +135,29 @@ Register Inline subcarry. Definition addc_def x y := let r := x + y in if r < x then C1 r else C0 r. -(* the same but direct implementation for effeciancy *) +(* the same but direct implementation for efficiency *) Primitive addc := #int63_addc. Notation "n '+c' m" := (addc n m) (at level 50, no associativity) : int63_scope. Definition addcarryc_def x y := let r := addcarry x y in if r <= x then C1 r else C0 r. -(* the same but direct implementation for effeciancy *) +(* the same but direct implementation for efficiency *) Primitive addcarryc := #int63_addcarryc. Definition subc_def x y := if y <= x then C0 (x - y) else C1 (x - y). -(* the same but direct implementation for effeciancy *) +(* the same but direct implementation for efficiency *) Primitive subc := #int63_subc. Notation "n '-c' m" := (subc n m) (at level 50, no associativity) : int63_scope. Definition subcarryc_def x y := if y < x then C0 (x - y - 1) else C1 (x - y - 1). -(* the same but direct implementation for effeciancy *) +(* the same but direct implementation for efficiency *) Primitive subcarryc := #int63_subcarryc. Definition diveucl_def x y := (x/y, x\%y). -(* the same but direct implementation for effeciancy *) +(* the same but direct implementation for efficiency *) Primitive diveucl := #int63_diveucl. Primitive diveucl_21 := #int63_div21. @@ -978,7 +978,7 @@ Proof. case (leb_spec digits j); rewrite H; auto with zarith. intros _ HH; generalize (HH H1); discriminate. clear H. - generalize (ltb_spec j i); case ltb; intros H2; unfold bit; simpl. + generalize (ltb_spec j i); case Int63.ltb; intros H2; unfold bit; simpl. assert (F2: (φ j < φ i)%Z) by (case H2; auto); clear H2. replace (is_zero (((x << i) >> j) << (digits - 1))) with true; auto. case (to_Z_bounded j); intros H1j H2j. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index bd5225d9ef..74cdd1797c 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -22,6 +22,10 @@ Declare Scope Q_scope. Delimit Scope Q_scope with Q. Bind Scope Q_scope with Q. Arguments Qmake _%Z _%positive. + +Register Q as rat.Q.type. +Register Qmake as rat.Q.Qmake. + Open Scope Q_scope. Ltac simpl_mult := rewrite ?Pos2Z.inj_mul. @@ -101,6 +105,10 @@ Notation "x > y" := (Qlt y x)(only parsing) : Q_scope. Notation "x >= y" := (Qle y x)(only parsing) : Q_scope. Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope. +Register Qeq as rat.Q.Qeq. +Register Qle as rat.Q.Qle. +Register Qlt as rat.Q.Qlt. + (** injection from Z is injective. *) Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b. @@ -278,6 +286,11 @@ Infix "*" := Qmult : Q_scope. Notation "/ x" := (Qinv x) : Q_scope. Infix "/" := Qdiv : Q_scope. +Register Qplus as rat.Q.Qplus. +Register Qminus as rat.Q.Qminus. +Register Qopp as rat.Q.Qopp. +Register Qmult as rat.Q.Qmult. + (** A light notation for [Zpos] *) Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z (Zpos b). @@ -1053,6 +1066,8 @@ Definition Qpower (q:Q) (z:Z) := Notation " q ^ z " := (Qpower q z) : Q_scope. +Register Qpower as rat.Q.Qpower. + Instance Qpower_comp : Proper (Qeq==>eq==>Qeq) Qpower. Proof. intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v index ce263e1d21..f8c6429982 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v @@ -32,8 +32,8 @@ Local Open Scope CReal_scope. CReal_abs : CReal -> CReal *) Lemma CauchyAbsStable : forall xn : positive -> Q, - QCauchySeq xn id - -> QCauchySeq (fun n => Qabs (xn n)) id. + QCauchySeq xn + -> QCauchySeq (fun n => Qabs (xn n)). Proof. intros xn cau n p q H H0. specialize (cau n p q H H0). diff --git a/theories/Reals/Cauchy/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v index cfcb8a694b..70574f6135 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyReals.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v @@ -40,104 +40,16 @@ Require CMorphisms. WARNING: this module is not meant to be imported directly, please import `Reals.Abstract.ConstructiveReals` instead. *) -Definition QSeqEquiv (un vn : positive -> Q) (cvmod : positive -> positive) +Definition QCauchySeq (un : positive -> Q) : Prop := forall (k : positive) (p q : positive), - Pos.le (cvmod k) p - -> Pos.le (cvmod k) q - -> Qlt (Qabs (un p - vn q)) (1 # k). - -(* A Cauchy sequence is a sequence equivalent to itself. - If sequences are equivalent, they are both Cauchy and have the same limit. *) -Definition QCauchySeq (un : positive -> Q) (cvmod : positive -> positive) : Prop - := QSeqEquiv un un cvmod. - -Lemma QSeqEquiv_sym : forall (un vn : positive -> Q) (cvmod : positive -> positive), - QSeqEquiv un vn cvmod - -> QSeqEquiv vn un cvmod. -Proof. - intros. intros k p q H0 H1. - rewrite Qabs_Qminus. apply H; assumption. -Qed. - -Lemma factorDenom : forall (a:Z) (b d:positive), (a # (d * b)) == (1#d) * (a#b). -Proof. - intros. unfold Qeq. simpl. destruct a; reflexivity. -Qed. - -Lemma QSeqEquiv_trans : forall (un vn wn : positive -> Q) - (cvmod cvmodw : positive -> positive), - QSeqEquiv un vn cvmod - -> QSeqEquiv vn wn cvmodw - -> QSeqEquiv un wn (fun q => Pos.max (cvmod (2 * q)%positive) - (cvmodw (2 * q)%positive)). -Proof. - intros. intros k p q H1 H2. - setoid_replace (un p - wn q) with (un p - vn p + (vn p - wn q)). - apply (Qle_lt_trans - _ (Qabs (un p - vn p) + Qabs (vn p - wn q))). - apply Qabs_triangle. apply (Qlt_le_trans _ ((1 # (2*k)) + (1 # (2*k)))). - apply Qplus_lt_le_compat. - - assert ((cvmod (2 * k)%positive <= p)%positive). - { apply (Pos.le_trans _ (Pos.max (cvmod (2 * k)%positive) - (cvmodw (2 * k)%positive))). - apply Pos.le_max_l. assumption. } - apply H. assumption. assumption. - - apply Qle_lteq. left. apply H0. - apply (Pos.le_trans _ (Pos.max (cvmod (2 * k)%positive) - (cvmodw (2 * k)%positive))). - apply Pos.le_max_r. assumption. - apply (Pos.le_trans _ (Pos.max (cvmod (2 * k)%positive) - (cvmodw (2 * k)%positive))). - apply Pos.le_max_r. assumption. - - rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. - - ring. -Qed. - -Definition QSeqEquivEx (un vn : positive -> Q) : Prop - := exists (cvmod : positive -> positive), QSeqEquiv un vn cvmod. - -Lemma QSeqEquivEx_sym : forall (un vn : positive -> Q), - QSeqEquivEx un vn -> QSeqEquivEx vn un. -Proof. - intros. destruct H. exists x. apply QSeqEquiv_sym. apply H. -Qed. - -Lemma QSeqEquivEx_trans : forall un vn wn : positive -> Q, - QSeqEquivEx un vn - -> QSeqEquivEx vn wn - -> QSeqEquivEx un wn. -Proof. - intros. destruct H,H0. - exists (fun q => Pos.max (x (2 * q)%positive) (x0 (2 * q)%positive)). - apply (QSeqEquiv_trans un vn wn); assumption. -Qed. - -Lemma QSeqEquiv_cau_r : forall (un vn : positive -> Q) (cvmod : positive -> positive), - QSeqEquiv un vn cvmod - -> QCauchySeq vn (fun k => cvmod (2 * k)%positive). -Proof. - intros. intros k p q H0 H1. - setoid_replace (vn p - vn q) - with (vn p - - un (cvmod (2 * k)%positive) - + (un (cvmod (2 * k)%positive) - vn q)). - - apply (Qle_lt_trans - _ (Qabs (vn p - - un (cvmod (2 * k)%positive)) - + Qabs (un (cvmod (2 * k)%positive) - vn q))). - apply Qabs_triangle. - apply (Qlt_le_trans _ ((1 # (2 * k)) + (1 # (2 * k)))). - apply Qplus_lt_le_compat. - + rewrite Qabs_Qminus. apply H. apply Pos.le_refl. assumption. - + apply Qle_lteq. left. apply H. apply Pos.le_refl. assumption. - + rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. - - ring. -Qed. + Pos.le k p + -> Pos.le k q + -> Qlt (Qabs (un p - un q)) (1 # k). (* A Cauchy real is a Cauchy sequence with the standard modulus *) Definition CReal : Set - := { x : (positive -> Q) | QCauchySeq x id }. + := { x : (positive -> Q) | QCauchySeq x }. Declare Scope CReal_scope. @@ -272,78 +184,6 @@ Proof. apply Qle_Qabs. apply H. Qed. -(* The equality on Cauchy reals is just QSeqEquiv, - which is independant of the convergence modulus. *) -Lemma CRealEq_modindep : forall (x y : CReal), - QSeqEquivEx (proj1_sig x) (proj1_sig y) - <-> forall n:positive, - Qle (Qabs (proj1_sig x n - proj1_sig y n)) (2 # n). -Proof. - assert (forall x y: CReal, QSeqEquivEx (proj1_sig x) (proj1_sig y) -> x <= y ). - { intros [xn limx] [yn limy] [cvmod H] [n abs]. simpl in abs, H. - pose (xn n - yn n - (2#n)) as eps. - destruct (Qarchimedean (/eps)) as [k maj]. - remember (Pos.max (cvmod k) n) as p. - assert (Pos.le (cvmod k) p). - { rewrite Heqp. apply Pos.le_max_l. } - assert (n <= p)%positive. - { rewrite Heqp. apply Pos.le_max_r. } - specialize (H k p p H0 H0). - setoid_replace (Z.pos k #1)%Q with (/ (1#k)) in maj. 2: reflexivity. - apply Qinv_lt_contravar in maj. 2: reflexivity. unfold eps in maj. - clear abs. (* less precise majoration *) - apply (Qplus_lt_r _ _ (2#n)) in maj. ring_simplify in maj. - apply (Qlt_not_le _ _ maj). clear maj. - setoid_replace (xn n + -1 * yn n) - with (xn n - xn p + (xn p - yn p + (yn p - yn n))). - 2: ring. - setoid_replace (2 # n)%Q with ((1 # n) + (1#n)). - rewrite <- Qplus_assoc. - apply Qplus_le_compat. apply (Qle_trans _ _ _ (Qle_Qabs _)). - apply Qlt_le_weak. apply limx. apply Pos.le_refl. assumption. - rewrite (Qplus_comm (1#n)). - apply Qplus_le_compat. apply (Qle_trans _ _ _ (Qle_Qabs _)). - apply Qlt_le_weak. exact H. - apply (Qle_trans _ _ _ (Qle_Qabs _)). apply Qlt_le_weak. apply limy. - assumption. apply Pos.le_refl. ring_simplify. reflexivity. - unfold eps. unfold Qminus. rewrite <- Qlt_minus_iff. exact abs. } - split. - - rewrite <- CRealEq_diff. intros. split. - apply H, QSeqEquivEx_sym. exact H0. apply H. exact H0. - - clear H. intros. destruct x as [xn limx], y as [yn limy]. - exists (fun q:positive => 2 * (3 * q))%positive. intros k p q H0 H1. - unfold proj1_sig. specialize (H (2 * (3 * k))%positive). - assert (3 * k <= 2 * (3 * k))%positive. - { generalize (3 * k)%positive. intros. apply (Pos.le_trans _ (1 * p0)). - apply Pos.le_refl. rewrite <- Pos.mul_le_mono_r. discriminate. } - setoid_replace (xn p - yn q) - with (xn p - xn (2 * (3 * k))%positive - + (xn (2 * (3 * k))%positive - yn (2 * (3 * k))%positive - + (yn (2 * (3 * k))%positive - yn q))). - 2: ring. - setoid_replace (1 # k)%Q with ((1 # 3 * k) + ((1 # 3 * k) + (1 # 3 * k))). - apply (Qle_lt_trans - _ (Qabs (xn p - xn (2 * (3 * k))%positive) - + (Qabs (xn (2 * (3 * k))%positive - yn (2 * (3 * k))%positive - + (yn (2 * (3 * k))%positive - yn q))))). - apply Qabs_triangle. apply Qplus_lt_le_compat. - apply limx. apply (Pos.le_trans _ (2 * (3 * k))). assumption. assumption. - assumption. - apply (Qle_trans - _ (Qabs (xn (2 * (3 * k))%positive - yn (2 * (3 * k))%positive) - + Qabs (yn (2 * (3 * k))%positive - yn q))). - apply Qabs_triangle. apply Qplus_le_compat. - setoid_replace (1 # 3 * k)%Q with (2 # 2 * (3 * k))%Q. apply H. - rewrite (factorDenom _ _ 3). - rewrite (factorDenom _ _ 2). rewrite (factorDenom _ _ 3). - rewrite Qmult_assoc. rewrite (Qmult_comm (1#2)). - rewrite <- Qmult_assoc. apply Qmult_comp. reflexivity. - unfold Qeq. reflexivity. - apply Qle_lteq. left. apply limy. assumption. - apply (Pos.le_trans _ (2 * (3 * k))). assumption. assumption. - rewrite (factorDenom _ _ 3). ring_simplify. reflexivity. -Qed. - (* Extend separation to all indices above *) Lemma CRealLt_aboveSig : forall (x y : CReal) (n : positive), (Qlt (2 # n) @@ -687,8 +527,7 @@ Qed. (* Injection of Q into CReal *) -Lemma ConstCauchy : forall q : Q, - QCauchySeq (fun _ => q) id. +Lemma ConstCauchy : forall q : Q, QCauchySeq (fun _ => q). Proof. intros. intros k p r H H0. unfold Qminus. rewrite Qplus_opp_r. unfold Qlt. simpl. @@ -844,7 +683,7 @@ Qed. Lemma CReal_plus_cauchy : forall (x y : CReal), QCauchySeq (fun n : positive => Qred (proj1_sig x (2 * n)%positive - + proj1_sig y (2 * n)%positive)) id. + + proj1_sig y (2 * n)%positive)). Proof. destruct x as [xn limx], y as [yn limy]; unfold proj1_sig. intros n p q H H0. @@ -873,30 +712,6 @@ Definition CReal_plus (x y : CReal) : CReal Infix "+" := CReal_plus : CReal_scope. -Lemma CReal_plus_unfold : forall (x y : CReal), - QSeqEquiv (proj1_sig (CReal_plus x y)) - (fun n : positive => proj1_sig x n + proj1_sig y n)%Q - (fun p => 2 * p)%positive. -Proof. - intros [xn limx] [yn limy]. - unfold CReal_plus, proj1_sig. - intros p n k H H0. rewrite Qred_correct. - setoid_replace (xn (2 * n)%positive + yn (2 * n)%positive - (xn k + yn k))%Q - with (xn (2 * n)%positive - xn k + (yn (2 * n)%positive - yn k))%Q. - 2: field. - apply (Qle_lt_trans _ (Qabs (xn (2 * n)%positive - xn k) + Qabs (yn (2 * n)%positive - yn k))). - apply Qabs_triangle. - setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. - apply Qplus_lt_le_compat. - - apply limx. apply (Pos.le_trans _ n). apply H. - apply (Pos.le_trans _ (1 * n)). apply Pos.le_refl. - apply Pos.mul_le_mono_r. discriminate. exact H0. - - apply Qlt_le_weak. apply limy. apply (Pos.le_trans _ n). apply H. - apply (Pos.le_trans _ (1 * n)). apply Pos.le_refl. - apply Pos.mul_le_mono_r. discriminate. exact H0. - - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. -Qed. - Definition CReal_opp (x : CReal) : CReal. Proof. destruct x as [xn limx]. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v index 5501645205..f4daedcb97 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v @@ -11,9 +11,7 @@ (* The multiplication and division of Cauchy reals. *) -Require Import QArith. -Require Import Qabs. -Require Import Qround. +Require Import QArith Qabs Qround. Require Import Logic.ConstructiveEpsilon. Require Export ConstructiveCauchyReals. Require CMorphisms. @@ -28,14 +26,15 @@ Definition QCauchySeq_bound (qn : positive -> Q) (cvmod : positive -> positive) | Z.neg p => p + 1 end. -Lemma QCauchySeq_bounded_prop (qn : positive -> Q) (cvmod : positive -> positive) - : QCauchySeq qn cvmod - -> forall n:positive, Pos.le (cvmod 1%positive) n - -> Qlt (Qabs (qn n)) (Z.pos (QCauchySeq_bound qn cvmod) # 1). +Lemma QCauchySeq_bounded_prop (qn : positive -> Q) + : QCauchySeq qn + -> forall n:positive, Qlt (Qabs (qn n)) (Z.pos (QCauchySeq_bound qn id) # 1). Proof. - intros H n H0. unfold QCauchySeq_bound. - specialize (H 1%positive (cvmod 1%positive) n (Pos.le_refl _) H0). - destruct (qn (cvmod 1%positive)) as [a b]. unfold Qnum. + intros H n. unfold QCauchySeq_bound. + assert (1 <= n)%positive as H0. { destruct n; discriminate. } + specialize (H 1%positive (1%positive) n (Pos.le_refl _) H0). + unfold id. + destruct (qn (1%positive)) as [a b]. unfold Qnum. rewrite Qabs_Qminus in H. apply (Qplus_lt_l _ _ (-Qabs (a#b))). apply (Qlt_le_trans _ 1). @@ -55,139 +54,89 @@ Proof. - apply H1. Qed. -Lemma CReal_mult_cauchy - : forall (xn yn zn : positive -> Q) (Ay Az : positive) (cvmod : positive -> positive), - QSeqEquiv xn yn cvmod - -> QCauchySeq zn id - -> (forall n:positive, Pos.le (cvmod 2%positive) n - -> Qlt (Qabs (yn n)) (Z.pos Ay # 1)) - -> (forall n:positive, Pos.le 1 n - -> Qlt (Qabs (zn n)) (Z.pos Az # 1)) - -> QSeqEquiv (fun n:positive => xn n * zn n) (fun n:positive => yn n * zn n) - (fun p => Pos.max (Pos.max (cvmod 2%positive) - (cvmod (2 * (Pos.max Ay Az) * p)%positive)) - (2 * (Pos.max Ay Az) * p)%positive). +Lemma factorDenom : forall (a:Z) (b d:positive), ((a # (d * b)) == (1#d) * (a#b))%Q. Proof. - intros xn yn zn Ay Az cvmod limx limz majy majz. - remember (Pos.mul 2 (Pos.max Ay Az)) as z. - intros k p q H H0. - setoid_replace (xn p * zn p - yn q * zn q)%Q - with ((xn p - yn q) * zn p + yn q * (zn p - zn q))%Q. + intros. unfold Qeq. simpl. destruct a; reflexivity. +Qed. + +Lemma CReal_mult_cauchy + : forall (x y : CReal) (A : positive), + (forall n : positive, (Qabs (proj1_sig x n) < Z.pos A # 1)%Q) + -> (forall n : positive, (Qabs (proj1_sig y n) < Z.pos A # 1)%Q) + -> QCauchySeq (fun n : positive => proj1_sig x (2 * A * n)%positive + * proj1_sig y (2 * A * n)%positive). +Proof. + intros [xn limx] [yn limy] A. unfold proj1_sig. + intros majx majy k p q H H0. + setoid_replace (xn (2*A*p)%positive * yn (2*A*p)%positive + - xn (2*A*q)%positive * yn (2*A*q)%positive)%Q + with ((xn (2*A*p)%positive - xn (2*A*q)%positive) * yn (2*A*p)%positive + + xn (2*A*q)%positive * (yn (2*A*p)%positive - yn (2*A*q)%positive))%Q. 2: ring. - apply (Qle_lt_trans _ (Qabs ((xn p - yn q) * zn p) - + Qabs (yn q * (zn p - zn q)))). - apply Qabs_triangle. rewrite Qabs_Qmult. rewrite Qabs_Qmult. + apply (Qle_lt_trans _ _ _ (Qabs_triangle _ _)). + rewrite Qabs_Qmult, Qabs_Qmult. setoid_replace (1#k)%Q with ((1#2*k) + (1#2*k))%Q. + 2: rewrite Qinv_plus_distr; reflexivity. apply Qplus_lt_le_compat. - - apply (Qle_lt_trans _ ((1#z * k) * Qabs (zn p)%nat)). - + apply Qmult_le_compat_r. apply Qle_lteq. left. apply limx. - apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) (z * k))). - apply Pos.le_max_l. refine (Pos.le_trans _ _ _ _ H). - rewrite <- Pos.max_assoc. apply Pos.le_max_r. - apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) (z * k))). - apply Pos.le_max_l. refine (Pos.le_trans _ _ _ _ H0). - rewrite <- Pos.max_assoc. apply Pos.le_max_r. apply Qabs_nonneg. - + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). + - apply (Qle_lt_trans _ ((1#2*A * k) * Qabs (yn (2*A*p)%positive))). + + apply Qmult_le_compat_r. apply Qlt_le_weak. apply limx. + apply Pos.mul_le_mono_l, H. apply Pos.mul_le_mono_l, H0. + apply Qabs_nonneg. + + rewrite <- (Qmult_1_r (1 # 2 * k)). rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. apply Qmult_lt_l. reflexivity. - apply (Qle_lt_trans _ (Qabs (zn p)%nat * (1 # Az))). - rewrite <- (Qmult_comm (1 # Az)). apply Qmult_le_compat_r. - unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_r. - apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Az)). + apply (Qle_lt_trans _ (Qabs (yn (2 * A * p)%positive) * (1 # A))). + rewrite <- (Qmult_comm (1 # A)). apply Qmult_le_compat_r. + unfold Qle. simpl. apply Z.le_refl. + apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#A)). 2: intro abs; inversion abs. rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. - setoid_replace (/(1#Az))%Q with (Z.pos Az # 1)%Q. + setoid_replace (/(1#A))%Q with (Z.pos A # 1)%Q. 2: reflexivity. - apply majz. refine (Pos.le_trans _ _ _ _ H). - apply (Pos.le_trans _ (2 * Pos.max Ay Az * k)). - discriminate. apply Pos.le_max_r. - - apply (Qle_trans _ ((1 # z * k) * Qabs (yn q)%nat)). - + rewrite Qmult_comm. apply Qmult_le_compat_r. apply Qle_lteq. - left. apply limz. - apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) - (z * k)%positive)). - apply Pos.le_max_r. refine (Pos.le_trans _ _ _ _ H). - rewrite <- Pos.max_assoc. apply Pos.le_max_r. - apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) - (z * k)%positive)). - apply Pos.le_max_r. refine (Pos.le_trans _ _ _ _ H0). - rewrite <- Pos.max_assoc. apply Pos.le_max_r. + apply majy. + - apply (Qle_trans _ ((1 # 2 * A * k) * Qabs (xn (2*A*q)%positive))). + + rewrite Qmult_comm. apply Qmult_le_compat_r. + apply Qlt_le_weak. apply limy. + apply Pos.mul_le_mono_l, H. apply Pos.mul_le_mono_l, H0. apply Qabs_nonneg. - + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). + + rewrite <- (Qmult_1_r (1 # 2 * k)). rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. - apply Qle_lteq. left. - apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. - apply (Qle_lt_trans _ (Qabs (yn q)%nat * (1 # Ay))). - rewrite <- (Qmult_comm (1 # Ay)). apply Qmult_le_compat_r. - unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. - apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Ay)). + apply Qlt_le_weak. + apply Qmult_lt_l. reflexivity. + apply (Qle_lt_trans _ (Qabs (xn (2 * A * q)%positive) * (1 # A))). + rewrite <- (Qmult_comm (1 # A)). apply Qmult_le_compat_r. + apply Qle_refl. + apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#A)). 2: intro abs; inversion abs. rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. - setoid_replace (/(1#Ay))%Q with (Z.pos Ay # 1)%Q. 2: reflexivity. - apply majy. refine (Pos.le_trans _ _ _ _ H0). - rewrite <- Pos.max_assoc. apply Pos.le_max_l. - - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. -Qed. - -Lemma linear_max : forall (p Ax Ay i : positive), - Pos.le p i - -> (Pos.max (Pos.max 2 (2 * Pos.max Ax Ay * p)) - (2 * Pos.max Ax Ay * p) - <= (2 * Pos.max Ax Ay) * i)%positive. -Proof. - intros. rewrite Pos.max_l. 2: apply Pos.le_max_r. rewrite Pos.max_r. - apply Pos.mul_le_mono_l. exact H. - apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. - rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2). - destruct (Pos.max Ax Ay * p)%positive; discriminate. + setoid_replace (/(1#A))%Q with (Z.pos A # 1)%Q. 2: reflexivity. + apply majx. Qed. Definition CReal_mult (x y : CReal) : CReal. Proof. - destruct x as [xn limx]. destruct y as [yn limy]. - pose (QCauchySeq_bound xn id) as Ax. - pose (QCauchySeq_bound yn id) as Ay. - exists (fun n : positive => xn ((2 * Pos.max Ax Ay) * n)%positive - * yn ((2 * Pos.max Ax Ay) * n)%positive). - intros p n k H0 H1. - apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). - intros. apply (QCauchySeq_bounded_prop xn id limx). - apply (Pos.le_trans _ 2). discriminate. exact H. - intros. exact (QCauchySeq_bounded_prop yn id limy _ H). - apply linear_max; assumption. apply linear_max; assumption. + exists (fun n : positive => proj1_sig x ((2 * Pos.max (QCauchySeq_bound (proj1_sig x) id) (QCauchySeq_bound (proj1_sig y) id)) * n)%positive + * proj1_sig y ((2 * Pos.max (QCauchySeq_bound (proj1_sig x) id) + (QCauchySeq_bound (proj1_sig y) id)) * n)%positive). + apply (CReal_mult_cauchy x y). + - intro n. destruct x as [xn caux]. unfold proj1_sig. + pose proof (QCauchySeq_bounded_prop xn caux). + apply (Qlt_le_trans _ (Z.pos (QCauchySeq_bound xn id) # 1)). + apply H. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + rewrite Pos2Z.inj_max. apply Z.le_max_l. + - intro n. destruct y as [yn cauy]. unfold proj1_sig. + pose proof (QCauchySeq_bounded_prop yn cauy). + apply (Qlt_le_trans _ (Z.pos (QCauchySeq_bound yn id) # 1)). + apply H. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + rewrite Pos2Z.inj_max. apply Z.le_max_r. Defined. Infix "*" := CReal_mult : CReal_scope. -Lemma CReal_mult_unfold : forall x y : CReal, - QSeqEquivEx (proj1_sig (CReal_mult x y)) - (fun n : positive => proj1_sig x n * proj1_sig y n)%Q. -Proof. - intros [xn limx] [yn limy]. unfold CReal_mult ; simpl. - pose proof (QCauchySeq_bounded_prop xn id limx) as majx. - pose proof (QCauchySeq_bounded_prop yn id limy) as majy. - remember (QCauchySeq_bound xn id) as Ax. - remember (QCauchySeq_bound yn id) as Ay. - exists (fun p : positive => - Pos.max (2 * Pos.max Ax Ay * p) - (2 * Pos.max Ax Ay * p)). - intros p n k H0 H1. rewrite Pos.max_l in H0, H1. - apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). - 2: apply majy. intros. apply majx. - refine (Pos.le_trans _ _ _ _ H). discriminate. - 3: apply Pos.le_refl. 3: apply Pos.le_refl. - apply linear_max. refine (Pos.le_trans _ _ _ _ H0). - apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. - apply Pos.mul_le_mono_r. discriminate. - rewrite Pos.max_l. - rewrite Pos.max_r. apply H1. 2: apply Pos.le_max_r. - apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. unfold id. - rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). - destruct (Pos.max Ax Ay * p)%positive; discriminate. -Qed. - Lemma CReal_mult_comm : forall x y : CReal, x * y == y * x. Proof. assert (forall x y : CReal, x * y <= y * x) as H. @@ -218,8 +167,8 @@ Proof. apply (Qle_trans _ ((Z.pos (QCauchySeq_bound xn id) # 1) * (2 # (2 * Pos.max (QCauchySeq_bound xn id) (QCauchySeq_bound yn id) * n)%positive))). apply Qmult_le_compat_r. - apply Qlt_le_weak, (QCauchySeq_bounded_prop xn id limx). - discriminate. discriminate. + apply Qlt_le_weak, (QCauchySeq_bounded_prop xn limx). + discriminate. unfold Qle, Qmult, Qnum, Qden. rewrite Pos.mul_1_l. rewrite <- (Z.mul_comm 2), <- Z.mul_assoc. apply Z.mul_le_mono_nonneg_l. discriminate. @@ -240,191 +189,270 @@ Proof. intros. rewrite CReal_mult_comm. apply CReal_mult_0_r. Qed. -Lemma CReal_mult_lt_0_compat : forall x y : CReal, - inject_Q 0 < x - -> inject_Q 0 < y - -> inject_Q 0 < x * y. +Lemma CRealLt_0_aboveSig : forall (x : CReal) (n : positive), + Qlt (2 # n) (proj1_sig x n) + -> forall p:positive, + Pos.le n p -> Qlt (1 # n) (proj1_sig x p). +Proof. + intros. destruct x as [xn caux]. + unfold proj1_sig. unfold proj1_sig in H. + specialize (caux n n p (Pos.le_refl n) H0). + apply (Qplus_lt_l _ _ (xn n-xn p)). + apply (Qlt_trans _ ((1#n) + (1#n))). + apply Qplus_lt_r. exact (Qle_lt_trans _ _ _ (Qle_Qabs _) caux). + rewrite Qinv_plus_distr. ring_simplify. exact H. +Qed. + +(* Correctness lemma for the Definition CReal_mult_lt_0_compat below. *) +Lemma CReal_mult_lt_0_compat_correct + : forall (x y : CReal) (H : 0 < x) (H0 : 0 < y), + (2 # 2 * proj1_sig H * proj1_sig H0 < + proj1_sig (x * y)%CReal (2 * proj1_sig H * proj1_sig H0)%positive - + proj1_sig (inject_Q 0) (2 * proj1_sig H * proj1_sig H0)%positive)%Q. Proof. - intros. destruct H as [x0 H], H0 as [x1 H0]. - pose proof (CRealLt_aboveSig (inject_Q 0) x x0 H). - pose proof (CRealLt_aboveSig (inject_Q 0) y x1 H0). + intros. + destruct H as [x0 H], H0 as [x1 H0]. unfold proj1_sig. + unfold inject_Q, proj1_sig, Qminus in H. rewrite Qplus_0_r in H. + pose proof (CRealLt_0_aboveSig x x0 H) as H1. + unfold inject_Q, proj1_sig, Qminus in H0. rewrite Qplus_0_r in H0. + pose proof (CRealLt_0_aboveSig y x1 H0) as H2. destruct x as [xn limx], y as [yn limy]; simpl in H, H1, H2, H0. - pose proof (QCauchySeq_bounded_prop xn id limx) as majx. - pose proof (QCauchySeq_bounded_prop yn id limy) as majy. - destruct (Qarchimedean (/ (xn x0 - 0 - (2 # x0)))). - destruct (Qarchimedean (/ (yn x1 - 0 - (2 # x1)))). - exists (Pos.max x0 x~0 * Pos.max x1 x2~0)%positive. - simpl. + unfold CReal_mult, inject_Q, proj1_sig. remember (QCauchySeq_bound xn id) as Ax. remember (QCauchySeq_bound yn id) as Ay. unfold Qminus. rewrite Qplus_0_r. - unfold Qminus in H1, H2. - specialize (H1 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive). - assert (Pos.max x1 x2~0 <= (Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive. - { rewrite Pos.mul_assoc. - rewrite <- (Pos.mul_1_l (Pos.max x1 x2~0)). - rewrite Pos.mul_assoc. apply Pos.mul_le_mono_r. discriminate. } - specialize (H2 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive H3). - rewrite Qplus_0_r in H1, H2. - apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (2 # Pos.max x1 x2~0))). - unfold Qlt; simpl. assert (forall p : positive, (Z.pos p < Z.pos p~0)%Z). - intro p. rewrite <- (Z.mul_1_l (Z.pos p)). - replace (Z.pos p~0) with (2 * Z.pos p)%Z. apply Z.mul_lt_mono_pos_r. - apply Pos2Z.is_pos. reflexivity. reflexivity. - apply H4. - apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (yn ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive))). - apply Qmult_lt_l. reflexivity. apply H2. apply Qmult_lt_r. - apply (Qlt_trans 0 (2 # Pos.max x1 x2~0)). reflexivity. apply H2. - apply H1. rewrite Pos.mul_comm. apply Pos2Nat.inj_le. - rewrite <- Pos.mul_assoc. rewrite Pos2Nat.inj_mul. - rewrite <- (mult_1_r (Pos.to_nat (Pos.max x0 x~0))). - rewrite <- mult_assoc. apply Nat.mul_le_mono_nonneg. - apply le_0_n. apply le_refl. auto. - rewrite mult_1_l. apply Pos2Nat.is_pos. + specialize (H2 (2 * (Pos.max Ax Ay) * (2 * x0 * x1))%positive). + setoid_replace (2 # 2 * x0 * x1)%Q with ((1#x0) * (1#x1))%Q. + assert (x0 <= 2 * Pos.max Ax Ay * (2 * x0 * x1))%positive. + { apply (Pos.le_trans _ (2 * Pos.max Ax Ay * x0)). + apply belowMultiple. apply Pos.mul_le_mono_l. + rewrite (Pos.mul_comm 2 x0), <- Pos.mul_assoc, Pos.mul_comm. + apply belowMultiple. } + apply (Qlt_trans _ (xn (2 * Pos.max Ax Ay * (2 * x0 * x1))%positive * (1#x1))). + - apply Qmult_lt_compat_r. reflexivity. apply H1, H3. + - apply Qmult_lt_l. + apply (Qlt_trans _ (1#x0)). reflexivity. apply H1, H3. + apply H2. apply (Pos.le_trans _ (2 * Pos.max Ax Ay * x1)). + apply belowMultiple. apply Pos.mul_le_mono_l. apply belowMultiple. + - unfold Qeq, Qmult, Qnum, Qden. + rewrite Z.mul_1_l, <- Pos2Z.inj_mul. reflexivity. +Qed. + +(* Strict inequality on CReal is in sort Type, for example + used in the computation of division. *) +Definition CReal_mult_lt_0_compat : forall x y : CReal, + 0 < x -> 0 < y -> 0 < x * y + := fun x y H H0 => exist _ (2 * proj1_sig H * proj1_sig H0)%positive + (CReal_mult_lt_0_compat_correct + x y H H0). + +Lemma CReal_mult_bound_indep + : forall (x y : CReal) (A : positive) + (xbound : forall n : positive, (Qabs (proj1_sig x n) < Z.pos A # 1)%Q) + (ybound : forall n : positive, (Qabs (proj1_sig y n) < Z.pos A # 1)%Q), + x * y == exist _ + (fun n : positive => proj1_sig x (2 * A * n)%positive + * proj1_sig y (2 * A * n)%positive)%Q + (CReal_mult_cauchy x y A xbound ybound). +Proof. + intros. apply CRealEq_diff. + pose proof (CReal_mult_cauchy x y) as xycau. intro n. + destruct x as [xn caux], y as [yn cauy]; + unfold CReal_mult, CReal_plus, proj1_sig; unfold proj1_sig in xycau. + pose proof (xycau A xbound ybound). + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + remember (Pos.max Ax Ay) as B. + setoid_replace (xn (2*B*n)%positive * yn (2*B*n)%positive + - xn (2*A*n)%positive * yn (2*A*n)%positive)%Q + with ((xn (2*B*n)%positive - xn (2*A*n)%positive) * yn (2*B*n)%positive + + xn (2*A*n)%positive * (yn (2*B*n)%positive - yn (2*A*n)%positive))%Q. + 2: ring. + apply (Qle_trans _ _ _ (Qabs_triangle _ _)). + rewrite Qabs_Qmult, Qabs_Qmult. + setoid_replace (2#n)%Q with ((1#n) + (1#n))%Q. + 2: rewrite Qinv_plus_distr; reflexivity. + apply Qplus_le_compat. + - apply (Qle_trans _ ((1#2*Pos.min A B * n) * Qabs (yn (2*B*n)%positive))). + + apply Qmult_le_compat_r. apply Qlt_le_weak. apply caux. + apply Pos.mul_le_mono_r, Pos.mul_le_mono_l, Pos.le_min_r. + apply Pos.mul_le_mono_r, Pos.mul_le_mono_l, Pos.le_min_l. + apply Qabs_nonneg. + + unfold proj1_sig in ybound. clear xbound. + apply (Qmult_le_l _ _ (Z.pos (2*Pos.min A B *n) # 1)). + reflexivity. rewrite Qmult_assoc. + setoid_replace ((Z.pos (2 * Pos.min A B * n) # 1) * (1 # 2 * Pos.min A B * n))%Q + with 1%Q. + rewrite Qmult_1_l. + setoid_replace ((Z.pos (2 * Pos.min A B * n) # 1) * (1 # n))%Q + with (Z.pos (2 * Pos.min A B) # 1)%Q. + apply (Qle_trans _ (Z.pos (Pos.min A B) # 1)). + destruct (Pos.lt_total A B). rewrite Pos.min_l. + apply Qlt_le_weak, ybound. apply Pos.lt_le_incl, H0. + destruct H0. rewrite Pos.min_l. + apply Qlt_le_weak, ybound. rewrite H0. apply Pos.le_refl. + rewrite Pos.min_r. subst B. apply (Qle_trans _ (Z.pos Ay #1)). subst Ay. + apply Qlt_le_weak, (QCauchySeq_bounded_prop yn cauy). + unfold Qle, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_max. apply Z.le_max_r. + apply Pos.lt_le_incl, H0. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply belowMultiple. + unfold Qeq, Qmult, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_mul. reflexivity. + unfold Qeq, Qmult, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_mul. reflexivity. + - rewrite Qmult_comm. + apply (Qle_trans _ ((1#2*Pos.min A B * n) * Qabs (xn (2*A*n)%positive))). + + apply Qmult_le_compat_r. apply Qlt_le_weak. apply cauy. + apply Pos.mul_le_mono_r, Pos.mul_le_mono_l, Pos.le_min_r. + apply Pos.mul_le_mono_r, Pos.mul_le_mono_l, Pos.le_min_l. + apply Qabs_nonneg. + + unfold proj1_sig in xbound. clear ybound. + apply (Qmult_le_l _ _ (Z.pos (2*Pos.min A B *n) # 1)). + reflexivity. rewrite Qmult_assoc. + setoid_replace ((Z.pos (2 * Pos.min A B * n) # 1) * (1 # 2 * Pos.min A B * n))%Q + with 1%Q. + rewrite Qmult_1_l. + setoid_replace ((Z.pos (2 * Pos.min A B * n) # 1) * (1 # n))%Q + with (Z.pos (2 * Pos.min A B) # 1)%Q. + apply (Qle_trans _ (Z.pos (Pos.min A B) # 1)). + destruct (Pos.lt_total A B). rewrite Pos.min_l. + apply Qlt_le_weak, xbound. apply Pos.lt_le_incl, H0. + destruct H0. rewrite Pos.min_l. + apply Qlt_le_weak, xbound. rewrite H0. apply Pos.le_refl. + rewrite Pos.min_r. subst B. apply (Qle_trans _ (Z.pos Ax #1)). subst Ax. + apply Qlt_le_weak, (QCauchySeq_bounded_prop xn caux). + unfold Qle, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_max. apply Z.le_max_l. + apply Pos.lt_le_incl, H0. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply belowMultiple. + unfold Qeq, Qmult, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_mul. reflexivity. + unfold Qeq, Qmult, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_mul. reflexivity. Qed. Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal, r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). Proof. - intros x y z. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n - * (proj1_sig (CReal_plus y z) n))%Q). - apply CReal_mult_unfold. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n - + proj1_sig (CReal_mult x z) n))%Q. - 2: apply QSeqEquivEx_sym; exists (fun p:positive => 2 * p)%positive - ; apply CReal_plus_unfold. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n - * (proj1_sig y n + proj1_sig z n))%Q). - - pose proof (CReal_plus_unfold y z). - destruct x as [xn limx], y as [yn limy], z as [zn limz]. - unfold CReal_plus, proj1_sig in H. unfold CReal_plus, proj1_sig. - pose proof (QCauchySeq_bounded_prop xn id) as majx. - pose proof (QCauchySeq_bounded_prop yn id) as majy. - pose proof (QCauchySeq_bounded_prop zn id) as majz. - remember (QCauchySeq_bound xn id) as Ax. - remember (QCauchySeq_bound yn id) as Ay. - remember (QCauchySeq_bound zn id) as Az. - pose proof (CReal_mult_cauchy (fun n => Qred (yn (n~0)%positive + zn (n~0)%positive))%Q - (fun n => yn n + zn n)%Q - xn (Ay + Az) Ax - (fun p:positive => 2 * p)%positive H limx). - exists (fun p : positive => (2 * (2 * Pos.max (Ay + Az) Ax * p))%positive). - intros p n k H1 H2. rewrite Qred_correct. - setoid_replace (xn n * (yn (n~0)%positive + zn (n~0)%positive) - xn k * (yn k + zn k))%Q - with ((yn (n~0)%positive + zn (n~0)%positive) * xn n - (yn k + zn k) * xn k)%Q. - 2: ring. - assert ((2 * Pos.max (Ay + Az) Ax * p) <= - 2 * (2 * Pos.max (Ay + Az) Ax * p))%positive. - { rewrite <- Pos.mul_assoc. - apply Pos.mul_le_mono_l. - apply (Pos.le_trans _ (1*(Pos.max (Ay + Az) Ax * p))). - apply Pos.le_refl. apply Pos.mul_le_mono_r. discriminate. } - rewrite <- (Qred_correct (yn (n~0)%positive + zn (n~0)%positive)). - apply H0. intros n0 H4. + (* Use same bound, max of the 3 bounds for every product. *) + intros x y z. + remember (QCauchySeq_bound (proj1_sig x) id) as Ax. + remember (QCauchySeq_bound (proj1_sig y) id) as Ay. + remember (QCauchySeq_bound (proj1_sig z) id) as Az. + pose (Pos.max Ax (Pos.add Ay Az)) as B. + assert (forall n : positive, (Qabs (proj1_sig x n) < Z.pos B # 1)%Q) as xbound. + { intro n. subst B. apply (Qlt_le_trans _ (Z.pos Ax #1)). + rewrite HeqAx. + apply (QCauchySeq_bounded_prop (proj1_sig x)). + destruct x. exact q. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply Pos.le_max_l. } + assert (forall n : positive, (Qlt (Qabs (proj1_sig (y+z) n)) (Z.pos B # 1))) + as sumbound. + { intro n. destruct y as [yn cauy], z as [zn cauz]. + unfold CReal_plus, proj1_sig. rewrite Qred_correct. + subst B. apply (Qlt_le_trans _ ((Z.pos Ay#1) + (Z.pos Az#1))). apply (Qle_lt_trans _ _ _ (Qabs_triangle _ _)). - rewrite Pos2Z.inj_add, <- Qinv_plus_distr. apply Qplus_lt_le_compat. - apply majy. exact limy. - refine (Pos.le_trans _ _ _ _ H4); discriminate. - apply Qlt_le_weak. apply majz. exact limz. - refine (Pos.le_trans _ _ _ _ H4); discriminate. - apply majx. exact limx. refine (Pos.le_trans _ _ _ _ H1). - rewrite Pos.max_l. rewrite Pos.max_r. apply Pos.le_refl. - rewrite <- (Pos.mul_le_mono_l 2). - apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. - rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. - destruct (Pos.max (Ay + Az) Ax * p)%positive; discriminate. - apply (Pos.le_trans _ (2 * (2 * Pos.max (Ay + Az) Ax * p))). - 2: apply Pos.le_max_r. - rewrite <- Pos.mul_assoc. rewrite (Pos.mul_assoc 2 2). - rewrite <- Pos.mul_le_mono_r. discriminate. - refine (Pos.le_trans _ _ _ _ H2). rewrite <- Pos.max_comm. - rewrite Pos.max_assoc. rewrite Pos.max_r. apply Pos.le_refl. - apply Pos.max_lub. apply H3. - rewrite <- Pos.mul_le_mono_l. - apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. - rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. - destruct (Pos.max (Ay + Az) Ax * p)%positive; discriminate. - - destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. - pose proof (QCauchySeq_bounded_prop xn id) as majx. - pose proof (QCauchySeq_bounded_prop yn id) as majy. - pose proof (QCauchySeq_bounded_prop zn id) as majz. - remember (QCauchySeq_bound xn id) as Ax. - remember (QCauchySeq_bound yn id) as Ay. - remember (QCauchySeq_bound zn id) as Az. - exists (fun p : positive => (2 * (Pos.max (Pos.max Ax Ay) Az) * (2 * p))%positive). - intros p n k H H0. - setoid_replace (xn n * (yn n + zn n) - - (xn ((Pos.max Ax Ay)~0 * k)%positive * - yn ((Pos.max Ax Ay)~0 * k)%positive + - xn ((Pos.max Ax Az)~0 * k)%positive * - zn ((Pos.max Ax Az)~0 * k)%positive))%Q - with (xn n * yn n - (xn ((Pos.max Ax Ay)~0 * k)%positive * - yn ((Pos.max Ax Ay)~0 * k)%positive) - + (xn n * zn n - xn ((Pos.max Ax Az)~0 * k)%positive * - zn ((Pos.max Ax Az)~0 * k)%positive))%Q. - 2: ring. - apply (Qle_lt_trans _ (Qabs (xn n * yn n - (xn ((Pos.max Ax Ay)~0 * k)%positive * - yn ((Pos.max Ax Ay)~0 * k)%positive)) - + Qabs (xn n * zn n - xn ((Pos.max Ax Az)~0 * k)%positive * - zn ((Pos.max Ax Az)~0 * k)%positive))). - apply Qabs_triangle. - setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. - apply Qplus_lt_le_compat. - + apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). - intros. apply majx. exact limx. - refine (Pos.le_trans _ _ _ _ H1). discriminate. - apply majy. exact limy. - rewrite <- Pos.max_assoc. - rewrite (Pos.max_l ((2 * Pos.max Ax Ay * (2 * p)))). - 2: apply Pos.le_refl. - refine (Pos.le_trans _ _ _ _ H). apply Pos.max_lub. - apply (Pos.le_trans _ (2*1)). - apply Pos.le_refl. rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. - destruct (Pos.max (Pos.max Ax Ay) Az * (2 * p))%positive; discriminate. - rewrite <- Pos.mul_assoc, <- Pos.mul_assoc. - rewrite <- Pos.mul_le_mono_l, <- Pos.mul_le_mono_r. - apply Pos.le_max_l. - rewrite <- Pos.max_assoc. - rewrite (Pos.max_l ((2 * Pos.max Ax Ay * (2 * p)))). - 2: apply Pos.le_refl. - rewrite Pos.max_r. apply (Pos.le_trans _ (1*k)). - rewrite Pos.mul_1_l. refine (Pos.le_trans _ _ _ _ H0). - rewrite <- Pos.mul_assoc, <- Pos.mul_assoc, <- Pos.mul_le_mono_l. - rewrite <- Pos.mul_le_mono_r. - apply Pos.le_max_l. apply Pos.mul_le_mono_r. discriminate. - apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. - rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. - destruct (Pos.max Ax Ay * (2 * p))%positive; discriminate. - + apply Qlt_le_weak. - apply (CReal_mult_cauchy xn xn zn Ax Az id limx limz). - intros. apply majx. exact limx. - refine (Pos.le_trans _ _ _ _ H1). discriminate. - intros. apply majz. exact limz. exact H1. - rewrite <- Pos.max_assoc. - rewrite (Pos.max_l ((2 * Pos.max Ax Az * (2 * p)))). - 2: apply Pos.le_refl. - refine (Pos.le_trans _ _ _ _ H). apply Pos.max_lub. - apply (Pos.le_trans _ (2*1)). - apply Pos.le_refl. rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. - destruct (Pos.max (Pos.max Ax Ay) Az * (2 * p))%positive; discriminate. - rewrite <- Pos.mul_assoc, <- Pos.mul_assoc. - rewrite <- Pos.mul_le_mono_l, <- Pos.mul_le_mono_r. - rewrite <- Pos.max_assoc, (Pos.max_comm Ay Az), Pos.max_assoc. - apply Pos.le_max_l. - rewrite <- Pos.max_assoc. - rewrite (Pos.max_l ((2 * Pos.max Ax Az * (2 * p)))). - 2: apply Pos.le_refl. - rewrite Pos.max_r. apply (Pos.le_trans _ (1*k)). - rewrite Pos.mul_1_l. refine (Pos.le_trans _ _ _ _ H0). - rewrite <- Pos.mul_assoc, <- Pos.mul_assoc, <- Pos.mul_le_mono_l. - rewrite <- Pos.mul_le_mono_r. - rewrite <- Pos.max_assoc, (Pos.max_comm Ay Az), Pos.max_assoc. - apply Pos.le_max_l. apply Pos.mul_le_mono_r. discriminate. - apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. - rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. - destruct (Pos.max Ax Az * (2 * p))%positive; discriminate. - + rewrite Qinv_plus_distr. unfold Qeq. reflexivity. + apply Qplus_lt_le_compat. rewrite HeqAy. + unfold proj1_sig. apply (QCauchySeq_bounded_prop yn cauy). + rewrite HeqAz. + unfold proj1_sig. apply Qlt_le_weak, (QCauchySeq_bounded_prop zn cauz). + unfold Qplus, Qle, Qnum, Qden. + apply Pos2Z.pos_le_pos. simpl. repeat rewrite Pos.mul_1_r. + apply Pos.le_max_r. } + rewrite (CReal_mult_bound_indep x (y+z) B xbound sumbound). + assert (forall n : positive, (Qabs (proj1_sig y n) < Z.pos B # 1)%Q) as ybound. + { intro n. subst B. apply (Qlt_le_trans _ (Z.pos Ay #1)). + rewrite HeqAy. + apply (QCauchySeq_bounded_prop (proj1_sig y)). + destruct y; exact q. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ay + Az)). + apply Pos2Nat.inj_le. rewrite <- (Nat.add_0_r (Pos.to_nat Ay)). + rewrite Pos2Nat.inj_add. apply Nat.add_le_mono_l, le_0_n. + apply Pos.le_max_r. } + rewrite (CReal_mult_bound_indep x y B xbound ybound). + assert (forall n : positive, (Qabs (proj1_sig z n) < Z.pos B # 1)%Q) as zbound. + { intro n. subst B. apply (Qlt_le_trans _ (Z.pos Az #1)). + rewrite HeqAz. + apply (QCauchySeq_bounded_prop (proj1_sig z)). + destruct z; exact q. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ay + Az)). + apply Pos2Nat.inj_le. rewrite <- (Nat.add_0_l (Pos.to_nat Az)). + rewrite Pos2Nat.inj_add. apply Nat.add_le_mono_r, le_0_n. + apply Pos.le_max_r. } + rewrite (CReal_mult_bound_indep x z B xbound zbound). + apply CRealEq_diff. + pose proof (CReal_mult_cauchy x y) as xycau. intro n. + destruct x as [xn caux], y as [yn cauy], z as [zn cauz]; + unfold CReal_mult, CReal_plus, proj1_sig; unfold proj1_sig in xycau. + rewrite Qred_correct, Qred_correct. + assert (forall a b c d e : Q, + c * (d + e) - (a+b) == c*d-a + (c*e-b))%Q. + { intros. ring. } + rewrite H. clear H. + setoid_replace (2#n)%Q with ((1#n) + (1#n))%Q. + 2: rewrite Qinv_plus_distr; reflexivity. + apply (Qle_trans _ _ _ (Qabs_triangle _ _)). + apply Qplus_le_compat. + - rewrite Qabs_Qminus. + replace (2 * B * (2 * n))%positive with (2 * (2 * B * n))%positive. + setoid_replace (xn (2 * (2 * B * n))%positive * yn (2 * (2 * B * n))%positive - + xn (2 * B * n)%positive * yn (2 * (2 * B * n))%positive)%Q + with ((xn (2 * (2 * B * n))%positive - xn (2 * B * n)%positive) + * yn (2 * (2 * B * n))%positive)%Q. + 2: ring. rewrite Qabs_Qmult. + apply (Qle_trans _ ((1 # 2*B*n) * Qabs (yn (2 * (2 * B * n))%positive))). + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. + apply Qlt_le_weak, caux. apply belowMultiple. apply Pos.le_refl. + apply (Qmult_le_l _ _ (Z.pos (2* B *n) # 1)). + reflexivity. rewrite Qmult_assoc. + setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # 2 * B * n))%Q + with 1%Q. + rewrite Qmult_1_l. + setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # n))%Q + with (Z.pos (2 * B) # 1)%Q. + apply (Qle_trans _ (Z.pos B # 1)). + apply Qlt_le_weak, ybound. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply belowMultiple. + unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + rewrite Pos2Z.inj_mul. reflexivity. + unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + rewrite Pos2Z.inj_mul. reflexivity. + rewrite <- (Pos.mul_assoc 2 B (2*n)%positive). + apply f_equal. rewrite Pos.mul_assoc, (Pos.mul_comm 2 B). reflexivity. + - rewrite Qabs_Qminus. + replace (2 * B * (2 * n))%positive with (2 * (2 * B * n))%positive. + setoid_replace (xn (2 * (2 * B * n))%positive * zn (2 * (2 * B * n))%positive - + xn (2 * B * n)%positive * zn (2 * (2 * B * n))%positive)%Q + with ((xn (2 * (2 * B * n))%positive - xn (2 * B * n)%positive) + * zn (2 * (2 * B * n))%positive)%Q. + 2: ring. rewrite Qabs_Qmult. + apply (Qle_trans _ ((1 # 2*B*n) * Qabs (zn (2 * (2 * B * n))%positive))). + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. + apply Qlt_le_weak, caux. apply belowMultiple. apply Pos.le_refl. + apply (Qmult_le_l _ _ (Z.pos (2* B *n) # 1)). + reflexivity. rewrite Qmult_assoc. + setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # 2 * B * n))%Q + with 1%Q. + rewrite Qmult_1_l. + setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # n))%Q + with (Z.pos (2 * B) # 1)%Q. + apply (Qle_trans _ (Z.pos B # 1)). + apply Qlt_le_weak, zbound. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply belowMultiple. + unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + rewrite Pos2Z.inj_mul. reflexivity. + unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + rewrite Pos2Z.inj_mul. reflexivity. + rewrite <- (Pos.mul_assoc 2 B (2*n)%positive). + apply f_equal. rewrite Pos.mul_assoc, (Pos.mul_comm 2 B). reflexivity. Qed. Lemma CReal_mult_plus_distr_r : forall r1 r2 r3 : CReal, @@ -461,116 +489,149 @@ Proof. apply CReal_mult_proper_l, H. Qed. -Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : positive -> Q), - QSeqEquivEx xn yn (* both are Cauchy with same limit *) - -> QSeqEquiv zn zn id - -> QSeqEquivEx (fun n => xn n * zn n)%Q (fun n => yn n * zn n)%Q. -Proof. - intros xn yn zn [cvmod cveq] H0. - exists (fun p => Pos.max (Pos.max (cvmod 2%positive) (cvmod (2 * (Pos.max (QCauchySeq_bound yn (fun k : positive => cvmod (2 * k)%positive)) (QCauchySeq_bound zn id)) * p)%positive)) - (2 * (Pos.max (QCauchySeq_bound yn (fun k : positive => cvmod (2 * k)%positive)) (QCauchySeq_bound zn id)) * p)%positive). - apply (CReal_mult_cauchy _ _ _ _ _ _ cveq H0). - exact (QCauchySeq_bounded_prop - yn (fun k => cvmod (2 * k)%positive) - (QSeqEquiv_cau_r xn yn cvmod cveq)). - exact (QCauchySeq_bounded_prop zn id H0). -Qed. - Lemma CReal_mult_assoc : forall x y z : CReal, (x * y) * z == x * (y * z). Proof. - (* - assert (forall x y z : CReal, (x * y) * z <= x * (y * z)) as H. - { intros. intros [n nmaj]. apply (Qlt_not_le _ _ nmaj). clear nmaj. - destruct x as [xn limx], y as [yn limy], z as [zn limz]; - unfold CReal_mult; simpl. - pose proof (QCauchySeq_bounded_prop xn id limx) as majx. - pose proof (QCauchySeq_bounded_prop yn id limy) as majy. - pose proof (QCauchySeq_bounded_prop zn id limz) as majz. - remember (QCauchySeq_bound xn id) as Ax. - remember (QCauchySeq_bound yn id) as Ay. - remember (QCauchySeq_bound zn id) as Az. - } - split. 2: apply H. rewrite CReal_mult_comm. - rewrite (CReal_mult_comm (x*y)). - apply (CReal_le_trans _ (z * y * x)). - apply CReal_mult_proper_r, CReal_mult_comm. - apply (CReal_le_trans _ (z * (y * x))). - apply H. apply CReal_mult_proper_l, CReal_mult_comm. -*) - - intros. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n * proj1_sig z n)%Q). - - apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n * proj1_sig z n)%Q). - apply CReal_mult_unfold. - destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. - pose proof (QCauchySeq_bounded_prop xn id limx) as majx. - pose proof (QCauchySeq_bounded_prop yn id limy) as majy. - pose proof (QCauchySeq_bounded_prop zn id limz) as majz. - remember (QCauchySeq_bound xn id) as Ax. - remember (QCauchySeq_bound yn id) as Ay. - remember (QCauchySeq_bound zn id) as Az. - apply CReal_mult_assoc_bounded_r. 2: exact limz. - exists (fun p : positive => - Pos.max (2 * Pos.max Ax Ay * p) - (2 * Pos.max Ax Ay * p)). - intros p n k H0 H1. - apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). - 2: exact majy. intros. apply majx. refine (Pos.le_trans _ _ _ _ H). - discriminate. rewrite Pos.max_l in H0, H1. - 2: apply Pos.le_refl. 2: apply Pos.le_refl. - apply linear_max. - apply (Pos.le_trans _ (2 * Pos.max Ax Ay * p)). - apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. - apply Pos.mul_le_mono_r. discriminate. - exact H0. rewrite Pos.max_l. 2: apply Pos.le_max_r. - rewrite Pos.max_r in H1. 2: apply Pos.le_refl. - refine (Pos.le_trans _ _ _ _ H1). rewrite Pos.max_r. - apply Pos.le_refl. apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. - unfold id. - rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). - destruct (Pos.max Ax Ay * p)%positive; discriminate. - - apply (QSeqEquivEx_trans - _ (fun n => proj1_sig x n * proj1_sig (CReal_mult y z) n)%Q). - 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. - destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. - pose proof (QCauchySeq_bounded_prop xn id limx) as majx. - pose proof (QCauchySeq_bounded_prop yn id limy) as majy. - pose proof (QCauchySeq_bounded_prop zn id limz) as majz. - remember (QCauchySeq_bound xn id) as Ax. - remember (QCauchySeq_bound yn id) as Ay. - remember (QCauchySeq_bound zn id) as Az. - pose proof (CReal_mult_assoc_bounded_r (fun n0 : positive => yn n0 * zn n0)%Q (fun n : positive => - yn ((Pos.max Ay Az)~0 * n)%positive - * zn ((Pos.max Ay Az)~0 * n)%positive)%Q xn) - as [cvmod cveq]. - + exists (fun p : positive => - Pos.max (2 * Pos.max Ay Az * p) - (2 * Pos.max Ay Az * p)). - intros p n k H0 H1. rewrite Pos.max_l in H0, H1. - apply (CReal_mult_cauchy yn yn zn Ay Az id limy limz). - 2: exact majz. intros. apply majy. refine (Pos.le_trans _ _ _ _ H). - discriminate. - 3: apply Pos.le_refl. 3: apply Pos.le_refl. - rewrite Pos.max_l. rewrite Pos.max_r. apply H0. - apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. unfold id. - rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). - destruct (Pos.max Ay Az * p)%positive; discriminate. - apply Pos.le_max_r. - apply linear_max. refine (Pos.le_trans _ _ _ _ H1). - apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. - apply Pos.mul_le_mono_r. discriminate. - + exact limx. - + exists cvmod. intros p k n H1 H2. specialize (cveq p k n H1 H2). - setoid_replace (xn k * yn k * zn k - - xn n * - (yn ((Pos.max Ay Az)~0 * n)%positive * - zn ((Pos.max Ay Az)~0 * n)%positive))%Q - with ((fun n : positive => yn n * zn n * xn n) k - - (fun n : positive => - yn ((Pos.max Ay Az)~0 * n)%positive * - zn ((Pos.max Ay Az)~0 * n)%positive * - xn n) n)%Q. - apply cveq. ring. + intros. + remember (QCauchySeq_bound (proj1_sig x) id) as Ax. + remember (QCauchySeq_bound (proj1_sig y) id) as Ay. + remember (QCauchySeq_bound (proj1_sig z) id) as Az. + pose (Pos.add (Ax * Ay) (Ay * Az)) as B. + assert (forall n : positive, (Qabs (proj1_sig x n) < Z.pos B # 1)%Q) as xbound. + { intro n. + destruct x as [xn limx]; unfold CReal_mult, proj1_sig. + apply (Qlt_le_trans _ (Z.pos Ax#1)). + rewrite HeqAx. + apply (QCauchySeq_bounded_prop xn limx). + subst B. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ax*Ay)). + rewrite Pos.mul_comm. apply belowMultiple. + apply Pos.lt_le_incl, Pos.lt_add_r. } + assert (forall n : positive, (Qabs (proj1_sig y n) < Z.pos B # 1)%Q) as ybound. + { intro n. + destruct y as [xn limx]; unfold CReal_mult, proj1_sig. + apply (Qlt_le_trans _ (Z.pos Ay#1)). + rewrite HeqAy. + apply (QCauchySeq_bounded_prop xn limx). + subst B. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ax*Ay)). + apply belowMultiple. apply Pos.lt_le_incl, Pos.lt_add_r. } + assert (forall n : positive, (Qabs (proj1_sig z n) < Z.pos B # 1)%Q) as zbound. + { intro n. + destruct z as [xn limx]; unfold CReal_mult, proj1_sig. + apply (Qlt_le_trans _ (Z.pos Az#1)). + rewrite HeqAz. + apply (QCauchySeq_bounded_prop xn limx). + subst B. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (Ay*Az)). + apply belowMultiple. rewrite Pos.add_comm. + apply Pos.lt_le_incl, Pos.lt_add_r. } + pose (exist (fun x0 : positive -> Q => QCauchySeq x0) + (fun n : positive => + (proj1_sig x (2 * B * n)%positive * proj1_sig y (2 * B * n)%positive)%Q) + (CReal_mult_cauchy x y B xbound ybound)) as xy. + rewrite (CReal_mult_proper_r + z (x*y) xy + (CReal_mult_bound_indep x y B xbound ybound)). + pose (exist (fun x0 : positive -> Q => QCauchySeq x0) + (fun n : positive => + (proj1_sig y (2 * B * n)%positive * proj1_sig z (2 * B * n)%positive)%Q) + (CReal_mult_cauchy y z B ybound zbound)) as yz. + rewrite (CReal_mult_proper_l + x (y*z) yz + (CReal_mult_bound_indep y z B ybound zbound)). + assert (forall n : positive, (Qabs (proj1_sig xy n) < Z.pos B # 1)%Q) as xybound. + { intro n. unfold xy, proj1_sig. clear xy yz. + destruct x as [xn limx], y as [yn limy]; unfold CReal_mult, proj1_sig. + rewrite Qabs_Qmult. + apply (Qle_lt_trans _ ((Z.pos Ax#1) * (Qabs (yn (2 * B * n)%positive)))). + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. + rewrite HeqAx. + apply Qlt_le_weak, (QCauchySeq_bounded_prop xn limx). + rewrite Qmult_comm. + apply (Qle_lt_trans _ ((Z.pos Ay#1) * (Z.pos Ax#1))). + apply Qmult_le_compat_r. 2: discriminate. rewrite HeqAy. + apply Qlt_le_weak, (QCauchySeq_bounded_prop yn limy). + subst B. unfold Qmult, Qlt, Qnum, Qden. + rewrite Pos.mul_1_r, Z.mul_1_r, Z.mul_1_r, <- Pos2Z.inj_mul. + apply Pos2Z.pos_lt_pos. rewrite Pos.mul_comm. apply Pos.lt_add_r. } + rewrite (CReal_mult_bound_indep _ z B xybound zbound). + assert (forall n : positive, (Qabs (proj1_sig yz n) < Z.pos B # 1)%Q) as yzbound. + { intro n. unfold yz, proj1_sig. clear xybound xy yz. + destruct z as [zn limz], y as [yn limy]; unfold CReal_mult, proj1_sig. + rewrite Qabs_Qmult. + apply (Qle_lt_trans _ ((Z.pos Ay#1) * (Qabs (zn (2 * B * n)%positive)))). + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. + rewrite HeqAy. + apply Qlt_le_weak, (QCauchySeq_bounded_prop yn limy). + rewrite Qmult_comm. + apply (Qle_lt_trans _ ((Z.pos Az#1) * (Z.pos Ay#1))). + apply Qmult_le_compat_r. 2: discriminate. rewrite HeqAz. + apply Qlt_le_weak, (QCauchySeq_bounded_prop zn limz). + subst B. unfold Qmult, Qlt, Qnum, Qden. + rewrite Pos.mul_1_r, Z.mul_1_r, Z.mul_1_r, <- Pos2Z.inj_mul. + apply Pos2Z.pos_lt_pos. rewrite Pos.add_comm, Pos.mul_comm. + apply Pos.lt_add_r. } + rewrite (CReal_mult_bound_indep x yz B xbound yzbound). + apply CRealEq_diff. intro n. unfold proj1_sig, xy, yz. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; + unfold CReal_mult, proj1_sig. + clear xybound yzbound xy yz. + assert (forall a b c d e : Q, a*b*c - d*(b*e) == b*(a*c - d*e))%Q. + { intros. ring. } + rewrite H. clear H. rewrite Qabs_Qmult, Qmult_comm. + setoid_replace (xn (2 * B * (2 * B * n))%positive * zn (2 * B * n)%positive - + xn (2 * B * n)%positive * zn (2 * B * (2 * B * n))%positive)%Q + with ((xn (2 * B * (2 * B * n))%positive - xn (2 * B * n)%positive) + * zn (2 * B * n)%positive + + xn (2 * B * n)%positive * + (zn (2*B*n)%positive - zn (2 * B * (2 * B * n))%positive))%Q. + 2: ring. + apply (Qle_trans _ ( (Qabs ((1 # (2 * B * n)) * zn (2 * B * n)%positive) + + Qabs (xn (2 * B * n)%positive * (1 # (2 * B * n)))) + * Qabs (yn (2 * B * (2 * B * n))%positive))). + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. + apply (Qle_trans _ _ _ (Qabs_triangle _ _)). + apply Qplus_le_compat. + rewrite Qabs_Qmult, Qabs_Qmult. + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. + apply Qlt_le_weak, limx. apply belowMultiple. apply Pos.le_refl. + rewrite Qabs_Qmult, Qabs_Qmult, Qmult_comm, <- (Qmult_comm (Qabs (1 # 2 * B * n))). + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. + apply Qlt_le_weak, limz. apply Pos.le_refl. apply belowMultiple. + rewrite Qabs_Qmult, Qabs_Qmult. + rewrite (Qmult_comm (Qabs (1 # 2 * B * n))). + rewrite <- Qmult_plus_distr_l. + rewrite (Qabs_pos (1 # 2 * B * n)). 2: discriminate. + rewrite <- (Qmult_comm (1 # 2 * B * n)), <- Qmult_assoc. + apply (Qmult_le_l _ _ (Z.pos (2* B *n) # 1)). + reflexivity. rewrite Qmult_assoc. + setoid_replace ((Z.pos (2 * B * n) # 1) * (1 # 2 * B * n))%Q + with 1%Q. + rewrite Qmult_1_l. + setoid_replace ((Z.pos (2 * B * n) # 1) * (2 # n))%Q + with (Z.pos (2 * 2 * B) # 1)%Q. + apply (Qle_trans _ (((Z.pos Az#1) + (Z.pos Ax#1)) * + Qabs (yn (2 * B * (2 * B * n))%positive))). + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. + apply Qplus_le_compat. rewrite HeqAz. + apply Qlt_le_weak, (QCauchySeq_bounded_prop zn limz). + rewrite HeqAx. + apply Qlt_le_weak, (QCauchySeq_bounded_prop xn limx). + rewrite Qmult_comm. + apply (Qle_trans _ ((Z.pos Ay#1)* ((Z.pos Az # 1) + (Z.pos Ax # 1)))). + apply Qmult_le_compat_r. + rewrite HeqAy. + apply Qlt_le_weak, (QCauchySeq_bounded_prop yn limy). discriminate. + rewrite Qinv_plus_distr. subst B. + unfold Qle, Qmult, Qplus, Qnum, Qden. + repeat rewrite Pos.mul_1_r. repeat rewrite Z.mul_1_r. + rewrite <- Pos2Z.inj_add, <- Pos2Z.inj_mul. + apply Pos2Z.pos_le_pos. rewrite Pos.mul_add_distr_l. + rewrite Pos.add_comm, Pos.mul_comm. apply belowMultiple. + unfold Qeq, Qmult, Qnum, Qden. + simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_comm. reflexivity. + unfold Qeq, Qmult, Qnum, Qden. + simpl. rewrite Pos.mul_1_r, Pos.mul_1_r. reflexivity. Qed. @@ -579,8 +640,8 @@ Proof. intros [rn limr]. split. - intros [m maj]. simpl in maj. rewrite Qmult_1_l in maj. - pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) id (ConstCauchy 1)). - pose proof (QCauchySeq_bounded_prop rn id limr). + pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) (ConstCauchy 1)). + pose proof (QCauchySeq_bounded_prop rn limr). remember (QCauchySeq_bound (fun _ : positive => 1%Q) id) as x. remember (QCauchySeq_bound rn id) as x0. specialize (limr m). @@ -595,8 +656,8 @@ Proof. apply Z.mul_le_mono_nonneg. discriminate. discriminate. discriminate. apply Z.le_refl. - intros [m maj]. simpl in maj. - pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) id (ConstCauchy 1)). - pose proof (QCauchySeq_bounded_prop rn id limr). + pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) (ConstCauchy 1)). + pose proof (QCauchySeq_bounded_prop rn limr). remember (QCauchySeq_bound (fun _ : positive => 1%Q) id) as x. remember (QCauchySeq_bound rn id) as x0. simpl in maj. rewrite Qmult_1_l in maj. @@ -730,22 +791,22 @@ Qed. Lemma CReal_mult_eq_reg_l : forall (r r1 r2 : CReal), r # 0 - -> CRealEq (CReal_mult r r1) (CReal_mult r r2) - -> CRealEq r1 r2. + -> r * r1 == r * r2 + -> r1 == r2. Proof. intros. destruct H; split. - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. - exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + exact (CRealLe_refl _ abs). apply (CReal_plus_lt_reg_l r). rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. - exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + exact (CRealLe_refl _ abs). apply (CReal_plus_lt_reg_l r). rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. - exact (CRealLt_irrefl _ abs). exact c. + exact (CRealLe_refl _ abs). exact c. - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. - exact (CRealLt_irrefl _ abs). exact c. + exact (CRealLe_refl _ abs). exact c. Qed. Lemma CReal_abs_appart_zero : forall (x : CReal) (n : positive), @@ -857,92 +918,60 @@ Proof. (proj1_sig d (Pos.of_nat (S n)) - proj1_sig c (Pos.of_nat (S n)))); assumption. Qed. -Lemma CRealShiftReal : forall (x : CReal) (k : positive), - QCauchySeq (fun n => proj1_sig x (Pos.max n k)) id. -Proof. - intros x k n p q H0 H1. - destruct x as [xn cau]; unfold proj1_sig. - apply cau. exact (Pos.le_trans _ _ _ H0 (Pos.le_max_l _ _)). - exact (Pos.le_trans _ _ _ H1 (Pos.le_max_l _ _)). -Qed. - -Lemma CRealShiftEqual : forall (x : CReal) (k : positive), - x == exist _ (fun n => proj1_sig x (Pos.max n k)) (CRealShiftReal x k). -Proof. - intros. split. - - intros [n maj]. destruct x as [xn cau]; simpl in maj. - specialize (cau n (Pos.max n k) n (Pos.le_max_l _ _ ) (Pos.le_refl _)). - apply (Qlt_not_le _ _ maj). clear maj. - apply (Qle_trans _ (Qabs (xn (Pos.max n k) - xn n))). - apply Qle_Qabs. apply Qlt_le_weak. apply (Qlt_trans _ _ _ cau). - unfold Qlt, Qnum, Qden. - apply Z.mul_lt_mono_pos_r. reflexivity. reflexivity. - - intros [n maj]. destruct x as [xn cau]; simpl in maj. - specialize (cau n (Pos.max n k) n (Pos.le_max_l _ _ ) (Pos.le_refl _)). - apply (Qlt_not_le _ _ maj). clear maj. - rewrite Qabs_Qminus in cau. - apply (Qle_trans _ (Qabs (xn n - xn (Pos.max n k)))). - apply Qle_Qabs. apply Qlt_le_weak. apply (Qlt_trans _ _ _ cau). - unfold Qlt, Qnum, Qden. - apply Z.mul_lt_mono_pos_r. reflexivity. reflexivity. +(* Find a positive index after which the Cauchy sequence proj1_sig x + stays above 0, so that it can be inverted. *) +Lemma CRealPosShift_correct + : forall (x : CReal) (xPos : 0 < x) (n : positive), + Pos.le (proj1_sig xPos) n + -> Qlt (1 # proj1_sig xPos) (proj1_sig x n). +Proof. + intros x xPos p pmaj. + destruct xPos as [n maj]; simpl in maj. + apply (CRealLt_0_aboveSig x n). + unfold proj1_sig in pmaj. + apply (Qlt_le_trans _ _ _ maj). + ring_simplify. apply Qle_refl. apply pmaj. Qed. -(* Find a positive negative real number, which rational sequence - stays above 0, so that it can be inversed. *) -Definition CRealPosShift (x : CReal) - : inject_Q 0 < x - -> { p : positive - | forall n:positive, Qlt (1 # p) (proj1_sig x (Pos.max n p)) }. -Proof. - intro xPos. - pose proof (CRealLt_aboveSig (inject_Q 0) x). - pose proof (CRealShiftReal x). - pose proof (CRealShiftEqual x). - destruct xPos as [n maj], x as [xn cau]; simpl in maj. - simpl in H. specialize (H n). - destruct (Qarchimedean (/ (xn n - 0 - (2 # n)))) as [a _]. - specialize (H maj); simpl in H. - remember (Pos.max n a~0) as k. - clear Heqk. clear maj. clear n. exists k. - intro n. simpl. apply (Qlt_trans _ (2 # k)). - apply Z.mul_lt_mono_pos_r. reflexivity. reflexivity. - specialize (H (Pos.max n k) (Pos.le_max_r _ _)). - apply (Qlt_le_trans _ _ _ H). ring_simplify. apply Qle_refl. -Qed. - -Lemma CReal_inv_pos_cauchy : forall (yn : positive -> Q) (k : positive), - (QCauchySeq yn id) - -> (forall n : positive, 1 # k < yn n)%Q - -> QCauchySeq (fun n : positive => / yn (k ^ 2 * n)%positive) id. -Proof. - intros yn k cau maj n p q H0 H1. - setoid_replace (/ yn (k ^ 2 * p)%positive - - / yn (k ^ 2 * q)%positive)%Q - with ((yn (k ^ 2 * q)%positive - - yn (k ^ 2 * p)%positive) - / (yn (k ^ 2 * q)%positive * - yn (k ^ 2 * p)%positive)). - + apply (Qle_lt_trans _ (Qabs (yn (k ^ 2 * q)%positive - - yn (k ^ 2 * p)%positive) +Lemma CReal_inv_pos_cauchy + : forall (x : CReal) (xPos : 0 < x) (k : positive), + (forall n:positive, Pos.le k n -> Qlt (1 # k) (proj1_sig x n)) + -> QCauchySeq (fun n : positive => / proj1_sig x (k ^ 2 * n)%positive). +Proof. + intros [xn xcau] xPos k maj. unfold proj1_sig. + intros n p q H0 H1. + setoid_replace (/ xn (k ^ 2 * p)%positive - / xn (k ^ 2 * q)%positive)%Q + with ((xn (k ^ 2 * q)%positive - + xn (k ^ 2 * p)%positive) + / (xn (k ^ 2 * q)%positive * + xn (k ^ 2 * p)%positive)). + + apply (Qle_lt_trans _ (Qabs (xn (k ^ 2 * q)%positive + - xn (k ^ 2 * p)%positive) / (1 # (k^2)))). assert (1 # k ^ 2 - < Qabs (yn (k ^ 2 * q)%positive * yn (k ^ 2 * p)%positive))%Q. + < Qabs (xn (k ^ 2 * q)%positive * xn (k ^ 2 * p)%positive))%Q. { rewrite Qabs_Qmult. unfold "^"%positive; simpl. rewrite factorDenom. rewrite Pos.mul_1_r. - apply (Qlt_trans _ ((1#k) * Qabs (yn (k * k * p)%positive))). + apply (Qlt_trans _ ((1#k) * Qabs (xn (k * k * p)%positive))). apply Qmult_lt_l. reflexivity. rewrite Qabs_pos. specialize (maj (k * k * p)%positive). - apply maj. apply (Qle_trans _ (1 # k)). + apply maj. rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple. + apply (Qle_trans _ (1 # k)). discriminate. apply Zlt_le_weak. apply maj. + rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple. apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. rewrite Qabs_pos. specialize (maj (k * k * p)%positive). - apply maj. apply (Qle_trans _ (1 # k)). discriminate. + apply maj. rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple. + apply (Qle_trans _ (1 # k)). discriminate. apply Zlt_le_weak. apply maj. + rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple. rewrite Qabs_pos. specialize (maj (k * k * q)%positive). - apply maj. apply (Qle_trans _ (1 # k)). discriminate. - apply Zlt_le_weak. apply maj. } + apply maj. rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple. + apply (Qle_trans _ (1 # k)). discriminate. + apply Zlt_le_weak. + apply maj. rewrite Pos.mul_comm, Pos.mul_assoc. apply belowMultiple. } unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). apply Qmult_le_compat_r. apply Qlt_le_weak. @@ -951,11 +980,11 @@ Proof. rewrite Qmult_comm. apply Qlt_shift_div_l. reflexivity. rewrite Qmult_1_l. apply H. apply Qabs_nonneg. simpl in maj. - specialize (cau (n * (k^2))%positive - (k ^ 2 * q)%positive - (k ^ 2 * p)%positive). + pose proof (xcau (n * (k^2))%positive + (k ^ 2 * q)%positive + (k ^ 2 * p)%positive). apply Qlt_shift_div_r. reflexivity. - apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. + apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply xcau. rewrite Pos.mul_comm. unfold id. apply Pos.mul_le_mono_l. exact H1. unfold id. rewrite Pos.mul_comm. @@ -963,25 +992,28 @@ Proof. rewrite factorDenom. apply Qle_refl. + field. split. intro abs. specialize (maj (k ^ 2 * p)%positive). - rewrite abs in maj. inversion maj. + rewrite abs in maj. apply (Qlt_not_le (1#k) 0). + apply maj. unfold "^"%positive; simpl. rewrite <- Pos.mul_assoc. + rewrite Pos.mul_comm. apply belowMultiple. discriminate. intro abs. specialize (maj (k ^ 2 * q)%positive). - rewrite abs in maj. inversion maj. + rewrite abs in maj. apply (Qlt_not_le (1#k) 0). + apply maj. unfold "^"%positive; simpl. rewrite <- Pos.mul_assoc. + rewrite Pos.mul_comm. apply belowMultiple. discriminate. Qed. -Definition CReal_inv_pos (x : CReal) (xPos : 0 < x) : CReal. -Proof. - destruct (CRealPosShift x xPos) as [k maj]. - exists (fun n : positive => / proj1_sig x (Pos.max (k ^ 2 * n) k)). - pose proof (CReal_inv_pos_cauchy (fun n => proj1_sig x (Pos.max n k)) k). - apply H. apply (CRealShiftReal x). apply maj. -Defined. +Definition CReal_inv_pos (x : CReal) (xPos : 0 < x) : CReal + := exist _ + (fun n : positive => / proj1_sig x (proj1_sig xPos ^ 2 * n)%positive) + (CReal_inv_pos_cauchy + x xPos (proj1_sig xPos) (CRealPosShift_correct x xPos)). -Lemma CReal_neg_lt_pos : forall x : CReal, x < 0 -> 0 < -x. +Definition CReal_neg_lt_pos : forall x : CReal, x < 0 -> 0 < -x. Proof. - intros. apply (CReal_plus_lt_reg_l x). - rewrite (CReal_plus_opp_r x), CReal_plus_0_r. exact H. -Qed. + intros x [n nmaj]. exists n. + apply (Qlt_le_trans _ _ _ nmaj). destruct x. simpl. + unfold Qminus. rewrite Qplus_0_l, Qplus_0_r. apply Qle_refl. +Defined. Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal := match xnz with @@ -999,33 +1031,32 @@ Proof. destruct rnz. - exfalso. apply CRealLt_asym in H. contradiction. - unfold CReal_inv_pos. - destruct (CRealPosShift r c) as [k maj]. - pose (fun n => proj1_sig r (Pos.max n k)) as rn. + pose proof (CRealPosShift_correct r c) as maj. destruct r as [xn cau]. unfold CRealLt; simpl. - destruct (Qarchimedean (rn 1%positive)) as [A majA]. + destruct (Qarchimedean (xn 1%positive)) as [A majA]. exists (2 * (A + 1))%positive. unfold Qminus. rewrite Qplus_0_r. - simpl in rn. - rewrite <- (Qmult_1_l (/ xn (Pos.max (k ^ 2 * (2 * (A + 1))) k))). - apply Qlt_shift_div_l. apply (Qlt_trans 0 (1#k)). reflexivity. - apply maj. rewrite <- (Qmult_inv_r (Z.pos A + 1 # 1)). + rewrite <- (Qmult_1_l (/ xn (proj1_sig c ^ 2 * (2 * (A + 1)))%positive)). + apply Qlt_shift_div_l. apply (Qlt_trans 0 (1# proj1_sig c)). reflexivity. + apply maj. unfold "^"%positive, Pos.iter. + rewrite <- Pos.mul_assoc, Pos.mul_comm. apply belowMultiple. + rewrite <- (Qmult_inv_r (Z.pos A + 1 # 1)). setoid_replace (2 # 2 * (A + 1))%Q with (Qinv (Z.pos A + 1 # 1)). 2: reflexivity. rewrite Qmult_comm. apply Qmult_lt_r. reflexivity. - rewrite <- (Qplus_lt_l _ _ (- rn 1%positive)). - apply (Qle_lt_trans _ (Qabs (rn (k ^ 2 * (2 * (A + 1)))%positive + - rn 1%positive))). + rewrite <- (Qplus_lt_l _ _ (- xn 1%positive)). + apply (Qle_lt_trans _ (Qabs (xn (proj1_sig c ^ 2 * (2 * (A + 1)))%positive + - xn 1%positive))). apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau. - destruct (Pos.max (k ^ 2 * (2 * (A + 1))) k)%positive; discriminate. - apply Pos.le_max_l. + apply Pos.le_1_l. apply Pos.le_1_l. rewrite <- Qinv_plus_distr. rewrite <- (Qplus_comm 1). rewrite <- Qplus_0_r. rewrite <- Qplus_assoc. rewrite <- Qplus_assoc. rewrite Qplus_le_r. rewrite Qplus_0_l. apply Qlt_le_weak. apply Qlt_minus_iff in majA. apply majA. intro abs. inversion abs. -Qed. +Defined. Lemma CReal_linear_shift : forall (x : CReal) (k : positive), - QCauchySeq (fun n => proj1_sig x (k * n)%positive) id. + QCauchySeq (fun n => proj1_sig x (k * n)%positive). Proof. intros [xn limx] k p n m H H0. unfold proj1_sig. apply limx. apply (Pos.le_trans _ n). apply H. @@ -1037,7 +1068,7 @@ Qed. Lemma CReal_linear_shift_eq : forall (x : CReal) (k : positive), x == - (exist (fun n : positive -> Q => QCauchySeq n id) + (exist (fun n : positive -> Q => QCauchySeq n) (fun n : positive => proj1_sig x (k * n)%positive) (CReal_linear_shift x k)). Proof. intros. apply CRealEq_diff. intro n. @@ -1053,55 +1084,40 @@ Qed. Lemma CReal_inv_l_pos : forall (r:CReal) (rnz : 0 < r), (CReal_inv_pos r rnz) * r == 1. Proof. - intros r c. unfold CReal_inv_pos. - destruct (CRealPosShift r c) as [k maj]. - apply CRealEq_diff. - apply CRealEq_modindep. - pose (exist (fun x => QCauchySeq x id) - (fun n => proj1_sig r (Pos.max n k)) (CRealShiftReal r k)) - as rshift. - apply (QSeqEquivEx_trans _ - (proj1_sig (CReal_mult ((let - (yn, cau) as s - return ((forall n : positive, 1 # k < proj1_sig s n) -> CReal) := rshift in - fun maj0 : forall n : positive, 1 # k < yn n => - exist (fun x : positive -> Q => QCauchySeq x id) - (fun n : positive => Qinv (yn (k * (k * 1) * n)%positive)) - (CReal_inv_pos_cauchy yn k cau maj0)) maj) rshift)))%Q. - - apply CRealEq_modindep. apply CRealEq_diff. - apply CReal_mult_proper_l. apply CRealShiftEqual. - - assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. - rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. - apply (QSeqEquivEx_trans _ - (proj1_sig (CReal_mult ((let - (yn, cau) as s - return ((forall n : positive, 1 # k < proj1_sig s n) -> CReal) := rshift in - fun maj0 : forall n : positive, 1 # k < yn n => - exist (fun x : positive -> Q => QCauchySeq x id) - (fun n : positive => Qinv (yn (k * (k * 1) * n)%positive)) - (CReal_inv_pos_cauchy yn k cau maj0)) maj) - (exist _ (fun n => proj1_sig rshift (k * (k * 1) * n)%positive) (CReal_linear_shift rshift _)))))%Q. - apply CRealEq_modindep. apply CRealEq_diff. - apply CReal_mult_proper_l. apply CReal_linear_shift_eq. - destruct r as [rn limr]. unfold rshift. simpl. - exists (fun n => 1%positive). intros p n m H2 H3. - remember (QCauchySeq_bound - (fun n0 : positive => / rn (Pos.max (k * (k * 1) * n0) k)) - id)%Q as x. - remember (QCauchySeq_bound - (fun n0 : positive => rn (Pos.max (k * (k * 1) * n0) k)%positive) - id) as x0. - rewrite Qmult_comm. - rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. - reflexivity. intro abs. unfold proj1_sig in maj. - specialize (maj ((k * (k * 1) * (Pos.max x x0 * n)~0)%positive)). - simpl in maj. rewrite abs in maj. inversion maj. + intros r c. + unfold CReal_inv_pos. + pose proof (CRealPosShift_correct r c) as maj. + rewrite (CReal_mult_proper_l + _ r (exist _ (fun n => proj1_sig r (proj1_sig c ^ 2 * n)%positive) + (CReal_linear_shift r _))). + 2: rewrite <- CReal_linear_shift_eq; apply reflexivity. + apply CRealEq_diff. intro n. + destruct r as [rn limr]. + unfold CReal_mult, inject_Q, proj1_sig. + rewrite Qmult_comm, Qmult_inv_r. + unfold Qminus. rewrite Qplus_opp_r, Qabs_pos. + discriminate. apply Qle_refl. + unfold proj1_sig in maj. + intro abs. + specialize (maj ((let (a, _) := c in a) ^ 2 * + (2 * + Pos.max + (QCauchySeq_bound + (fun n : positive => Qinv (rn ((let (a, _) := c in a) ^ 2 * n))) id) + (QCauchySeq_bound + (fun n : positive => rn ((let (a, _) := c in a) ^ 2 * n)) id) * n))%positive). + simpl in maj. unfold proj1_sig in maj, abs. + rewrite abs in maj. clear abs. + apply (Qlt_not_le (1 # (let (a, _) := c in a)) 0). + apply maj. unfold "^"%positive, Pos.iter. + rewrite <- Pos.mul_assoc, Pos.mul_comm. apply belowMultiple. + discriminate. Qed. Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), ((/ r) rnz) * r == 1. Proof. - intros. unfold CReal_inv; simpl. destruct rnz. + intros. unfold CReal_inv. destruct rnz. - rewrite <- CReal_opp_mult_distr_l, CReal_opp_mult_distr_r. apply CReal_inv_l_pos. - apply CReal_inv_l_pos. @@ -1209,18 +1225,22 @@ Proof. apply Qabs_Qle_condition. split. apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#j)). reflexivity. apply jmaj. + apply (Pos.le_trans _ (2*j)). apply belowMultiple. + apply Pos.mul_le_mono_l. apply (Pos.le_trans _ (1 * Pos.max k (Pos.max i j))). rewrite Pos.mul_1_l. apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_r _ _)). apply Pos.le_max_r. - rewrite <- Pos.mul_le_mono_r. discriminate. + rewrite <- Pos.mul_le_mono_r. destruct (Pos.max a b); discriminate. apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#i)). reflexivity. apply imaj. + apply (Pos.le_trans _ (2*i)). apply belowMultiple. + apply Pos.mul_le_mono_l. apply (Pos.le_trans _ (1 * Pos.max k (Pos.max i j))). rewrite Pos.mul_1_l. apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_l _ _)). apply Pos.le_max_r. - rewrite <- Pos.mul_le_mono_r. discriminate. + rewrite <- Pos.mul_le_mono_r. destruct (Pos.max a b); discriminate. - left. apply (CReal_mult_lt_reg_r (exist _ yn ycau) _ _ c). rewrite CReal_mult_0_l. exact H. - right. apply (CReal_mult_lt_reg_r (CReal_opp (exist _ yn ycau))). diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index 3ccb7af796..be844c413a 100644 --- a/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -138,7 +138,7 @@ Proof. destruct x as [xn cau]. unfold CReal_abs, CReal_minus, CReal_plus, CReal_opp, inject_Q, proj1_sig in kmaj. apply (Qlt_not_le _ _ kmaj). clear kmaj. - unfold QCauchySeq, QSeqEquiv in cau. + unfold QCauchySeq in cau. rewrite <- (Qplus_le_l _ _ (1#n)). ring_simplify. unfold id in cau. destruct (Pos.lt_total (2*k) n). 2: destruct H. - specialize (cau k (2*k)%positive n). @@ -160,7 +160,7 @@ Qed. Lemma Rcauchy_limit : forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn), QCauchySeq (fun n : positive => - let (p, _) := xcau (4 * n)%positive in proj1_sig (xn p) (4 * n)%positive) id. + let (p, _) := xcau (4 * n)%positive in proj1_sig (xn p) (4 * n)%positive). Proof. intros xn xcau n p q H0 H1. destruct (xcau (4 * p)%positive) as [i imaj], @@ -225,33 +225,27 @@ Proof. let (p, _) := cau (4 * n)%positive in proj1_sig (xn p) (4 * n)%positive) (Rcauchy_limit xn cau)) (2*p)) as H. - simpl (inject_Q - (proj1_sig - (exist (fun x : positive -> Q => QCauchySeq x id) - (fun n : positive => - let (p, _) := cau (4 * n)%positive in - proj1_sig (xn p) (4 * n)%positive) (Rcauchy_limit xn cau)) - (2 * p)%positive)) in H. + unfold proj1_sig in H. pose proof (cau (2*p)%positive) as [k cv]. - destruct (cau (p~0~0~0)%positive) as [i imaj]. + destruct (cau (4 * (2 * p))%positive) as [i imaj]. (* The convergence modulus does not matter here, because a converging Cauchy sequence always converges to its limit with twice the Cauchy modulus. *) exists (max k i). intros j H0. setoid_replace (xn j - - exist (fun x : positive -> Q => QCauchySeq x id) + exist (fun x : positive -> Q => QCauchySeq x) (fun n : positive => let (p0, _) := cau (4 * n)%positive in proj1_sig (xn p0) (4 * n)%positive) (Rcauchy_limit xn cau)) with (xn j - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive) + (inject_Q (proj1_sig (xn i) (p~0~0~0)%positive) - - exist (fun x : positive -> Q => QCauchySeq x id) + exist (fun x : positive -> Q => QCauchySeq x) (fun n : positive => let (p0, _) := cau (4 * n)%positive in proj1_sig (xn p0) (4 * n)%positive) (Rcauchy_limit xn cau))). 2: ring. apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)). apply (CReal_le_trans _ (inject_Q (1#2*p) + inject_Q (1#2*p))). - apply CReal_plus_le_compat. + apply CReal_plus_le_compat. unfold proj1_sig in H. 2: rewrite CReal_abs_minus_sym; exact H. specialize (imaj j i (le_trans _ _ _ (Nat.le_max_r _ _) H0) (le_refl _)). apply (CReal_le_trans _ (inject_Q (1 # 4 * p) + inject_Q (1 # 4 * p))). diff --git a/theories/Reals/Rregisternames.v b/theories/Reals/Rregisternames.v index f09edef600..8b078f2cf3 100644 --- a/theories/Reals/Rregisternames.v +++ b/theories/Reals/Rregisternames.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Reals. +Require Import Raxioms Rfunctions Qreals. (*****************************************************************) (** Register names for use in plugins *) @@ -18,6 +18,9 @@ Register R as reals.R.type. Register R0 as reals.R.R0. Register R1 as reals.R.R1. Register Rle as reals.R.Rle. +Register Rgt as reals.R.Rgt. +Register Rlt as reals.R.Rlt. +Register Rge as reals.R.Rge. Register Rplus as reals.R.Rplus. Register Ropp as reals.R.Ropp. Register Rminus as reals.R.Rminus. @@ -26,5 +29,6 @@ Register Rinv as reals.R.Rinv. Register Rdiv as reals.R.Rdiv. Register IZR as reals.R.IZR. Register Rabs as reals.R.Rabs. -Register sqrt as reals.R.sqrt. Register powerRZ as reals.R.powerRZ. +Register pow as reals.R.pow. +Register Qreals.Q2R as reals.R.Q2R. diff --git a/theories/Sorting/CPermutation.v b/theories/Sorting/CPermutation.v index fac9cd1d6d..31d9f7f0ed 100644 --- a/theories/Sorting/CPermutation.v +++ b/theories/Sorting/CPermutation.v @@ -154,7 +154,7 @@ Qed. Lemma CPermutation_length_1 : forall a b, CPermutation [a] [b] -> a = b. Proof. intros; now apply Permutation_length_1, CPermutation_Permutation. Qed. -Lemma CPermutation_length_1_inv : forall l a, CPermutation [a] l -> l = [a]. +Lemma CPermutation_length_1_inv : forall a l, CPermutation [a] l -> l = [a]. Proof. intros; now apply Permutation_length_1_inv, CPermutation_Permutation. Qed. Lemma CPermutation_swap : forall a b, CPermutation [a; b] [b; a]. @@ -235,9 +235,8 @@ induction m as [| b m]; intros l HC. apply CPermutation_nil in HC; inversion HC. - symmetry in HC. destruct (CPermutation_vs_cons_inv HC) as [m1 [m2 [-> Heq]]]. - apply map_eq_app in Heq as [l1 [l1' [-> [-> Heq]]]]. - symmetry in Heq. - apply map_eq_cons in Heq as [a [l1'' [-> [-> ->]]]]. + apply map_eq_app in Heq as [l1 [l1' [-> [<- Heq]]]]. + apply map_eq_cons in Heq as [a [l1'' [-> [<- <-]]]]. exists (a :: l1'' ++ l1); split. + now simpl; rewrite map_app. + now rewrite app_comm_cons. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index ffef8a216d..1dd9285412 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -552,7 +552,6 @@ Proof. - symmetry in HP. destruct (Permutation_vs_cons_inv HP) as [l3 [l4 Heq]]. destruct (map_eq_app _ _ _ _ Heq) as [l1' [l2' [Heq1 [Heq2 Heq3]]]]; subst. - symmetry in Heq3. destruct (map_eq_cons _ _ Heq3) as [b [l1'' [Heq1' [Heq2' Heq3']]]]; subst. rewrite map_app in HP; simpl in HP. symmetry in HP. diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v index 0ad79825d2..adffa1ded4 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -13,14 +13,15 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -Require Import Orders PeanoNat POrderedType BinNat BinInt +Require Import Orders BoolOrder PeanoNat POrderedType BinNat BinInt RelationPairs EqualitiesFacts. (** * Examples of Ordered Type structures. *) -(** Ordered Type for [nat], [Positive], [N], [Z] with the usual order. *) +(** Ordered Type for [bool], [nat], [Positive], [N], [Z] with the usual order. *) +Module Bool_as_OT := BoolOrder.BoolOrd. Module Nat_as_OT := PeanoNat.Nat. Module Positive_as_OT := BinPos.Pos. Module N_as_OT := BinNat.N. @@ -30,8 +31,9 @@ Module Z_as_OT := BinInt.Z. Module OT_as_DT (O:OrderedType) <: DecidableType := O. -(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *) +(** (Usual) Decidable Type for [bool], [nat], [positive], [N], [Z] *) +Module Bool_as_DT <: UsualDecidableType := Bool_as_OT. Module Nat_as_DT <: UsualDecidableType := Nat_as_OT. Module Positive_as_DT <: UsualDecidableType := Positive_as_OT. Module N_as_DT <: UsualDecidableType := N_as_OT. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 0b3656f586..78b26c83ea 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -44,6 +44,7 @@ Register succ as num.Z.succ. Register pred as num.Z.pred. Register sub as num.Z.sub. Register mul as num.Z.mul. +Register pow as num.Z.pow. Register of_nat as num.Z.of_nat. (** When including property functors, only inline t eq zero one two *) diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 55b9ec4a44..c05ed9ebf4 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -208,7 +208,7 @@ Definition gtb x y := | _ => false end. -Fixpoint eqb x y := +Definition eqb x y := match x, y with | 0, 0 => true | pos p, pos q => Pos.eqb p q diff --git a/theories/extraction/ExtrHaskellString.v b/theories/extraction/ExtrHaskellString.v index 8c61f4e96b..80f527f51b 100644 --- a/theories/extraction/ExtrHaskellString.v +++ b/theories/extraction/ExtrHaskellString.v @@ -8,6 +8,8 @@ Require Import Ascii. Require Import String. Require Import Coq.Strings.Byte. +Require Export ExtrHaskellBasic. + (** * At the moment, Coq's extraction has no way to add extra import * statements to the extracted Haskell code. You will have to @@ -35,19 +37,19 @@ Extract Inductive ascii => "Prelude.Char" (Data.Bits.testBit (Data.Char.ord a) 5) (Data.Bits.testBit (Data.Char.ord a) 6) (Data.Bits.testBit (Data.Char.ord a) 7))". -Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)". -Extract Inlined Constant Ascii.eqb => "(Prelude.==)". +Extract Inlined Constant Ascii.ascii_dec => "((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)". +Extract Inlined Constant Ascii.eqb => "((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)". Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. -Extract Inlined Constant String.string_dec => "(Prelude.==)". -Extract Inlined Constant String.eqb => "(Prelude.==)". +Extract Inlined Constant String.string_dec => "((Prelude.==) :: Prelude.String -> Prelude.String -> Prelude.Bool)". +Extract Inlined Constant String.eqb => "((Prelude.==) :: Prelude.String -> Prelude.String -> Prelude.Bool)". (* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) Extract Inductive byte => "Prelude.Char" ["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. -Extract Inlined Constant Byte.eqb => "(Prelude.==)". -Extract Inlined Constant Byte.byte_eq_dec => "(Prelude.==)". +Extract Inlined Constant Byte.eqb => "((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)". +Extract Inlined Constant Byte.byte_eq_dec => "((Prelude.==) :: Prelude.Char -> Prelude.Char -> Prelude.Bool)". Extract Inlined Constant Ascii.ascii_of_byte => "(\x -> x)". Extract Inlined Constant Ascii.byte_of_ascii => "(\x -> x)". diff --git a/theories/extraction/ExtrOCamlFloats.v b/theories/extraction/ExtrOCamlFloats.v index 02f4b2898b..8d01620ef2 100644 --- a/theories/extraction/ExtrOCamlFloats.v +++ b/theories/extraction/ExtrOCamlFloats.v @@ -14,10 +14,10 @@ Note: the extraction of primitive floats relies on Coq's internal file kernel/float64.ml, so make sure the corresponding binary is available when linking the extracted OCaml code. -For example, if you build a (_CoqProject + coq_makefile)-based project +For example, if you build a ("_CoqProject" + coq_makefile)-based project and if you created an empty subfolder "extracted" and a file "test.v" containing [Cd "extracted". Separate Extraction function_to_extract.], -you will just need to add in the _CoqProject: [test.v], [-I extracted] +you will just need to add in the "_CoqProject" file: [test.v], [-I extracted] and the list of [extracted/*.ml] and [extracted/*.mli] files, then add [CAMLFLAGS += -w -33] in the Makefile.local file. *) diff --git a/theories/extraction/ExtrOcamlBigIntConv.v b/theories/extraction/ExtrOcamlBigIntConv.v index 7740bb41d9..29bd732c78 100644 --- a/theories/extraction/ExtrOcamlBigIntConv.v +++ b/theories/extraction/ExtrOcamlBigIntConv.v @@ -45,14 +45,14 @@ Fixpoint bigint_of_pos p := | xI p => bigint_succ (bigint_twice (bigint_of_pos p)) end. -Fixpoint bigint_of_z z := +Definition bigint_of_z z := match z with | Z0 => bigint_zero | Zpos p => bigint_of_pos p | Zneg p => bigint_opp (bigint_of_pos p) end. -Fixpoint bigint_of_n n := +Definition bigint_of_n n := match n with | N0 => bigint_zero | Npos p => bigint_of_pos p diff --git a/theories/extraction/ExtrOcamlIntConv.v b/theories/extraction/ExtrOcamlIntConv.v index a5be08ece4..d9c88defa5 100644 --- a/theories/extraction/ExtrOcamlIntConv.v +++ b/theories/extraction/ExtrOcamlIntConv.v @@ -42,14 +42,14 @@ Fixpoint int_of_pos p := | xI p => int_succ (int_twice (int_of_pos p)) end. -Fixpoint int_of_z z := +Definition int_of_z z := match z with | Z0 => int_zero | Zpos p => int_of_pos p | Zneg p => int_opp (int_of_pos p) end. -Fixpoint int_of_n n := +Definition int_of_n n := match n with | N0 => int_zero | Npos p => int_of_pos p diff --git a/theories/micromega/DeclConstant.v b/theories/micromega/DeclConstant.v index bd8490d796..2e50481b13 100644 --- a/theories/micromega/DeclConstant.v +++ b/theories/micromega/DeclConstant.v @@ -35,6 +35,7 @@ Require Import List. (** Ground terms (see [GT] below) are built inductively from declared constants. *) Class DeclaredConstant {T : Type} (F : T). +Register DeclaredConstant as micromega.DeclaredConstant.type. Class GT {T : Type} (F : T). diff --git a/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v index 28c7e8c554..7bef11e89a 100644 --- a/theories/micromega/EnvRing.v +++ b/theories/micromega/EnvRing.v @@ -31,6 +31,14 @@ Inductive PExpr {C} : Type := | PEpow : PExpr -> N -> PExpr. Arguments PExpr : clear implicits. +Register PEc as micromega.PExpr.PEc. +Register PEX as micromega.PExpr.PEX. +Register PEadd as micromega.PExpr.PEadd. +Register PEsub as micromega.PExpr.PEsub. +Register PEmul as micromega.PExpr.PEmul. +Register PEopp as micromega.PExpr.PEopp. +Register PEpow as micromega.PExpr.PEpow. + (* Definition of multivariable polynomials with coefficients in C : Type [Pol] represents [X1 ... Xn]. The representation is Horner's where a [n] variable polynomial @@ -60,6 +68,10 @@ Inductive Pol {C} : Type := | PX : Pol -> positive -> Pol -> Pol. Arguments Pol : clear implicits. +Register Pc as micromega.Pol.Pc. +Register Pinj as micromega.Pol.Pinj. +Register PX as micromega.Pol.PX. + Section MakeRingPol. (* Ring elements *) diff --git a/theories/micromega/Lra.v b/theories/micromega/Lra.v index 22cef50e0d..5c8cece845 100644 --- a/theories/micromega/Lra.v +++ b/theories/micromega/Lra.v @@ -20,6 +20,7 @@ Require Import Rdefinitions. Require Import RingMicromega. Require Import VarMap. Require Coq.micromega.Tauto. +Require Import Rregisternames. Declare ML Module "micromega_plugin". Ltac rchange := diff --git a/theories/micromega/QMicromega.v b/theories/micromega/QMicromega.v index e28de1a620..1fbc5a648a 100644 --- a/theories/micromega/QMicromega.v +++ b/theories/micromega/QMicromega.v @@ -154,6 +154,9 @@ Qed. Definition QWitness := Psatz Q. +Register QWitness as micromega.QWitness.type. + + Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool. Require Import List. diff --git a/theories/micromega/RMicromega.v b/theories/micromega/RMicromega.v index a67c273c7f..fd8903eac9 100644 --- a/theories/micromega/RMicromega.v +++ b/theories/micromega/RMicromega.v @@ -150,7 +150,17 @@ Inductive Rcst := | CInv (r : Rcst) | COpp (r : Rcst). - +Register Rcst as micromega.Rcst.type. +Register C0 as micromega.Rcst.C0. +Register C1 as micromega.Rcst.C1. +Register CQ as micromega.Rcst.CQ. +Register CZ as micromega.Rcst.CZ. +Register CPlus as micromega.Rcst.CPlus. +Register CMinus as micromega.Rcst.CMinus. +Register CMult as micromega.Rcst.CMult. +Register CPow as micromega.Rcst.CPow. +Register CInv as micromega.Rcst.CInv. +Register COpp as micromega.Rcst.COpp. Definition z_of_exp (z : Z + nat) := match z with diff --git a/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v index 04de9509ac..fb7fbcf80b 100644 --- a/theories/micromega/RingMicromega.v +++ b/theories/micromega/RingMicromega.v @@ -298,6 +298,15 @@ Inductive Psatz : Type := | PsatzC : C -> Psatz | PsatzZ : Psatz. +Register PsatzIn as micromega.Psatz.PsatzIn. +Register PsatzSquare as micromega.Psatz.PsatzSquare. +Register PsatzMulC as micromega.Psatz.PsatzMulC. +Register PsatzMulE as micromega.Psatz.PsatzMulE. +Register PsatzAdd as micromega.Psatz.PsatzAdd. +Register PsatzC as micromega.Psatz.PsatzC. +Register PsatzZ as micromega.Psatz.PsatzZ. + + (** Given a list [l] of NFormula and an extended polynomial expression [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a logic consequence of the conjunction of the formulae in l. @@ -672,6 +681,13 @@ Inductive Op2 : Set := (* binary relations *) | OpLt | OpGt. +Register OpEq as micromega.Op2.OpEq. +Register OpNEq as micromega.Op2.OpNEq. +Register OpLe as micromega.Op2.OpLe. +Register OpGe as micromega.Op2.OpGe. +Register OpLt as micromega.Op2.OpLt. +Register OpGt as micromega.Op2.OpGt. + Definition eval_op2 (o : Op2) : R -> R -> Prop := match o with | OpEq => req @@ -686,12 +702,15 @@ Definition eval_pexpr : PolEnv -> PExpr C -> R := PEeval rplus rtimes rminus ropp phi pow_phi rpow. #[universes(template)] -Record Formula (T:Type) : Type := { +Record Formula (T:Type) : Type := Build_Formula{ Flhs : PExpr T; Fop : Op2; Frhs : PExpr T }. +Register Formula as micromega.Formula.type. +Register Build_Formula as micromega.Formula.Build_Formula. + Definition eval_formula (env : PolEnv) (f : Formula C) : Prop := let (lhs, op, rhs) := f in (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs). diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index a3e3cc3e9d..6e89089355 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -37,6 +37,16 @@ Section S. | N : GFormula -> GFormula | I : GFormula -> option AF -> GFormula -> GFormula. + Register TT as micromega.GFormula.TT. + Register FF as micromega.GFormula.FF. + Register X as micromega.GFormula.X. + Register A as micromega.GFormula.A. + Register Cj as micromega.GFormula.Cj. + Register D as micromega.GFormula.D. + Register N as micromega.GFormula.N. + Register I as micromega.GFormula.I. + + Section MAPX. Variable F : TX -> TX. @@ -137,6 +147,8 @@ End S. (** Typical boolean formulae *) Definition BFormula (A : Type) := @GFormula A Prop unit unit. +Register BFormula as micromega.BFormula.type. + Section MAPATOMS. Context {TA TA':Type}. Context {TX : Type}. diff --git a/theories/micromega/VarMap.v b/theories/micromega/VarMap.v index c2472f6303..e28c27f400 100644 --- a/theories/micromega/VarMap.v +++ b/theories/micromega/VarMap.v @@ -33,6 +33,11 @@ Inductive t {A} : Type := | Branch : t -> A -> t -> t . Arguments t : clear implicits. +Register Branch as micromega.VarMap.Branch. +Register Elt as micromega.VarMap.Elt. +Register Empty as micromega.VarMap.Empty. +Register t as micromega.VarMap.type. + Section MakeVarMap. Variable A : Type. diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index efb263faf3..bff9671fee 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -564,10 +564,14 @@ Inductive ZArithProof := . (*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof.*) +Register ZArithProof as micromega.ZArithProof.type. +Register DoneProof as micromega.ZArithProof.DoneProof. +Register RatProof as micromega.ZArithProof.RatProof. +Register CutProof as micromega.ZArithProof.CutProof. +Register EnumProof as micromega.ZArithProof.EnumProof. +Register ExProof as micromega.ZArithProof.ExProof. -(* n/d <= x -> d*x - n >= 0 *) - (* In order to compute the 'cut', we need to express a polynomial P as a * Q + b. - b is the constant diff --git a/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v index 521ac61e18..5b15dc072a 100644 --- a/theories/micromega/ZifyInst.v +++ b/theories/micromega/ZifyInst.v @@ -42,6 +42,9 @@ Instance Op_lt : BinRel lt := {| TR := Z.lt; TRInj := Nat2Z.inj_lt |}. Add BinRel Op_lt. +Instance Op_Nat_lt : BinRel Nat.lt := Op_lt. +Add BinRel Op_Nat_lt. + Instance Op_gt : BinRel gt := {| TR := Z.gt; TRInj := Nat2Z.inj_gt |}. Add BinRel Op_gt. @@ -50,10 +53,16 @@ Instance Op_le : BinRel le := {| TR := Z.le; TRInj := Nat2Z.inj_le |}. Add BinRel Op_le. +Instance Op_Nat_le : BinRel Nat.le := Op_le. +Add BinRel Op_Nat_le. + Instance Op_eq_nat : BinRel (@eq nat) := {| TR := @eq Z ; TRInj := fun x y : nat => iff_sym (Nat2Z.inj_iff x y) |}. Add BinRel Op_eq_nat. +Instance Op_Nat_eq : BinRel (Nat.eq) := Op_eq_nat. +Add BinRel Op_Nat_eq. + (* zify_nat_op *) Instance Op_plus : BinOp Nat.add := {| TBOp := Z.add; TBOpInj := Nat2Z.inj_add |}. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 57ba036a62..a26eb9dfbe 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -647,7 +647,7 @@ archclean:: $(MLIFILES:.mli=.cmi): %.cmi: %.mli $(SHOW)'CAMLC -c $<' - $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< $(MLGFILES:.mlg=.ml): %.ml: %.mlg $(SHOW)'COQPP $<' @@ -656,53 +656,53 @@ $(MLGFILES:.mlg=.ml): %.ml: %.mlg # Stupid hack around a deficient syntax: we cannot concatenate two expansions $(filter %.cmo, $(MLFILES:.ml=.cmo) $(MLGFILES:.mlg=.cmo)): %.cmo: %.ml $(SHOW)'CAMLC -c $<' - $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< # Same hack $(filter %.cmx, $(MLFILES:.ml=.cmx) $(MLGFILES:.mlg=.cmx)): %.cmx: %.ml $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' - $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(FOR_PACK) $< + $(HIDE)$(TIMER) $(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(FOR_PACK) $< $(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa $(SHOW)'CAMLOPT -shared -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ -linkall -shared -o $@ $< $(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib $(SHOW)'CAMLC -a -o $@' - $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ $(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib $(SHOW)'CAMLOPT -a -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ $(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa $(SHOW)'CAMLOPT -shared -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ -shared -linkall -o $@ $< $(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx $(SHOW)'CAMLOPT -a -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $< + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $< $(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack $(SHOW)'CAMLC -a -o $@' - $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ $(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack $(SHOW)'CAMLC -pack -o $@' - $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ $(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack $(SHOW)'CAMLOPT -pack -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ # This rule is for _CoqProject with no .mllib nor .mlpack $(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ -shared -o $@ $< ifneq (,$(TIMING)) diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 86d213453b..aa3c5b9d3b 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -316,7 +316,7 @@ let identifier = (* This misses unicode stuff, and it adds "[" and "]". It's only an approximation of idents - used for detecting whether an underscore is part of an identifier or meant to indicate emphasis *) -let nonidentchar = [^ 'A'-'Z' 'a'-'z' '_' '[' ']' '\'' '0'-'9' '@' ] +let nonidentchar = [^ 'A'-'Z' 'a'-'z' '_' '[' ']' '\'' '0'-'9' '@' '\"' '\'' '`'] let printing_token = [^ ' ' '\t']* diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index ebea5e146c..743d1d2026 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -710,7 +710,7 @@ let make_bl_scheme mode mind = let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let bl_goal = EConstr.of_constr bl_goal in - let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal + let (ans, _, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, EConstr.EInstance.empty) lnamesparrec nparrec) in ([|ans|], ctx) @@ -843,7 +843,7 @@ let make_lb_scheme mode mind = let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let lb_goal = EConstr.of_constr lb_goal in - let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal + let (ans, _, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) in ([|ans|], ctx) @@ -1014,7 +1014,7 @@ let make_eq_decidability mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let side_eff = side_effect_of_mode mode in - let (ans, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx + let (ans, _, _, _, ctx) = Declare.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:(EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) (compute_dec_tact ind lnamesparrec nparrec) in diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index e4fa212a23..d3c1d2e767 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -53,7 +53,7 @@ let rec partial_order cmp = function (z, Inr (List.add_set cmp x (List.remove cmp y zge))) else (z, Inr zge)) res in - browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge)) + browse ((y,Inl x)::res) xge' (List.union cmp xge yge) else browse res (List.add_set cmp y (List.union cmp xge' yge)) xge with Not_found -> browse res (List.add_set cmp y xge') xge @@ -82,16 +82,25 @@ let warn_non_full_mutual = (fun (x,xge,y,yge,isfix,rest) -> non_full_mutual_message x xge y yge isfix rest) -let check_mutuality env evd isfix fixl = +let warn_non_recursive = + CWarnings.create ~name:"non-recursive" ~category:"fixpoints" + (fun (x,isfix) -> + let k = if isfix then "fixpoint" else "cofixpoint" in + strbrk "Not a truly recursive " ++ str k ++ str ".") + +let check_true_recursivity env evd isfix fixl = let names = List.map fst fixl in let preorder = List.map (fun (id,def) -> - (id, List.filter (fun id' -> not (Id.equal id id') && Termops.occur_var env evd id' def) names)) + (id, List.filter (fun id' -> Termops.occur_var env evd id' def) names)) fixl in let po = partial_order Id.equal preorder in match List.filter (function (_,Inr _) -> true | _ -> false) po with | (x,Inr xge)::(y,Inr yge)::rest -> warn_non_full_mutual (x,xge,y,yge,isfix,rest) + | _ -> + match po with + | [x,Inr []] -> warn_non_recursive (x,isfix) | _ -> () let interp_fix_context ~program_mode ~cofix env sigma fix = @@ -222,7 +231,7 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis let check_recursive isfix env evd (fixnames,_,fixdefs,_) = if List.for_all Option.has_some fixdefs then begin let fixdefs = List.map Option.get fixdefs in - check_mutuality env evd isfix (List.combine fixnames fixdefs) + check_true_recursivity env evd isfix (List.combine fixnames fixdefs) end let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = @@ -232,12 +241,12 @@ let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = Evd.evar_universe_context evd, (fixnames,fixrs,fixdefs,fixtypes) (* XXX: Unify with interp_recursive *) -let interp_fixpoint ~cofix l : +let interp_fixpoint ?(check_recursivity=true) ~cofix l : ( (Constr.t, Constr.types) recursive_preentry * UState.universe_decl * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list) = let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l in - check_recursive true env evd fix; + if check_recursivity then check_recursive true env evd fix; let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index a19b96f0f3..dcb61d38d9 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -58,7 +58,8 @@ val interp_recursive : (** Exported for Funind *) val interp_fixpoint - : cofix:bool + : ?check_recursivity:bool -> + cofix:bool -> lident option fix_expr_gen list -> (Constr.t, Constr.types) recursive_preentry * UState.universe_decl * UState.t * diff --git a/vernac/declare.ml b/vernac/declare.ml index 366dd2d026..f4636c5724 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -135,11 +135,6 @@ type import_status = ImportDefaultBehavior | ImportNeedQualified (** Declaration of constants and parameters *) -type constant_obj = { - cst_kind : Decls.logical_kind; - cst_locl : import_status; -} - type 'a proof_entry = { proof_entry_body : 'a Entries.const_entry_body; (* List of section variables *) @@ -265,8 +260,11 @@ type 'a constant_entry = | ParameterEntry of Entries.parameter_entry | PrimitiveEntry of Entries.primitive_entry -(* At load-time, the segment starting from the module name to the discharge *) -(* section (if Remark or Fact) is needed to access a construction *) +type constant_obj = { + cst_kind : Decls.logical_kind; + cst_locl : import_status; +} + let load_constant i ((sp,kn), obj) = if Nametab.exists_cci sp then raise (AlreadyDeclared (None, Libnames.basename sp)); @@ -292,8 +290,7 @@ let check_exists id = raise (AlreadyDeclared (None, id)) let cache_constant ((sp,kn), obj) = - (* Invariant: the constant must exist in the logical environment, except when - redefining it when exiting a section. See [discharge_constant]. *) + (* Invariant: the constant must exist in the logical environment *) let kn' = if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) then Constant.make1 kn @@ -306,13 +303,7 @@ let cache_constant ((sp,kn), obj) = let discharge_constant ((sp, kn), obj) = Some obj -(* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_constant cst = { - cst_kind = cst.cst_kind; - cst_locl = cst.cst_locl; -} - -let classify_constant cst = Libobject.Substitute (dummy_constant cst) +let classify_constant cst = Libobject.Substitute cst let (objConstant : constant_obj Libobject.Dyn.tag) = let open Libobject in @@ -589,12 +580,12 @@ let fixpoint_message indexes l = | [] -> CErrors.anomaly (Pp.str "no recursive definition.") | [id] -> Id.print id ++ str " is recursively defined" ++ (match indexes with - | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" + | Some [|i|] -> str " (guarded on "++pr_rank i++str " argument)" | _ -> mt ()) | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ spc () ++ str "are recursively defined" ++ match indexes with - | Some a -> spc () ++ str "(decreasing respectively on " ++ + | Some a -> spc () ++ str "(guarded respectively on " ++ prvect_with_sep pr_comma pr_rank a ++ str " arguments)" | None -> mt ())) @@ -771,7 +762,7 @@ let build_constant_by_tactic ~name ?(opaque=Transparent) ~uctx ~sign ~poly typ t let build_by_tactic ?(side_eff=true) env ~uctx ~poly ~typ tac = let name = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = Environ.(val_of_named_context (named_context env)) in - let ce, status, univs = build_constant_by_tactic ~name ~uctx ~sign ~poly typ tac in + let ce, status, uctx = build_constant_by_tactic ~name ~uctx ~sign ~poly typ tac in let cb, uctx = if side_eff then inline_private_constants ~uctx env ce else @@ -779,7 +770,7 @@ let build_by_tactic ?(side_eff=true) env ~uctx ~poly ~typ tac = let (cb, ctx), _eff = Future.force ce.proof_entry_body in cb, UState.merge ~sideff:false Evd.univ_rigid uctx ctx in - cb, ce.proof_entry_type, status, univs + cb, ce.proof_entry_type, ce.proof_entry_universes, status, uctx let declare_abstract ~name ~poly ~kind ~sign ~secsign ~opaque ~solve_tac sigma concl = (* EJGA: flush_and_check_evars is only used in abstract, could we diff --git a/vernac/declare.mli b/vernac/declare.mli index e23e148ddc..a297f25868 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -249,7 +249,7 @@ val build_by_tactic -> poly:bool -> typ:EConstr.types -> unit Proofview.tactic - -> Constr.constr * Constr.types option * bool * UState.t + -> Constr.constr * Constr.types option * Entries.universes_entry * bool * UState.t (** {6 Helpers to obtain proof state when in an interactive proof } *) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 13145d3757..3cb10364b5 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -68,6 +68,11 @@ let make_bullet s = let add_control_flag ~loc ~flag { CAst.v = cmd } = CAst.make ~loc { cmd with control = flag :: cmd.control } +let test_hash_ident = + let open Pcoq.Lookahead in + to_entry "test_hash_ident" begin + lk_kw "#" >> lk_ident >> check_no_space + end } GRAMMAR EXTEND Gram @@ -226,63 +231,9 @@ GRAMMAR EXTEND Gram | IDENT "Constraint"; l = LIST1 univ_constraint SEP "," -> { VernacConstraint l } ] ] ; - - register_token: - [ [ r = register_prim_token -> { CPrimitives.OT_op r } - | r = register_type_token -> { CPrimitives.OT_type r } ] ] - ; - - register_type_token: - [ [ "#int63_type" -> { CPrimitives.PT_int63 } - | "#float64_type" -> { CPrimitives.PT_float64 } ] ] - ; - - register_prim_token: - [ [ "#int63_head0" -> { CPrimitives.Int63head0 } - | "#int63_tail0" -> { CPrimitives.Int63tail0 } - | "#int63_add" -> { CPrimitives.Int63add } - | "#int63_sub" -> { CPrimitives.Int63sub } - | "#int63_mul" -> { CPrimitives.Int63mul } - | "#int63_div" -> { CPrimitives.Int63div } - | "#int63_mod" -> { CPrimitives.Int63mod } - | "#int63_lsr" -> { CPrimitives.Int63lsr } - | "#int63_lsl" -> { CPrimitives.Int63lsl } - | "#int63_land" -> { CPrimitives.Int63land } - | "#int63_lor" -> { CPrimitives.Int63lor } - | "#int63_lxor" -> { CPrimitives.Int63lxor } - | "#int63_addc" -> { CPrimitives.Int63addc } - | "#int63_subc" -> { CPrimitives.Int63subc } - | "#int63_addcarryc" -> { CPrimitives.Int63addCarryC } - | "#int63_subcarryc" -> { CPrimitives.Int63subCarryC } - | "#int63_mulc" -> { CPrimitives.Int63mulc } - | "#int63_diveucl" -> { CPrimitives.Int63diveucl } - | "#int63_div21" -> { CPrimitives.Int63div21 } - | "#int63_addmuldiv" -> { CPrimitives.Int63addMulDiv } - | "#int63_eq" -> { CPrimitives.Int63eq } - | "#int63_lt" -> { CPrimitives.Int63lt } - | "#int63_le" -> { CPrimitives.Int63le } - | "#int63_compare" -> { CPrimitives.Int63compare } - | "#float64_opp" -> { CPrimitives.Float64opp } - | "#float64_abs" -> { CPrimitives.Float64abs } - | "#float64_eq" -> { CPrimitives.Float64eq } - | "#float64_lt" -> { CPrimitives.Float64lt } - | "#float64_le" -> { CPrimitives.Float64le } - | "#float64_compare" -> { CPrimitives.Float64compare } - | "#float64_classify" -> { CPrimitives.Float64classify } - | "#float64_add" -> { CPrimitives.Float64add } - | "#float64_sub" -> { CPrimitives.Float64sub } - | "#float64_mul" -> { CPrimitives.Float64mul } - | "#float64_div" -> { CPrimitives.Float64div } - | "#float64_sqrt" -> { CPrimitives.Float64sqrt } - | "#float64_of_int63" -> { CPrimitives.Float64ofInt63 } - | "#float64_normfr_mantissa" -> { CPrimitives.Float64normfr_mantissa } - | "#float64_frshiftexp" -> { CPrimitives.Float64frshiftexp } - | "#float64_ldshiftexp" -> { CPrimitives.Float64ldshiftexp } - | "#float64_next_up" -> { CPrimitives.Float64next_up } - | "#float64_next_down" -> { CPrimitives.Float64next_down } - ] ] - ; - + register_token: + [ [ test_hash_ident; "#"; r = IDENT -> { CPrimitives.parse_op_or_type ~loc r } ] ] + ; thm_token: [ [ "Theorem" -> { Theorem } | IDENT "Lemma" -> { Lemma } diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 060f069419..bed593234b 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -133,7 +133,7 @@ let solve_by_tac ?loc name evi t poly uctx = try (* the status is dropped. *) let env = Global.env () in - let body, types, _, uctx = + let body, types, _univs, _, uctx = Declare.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in Inductiveops.control_only_guard env (Evd.from_ctx uctx) (EConstr.of_constr body); Some (body, types, uctx) diff --git a/vernac/pfedit.ml b/vernac/pfedit.ml index d6b9592176..e6c66ee503 100644 --- a/vernac/pfedit.ml +++ b/vernac/pfedit.ml @@ -1,9 +1,19 @@ (* Compat API / *) let get_current_context = Declare.get_current_context +[@@ocaml.deprecated "Use [Declare.get_current_context]"] let solve = Proof.solve +[@@ocaml.deprecated "Use [Proof.solve]"] let by = Declare.by +[@@ocaml.deprecated "Use [Declare.by]"] let refine_by_tactic = Proof.refine_by_tactic +[@@ocaml.deprecated "Use [Proof.refine_by_tactic]"] (* We don't want to export this anymore, but we do for now *) -let build_by_tactic = Declare.build_by_tactic +let build_by_tactic ?side_eff env ~uctx ~poly ~typ tac = + let b, t, _unis, safe, uctx = + Declare.build_by_tactic ?side_eff env ~uctx ~poly ~typ tac in + b, t, safe, uctx +[@@ocaml.deprecated "Use [Proof.build_by_tactic]"] + let build_constant_by_tactic = Declare.build_constant_by_tactic +[@@ocaml.deprecated "Use [Proof.build_constant_by_tactic]"] diff --git a/vernac/proof_global.ml b/vernac/proof_global.ml index b6c07042e2..54d1db44a4 100644 --- a/vernac/proof_global.ml +++ b/vernac/proof_global.ml @@ -1,7 +1,12 @@ (* compatibility module; can be removed once we agree on the API *) type t = Declare.Proof.t +[@@ocaml.deprecated "Use [Declare.Proof.t]"] let map_proof = Declare.Proof.map_proof +[@@ocaml.deprecated "Use [Declare.Proof.map_proof]"] let get_proof = Declare.Proof.get_proof +[@@ocaml.deprecated "Use [Declare.Proof.get_proof]"] -type opacity_flag = Declare.opacity_flag = Opaque | Transparent +type opacity_flag = Declare.opacity_flag = + | Opaque [@ocaml.deprecated "Use [Declare.Opaque]"] + | Transparent [@ocaml.deprecated "Use [Declare.Transparent]"] diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index df39c617d3..df94f69cf6 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -475,7 +475,7 @@ let program_inference_hook env sigma ev = Evarutil.is_ground_term sigma concl) then None else - let c, _, _, ctx = + let c, _, _, _, ctx = Declare.build_by_tactic ~poly:false env ~uctx:(Evd.evar_universe_context sigma) ~typ:concl tac in Some (Evd.set_universe_context sigma ctx, EConstr.of_constr c) |