diff options
143 files changed, 4478 insertions, 4090 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1be10f91d0..a8ddb09a5d 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-04-20-V1" + CACHEKEY: "bionic_coq-V2019-06-11-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -295,16 +295,12 @@ windows32: - /^pr-.*$/ lint: - image: docker:git stage: test - script: - - apk add bash - - dev/lint-repository.sh + script: dev/lint-repository.sh dependencies: [] - before_script: [] variables: - # we need an unknown amount of history for per-commit linting - GIT_DEPTH: "" + GIT_DEPTH: "" # we need an unknown amount of history for per-commit linting + OPAM_SWITCH: base pkg:opam: stage: test diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index f0e17909c1..0d11d092ba 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -105,6 +105,12 @@ files end with newlines) is checked by the `lint` job on GitLab CI (using git hook which fixes these errors at commit time. `configure` automatically sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. +Each commit in your pull request should compile (this makes bisecting +easier). The `lint` job checks compilation of the OCaml files, please +try to keep the rest of Coq in a functioning state as well. + +You may run the linter yourself with `dev/lint-repository.sh`. + Here are a few tags Coq developers may add to your PR and what they mean. In general feedback and requests for you as the pull request author will be in the comments and tags are only used to organize pull requests. @@ -50,10 +50,15 @@ WHAT DO YOU NEED ? findlib/ocamlfind as Coq's makefile will use it to locate the libraries during the build. + Debian / Ubuntu users can get the necessary system packages for + CoqIDE with: + + $ sudo apt-get install libgtksourceview-3.0-dev + Opam (https://opam.ocaml.org/) is recommended to install OCaml and the corresponding packages. - $ opam install num ocamlfind lablgtk conf-gtksourceview + $ opam install num ocamlfind lablgtk3-sourceview3 should get you a reasonable OCaml environment to compile Coq. diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 7c8f73c7e4..78ca5e830a 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -331,7 +331,9 @@ IF "%CYGWIN_QUIET%" == "Y" ( )
IF "%GTK_FROM_SOURCES%"=="N" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk3,mingw64-%ARCH%-gtksourceview3.0
+ SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk3,mingw64-%ARCH%-libxml2
+ REM gtksourceview3 is always built from sources until the bug in DLLMain is fixed in cygwin
+ REM SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtksourceview3.0
)
REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
@@ -362,6 +364,9 @@ IF NOT "%APPVEYOR%" == "True" ( ECHO "========== INSTALL CYGWIN =========="
+REM If you need to add packages, see https://cygwin.com/packages/package_list.html for package names
+REM In the description of each package you also find the file list and maintainer there
+
IF "%RUNSETUP%"=="Y" (
%SETUP% ^
--proxy "%PROXY%" ^
@@ -376,6 +381,7 @@ IF "%RUNSETUP%"=="Y" ( -P pkg-config ^
-P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-windows_default_manifest ^
-P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^
+ -P adwaita-icon-theme ^
-P libiconv-devel,libunistring-devel,libncurses-devel ^
-P gettext-devel,libgettextpo-devel ^
-P libglib2.0-devel,libgdk_pixbuf2.0-devel ^
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 549f70e8fe..0699e2bd44 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -104,7 +104,8 @@ cd /build mkdir -p "$SOURCE_LOCAL_CACHE_CFMT" # sysroot prefix for the above /build/host/target combination -PREFIX=$CYGWIN_INSTALLDIR_MFMT/usr/$TARGET_ARCH/sys-root/mingw +# This must be in MFMT (C:/.../) because the OCaml library path is based on it and OCaml is a MinGW application. +PREFIXMINGW=$CYGWIN_INSTALLDIR_MFMT/usr/$TARGET_ARCH/sys-root/mingw # Install / Prefix folder for COQ PREFIXCOQ=$RESULT_INSTALLDIR_MFMT @@ -113,10 +114,10 @@ PREFIXCOQ=$RESULT_INSTALLDIR_MFMT if [ "$INSTALLOCAML" == "Y" ]; then PREFIXOCAML=$PREFIXCOQ else - PREFIXOCAML=$PREFIX + PREFIXOCAML=$PREFIXMINGW fi -mkdir -p "$PREFIX/bin" +mkdir -p "$PREFIXMINGW/bin" mkdir -p "$PREFIXCOQ/bin" mkdir -p "$PREFIXOCAML/bin" @@ -487,7 +488,7 @@ function build_post { function build_conf_make_inst { if build_prep "$1" "$2" "$3" ; then $4 - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIX" "${@:5}" + logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXMINGW" "${@:5}" # shellcheck disable=SC2086 log1 make $MAKE_OPT log2 make install @@ -895,9 +896,9 @@ function make_libxml2 { # Note: latest release version 2.9.2 fails during configuring lzma, so using 2.9.1 # Note: python binding requires <sys/select.h> which doesn't exist on cygwin if build_prep https://git.gnome.org/browse/libxml2/snapshot libxml2-2.9.1 tar.xz ; then - # ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIX" --disable-shared --without-python + # ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIXMINGW" --disable-shared --without-python # shared library required by gtksourceview - ./autogen.sh --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIX" --without-python + ./autogen.sh --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXMINGW" --without-python # shellcheck disable=SC2086 log1 make $MAKE_OPT all log2 make install @@ -910,14 +911,13 @@ function make_libxml2 { function make_gtk_sourceview3 { # Cygwin packet dependencies: intltool - # gtksourceview-2.11.2 requires GTK2 - # gtksourceview-2.91.9 requires GTK3 - # => We use gtksourceview-2.11.2 which seems to be the newest GTK2 based one + # Note: this is always built from sources cause of a bug in the cygwin delivery. + # Just dependencies are only built if we build from sources if [ "$GTK_FROM_SOURCES" == "Y" ]; then make_gtk3 make_libxml2 - build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.9 tar.bz2 true fi + build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.11 tar.xz make_arch_pkg_config } ##### FLEXDLL FLEXLINK ##### @@ -930,7 +930,7 @@ function make_gtk_sourceview3 { # Install flexdll objects function install_flexdll { - cp flexdll.h "/usr/$TARGET_ARCH/sys-root/mingw/include" + cp flexdll.h "$PREFIXMINGW/include" if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then cp flexdll*_mingw.o "/usr/$TARGET_ARCH/bin" cp flexdll*_mingw.o "$PREFIXOCAML/bin" @@ -1202,7 +1202,7 @@ function make_lablgtk { function copy_coq_dll { if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - cp "/usr/${ARCH}-w64-mingw32/sys-root/mingw/bin/$1" "$PREFIXCOQ/bin/$1" + cp "$PREFIXMINGW/bin/$1" "$PREFIXCOQ/bin/$1" fi } @@ -1282,27 +1282,58 @@ function copy_coq_objects { } # Copy required GTK config and support files +# This must be called from inside the coq build folder! function copy_coq_gtk { - echo 'gtk-theme-name = "Default"' > "$PREFIX/etc/gtk-3.0/gtkrc" - echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-3.0/gtkrc" + + glib-compile-schemas $PREFIXMINGW/share/glib-2.0/schemas/ + echo 'gtk-theme-name = "Default"' > "$PREFIXMINGW/etc/gtk-3.0/gtkrc" if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIX/etc/gtk-3.0" '*' "$PREFIXCOQ/gtk-3.0" - install_glob "$PREFIX/share/gtksourceview-3.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-3.0/language-specs" - install_glob "$PREFIX/share/gtksourceview-3.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-3.0/styles" - install_rec "$PREFIX/share/themes" '*' "$PREFIXCOQ/share/themes" + install_glob "$PREFIXMINGW/etc/gtk-3.0" '*' "$PREFIXCOQ/gtk-3.0" + install -D -T "$PREFIXMINGW/share/glib-2.0/schemas/gschemas.compiled" "$PREFIXCOQ/share/glib-2.0/schemas/gschemas.compiled" + + install_glob "$PREFIXMINGW/share/gtksourceview-3.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-3.0/language-specs" + install -D -T "ide/coq.lang" "$PREFIXCOQ/share/gtksourceview-3.0/language-specs/coq.lang" + install -D -T "ide/coq-ssreflect.lang" "$PREFIXCOQ/share/gtksourceview-3.0/language-specs/coq-ssreflect.lang" + + install_glob "$PREFIXMINGW/share/gtksourceview-3.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-3.0/styles" + install -D -T "ide/coq_style.xml" "$PREFIXCOQ/share/gtksourceview-3.0/styles/coq_style.xml" + + install_rec "$PREFIXMINGW/share/themes" '*' "$PREFIXCOQ/share/themes" + + FOLDERS="" + # The sizes include all default sizes given in index.theme + # The types used haven been recorded with ProcMon in an installation with all icons present + for SIZE in 16x16 22x22 32x32 48x48; do + for TYPE in \ + actions/bookmark actions/document devices/drive actions/format-text actions/go actions/list \ + actions/media actions/pan actions/process actions/system actions/window \ + mimetypes/text places/folder places/user status/dialog + do + CLASS=$(dirname $TYPE) + ICON=$(basename $TYPE) + if [[ ! "$FOLDERS" =~ "$SIZE/$CLASS" ]] ;then + FOLDERS="$FOLDERS$SIZE/$CLASS," + fi + install_rec "/usr/share/icons/Adwaita/$SIZE/$CLASS" "$ICON*" "$PREFIXCOQ/share/icons/Adwaita/$SIZE/$CLASS" + done + done + echo Folders=$FOLDERS + install -D -T "/usr/share/icons/Adwaita/index.theme" "$PREFIXCOQ/share/icons/Adwaita/index.theme" + sed -i "s|^Directories=.*|Directories=$FOLDERS|" "$PREFIXCOQ/share/icons/Adwaita/index.theme" + gtk-update-icon-cache -f "$PREFIXCOQ/share/icons/Adwaita/" # This below item look like a bug in make install - if [ -d "$PREFIXCOQ/share/coq/" ] ; then - COQSHARE="$PREFIXCOQ/share/coq/" - else - COQSHARE="$PREFIXCOQ/share/" - fi - - mkdir -p "$PREFIXCOQ/ide" - mv "$COQSHARE"*.png "$PREFIXCOQ/ide" - rmdir "$PREFIXCOQ/share/coq" || true + # if [ -d "$PREFIXCOQ/share/coq/" ] ; then + # COQSHARE="$PREFIXCOQ/share/coq/" + # else + # COQSHARE="$PREFIXCOQ/share/" + # fi + + # mkdir -p "$PREFIXCOQ/ide" + # mv "$COQSHARE"*.png "$PREFIXCOQ/ide" + # rmdir "$PREFIXCOQ/share/coq" || true fi } @@ -1454,7 +1485,7 @@ function make_gcc { --enable-languages=c --disable-nls \ --disable-libsanitizer --disable-libssp --disable-libquadmath --disable-libgomp --disable-libvtv --disable-lto # --disable-decimal-float seems to be required - # --with-sysroot="$PREFIX" results in configure error that this is not an absolute path + # --with-sysroot="$PREFIXMINGW" results in configure error that this is not an absolute path # shellcheck disable=SC2086 log1 make $MAKE_OPT log2 make install diff --git a/dev/build/windows/patches_coq/ocaml-4.07.1.patch b/dev/build/windows/patches_coq/ocaml-4.07.1.patch new file mode 100755 index 0000000000..2d61b5b838 --- /dev/null +++ b/dev/build/windows/patches_coq/ocaml-4.07.1.patch @@ -0,0 +1,97 @@ +diff/patch file created on Tue, Jun 11, 2019 10:15:38 AM with: +difftar-folder.sh tarballs/ocaml-4.07.1.tar.gz ocaml-4.07.1 1 +TARFILE= tarballs/ocaml-4.07.1.tar.gz +FOLDER= ocaml-4.07.1/ +TARSTRIP= 1 +TARPREFIX= ocaml-4.07.1/ +ORIGFOLDER= ocaml-4.07.1.orig +--- ocaml-4.07.1.orig/byterun/caml/osdeps.h 2018-10-04 15:38:56.000000000 +0200 ++++ ocaml-4.07.1/byterun/caml/osdeps.h 2019-06-11 10:13:50.766997600 +0200 +@@ -98,6 +98,11 @@ + */ + extern char_os *caml_secure_getenv(char_os const *var); + ++/* Modify or delete environment variable. ++ Returns 0 on success or an error code. ++*/ ++extern int caml_putenv(char_os const *var, char_os const *value); ++ + /* If [fd] refers to a terminal or console, return the number of rows + (lines) that it displays. Otherwise, or if the number of rows + cannot be determined, return -1. */ +--- ocaml-4.07.1.orig/byterun/debugger.c 2018-10-04 15:38:56.000000000 +0200 ++++ ocaml-4.07.1/byterun/debugger.c 2019-06-11 10:14:02.706013700 +0200 +@@ -180,6 +180,7 @@ + if (address == NULL) return; + if (dbg_addr != NULL) caml_stat_free(dbg_addr); + dbg_addr = address; ++ caml_putenv(_T("CAML_DEBUG_SOCKET"),_T("")); + + #ifdef _WIN32 + winsock_startup(); +--- ocaml-4.07.1.orig/byterun/unix.c 2018-10-04 15:38:56.000000000 +0200 ++++ ocaml-4.07.1/byterun/unix.c 2019-06-11 10:14:11.252438800 +0200 +@@ -430,6 +430,19 @@ + #endif + } + ++int caml_putenv(char_os const *var, char_os const *value) ++{ ++ char_os * s; ++ int ret; ++ ++ s = caml_stat_strconcat_os(3, var, _T("="), value); ++ ret = putenv_os(s); ++ if (ret == -1) { ++ caml_stat_free(s); ++ } ++ return ret; ++} ++ + int caml_num_rows_fd(int fd) + { + #ifdef TIOCGWINSZ +--- ocaml-4.07.1.orig/byterun/win32.c 2018-10-04 15:38:56.000000000 +0200 ++++ ocaml-4.07.1/byterun/win32.c 2019-06-11 10:14:19.485640700 +0200 +@@ -727,6 +727,19 @@ + return _wgetenv(var); + } + ++int caml_putenv(char_os const *var, char_os const *value) ++{ ++ char_os * s; ++ int ret; ++ ++ s = caml_stat_strconcat_os(3, var, _T("="), value); ++ ret = putenv_os(s); ++ if (ret == -1) { ++ caml_stat_free(s); ++ } ++ return ret; ++} ++ + /* caml_win32_getenv is used to implement Sys.getenv and Unix.getenv in such a + way that they get direct access to the Win32 environment rather than to the + copy that is cached by the C runtime system. The result of caml_win32_getenv +--- ocaml-4.07.1.orig/config/Makefile.mingw 2018-10-04 15:38:56.000000000 +0200 ++++ ocaml-4.07.1//config/Makefile.mingw 2019-06-11 10:14:44.492969800 +0200 +@@ -89,7 +89,7 @@ + NATDYNLINK=true + NATDYNLINKOPTS= + CMXS=cmxs +-RUNTIMED=false ++RUNTIMED=true + ASM_CFI_SUPPORTED=false + WITH_FRAME_POINTERS=false + UNIX_OR_WIN32=win32 +--- ocaml-4.07.1.orig/config/Makefile.mingw64 2018-10-04 15:38:56.000000000 +0200 ++++ ocaml-4.07.1//config/Makefile.mingw64 2019-06-11 10:14:53.664784900 +0200 +@@ -89,7 +89,7 @@ + NATDYNLINK=true + NATDYNLINKOPTS= + CMXS=cmxs +-RUNTIMED=false ++RUNTIMED=true + ASM_CFI_SUPPORTED=false + WITH_FRAME_POINTERS=false + UNIX_OR_WIN32=win32 diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index bba17314f7..e8c8d22678 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -11,7 +11,7 @@ git_download fiat_crypto # c.f. https://github.com/coq/coq/pull/8313#issuecomment-416650241 fiat_crypto_CI_TARGETS1="c-files printlite lite" -fiat_crypto_CI_TARGETS2="print-nobigmem nobigmem" +fiat_crypto_CI_TARGETS2="coq" ( cd "${CI_BUILD_DIR}/fiat_crypto" && git submodule update --init --recursive && \ ulimit -s 32768 && \ diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 8eebb3af64..818454dbbc 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-04-20-V1" +# CACHEKEY: "bionic_coq-V2019-06-11-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -38,7 +38,7 @@ ENV COMPILER="4.05.0" # `num` does not have a version number as the right version to install varies # with the compiler version. ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.4.0" \ - CI_OPAM="menhir.20181113 elpi.1.2.0 ocamlgraph.1.8.8" + CI_OPAM="menhir.20181113 elpi.1.3.1 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" diff --git a/dev/ci/user-overlays/08726-herbelin-master+more-stable-meaning-to-Discharge-flag.sh b/dev/ci/user-overlays/08726-herbelin-master+more-stable-meaning-to-Discharge-flag.sh new file mode 100644 index 0000000000..242b177d71 --- /dev/null +++ b/dev/ci/user-overlays/08726-herbelin-master+more-stable-meaning-to-Discharge-flag.sh @@ -0,0 +1,23 @@ +if [ "$CI_PULL_REQUEST" = "8726" ] || [ "$CI_BRANCH" = "master+more-stable-meaning-to-Discharge-flag" ]; then + + fiat_parsers_CI_BRANCH=master+change-for-coq-pr8726 + fiat_parsers_CI_REF=master+change-for-coq-pr8726 + fiat_parsers_CI_GITURL=https://github.com/herbelin/fiat + + elpi_CI_BRANCH=coq-master+fix-global-pr8726 + elpi_CI_REF=coq-master+fix-global-pr8726 + elpi_CI_GITURL=https://github.com/herbelin/coq-elpi + + equations_CI_BRANCH=master+fix-global-pr8726 + equations_CI_REF=master+fix-global-pr8726 + equations_CI_GITURL=https://github.com/herbelin/Coq-Equations + + mtac2_CI_BRANCH=master+fix-global-pr8726 + mtac2_CI_REF=master+fix-global-pr8726 + mtac2_CI_GITURL=https://github.com/herbelin/Mtac2 + + paramcoq_CI_BRANCH=master+fix-global-pr8726 + paramcoq_CI_REF=master+fix-global-pr8726 + paramcoq_CI_GITURL=https://github.com/herbelin/paramcoq + +fi diff --git a/dev/ci/user-overlays/09566-ejgallego-proof_global+move_termination_routine_out.sh b/dev/ci/user-overlays/09566-ejgallego-proof_global+move_termination_routine_out.sh new file mode 100644 index 0000000000..e4cf74aa51 --- /dev/null +++ b/dev/ci/user-overlays/09566-ejgallego-proof_global+move_termination_routine_out.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "9566" ] || [ "$CI_BRANCH" = "proof_global+move_termination_routine_out" ]; then + + aac_tactics_CI_REF=proof_global+move_termination_routine_out + aac_tactics_CI_GITURL=https://github.com/ejgallego/aac-tactics + + equations_CI_REF=proof_global+move_termination_routine_out + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + paramcoq_CI_REF=proof_global+move_termination_routine_out + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + +fi diff --git a/dev/ci/user-overlays/10319-SkySkimmer-vernac-when-sideff.sh b/dev/ci/user-overlays/10319-SkySkimmer-vernac-when-sideff.sh new file mode 100644 index 0000000000..c5f1510357 --- /dev/null +++ b/dev/ci/user-overlays/10319-SkySkimmer-vernac-when-sideff.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "10319" ] || [ "$CI_BRANCH" = "vernac-when-sideff" ]; then + + mtac2_CI_REF=vernac-when-sideff + mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 + + equations_CI_REF=vernac-when-sideff + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/10334-ppedrot-rm-kernel-sideeff-role.sh b/dev/ci/user-overlays/10334-ppedrot-rm-kernel-sideeff-role.sh new file mode 100644 index 0000000000..2c3f490c03 --- /dev/null +++ b/dev/ci/user-overlays/10334-ppedrot-rm-kernel-sideeff-role.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10334" ] || [ "$CI_BRANCH" = "rm-kernel-sideeff-role" ]; then + + equations_CI_REF=rm-kernel-sideeff-role + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/10358-gares-elpi13.sh b/dev/ci/user-overlays/10358-gares-elpi13.sh new file mode 100644 index 0000000000..d2ba9b5ddf --- /dev/null +++ b/dev/ci/user-overlays/10358-gares-elpi13.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10358" ] || [ "$CI_BRANCH" = "elpi-13-coq" ]; then + + elpi_CI_REF="elpi-13-coq" + elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi + +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 339ac2d9b7..51d90df89f 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -5,6 +5,21 @@ - Functions and types deprecated in 8.10 have been removed in Coq 8.11. +- Type Decl_kinds.locality has been restructured, see commit + message. Main change to do generally is to change the flag "Global" + to "Global ImportDefaultBehavior". + +Proof state: + + Proofs that are attached to a top-level constant (such as lemmas) + are represented by `Lemmas.t`, as they do contain additional + information related to the constant declaration. + + Plugins that require access to the information about currently + opened lemmas can add one of the `![proof]` attributes to their + `mlg` entry, which will refine the type accordingly. See + documentation in `vernacentries` for more information. + ## Changes between Coq 8.9 and Coq 8.10 ### ML4 Pre Processing @@ -59,6 +74,19 @@ Coqlib: command then enables to locate the registered constant through its name. The name resolution is dynamic. +Proof state: + +- Handling of proof state has been fully functionalized, thus it is + not possible to call global functions such as `get_current_context ()`. + + The main type for functions that need to handle proof state is + `Proof_global.t`. + + Unfortunately, this change was not possible to do in a + backwards-compatible way, but in most case the api changes are + straightforward, with functions taking and returning an extra + argument. + Macros: - The RAW_TYPED AS and GLOB_TYPED AS stanzas of the ARGUMENT EXTEND macro are diff --git a/dev/lint-commits.sh b/dev/lint-commits.sh index 96c92e3162..539bb5f1f9 100755 --- a/dev/lint-commits.sh +++ b/dev/lint-commits.sh @@ -19,21 +19,40 @@ fi BASE_COMMIT="$1" HEAD_COMMIT="$2" -bad=() +bad_ws=() +bad_compile=() while IFS= read -r commit; do echo Checking "$commit" # git diff --check # uses .gitattributes to know what to check if ! git diff --check "${commit}^" "$commit"; - then - bad+=("$commit") + then bad_ws+=("$commit") + fi + + if ! make -f Makefile.dune check + then bad_compile+=("$commit") fi done < <(git rev-list "$HEAD_COMMIT" --not "$BASE_COMMIT" --) -if [ "${#bad[@]}" != 0 ] +# report errors + +CODE=0 + +if [ "${#bad_ws[@]}" != 0 ] then >&2 echo "Whitespace errors!" - >&2 echo "In commits ${bad[*]}" + >&2 echo "In commits ${bad_ws[*]}" >&2 echo "If you use emacs, you can prevent this kind of error from reoccurring by installing ws-butler and enabling ws-butler-convert-leading-tabs-or-spaces." - exit 1 + >&2 echo + CODE=1 fi + +if [ "${#bad_compile[@]}" != 0 ] +then + >&2 echo "Compilation errors!" + >&2 echo "In commits ${bad_compile[*]}" + >&2 echo + CODE=1 +fi + +exit $CODE diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index ff9b32fe78..0338cd42c7 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -73,8 +73,6 @@ FLAGS_ML_PATH = os.path.join(ROOT_PATH, 'lib', 'flags.ml') COQARGS_ML_PATH = os.path.join(ROOT_PATH, 'toplevel', 'coqargs.ml') G_VERNAC_PATH = os.path.join(ROOT_PATH, 'vernac', 'g_vernac.mlg') DOC_INDEX_PATH = os.path.join(ROOT_PATH, 'doc', 'stdlib', 'index-list.html.template') -BUG_4798_PATH = os.path.join(ROOT_PATH, 'test-suite', 'bugs', 'closed', 'bug_4798.v') -BUG_9166_PATH = os.path.join(ROOT_PATH, 'test-suite', 'bugs', 'closed', 'bug_9166.v') TEST_SUITE_RUN_PATH = os.path.join(ROOT_PATH, 'test-suite', 'tools', 'update-compat', 'run.sh') TEST_SUITE_PATHS = tuple(os.path.join(ROOT_PATH, 'test-suite', 'success', i) for i in ('CompatOldOldFlag.v', 'CompatOldFlag.v', 'CompatPreviousFlag.v', 'CompatCurrentFlag.v')) @@ -401,34 +399,6 @@ dev/tools/update-compat.py --assert-unchanged %s || exit $? ''' % ' '.join([('--master' if args['master'] else ''), ('--release' if args['release'] else '')]).strip() update_if_changed(contents, new_contents, TEST_SUITE_RUN_PATH, pass_through_shebang=True, **args) -def update_bug_4789(new_versions, **args): - # we always update this compat notation to oldest - # currently-supported compat version, which should never be the - # current version - with open(BUG_4798_PATH, 'r') as f: contents = f.read() - new_contents = BUG_HEADER + r"""Check match 2 with 0 => 0 | S n => n end. -Notation "|" := 1 (compat "%s"). -Check match 2 with 0 => 0 | S n => n end. (* fails *) -""" % new_versions[0] - update_if_changed(contents, new_contents, BUG_4798_PATH, **args) - -def update_bug_9166(new_versions, **args): - # we always update this compat notation to oldest - # currently-supported compat version, which should never be the - # current version - with open(BUG_9166_PATH, 'r') as f: contents = f.read() - new_contents = BUG_HEADER + r"""Set Warnings "+deprecated". - -Notation bar := option (compat "%s"). - -Definition foo (x: nat) : nat := - match x with - | 0 => 0 - | S bar => bar - end. -""" % new_versions[0] - update_if_changed(contents, new_contents, BUG_9166_PATH, **args) - def update_compat_notations_in(old_versions, new_versions, contents): for v in old_versions: if v not in new_versions: @@ -508,7 +478,5 @@ if __name__ == '__main__': update_test_suite(new_versions, **args) update_test_suite_run(**args) update_doc_index(new_versions, **args) - update_bug_4789(new_versions, **args) - update_bug_9166(new_versions, **args) update_compat_notations(known_versions, new_versions, **args) display_git_grep(known_versions, new_versions) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 4ce87faaa1..87b4d31054 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -533,7 +533,7 @@ let _ = let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintConstr", TyNonTerminal(ty_constr, TyNil)) in let cmd_fn c ~atts = VtDefault (fun () -> in_current_context econstr_display c) in - let cmd_class _ = VtQuery,VtNow in + let cmd_class _ = VtQuery in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintConstr" [cmd] @@ -542,7 +542,7 @@ let _ = let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintPureConstr", TyNonTerminal(ty_constr, TyNil)) in let cmd_fn c ~atts = VtDefault (fun () -> in_current_context print_pure_econstr c) in - let cmd_class _ = VtQuery,VtNow in + let cmd_class _ = VtQuery in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintPureConstr" [cmd] diff --git a/doc/changelog/03-notations/10180-deprecate-notations.rst b/doc/changelog/03-notations/10180-deprecate-notations.rst new file mode 100644 index 0000000000..01f2e893ed --- /dev/null +++ b/doc/changelog/03-notations/10180-deprecate-notations.rst @@ -0,0 +1,6 @@ +- The :cmd:`Notation` and :cmd:`Infix` commands now support the `deprecated` + attribute. The former `compat` annotation for notations is + deprecated, and its semantics changed. It is now made equivalent to using + a `deprecated` attribute, and is no longer connected with the `-compat` + command-line flag. + (`#10180 <https://github.com/coq/coq/pull/10180>`_, by Maxime Dénès). diff --git a/doc/changelog/04-tactics/10318-select-only-error.rst b/doc/changelog/04-tactics/10318-select-only-error.rst new file mode 100644 index 0000000000..03ed15d948 --- /dev/null +++ b/doc/changelog/04-tactics/10318-select-only-error.rst @@ -0,0 +1,4 @@ +- The goal selector tactical ``only`` now checks that the goal range + it is given is valid instead of ignoring goals out of the focus + range. (`#10318 <https://github.com/coq/coq/pull/10318>`_, by Gaëtan + Gilbert). diff --git a/doc/changelog/06-ssreflect/10302-case-HoTT.rst b/doc/changelog/06-ssreflect/10302-case-HoTT.rst new file mode 100644 index 0000000000..686b3c3cca --- /dev/null +++ b/doc/changelog/06-ssreflect/10302-case-HoTT.rst @@ -0,0 +1,7 @@ +- Make the ``case E: t`` tactic work together with + :flag:`Universe Polymorphism` and equality in :g:`Type`. + This makes tacn:`case` compatible with the HoTT + library https://github.com/HoTT/HoTT. + (`#10302 <https://github.com/coq/coq/pull/10302>`_, + fixes `#10301 <https://github.com/coq/coq/issues/10301>`_, + by Andreas Lynge, review by Enrico Tassi) diff --git a/doc/changelog/06-ssreflect/10305-unfold-HoTT.rst b/doc/changelog/06-ssreflect/10305-unfold-HoTT.rst new file mode 100644 index 0000000000..b82de1a879 --- /dev/null +++ b/doc/changelog/06-ssreflect/10305-unfold-HoTT.rst @@ -0,0 +1,7 @@ +- Make the ``rewrite /t`` tactic work together with + :flag:`Universe Polymorphism`. + This makes tacn:`rewrite` compatible with the HoTT + library https://github.com/HoTT/HoTT. + (`#10305 <https://github.com/coq/coq/pull/10305>`_, + fixes `#9336 <https://github.com/coq/coq/issues/9336>`_, + by Andreas Lynge, review by Enrico Tassi) diff --git a/doc/changelog/08-tools/10245-require-command-line.rst b/doc/changelog/08-tools/10245-require-command-line.rst new file mode 100644 index 0000000000..54417077f5 --- /dev/null +++ b/doc/changelog/08-tools/10245-require-command-line.rst @@ -0,0 +1,6 @@ +- Add command line options `-require-import`, `-require-export`, + `-require-import-from` and `-require-export-from`, as well as their + shorthand, `-ri`, `-re`, `-refrom` and -`rifrom`. Deprecate + confusing command line option `-require` + (`#10245 <https://github.com/coq/coq/pull/10245>`_ + by Hugo Herbelin, review by Emilio Gallego). diff --git a/doc/changelog/09-coqide/10360-windows.rst b/doc/changelog/09-coqide/10360-windows.rst new file mode 100644 index 0000000000..b7f8374c73 --- /dev/null +++ b/doc/changelog/09-coqide/10360-windows.rst @@ -0,0 +1,3 @@ +- Fix CoqIDE instability on Windows after the update to gtk3 + (`#10360 <https://github.com/coq/coq/pull/10360>`_, by Michael Soegtrop, + closes `#9885 <https://github.com/coq/coq/issues/9885>`_). diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 0b005a2341..73d94c2a51 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -287,7 +287,7 @@ VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY | ![ proof_query ] [ "ExploreProof" ] -> { fun ~pstate -> let sigma, env = Pfedit.get_current_context pstate in - let pprf = Proof.partial_proof Proof_global.(give_me_the_proof pstate) in + let pprf = Proof.partial_proof (Proof_global.get_proof pstate) in Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 1e582e6456..eb8161c2bb 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -7,7 +7,7 @@ let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = DeclareDef.declare_definition ident k ce ubinders imps ?hook_data let declare_definition ~poly ident sigma body = - let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in + let k = Decl_kinds.(Global ImportDefaultBehavior, poly, Definition) in let udecl = UState.default_univ_decl in edeclare ident k ~opaque:false sigma udecl body None [] diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index db4ebd5e38..6ff15e52a3 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -120,7 +120,9 @@ reference manual. Here are the most important user-visible changes: - CoqIDE: - - CoqIDE now depends on gtk+3 and lablgtk3 instead of gtk+2 and lablgtk2 + - CoqIDE now depends on gtk+3 and lablgtk3 instead of gtk+2 and lablgtk2. + The INSTALL file available in the Coq sources has been updated to list + the new dependencies (`#9279 <https://github.com/coq/coq/pull/9279>`_, by Hugo Herbelin, with help from Jacques Garrigue, Emilio Jesús Gallego Arias, Michael Sogetrop and Vincent Laporte). @@ -525,7 +527,13 @@ Other changes in 8.10+beta1 (`#9829 <https://github.com/coq/coq/pull/9829>`_, by Vincent Laporte). - :cmd:`Coercion` does not warn ambiguous paths which are obviously - convertible with existing ones + convertible with existing ones. The ambiguous paths messages have been + turned to warnings, thus now they could appear in the output of ``coqc``. + The convertibility checking procedure for coercion paths is complete for + paths consisting of coercions satisfying the uniform inheritance condition, + but some coercion paths could be reported as ambiguous even if they are + convertible with existing ones when they have coercions that don't satisfy + the uniform inheritance condition (`#9743 <https://github.com/coq/coq/pull/9743>`_, closes `#3219 <https://github.com/coq/coq/issues/3219>`_, by Kazuhiko Sakaguchi). @@ -957,6 +965,19 @@ Notations refer to `app`. Solution: wrap `_ ++ _` in `(_ ++ _)%list` (or whichever scope you want). +Changes in 8.8.0 +~~~~~~~~~~~~~~~~ + +Various bug fixes. + +Changes in 8.8.1 +~~~~~~~~~~~~~~~~ + +- Some quality-of-life fixes. +- Numerous improvements to the documentation. +- Fix a critical bug related to primitive projections and :tacn:`native_compute`. +- Ship several additional Coq libraries with the Windows installer. + Version 8.8 ----------- diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index ebaa6fde66..38f6714f46 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -1508,7 +1508,10 @@ the following attributes names are recognized: Takes as value the optional attributes ``since`` and ``note``; both have a string value. - This attribute can trigger the following warnings: + 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. @string. :undocumented: @@ -1516,6 +1519,11 @@ the following attributes names are recognized: .. warn:: Tactic Notation @qualid is deprecated since @string. @string. :undocumented: + .. warn:: Notation @string__1 is deprecated since @string__2. @string__3. + + :n:`@string__1` is the actual notation, :n:`@string__2` is the version number, + :n:`@string__3` is the note. + .. example:: .. coqtop:: all reset warn diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index bdda35fcc0..48d5f4075e 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -124,11 +124,11 @@ and ``coqtop``, unless stated otherwise: :ref:`names-of-libraries` and the command Declare ML Module Section :ref:`compiled-files`. -:-Q *directory* dirpath: Add physical path *directory* to the list of +:-Q *directory* *dirpath*: Add physical path *directory* to the list of directories where |Coq| looks for a file and bind it to the logical directory *dirpath*. The subdirectory structure of *directory* is recursively available from |Coq| using absolute names (extending the - dirpath prefix) (see Section :ref:`qualified-names`).Note that only those + :n:`@dirpath` prefix) (see Section :ref:`qualified-names`). Note that only those subdirectories and files which obey the lexical conventions of what is an :n:`@ident` are taken into account. Conversely, the underlying file systems or operating systems may be more restrictive @@ -138,13 +138,13 @@ and ``coqtop``, unless stated otherwise: disallow two files differing only in the case in the same directory. .. seealso:: Section :ref:`names-of-libraries`. -:-R *directory* dirpath: Do as -Q *directory* dirpath but make the +:-R *directory* *dirpath*: Do as ``-Q`` *directory* *dirpath* but make the subdirectory structure of *directory* recursively visible so that the recursive contents of physical *directory* is available from |Coq| using short or partially qualified names. .. seealso:: Section :ref:`names-of-libraries`. -:-top dirpath: Set the toplevel module name to dirpath instead of Top. +:-top *dirpath*: Set the toplevel module name to :n:`@dirpath` instead of ``Top``. Not valid for `coqc` as the toplevel module name is inferred from the name of the output file. :-exclude-dir *directory*: Exclude any subdirectory named *directory* @@ -164,10 +164,17 @@ and ``coqtop``, unless stated otherwise: :-lv *file*, -load-vernac-source-verbose *file*: Load and execute the |Coq| script from *file.v*. Write its contents to the standard output as it is executed. -:-load-vernac-object dirpath: Load |Coq| compiled library dirpath. This - is equivalent to runningRequire dirpath. -:-require dirpath: Load |Coq| compiled library dirpath and import it. - This is equivalent to running Require Import dirpath. +:-load-vernac-object *qualid*: Load |Coq| compiled library :n:`@qualid`. This + is equivalent to running :cmd:`Require` :n:`qualid`. +:-ri *qualid*, -require-import *qualid*: Load |Coq| compiled library :n:`@qualid` and import it. + This is equivalent to running :cmd:`Require Import` :n:`@qualid`. +:-re *qualid*, -require-export *qualid*: Load |Coq| compiled library :n:`@qualid` and transitively import it. + This is equivalent to running :cmd:`Require Export` :n:`@qualid`. +:-rifrom *dirpath* *qualid*, -require-import-from *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid` and import it. + This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Import` :n:`@qualid`. +:-refrom *dirpath* *qualid*, -require-export-from *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid` and transitively import it. + This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Export` :n:`@qualid`. +:-require *qualid*: Deprecated; use ``-ri`` *qualid*. :-batch: Exit just after argument parsing. Available for ``coqtop`` only. :-compile *file.v*: Deprecated; use ``coqc`` instead. Compile file *file.v* into *file.vo*. This option implies -batch (exit just after argument parsing). It is available only @@ -193,7 +200,7 @@ and ``coqtop``, unless stated otherwise: :-emacs, -ide-slave: Start a special toplevel to communicate with a specific IDE. :-impredicative-set: Change the logical theory of |Coq| by declaring the - sort Set impredicative. + sort :g:`Set` impredicative. .. warning:: diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index c48dd5b99e..46f9826e41 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -52,7 +52,7 @@ the variable :token:`ident` matches any complex expression with (possible) dependencies in the variables :n:`@ident__i` and returns a functional term of the form :n:`fun @ident__1 … ident__n => @term`. -The main entry of the grammar is :n:`@expr`. This language is used in proof +The main entry of the grammar is :n:`@ltac_expr`. This language is used in proof mode but it can also be used in toplevel definitions as shown below. .. note:: @@ -89,39 +89,39 @@ mode but it can also be used in toplevel definitions as shown below. :n:`((try (repeat (@tactic__1 || @tactic__2)); @tactic__3); [ {+| @tactic } ]); @tactic__4` .. productionlist:: coq - expr : `expr` ; `expr` - : [> `expr` | ... | `expr` ] - : `expr` ; [ `expr` | ... | `expr` ] - : `tacexpr3` - tacexpr3 : do (`natural` | `ident`) `tacexpr3` - : progress `tacexpr3` - : repeat `tacexpr3` - : try `tacexpr3` - : once `tacexpr3` - : exactly_once `tacexpr3` - : timeout (`natural` | `ident`) `tacexpr3` - : time [`string`] `tacexpr3` - : only `selector`: `tacexpr3` - : `tacexpr2` - tacexpr2 : `tacexpr1` || `tacexpr3` - : `tacexpr1` + `tacexpr3` - : tryif `tacexpr1` then `tacexpr1` else `tacexpr1` - : `tacexpr1` - tacexpr1 : fun `name` ... `name` => `atom` + ltac_expr : `ltac_expr` ; `ltac_expr` + : [> `ltac_expr` | ... | `ltac_expr` ] + : `ltac_expr` ; [ `ltac_expr` | ... | `ltac_expr` ] + : `ltac_expr3` + ltac_expr3 : do (`natural` | `ident`) `ltac_expr3` + : progress `ltac_expr3` + : repeat `ltac_expr3` + : try `ltac_expr3` + : once `ltac_expr3` + : exactly_once `ltac_expr3` + : timeout (`natural` | `ident`) `ltac_expr3` + : time [`string`] `ltac_expr3` + : only `selector`: `ltac_expr3` + : `ltac_expr2` + ltac_expr2 : `ltac_expr1` || `ltac_expr3` + : `ltac_expr1` + `ltac_expr3` + : tryif `ltac_expr1` then `ltac_expr1` else `ltac_expr1` + : `ltac_expr1` + ltac_expr1 : fun `name` ... `name` => `atom` : let [rec] `let_clause` with ... with `let_clause` in `atom` : match goal with `context_rule` | ... | `context_rule` end : match reverse goal with `context_rule` | ... | `context_rule` end - : match `expr` with `match_rule` | ... | `match_rule` end + : match `ltac_expr` with `match_rule` | ... | `match_rule` end : lazymatch goal with `context_rule` | ... | `context_rule` end : lazymatch reverse goal with `context_rule` | ... | `context_rule` end - : lazymatch `expr` with `match_rule` | ... | `match_rule` end + : lazymatch `ltac_expr` with `match_rule` | ... | `match_rule` end : multimatch goal with `context_rule` | ... | `context_rule` end : multimatch reverse goal with `context_rule` | ... | `context_rule` end - : multimatch `expr` with `match_rule` | ... | `match_rule` end + : multimatch `ltac_expr` with `match_rule` | ... | `match_rule` end : abstract `atom` : abstract `atom` using `ident` - : first [ `expr` | ... | `expr` ] - : solve [ `expr` | ... | `expr` ] + : first [ `ltac_expr` | ... | `ltac_expr` ] + : solve [ `ltac_expr` | ... | `ltac_expr` ] : idtac [ `message_token` ... `message_token`] : fail [`natural`] [`message_token` ... `message_token`] : gfail [`natural`] [`message_token` ... `message_token`] @@ -134,31 +134,31 @@ mode but it can also be used in toplevel definitions as shown below. : type_term `term` : numgoals : guard `test` - : assert_fails `tacexpr3` - : assert_succeeds `tacexpr3` + : assert_fails `ltac_expr3` + : assert_succeeds `ltac_expr3` : `tactic` : `qualid` `tacarg` ... `tacarg` : `atom` atom : `qualid` : () : `integer` - : ( `expr` ) + : ( `ltac_expr` ) component : `string` | `qualid` message_token : `string` | `ident` | `integer` tacarg : `qualid` : () : ltac : `atom` : `term` - let_clause : `ident` [`name` ... `name`] := `expr` - context_rule : `context_hyp`, ..., `context_hyp` |- `cpattern` => `expr` - : `cpattern` => `expr` - : |- `cpattern` => `expr` - : _ => `expr` + let_clause : `ident` [`name` ... `name`] := `ltac_expr` + context_rule : `context_hyp`, ..., `context_hyp` |- `cpattern` => `ltac_expr` + : `cpattern` => `ltac_expr` + : |- `cpattern` => `ltac_expr` + : _ => `ltac_expr` context_hyp : `name` : `cpattern` : `name` := `cpattern` [: `cpattern`] - match_rule : `cpattern` => `expr` - : context [`ident`] [ `cpattern` ] => `expr` - : _ => `expr` + match_rule : `cpattern` => `ltac_expr` + : context [`ident`] [ `cpattern` ] => `ltac_expr` + : _ => `ltac_expr` test : `integer` = `integer` : `integer` (< | <= | > | >=) `integer` selector : [`ident`] @@ -171,8 +171,8 @@ mode but it can also be used in toplevel definitions as shown below. .. productionlist:: coq top : [Local] Ltac `ltac_def` with ... with `ltac_def` - ltac_def : `ident` [`ident` ... `ident`] := `expr` - : `qualid` [`ident` ... `ident`] ::= `expr` + ltac_def : `ident` [`ident` ... `ident`] := `ltac_expr` + : `qualid` [`ident` ... `ident`] ::= `ltac_expr` .. _ltac-semantics: @@ -197,12 +197,12 @@ Sequence A sequence is an expression of the following form: -.. tacn:: @expr__1 ; @expr__2 +.. tacn:: @ltac_expr__1 ; @ltac_expr__2 :name: ltac-seq - The expression :n:`@expr__1` is evaluated to :n:`v__1`, which must be + The expression :n:`@ltac_expr__1` is evaluated to :n:`v__1`, which must be a tactic value. The tactic :n:`v__1` is applied to the current goal, - possibly producing more goals. Then :n:`@expr__2` is evaluated to + possibly producing more goals. Then :n:`@ltac_expr__2` is evaluated to produce :n:`v__2`, which must be a tactic value. The tactic :n:`v__2` is applied to all the goals produced by the prior application. Sequence is associative. @@ -213,10 +213,10 @@ Local application of tactics Different tactics can be applied to the different goals using the following form: -.. tacn:: [> {*| @expr }] +.. tacn:: [> {*| @ltac_expr }] :name: [> ... | ... | ... ] (dispatch) - The expressions :n:`@expr__i` are evaluated to :n:`v__i`, for + The expressions :n:`@ltac_expr__i` are evaluated to :n:`v__i`, for i = 1, ..., n and all have to be tactics. The :n:`v__i` is applied to the i-th goal, for i = 1, ..., n. It fails if the number of focused goals is not exactly n. @@ -227,31 +227,31 @@ following form: were given. For instance, ``[> | auto]`` is a shortcut for ``[> idtac | auto ]``. - .. tacv:: [> {*| @expr__i} | @expr .. | {*| @expr__j}] + .. tacv:: [> {*| @ltac_expr__i} | @ltac_expr .. | {*| @ltac_expr__j}] - In this variant, :n:`@expr` is used for each goal coming after those - covered by the list of :n:`@expr__i` but before those covered by the - list of :n:`@expr__j`. + In this variant, :n:`@ltac_expr` is used for each goal coming after those + covered by the list of :n:`@ltac_expr__i` but before those covered by the + list of :n:`@ltac_expr__j`. - .. tacv:: [> {*| @expr} | .. | {*| @expr}] + .. tacv:: [> {*| @ltac_expr} | .. | {*| @ltac_expr}] In this variant, idtac is used for the goals not covered by the two lists of - :n:`@expr`. + :n:`@ltac_expr`. - .. tacv:: [> @expr .. ] + .. tacv:: [> @ltac_expr .. ] - In this variant, the tactic :n:`@expr` is applied independently to each of + In this variant, the tactic :n:`@ltac_expr` is applied independently to each of the goals, rather than globally. In particular, if there are no goals, the tactic is not run at all. A tactic which expects multiple goals, such as ``swap``, would act as if a single goal is focused. - .. tacv:: @expr__0 ; [{*| @expr__i}] + .. tacv:: @ltac_expr__0 ; [{*| @ltac_expr__i}] This variant of local tactic application is paired with a sequence. In this - variant, there must be as many :n:`@expr__i` as goals generated - by the application of :n:`@expr__0` to each of the individual goals + variant, there must be as many :n:`@ltac_expr__i` as goals generated + by the application of :n:`@ltac_expr__0` to each of the individual goals independently. All the above variants work in this form too. - Formally, :n:`@expr ; [ ... ]` is equivalent to :n:`[> @expr ; [> ... ] .. ]`. + Formally, :n:`@ltac_expr ; [ ... ]` is equivalent to :n:`[> @ltac_expr ; [> ... ] .. ]`. .. _goal-selectors: @@ -261,53 +261,53 @@ Goal selectors We can restrict the application of a tactic to a subset of the currently focused goals with: -.. tacn:: @toplevel_selector : @expr +.. tacn:: @toplevel_selector : @ltac_expr :name: ... : ... (goal selector) We can also use selectors as a tactical, which allows to use them nested in a tactic expression, by using the keyword ``only``: - .. tacv:: only @selector : @expr + .. tacv:: only @selector : @ltac_expr :name: only ... : ... - When selecting several goals, the tactic :token:`expr` is applied globally to all + When selecting several goals, the tactic :token:`ltac_expr` is applied globally to all selected goals. - .. tacv:: [@ident] : @expr + .. tacv:: [@ident] : @ltac_expr - In this variant, :token:`expr` is applied locally to a goal previously named + In this variant, :token:`ltac_expr` is applied locally to a goal previously named by the user (see :ref:`existential-variables`). - .. tacv:: @num : @expr + .. tacv:: @num : @ltac_expr - In this variant, :token:`expr` is applied locally to the :token:`num`-th goal. + In this variant, :token:`ltac_expr` is applied locally to the :token:`num`-th goal. - .. tacv:: {+, @num-@num} : @expr + .. tacv:: {+, @num-@num} : @ltac_expr - In this variant, :n:`@expr` is applied globally to the subset of goals + In this variant, :n:`@ltac_expr` is applied globally to the subset of goals described by the given ranges. You can write a single ``n`` as a shortcut for ``n-n`` when specifying multiple ranges. - .. tacv:: all: @expr + .. tacv:: all: @ltac_expr :name: all: ... - In this variant, :token:`expr` is applied to all focused goals. ``all:`` can only + In this variant, :token:`ltac_expr` is applied to all focused goals. ``all:`` can only be used at the toplevel of a tactic expression. - .. tacv:: !: @expr + .. tacv:: !: @ltac_expr - In this variant, if exactly one goal is focused, :token:`expr` is + In this variant, if exactly one goal is focused, :token:`ltac_expr` is applied to it. Otherwise the tactic fails. ``!:`` can only be used at the toplevel of a tactic expression. - .. tacv:: par: @expr + .. tacv:: par: @ltac_expr :name: par: ... - In this variant, :n:`@expr` is applied to all focused goals in parallel. + In this variant, :n:`@ltac_expr` is applied to all focused goals in parallel. The number of workers can be controlled via the command line option ``-async-proofs-tac-j`` taking as argument the desired number of workers. Limitations: ``par:`` only works on goals containing no existential - variables and :n:`@expr` must either solve the goal completely or do + variables and :n:`@ltac_expr` must either solve the goal completely or do nothing (i.e. it cannot make some progress). ``par:`` can only be used at the toplevel of a tactic expression. @@ -322,10 +322,10 @@ For loop There is a for loop that repeats a tactic :token:`num` times: -.. tacn:: do @num @expr +.. tacn:: do @num @ltac_expr :name: do - :n:`@expr` is evaluated to ``v`` which must be a tactic value. This tactic + :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. This tactic value ``v`` is applied :token:`num` times. Supposing :token:`num` > 1, after the first application of ``v``, ``v`` is applied, at least once, to the generated subgoals and so on. It fails if the application of ``v`` fails before the num @@ -336,24 +336,24 @@ Repeat loop We have a repeat loop with: -.. tacn:: repeat @expr +.. tacn:: repeat @ltac_expr :name: repeat - :n:`@expr` is evaluated to ``v``. If ``v`` denotes a tactic, this tactic is + :n:`@ltac_expr` is evaluated to ``v``. If ``v`` denotes a tactic, this tactic is applied to each focused goal independently. If the application succeeds, the tactic is applied recursively to all the generated subgoals until it eventually fails. The recursion stops in a subgoal when the tactic has failed *to make - progress*. The tactic :n:`repeat @expr` itself never fails. + progress*. The tactic :n:`repeat @ltac_expr` itself never fails. Error catching ~~~~~~~~~~~~~~ We can catch the tactic errors with: -.. tacn:: try @expr +.. tacn:: try @ltac_expr :name: try - :n:`@expr` is evaluated to ``v`` which must be a tactic value. The tactic + :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied to each focused goal independently. If the application of ``v`` fails in a goal, it catches the error and leaves the goal unchanged. If the level of the exception is positive, then the exception is re-raised with its @@ -364,10 +364,10 @@ Detecting progress We can check if a tactic made progress with: -.. tacn:: progress @expr +.. tacn:: progress @ltac_expr :name: progress - :n:`@expr` is evaluated to v which must be a tactic value. The tactic value ``v`` + :n:`@ltac_expr` is evaluated to v which must be a tactic value. The tactic value ``v`` is applied to each focued subgoal independently. If the application of ``v`` to one of the focused subgoal produced subgoals equal to the initial goals (up to syntactical equality), then an error of level 0 is raised. @@ -380,19 +380,19 @@ Backtracking branching We can branch with the following structure: -.. tacn:: @expr__1 + @expr__2 +.. tacn:: @ltac_expr__1 + @ltac_expr__2 :name: + (backtracking branching) - :n:`@expr__1` and :n:`@expr__2` are evaluated respectively to :n:`v__1` and + :n:`@ltac_expr__1` and :n:`@ltac_expr__2` are evaluated respectively to :n:`v__1` and :n:`v__2` which must be tactic values. The tactic value :n:`v__1` is applied to each focused goal independently and if it fails or a later tactic fails, then the proof backtracks to the current goal and :n:`v__2` is applied. Tactics can be seen as having several successes. When a tactic fails it asks for more successes of the prior tactics. - :n:`@expr__1 + @expr__2` has all the successes of :n:`v__1` followed by all the + :n:`@ltac_expr__1 + @ltac_expr__2` has all the successes of :n:`v__1` followed by all the successes of :n:`v__2`. Algebraically, - :n:`(@expr__1 + @expr__2); @expr__3 = (@expr__1; @expr__3) + (@expr__2; @expr__3)`. + :n:`(@ltac_expr__1 + @ltac_expr__2); @ltac_expr__3 = (@ltac_expr__1; @ltac_expr__3) + (@ltac_expr__2; @ltac_expr__3)`. Branching is left-associative. @@ -403,22 +403,22 @@ Backtracking branching may be too expensive. In this case we may restrict to a local, left biased, branching and consider the first tactic to work (i.e. which does not fail) among a panel of tactics: -.. tacn:: first [{*| @expr}] +.. tacn:: first [{*| @ltac_expr}] :name: first - The :n:`@expr__i` are evaluated to :n:`v__i` and :n:`v__i` must be + The :n:`@ltac_expr__i` are evaluated to :n:`v__i` and :n:`v__i` must be tactic values for i = 1, ..., n. Supposing n > 1, - :n:`first [@expr__1 | ... | @expr__n]` applies :n:`v__1` in each + :n:`first [@ltac_expr__1 | ... | @ltac_expr__n]` applies :n:`v__1` in each focused goal independently and stops if it succeeds; otherwise it tries to apply :n:`v__2` and so on. It fails when there is no applicable tactic. In other words, - :n:`first [@expr__1 | ... | @expr__n]` behaves, in each goal, as the first + :n:`first [@ltac_expr__1 | ... | @ltac_expr__n]` behaves, in each goal, as the first :n:`v__i` to have *at least* one success. .. exn:: No applicable tactic. :undocumented: - .. tacv:: first @expr + .. tacv:: first @ltac_expr This is an |Ltac| alias that gives a primitive access to the first tactical as an |Ltac| definition without going through a parsing rule. It @@ -437,14 +437,14 @@ Left-biased branching Yet another way of branching without backtracking is the following structure: -.. tacn:: @expr__1 || @expr__2 +.. tacn:: @ltac_expr__1 || @ltac_expr__2 :name: || (left-biased branching) - :n:`@expr__1` and :n:`@expr__2` are evaluated respectively to :n:`v__1` and + :n:`@ltac_expr__1` and :n:`@ltac_expr__2` are evaluated respectively to :n:`v__1` and :n:`v__2` which must be tactic values. The tactic value :n:`v__1` is applied in each subgoal independently and if it fails *to progress* then - :n:`v__2` is applied. :n:`@expr__1 || @expr__2` is - equivalent to :n:`first [ progress @expr__1 | @expr__2 ]` (except that + :n:`v__2` is applied. :n:`@ltac_expr__1 || @ltac_expr__2` is + equivalent to :n:`first [ progress @ltac_expr__1 | @ltac_expr__2 ]` (except that if it fails, it fails like :n:`v__2`). Branching is left-associative. Generalized biased branching @@ -452,19 +452,19 @@ Generalized biased branching The tactic -.. tacn:: tryif @expr__1 then @expr__2 else @expr__3 +.. tacn:: tryif @ltac_expr__1 then @ltac_expr__2 else @ltac_expr__3 :name: tryif is a generalization of the biased-branching tactics above. The - expression :n:`@expr__1` is evaluated to :n:`v__1`, which is then + expression :n:`@ltac_expr__1` is evaluated to :n:`v__1`, which is then applied to each subgoal independently. For each goal where :n:`v__1` - succeeds at least once, :n:`@expr__2` is evaluated to :n:`v__2` which + succeeds at least once, :n:`@ltac_expr__2` is evaluated to :n:`v__2` which is then applied collectively to the generated subgoals. The :n:`v__2` tactic can trigger backtracking points in :n:`v__1`: where :n:`v__1` succeeds at least once, - :n:`tryif @expr__1 then @expr__2 else @expr__3` is equivalent to + :n:`tryif @ltac_expr__1 then @ltac_expr__2 else @ltac_expr__3` is equivalent to :n:`v__1; v__2`. In each of the goals where :n:`v__1` does not succeed at least - once, :n:`@expr__3` is evaluated in :n:`v__3` which is is then applied to the + once, :n:`@ltac_expr__3` is evaluated in :n:`v__3` which is is then applied to the goal. Soft cut @@ -473,13 +473,13 @@ Soft cut Another way of restricting backtracking is to restrict a tactic to a single success *a posteriori*: -.. tacn:: once @expr +.. tacn:: once @ltac_expr :name: once - :n:`@expr` is evaluated to ``v`` which must be a tactic value. The tactic value + :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied but only its first success is used. If ``v`` fails, - :n:`once @expr` fails like ``v``. If ``v`` has at least one success, - :n:`once @expr` succeeds once, but cannot produce more successes. + :n:`once @ltac_expr` fails like ``v``. If ``v`` has at least one success, + :n:`once @ltac_expr` succeeds once, but cannot produce more successes. Checking the successes ~~~~~~~~~~~~~~~~~~~~~~ @@ -487,14 +487,14 @@ Checking the successes Coq provides an experimental way to check that a tactic has *exactly one* success: -.. tacn:: exactly_once @expr +.. tacn:: exactly_once @ltac_expr :name: exactly_once - :n:`@expr` is evaluated to ``v`` which must be a tactic value. The tactic value + :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied if it has at most one success. If ``v`` fails, - :n:`exactly_once @expr` fails like ``v``. If ``v`` has a exactly one success, - :n:`exactly_once @expr` succeeds like ``v``. If ``v`` has two or more - successes, exactly_once expr fails. + :n:`exactly_once @ltac_expr` fails like ``v``. If ``v`` has a exactly one success, + :n:`exactly_once @ltac_expr` succeeds like ``v``. If ``v`` has two or more + successes, :n:`exactly_once @ltac_expr` fails. .. warning:: @@ -513,10 +513,10 @@ Checking the failure Coq provides a derived tactic to check that a tactic *fails*: -.. tacn:: assert_fails @expr +.. tacn:: assert_fails @ltac_expr :name: assert_fails - This behaves like :n:`tryif @expr then fail 0 tac "succeeds" else idtac`. + This behaves like :n:`tryif @ltac_expr then fail 0 tac "succeeds" else idtac`. Checking the success ~~~~~~~~~~~~~~~~~~~~ @@ -524,7 +524,7 @@ Checking the success Coq provides a derived tactic to check that a tactic has *at least one* success: -.. tacn:: assert_succeeds @expr +.. tacn:: assert_succeeds @ltac_expr :name: assert_succeeds This behaves like @@ -536,19 +536,19 @@ Solving We may consider the first to solve (i.e. which generates no subgoal) among a panel of tactics: -.. tacn:: solve [{*| @expr}] +.. tacn:: solve [{*| @ltac_expr}] :name: solve - The :n:`@expr__i` are evaluated to :n:`v__i` and :n:`v__i` must be + The :n:`@ltac_expr__i` are evaluated to :n:`v__i` and :n:`v__i` must be tactic values, for i = 1, ..., n. Supposing n > 1, - :n:`solve [@expr__1 | ... | @expr__n]` applies :n:`v__1` to + :n:`solve [@ltac_expr__1 | ... | @ltac_expr__n]` applies :n:`v__1` to each goal independently and stops if it succeeds; otherwise it tries to apply :n:`v__2` and so on. It fails if there is no solving tactic. .. exn:: Cannot solve the goal. :undocumented: - .. tacv:: solve @expr + .. tacv:: solve @ltac_expr This is an |Ltac| alias that gives a primitive access to the :n:`solve:` tactical. See the :n:`first` tactical for more information. @@ -651,10 +651,10 @@ Timeout We can force a tactic to stop if it has not finished after a certain amount of time: -.. tacn:: timeout @num @expr +.. tacn:: timeout @num @ltac_expr :name: timeout - :n:`@expr` is evaluated to ``v`` which must be a tactic value. The tactic value + :n:`@ltac_expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied normally, except that it is interrupted after :n:`@num` seconds if it is still running. In this case the outcome is a failure. @@ -673,10 +673,10 @@ Timing a tactic A tactic execution can be timed: -.. tacn:: time @string @expr +.. tacn:: time @string @ltac_expr :name: time - evaluates :n:`@expr` and displays the running time of the tactic expression, whether it + evaluates :n:`@ltac_expr` and displays the running time of the tactic expression, whether it fails or succeeds. In case of several successes, the time for each successive run is displayed. Time is in seconds and is machine-dependent. The :n:`@string` argument is optional. When provided, it is used to identify this particular @@ -688,10 +688,10 @@ Timing a tactic that evaluates to a term Tactic expressions that produce terms can be timed with the experimental tactic -.. tacn:: time_constr @expr +.. tacn:: time_constr @ltac_expr :name: time_constr - which evaluates :n:`@expr ()` and displays the time the tactic expression + which evaluates :n:`@ltac_expr ()` and displays the time the tactic expression evaluated, assuming successful evaluation. Time is in seconds and is machine-dependent. @@ -739,12 +739,12 @@ Local definitions Local definitions can be done as follows: -.. tacn:: let @ident__1 := @expr__1 {* with @ident__i := @expr__i} in @expr +.. tacn:: let @ident__1 := @ltac_expr__1 {* with @ident__i := @ltac_expr__i} in @ltac_expr :name: let ... := ... - each :n:`@expr__i` is evaluated to :n:`v__i`, then, :n:`@expr` is evaluated + each :n:`@ltac_expr__i` is evaluated to :n:`v__i`, then, :n:`@ltac_expr` is evaluated by substituting :n:`v__i` to each occurrence of :n:`@ident__i`, for - i = 1, ..., n. There are no dependencies between the :n:`@expr__i` and the + i = 1, ..., n. There are no dependencies between the :n:`@ltac_expr__i` and the :n:`@ident__i`. Local definitions can be made recursive by using :n:`let rec` instead of :n:`let`. @@ -763,7 +763,7 @@ An application is an expression of the following form: The reference :n:`@qualid` must be bound to some defined tactic definition expecting at least as many arguments as the provided :n:`tacarg`. The - expressions :n:`@expr__i` are evaluated to :n:`v__i`, for i = 1, ..., n. + expressions :n:`@ltac_expr__i` are evaluated to :n:`v__i`, for i = 1, ..., n. .. what expressions ?? @@ -773,7 +773,7 @@ Function construction A parameterized tactic can be built anonymously (without resorting to local definitions) with: -.. tacn:: fun {+ @ident} => @expr +.. tacn:: fun {+ @ident} => @ltac_expr Indeed, local definitions of functions are a syntactic sugar for binding a :n:`fun` tactic to an identifier. @@ -783,9 +783,9 @@ Pattern matching on terms We can carry out pattern matching on terms with: -.. tacn:: match @expr with {+| @cpattern__i => @expr__i} end +.. tacn:: match @ltac_expr with {+| @cpattern__i => @ltac_expr__i} end - The expression :n:`@expr` is evaluated and should yield a term which is + The expression :n:`@ltac_expr` is evaluated and should yield a term which is matched against :n:`cpattern__1`. The matching is non-linear: if a metavariable occurs more than once, it should match the same expression every time. It is first-order except on the variables of the form :n:`@?id` @@ -799,20 +799,20 @@ We can carry out pattern matching on terms with: same types. This provides with a primitive form of matching under context which does not require manipulating a functional term. - If the matching with :n:`@cpattern__1` succeeds, then :n:`@expr__1` is + If the matching with :n:`@cpattern__1` succeeds, then :n:`@ltac_expr__1` is evaluated into some value by substituting the pattern matching - instantiations to the metavariables. If :n:`@expr__1` evaluates to a + instantiations to the metavariables. If :n:`@ltac_expr__1` evaluates to a tactic and the match expression is in position to be applied to a goal (e.g. it is not bound to a variable by a :n:`let in`), then this tactic is applied. If the tactic succeeds, the list of resulting subgoals is the - result of the match expression. If :n:`@expr__1` does not evaluate to a + result of the match expression. If :n:`@ltac_expr__1` does not evaluate to a tactic or if the match expression is not in position to be applied to a - goal, then the result of the evaluation of :n:`@expr__1` is the result + goal, then the result of the evaluation of :n:`@ltac_expr__1` is the result of the match expression. If the matching with :n:`@cpattern__1` fails, or if it succeeds but the - evaluation of :n:`@expr__1` fails, or if the evaluation of - :n:`@expr__1` succeeds but returns a tactic in execution position whose + evaluation of :n:`@ltac_expr__1` fails, or if the evaluation of + :n:`@ltac_expr__1` succeeds but returns a tactic in execution position whose execution fails, then :n:`cpattern__2` is used and so on. The pattern :n:`_` matches any term and shadows all remaining patterns if any. If all clauses fail (in particular, there is no pattern :n:`_`) then a @@ -828,9 +828,9 @@ We can carry out pattern matching on terms with: .. exn:: Argument of match does not evaluate to a term. - This happens when :n:`@expr` does not denote a term. + This happens when :n:`@ltac_expr` does not denote a term. - .. tacv:: multimatch @expr with {+| @cpattern__i => @expr__i} end + .. tacv:: multimatch @ltac_expr with {+| @cpattern__i => @ltac_expr__i} end Using multimatch instead of match will allow subsequent tactics to backtrack into a right-hand side tactic which has backtracking points @@ -839,7 +839,7 @@ We can carry out pattern matching on terms with: The syntax :n:`match …` is, in fact, a shorthand for :n:`once multimatch …`. - .. tacv:: lazymatch @expr with {+| @cpattern__i => @expr__i} end + .. tacv:: lazymatch @ltac_expr with {+| @cpattern__i => @ltac_expr__i} end Using lazymatch instead of match will perform the same pattern matching procedure but will commit to the first matching branch @@ -884,13 +884,13 @@ We can perform pattern matching on goals using the following expression: .. we should provide the full grammar here -.. tacn:: match goal with {+| {+, @context_hyp} |- @cpattern => @expr } | _ => @expr end +.. tacn:: match goal with {+| {+, @context_hyp} |- @cpattern => @ltac_expr } | _ => @ltac_expr end :name: match goal If each hypothesis pattern :n:`hyp`\ :sub:`1,i`, with i = 1, ..., m\ :sub:`1` is matched (non-linear first-order unification) by a hypothesis of the goal and if :n:`cpattern_1` is matched by the conclusion of the goal, - then :n:`@expr__1` is evaluated to :n:`v__1` by substituting the + then :n:`@ltac_expr__1` is evaluated to :n:`v__1` by substituting the pattern matching to the metavariables and the real hypothesis names bound to the possible hypothesis names occurring in the hypothesis patterns. If :n:`v__1` is a tactic value, then it is applied to the @@ -898,7 +898,7 @@ We can perform pattern matching on goals using the following expression: is tried with the same proof context pattern. If there is no other combination of hypotheses then the second proof context pattern is tried and so on. If the next to last proof context pattern fails then - the last :n:`@expr` is evaluated to :n:`v` and :n:`v` is + the last :n:`@ltac_expr` is evaluated to :n:`v` and :n:`v` is applied. Note also that matching against subterms (using the :n:`context @ident [ @cpattern ]`) is available and is also subject to yielding several matchings. @@ -922,7 +922,7 @@ We can perform pattern matching on goals using the following expression: first), but it possible to reverse this order (oldest first) with the :n:`match reverse goal with` variant. - .. tacv:: multimatch goal with {+| {+, @context_hyp} |- @cpattern => @expr } | _ => @expr end + .. tacv:: multimatch goal with {+| {+, @context_hyp} |- @cpattern => @ltac_expr } | _ => @ltac_expr end Using :n:`multimatch` instead of :n:`match` will allow subsequent tactics to backtrack into a right-hand side tactic which has backtracking points @@ -933,7 +933,7 @@ We can perform pattern matching on goals using the following expression: The syntax :n:`match [reverse] goal …` is, in fact, a shorthand for :n:`once multimatch [reverse] goal …`. - .. tacv:: lazymatch goal with {+| {+, @context_hyp} |- @cpattern => @expr } | _ => @expr end + .. tacv:: lazymatch goal with {+| {+, @context_hyp} |- @cpattern => @ltac_expr } | _ => @ltac_expr end Using lazymatch instead of match will perform the same pattern matching procedure but will commit to the first matching branch with the first @@ -948,11 +948,11 @@ Filling a term context The following expression is not a tactic in the sense that it does not produce subgoals but generates a term to be used in tactic expressions: -.. tacn:: context @ident [@expr] +.. tacn:: context @ident [@ltac_expr] :n:`@ident` must denote a context variable bound by a context pattern of a match expression. This expression evaluates replaces the hole of the - value of :n:`@ident` by the value of :n:`@expr`. + value of :n:`@ident` by the value of :n:`@ltac_expr`. .. exn:: Not a context variable. :undocumented: @@ -1072,10 +1072,10 @@ Testing boolean expressions Proving a subgoal as a separate lemma ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. tacn:: abstract @expr +.. tacn:: abstract @ltac_expr :name: abstract - From the outside, :n:`abstract @expr` is the same as :n:`solve @expr`. + From the outside, :n:`abstract @ltac_expr` is the same as :n:`solve @ltac_expr`. Internally it saves an auxiliary lemma called ``ident_subproofn`` where ``ident`` is the name of the current goal and ``n`` is chosen so that this is a fresh name. Such an auxiliary lemma is inlined in the final proof term. @@ -1098,7 +1098,7 @@ Proving a subgoal as a separate lemma if used as part of typeclass resolution, it may produce wrong terms when in universe polymorphic mode. - .. tacv:: abstract @expr using @ident + .. tacv:: abstract @ltac_expr using @ident Give explicitly the name of the auxiliary lemma. @@ -1107,7 +1107,7 @@ Proving a subgoal as a separate lemma Use this feature at your own risk; explicitly named and reused subterms don’t play well with asynchronous proofs. - .. tacv:: transparent_abstract @expr + .. tacv:: transparent_abstract @ltac_expr :name: transparent_abstract Save the subproof in a transparent lemma rather than an opaque one. @@ -1117,7 +1117,7 @@ Proving a subgoal as a separate lemma Use this feature at your own risk; building computationally relevant terms with tactics is fragile. - .. tacv:: transparent_abstract @expr using @ident + .. tacv:: transparent_abstract @ltac_expr using @ident Give explicitly the name of the auxiliary transparent lemma. @@ -1139,7 +1139,7 @@ Defining |Ltac| functions Basically, |Ltac| toplevel definitions are made as follows: -.. cmd:: {? Local} Ltac @ident {* @ident} := @expr +.. cmd:: {? Local} Ltac @ident {* @ident} := @ltac_expr :name: Ltac This defines a new |Ltac| function that can be used in any tactic @@ -1152,13 +1152,13 @@ Basically, |Ltac| toplevel definitions are made as follows: The preceding definition can equivalently be written: - :n:`Ltac @ident := fun {+ @ident} => @expr` + :n:`Ltac @ident := fun {+ @ident} => @ltac_expr` - .. cmdv:: Ltac @ident {* @ident} {* with @ident {* @ident}} := @expr + .. cmdv:: Ltac @ident {* @ident} {* with @ident {* @ident}} := @ltac_expr This syntax allows recursive and mutual recursive function definitions. - .. cmdv:: Ltac @qualid {* @ident} ::= @expr + .. cmdv:: Ltac @qualid {* @ident} ::= @ltac_expr This syntax *redefines* an existing user-defined tactic. @@ -1585,7 +1585,7 @@ Backtraces Info trace ~~~~~~~~~~ -.. cmd:: Info @num @expr +.. cmd:: Info @num @ltac_expr :name: Info This command can be used to print the trace of the path eventually taken by an diff --git a/doc/tools/coqrst/notations/fontsupport.py b/doc/tools/coqrst/notations/fontsupport.py index a3efd97f5b..cc983565ff 100755 --- a/doc/tools/coqrst/notations/fontsupport.py +++ b/doc/tools/coqrst/notations/fontsupport.py @@ -12,6 +12,9 @@ """Transform a font to center each of its characters in square bounding boxes. See https://stackoverflow.com/questions/37377476/ for background information. + +This script is here for reference. It was used to generate the modified +font CoqNotations.ttf from UbuntuMono-B.ttf. """ from collections import Counter diff --git a/engine/evd.ml b/engine/evd.ml index 15b4c31851..34de2f41bb 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -430,6 +430,14 @@ type evar_flags = restricted_evars : Evar.t Evar.Map.t; typeclass_evars : Evar.Set.t } +type side_effect_role = +| Schema of inductive * string + +type side_effects = { + seff_private : Safe_typing.private_constants; + seff_roles : side_effect_role Cmap.t; +} + type evar_map = { (* Existential variables *) defn_evars : evar_info EvMap.t; @@ -444,7 +452,7 @@ type evar_map = { metas : clbinding Metamap.t; evar_flags : evar_flags; (** Interactive proofs *) - effects : Safe_typing.private_constants; + effects : side_effects; future_goals : Evar.t list; (** list of newly created evars, to be eventually turned into goals if not solved.*) principal_future_goal : Evar.t option; (** if [Some e], [e] must be @@ -672,6 +680,11 @@ let empty_evar_flags = restricted_evars = Evar.Map.empty; typeclass_evars = Evar.Set.empty } +let empty_side_effects = { + seff_private = Safe_typing.empty_private_constants; + seff_roles = Cmap.empty; +} + let empty = { defn_evars = EvMap.empty; undf_evars = EvMap.empty; @@ -680,7 +693,7 @@ let empty = { last_mods = Evar.Set.empty; evar_flags = empty_evar_flags; metas = Metamap.empty; - effects = Safe_typing.empty_private_constants; + effects = empty_side_effects; evar_names = EvNames.empty; (* id<->key for undefined evars *) future_goals = []; principal_future_goal = None; @@ -1011,12 +1024,17 @@ exception UniversesDiffer = UState.UniversesDiffer (**********************************************************) (* Side effects *) +let concat_side_effects eff eff' = { + seff_private = Safe_typing.concat_private eff.seff_private eff'.seff_private; + seff_roles = Cmap.fold Cmap.add eff.seff_roles eff'.seff_roles; +} + let emit_side_effects eff evd = - { evd with effects = Safe_typing.concat_private eff evd.effects; - universes = UState.emit_side_effects eff evd.universes } + let effects = concat_side_effects eff evd.effects in + { evd with effects; universes = UState.emit_side_effects eff.seff_private evd.universes } let drop_side_effects evd = - { evd with effects = Safe_typing.empty_private_constants; } + { evd with effects = empty_side_effects; } let eval_side_effects evd = evd.effects diff --git a/engine/evd.mli b/engine/evd.mli index 587a1de044..5478431e14 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -307,10 +307,22 @@ val dependent_evar_ident : Evar.t -> evar_map -> Id.t (** {5 Side-effects} *) -val emit_side_effects : Safe_typing.private_constants -> evar_map -> evar_map +type side_effect_role = +| Schema of inductive * string + +type side_effects = { + seff_private : Safe_typing.private_constants; + seff_roles : side_effect_role Cmap.t; +} + +val empty_side_effects : side_effects + +val concat_side_effects : side_effects -> side_effects -> side_effects + +val emit_side_effects : side_effects -> evar_map -> evar_map (** Push a side-effect into the evar map. *) -val eval_side_effects : evar_map -> Safe_typing.private_constants +val eval_side_effects : evar_map -> side_effects (** Return the effects contained in the evar map. *) val drop_side_effects : evar_map -> evar_map diff --git a/engine/proofview.ml b/engine/proofview.ml index c00c90e5e9..d4f6fe3aef 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -373,32 +373,24 @@ let tclTRYFOCUS i j t = tclFOCUS ~nosuchgoal:(tclUNIT ()) i j t let tclFOCUSLIST ?(nosuchgoal=tclZERO (NoSuchGoals 0)) l t = let open Proof in Comb.get >>= fun comb -> - let n = CList.length comb in - (* First, remove empty intervals, and bound the intervals to the number - of goals. *) - let sanitize (i, j) = - if i > j then None - else if i > n then None - else if j < 1 then None - else Some ((max i 1), (min j n)) - in - let l = CList.map_filter sanitize l in + let n = CList.length comb in + let ok (i, j) = 1 <= i && i <= j && j <= n in + if not (CList.for_all ok l) then nosuchgoal + else match l with - | [] -> nosuchgoal - | (mi, _) :: _ -> - (* Get the left-most goal to focus. This goal won't move, and we - will then place all the other goals to focus to the right. *) - let mi = CList.fold_left (fun m (i, _) -> min m i) mi l in - (* [CList.goto] returns a zipper, so that - [(rev left) @ sub_right = comb]. *) - let left, sub_right = CList.goto (mi-1) comb in - let p x _ = CList.exists (fun (i, j) -> i <= x + mi && x + mi <= j) l in - let sub, right = CList.partitioni p sub_right in - let mj = mi - 1 + CList.length sub in - Comb.set (CList.rev_append left (sub @ right)) >> - tclFOCUS mi mj t - - + | [] -> nosuchgoal + | (mi, _) :: _ -> + (* Get the left-most goal to focus. This goal won't move, and we + will then place all the other goals to focus to the right. *) + let mi = CList.fold_left (fun m (i, _) -> min m i) mi l in + (* [CList.goto] returns a zipper, so that + [(rev left) @ sub_right = comb]. *) + let left, sub_right = CList.goto (mi-1) comb in + let p x _ = CList.exists (fun (i, j) -> i <= x + mi && x + mi <= j) l in + let sub, right = CList.partitioni p sub_right in + let mj = mi - 1 + CList.length sub in + Comb.set (CList.rev_append left (sub @ right)) >> + tclFOCUS mi mj t (** Like {!tclFOCUS} but selects a single goal by name. *) let tclFOCUSID ?(nosuchgoal=tclZERO (NoSuchGoals 1)) id t = diff --git a/engine/proofview.mli b/engine/proofview.mli index 60697c1611..22e67357cd 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -381,7 +381,7 @@ val tclENV : Environ.env tactic (** {7 Put-like primitives} *) (** [tclEFFECTS eff] add the effects [eff] to the current state. *) -val tclEFFECTS : Safe_typing.private_constants -> unit tactic +val tclEFFECTS : Evd.side_effects -> unit tactic (** [mark_as_unsafe] declares the current tactic is unsafe. *) val mark_as_unsafe : unit tactic diff --git a/engine/uState.mli b/engine/uState.mli index 3df7f9e8e9..a34d4db8a6 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -100,7 +100,7 @@ val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t universes are preserved. *) val restrict : t -> Univ.LSet.t -> t -val demote_seff_univs : Safe_typing.private_constants Entries.definition_entry -> t -> t +val demote_seff_univs : 'a Entries.definition_entry -> t -> t type rigid = | UnivRigid diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 8da9900724..89f9411f06 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -732,6 +732,7 @@ object(self) let start = self#get_start_of_input in let stop = self#get_end_of_input in Minilib.log(Printf.sprintf "cleanup tags %d %d" start#offset stop#offset); + buffer#remove_tag Tags.Script.sentence ~start ~stop; buffer#remove_tag Tags.Script.tooltip ~start ~stop; buffer#remove_tag Tags.Script.processed ~start ~stop; buffer#remove_tag Tags.Script.incomplete ~start ~stop; @@ -23,6 +23,11 @@ (libraries coq.toplevel coqide-server.protocol) (link_flags -linkall)) +(install + (section bin) + (package coqide-server) + (files (idetop.bc as coqidetop.byte))) + ; IDE Client (library (name coqide_gui) diff --git a/ide/idetop.ml b/ide/idetop.ml index 90bd2f314d..a3b8854e8f 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -339,8 +339,7 @@ let import_search_constraint = function | Interface.Include_Blacklist -> Search.Include_Blacklist let search flags = - let pstate = Vernacstate.Proof_global.get () in - let pstate = Option.map Proof_global.get_current_pstate pstate in + let pstate = Vernacstate.Proof_global.get_pstate () in List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) diff --git a/ide/session.ml b/ide/session.ml index 90412f53f0..d0c3969ab2 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -447,7 +447,7 @@ let build_layout (sn:session) = let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in let state_paned = GPack.paned `VERTICAL - ~packing:(eval_paned#pack2 ~shrink:false) () in + ~packing:(eval_paned#pack2 ~shrink:true) () in (* Proof buffer. *) @@ -455,19 +455,21 @@ let build_layout (sn:session) = let proof_detachable = Wg_Detachable.detachable ~title () in let () = proof_detachable#button#misc#hide () in let () = proof_detachable#frame#set_shadow_type `IN in - let () = state_paned#add1 proof_detachable#coerce in - let callback _ = proof_detachable#show in + let () = state_paned#pack1 ~shrink:true proof_detachable#coerce in + let proof_scroll = GBin.scrolled_window + ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_detachable#pack () in + let callback _ = proof_detachable#show; + proof_scroll#coerce#misc#set_size_request ~width:0 ~height:0 () + in let () = proof_detachable#connect#attached ~callback in let callback _ = - sn.proof#coerce#misc#set_size_request ~width:500 ~height:400 () + proof_scroll#coerce#misc#set_size_request ~width:500 ~height:400 () in let () = proof_detachable#connect#detached ~callback in - let proof_scroll = GBin.scrolled_window - ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_detachable#pack () in (* Message buffer. *) - let message_frame = GPack.notebook ~packing:state_paned#add () in + let message_frame = GPack.notebook ~packing:(state_paned#pack2 ~shrink:true) () in let add_msg_page pos name text (w : GObj.widget) = let detachable = Wg_Detachable.detachable ~title:(text^" ("^name^")") () in @@ -503,18 +505,14 @@ let build_layout (sn:session) = let _ = eval_paned#misc#connect#size_allocate ~callback: - (let old_paned_width = ref 2 in - let old_paned_height = ref 2 in + (let b = ref true in fun {Gtk.width=paned_width;Gtk.height=paned_height} -> - if !old_paned_width <> paned_width || - !old_paned_height <> paned_height - then begin + if !b then begin eval_paned#set_position - (eval_paned#position * paned_width / !old_paned_width); + (paned_width / 2); state_paned#set_position - (state_paned#position * paned_height / !old_paned_height); - old_paned_width := paned_width; - old_paned_height := paned_height; + (paned_height / 2); + b := false end) in session_box#pack sn.finder#coerce; diff --git a/interp/declare.ml b/interp/declare.ml index cc6f29f756..17de06ed57 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -39,10 +39,10 @@ type constant_obj = { cst_decl : Cooking.recipe option; (** Non-empty only when rebuilding a constant after a section *) cst_kind : logical_kind; - cst_locl : bool; + cst_locl : import_status; } -type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind +type constant_declaration = Evd.side_effects constant_entry * logical_kind (* At load-time, the segment starting from the module name to the discharge *) (* section (if Remark or Fact) is needed to access a construction *) @@ -63,8 +63,9 @@ let cooking_info segment = (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn), obj) = (* Never open a local definition *) - if obj.cst_locl then () - else + match obj.cst_locl with + | ImportNeedQualified -> () + | ImportDefaultBehavior -> let con = Global.constant_of_delta_kn kn in Nametab.push (Nametab.Exactly i) sp (ConstRef con) @@ -137,14 +138,14 @@ let register_constant kn kind local = update_tables kn let register_side_effect (c, role) = - let () = register_constant c (IsProof Theorem) false in + let () = register_constant c (IsProof Theorem) ImportDefaultBehavior in match role with - | Subproof -> () - | Schema (ind, kind) -> !declare_scheme kind [|ind,c|] + | None -> () + | Some (Evd.Schema (ind, kind)) -> !declare_scheme kind [|ind,c|] let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types - ?(univs=default_univ_entry) ?(eff=Safe_typing.empty_private_constants) body = + ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) body = { const_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); const_entry_secctx = None; const_entry_type = types; @@ -153,7 +154,14 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types const_entry_feedback = None; const_entry_inline_code = inline} -let define_constant ?role ?(export_seff=false) id cd = +let get_roles export eff = + let map c = + let role = try Some (Cmap.find c eff.Evd.seff_roles) with Not_found -> None in + (c, role) + in + List.map map export + +let define_constant ~side_effect ?(export_seff=false) id cd = (* Logically define the constant and its subproofs, no libobject tampering *) let is_poly de = match de.const_entry_universes with | Monomorphic_entry _ -> false @@ -167,30 +175,43 @@ let define_constant ?role ?(export_seff=false) id cd = not de.const_entry_opaque || is_poly de -> (* This globally defines the side-effects in the environment. *) - let body, export = Global.export_private_constants ~in_section (Future.force de.const_entry_body) in + let body, eff = Future.force de.const_entry_body in + let body, export = Global.export_private_constants ~in_section (body, eff.Evd.seff_private) in + let export = get_roles export eff in let de = { de with const_entry_body = Future.from_val (body, ()) } in export, ConstantEntry (PureEntry, DefinitionEntry de) - | _ -> [], ConstantEntry (EffectEntry, cd) + | DefinitionEntry de -> + let map (body, eff) = body, eff.Evd.seff_private in + let body = Future.chain de.const_entry_body map in + let de = { de with const_entry_body = body } in + [], ConstantEntry (EffectEntry, DefinitionEntry de) + | ParameterEntry _ | PrimitiveEntry _ as cd -> + [], ConstantEntry (PureEntry, cd) in - let kn, eff = Global.add_constant ?role ~in_section id decl in + let kn, eff = Global.add_constant ~side_effect ~in_section id decl in kn, eff, export -let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = +let declare_constant ?(internal = UserIndividualRequest) ?(local = ImportDefaultBehavior) id ?(export_seff=false) (cd, kind) = let () = check_exists id in - let kn, _eff, export = define_constant ~export_seff id cd in + let kn, (), export = define_constant ~side_effect:PureEntry ~export_seff id cd in (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in let () = register_constant kn kind local in kn -let declare_private_constant ~role ?(internal=UserIndividualRequest) ?(local = false) id (cd, kind) = - let kn, eff, export = define_constant ~role id cd in +let declare_private_constant ?role ?(internal=UserIndividualRequest) ?(local = ImportDefaultBehavior) id (cd, kind) = + let kn, eff, export = define_constant ~side_effect:EffectEntry id cd in let () = assert (List.is_empty export) in let () = register_constant kn kind local in + let seff_roles = match role with + | None -> Cmap.empty + | Some r -> Cmap.singleton kn r + in + let eff = { Evd.seff_private = eff; Evd.seff_roles; } in kn, eff let declare_definition ?(internal=UserIndividualRequest) - ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) + ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = ImportDefaultBehavior) id ?types (body,univs) = let cb = definition_entry ?types ~univs ~opaque body @@ -200,7 +221,7 @@ let declare_definition ?(internal=UserIndividualRequest) (** Declaration of section variables and local definitions *) type section_variable_entry = - | SectionLocalDef of Safe_typing.private_constants definition_entry + | SectionLocalDef of Evd.side_effects definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind @@ -221,7 +242,9 @@ let cache_variable ((sp,_),o) = | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) - let ((body, uctx), eff) = Global.export_private_constants ~in_section:true (Future.force de.const_entry_body) in + let (body, eff) = Future.force de.const_entry_body in + let ((body, uctx), export) = Global.export_private_constants ~in_section:true (body, eff.Evd.seff_private) in + let eff = get_roles export eff in let () = List.iter register_side_effect eff in let poly, univs = match de.const_entry_universes with | Monomorphic_entry uctx -> false, uctx diff --git a/interp/declare.mli b/interp/declare.mli index 0b1a396a34..e2485d7cf0 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -23,7 +23,7 @@ open Decl_kinds (** Declaration of local constructions (Variable/Hypothesis/Local) *) type section_variable_entry = - | SectionLocalDef of Safe_typing.private_constants definition_entry + | SectionLocalDef of Evd.side_effects definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind @@ -33,7 +33,7 @@ val declare_variable : variable -> variable_declaration -> Libobject.object_name (** Declaration of global constructions i.e. Definition/Theorem/Axiom/Parameter/... *) -type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind +type constant_declaration = Evd.side_effects constant_entry * logical_kind type internal_flag = | UserAutomaticRequest @@ -44,7 +44,7 @@ type internal_flag = val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool -> ?types:types -> ?univs:Entries.universes_entry -> - ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry + ?eff:Evd.side_effects -> constr -> Evd.side_effects definition_entry (** [declare_constant id cd] declares a global declaration (constant/parameter) with name [id] in the current section; it returns @@ -53,14 +53,14 @@ val definition_entry : ?fix_exn:Future.fix_exn -> internal specify if the constant has been created by the kernel or by the user, and in the former case, if its errors should be silent *) val declare_constant : - ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> Constant.t + ?internal:internal_flag -> ?local:import_status -> Id.t -> ?export_seff:bool -> constant_declaration -> Constant.t val declare_private_constant : - role:side_effect_role -> ?internal:internal_flag -> ?local:bool -> Id.t -> constant_declaration -> Constant.t * Safe_typing.private_constants + ?role:Evd.side_effect_role -> ?internal:internal_flag -> ?local:import_status -> Id.t -> constant_declaration -> Constant.t * Evd.side_effects val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> - ?local:bool -> Id.t -> ?types:constr -> + ?local:import_status -> Id.t -> ?types:constr -> constr Entries.in_universes_entry -> Constant.t (** Since transparent constants' side effects are globally declared, we diff --git a/interp/deprecation.ml b/interp/deprecation.ml new file mode 100644 index 0000000000..b6f0dceb89 --- /dev/null +++ b/interp/deprecation.ml @@ -0,0 +1,21 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type t = { since : string option ; note : string option } + +let make ?since ?note () = { since ; note } + +let create_warning ~object_name ~warning_name name_printer = + let open Pp in + CWarnings.create ~name:warning_name ~category:"deprecated" + (fun (qid,depr) -> str object_name ++ spc () ++ name_printer qid ++ + strbrk " is deprecated" ++ + pr_opt (fun since -> str "since " ++ str since) depr.since ++ + str "." ++ pr_opt (fun note -> str note) depr.note) diff --git a/interp/deprecation.mli b/interp/deprecation.mli new file mode 100644 index 0000000000..aab87c11a2 --- /dev/null +++ b/interp/deprecation.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type t = { since : string option ; note : string option } + +val make : ?since:string -> ?note:string -> unit -> t + +val create_warning : object_name:string -> warning_name:string -> + ('b -> Pp.t) -> ?loc:Loc.t -> 'b * t -> unit diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index a537b4848c..274f9b851a 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -91,7 +91,8 @@ let type_of_logical_kind = function (match a with | Definitional -> "defax" | Logical -> "prfax" - | Conjectural -> "prfax") + | Conjectural -> "prfax" + | Context -> "prfax") | IsProof th -> (match th with | Theorem diff --git a/interp/interp.mllib b/interp/interp.mllib index b65a171ef9..52978a2ab6 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,3 +1,4 @@ +Deprecation NumTok Constrexpr Tactypes diff --git a/interp/notation.ml b/interp/notation.ml index a7bac96d31..cc06d5abfc 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -72,6 +72,7 @@ type notation_location = (DirPath.t * DirPath.t) * string type notation_data = { not_interp : interpretation; not_location : notation_location; + not_deprecation : Deprecation.t option; } type scope = { @@ -1095,7 +1096,7 @@ let warn_notation_overridden = str "Notation" ++ spc () ++ pr_notation ntn ++ spc () ++ strbrk "was already used" ++ which_scope ++ str ".") -let declare_notation_interpretation ntn scopt pat df ~onlyprint = +let declare_notation_interpretation ntn scopt pat df ~onlyprint deprecation = let scope = match scopt with Some s -> s | None -> default_scope in let sc = find_scope scope in if not onlyprint then begin @@ -1109,6 +1110,7 @@ let declare_notation_interpretation ntn scopt pat df ~onlyprint = let notdata = { not_interp = pat; not_location = df; + not_deprecation = deprecation; } in let sc = { sc with notations = NotationMap.add ntn notdata sc.notations } in scope_map := String.Map.add scope sc !scope_map @@ -1125,10 +1127,10 @@ let declare_uninterpretation rule (metas,c as pat) = let rec find_interpretation ntn find = function | [] -> raise Not_found | Scope scope :: scopes -> - (try let (pat,df) = find scope in pat,(df,Some scope) + (try let n = find scope in (n,Some scope) with Not_found -> find_interpretation ntn find scopes) | SingleNotation ntn'::scopes when notation_eq ntn' ntn -> - (try let (pat,df) = find default_scope in pat,(df,None) + (try let n = find default_scope in (n,None) with Not_found -> (* e.g. because single notation only for constr, not cases_pattern *) find_interpretation ntn find scopes) @@ -1136,8 +1138,7 @@ let rec find_interpretation ntn find = function find_interpretation ntn find scopes let find_notation ntn sc = - let n = NotationMap.find ntn (find_scope sc).notations in - (n.not_interp, n.not_location) + NotationMap.find ntn (find_scope sc).notations let notation_of_prim_token = function | Numeral (SPlus,n) -> InConstrEntrySomeLevel, NumTok.to_string n @@ -1147,7 +1148,9 @@ let notation_of_prim_token = function let find_prim_token check_allowed ?loc p sc = (* Try for a user-defined numerical notation *) try - let (_,c),df = find_notation (notation_of_prim_token p) sc in + let n = find_notation (notation_of_prim_token p) sc in + let (_,c) = n.not_interp in + let df = n.not_location in let pat = Notation_ops.glob_constr_of_notation_constr ?loc c in check_allowed pat; pat, df @@ -1167,7 +1170,9 @@ let find_prim_token check_allowed ?loc p sc = let interp_prim_token_gen ?loc g p local_scopes = let scopes = make_current_scopes local_scopes in let p_as_ntn = try notation_of_prim_token p with Not_found -> InConstrEntrySomeLevel,"" in - try find_interpretation p_as_ntn (find_prim_token ?loc g p) scopes + try + let (pat,loc), sc = find_interpretation p_as_ntn (find_prim_token ?loc g p) scopes in + pat, (loc,sc) with Not_found -> user_err ?loc ~hdr:"interp_prim_token" ((match p with @@ -1192,11 +1197,18 @@ let rec check_allowed_ref_in_pat looked_for = DAst.(with_val (function let interp_prim_token_cases_pattern_expr ?loc looked_for p = interp_prim_token_gen ?loc (check_allowed_ref_in_pat looked_for) p +let warn_deprecated_notation = + Deprecation.create_warning ~object_name:"Notation" ~warning_name:"deprecated-notation" + pr_notation + let interp_notation ?loc ntn local_scopes = let scopes = make_current_scopes local_scopes in - try find_interpretation ntn (find_notation ntn) scopes + try + let (n,sc) = find_interpretation ntn (find_notation ntn) scopes in + Option.iter (fun d -> warn_deprecated_notation (ntn,d)) n.not_deprecation; + n.not_interp, (n.not_location, sc) with Not_found -> - user_err ?loc + user_err ?loc (str "Unknown interpretation for notation " ++ pr_notation ntn ++ str ".") let uninterp_notations c = diff --git a/interp/notation.mli b/interp/notation.mli index a67948a778..b32561d908 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -217,7 +217,8 @@ type interp_rule = | SynDefRule of KerName.t val declare_notation_interpretation : notation -> scope_name option -> - interpretation -> notation_location -> onlyprint:bool -> unit + interpretation -> notation_location -> onlyprint:bool -> + Deprecation.t option -> unit val declare_uninterpretation : interp_rule -> interpretation -> unit diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index a7e1de736c..8df04187f1 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -19,20 +19,24 @@ open Notation_term (* Syntactic definitions. *) -type version = Flags.compat_version option +type syndef = + { syndef_pattern : interpretation; + syndef_onlyparsing : bool; + syndef_deprecation : Deprecation.t option; + } let syntax_table = - Summary.ref (KNmap.empty : (interpretation*version) KNmap.t) - ~name:"SYNTAXCONSTANT" + Summary.ref (KNmap.empty : syndef KNmap.t) + ~name:"SYNDEFS" -let add_syntax_constant kn c onlyparse = - syntax_table := KNmap.add kn (c,onlyparse) !syntax_table +let add_syntax_constant kn syndef = + syntax_table := KNmap.add kn syndef !syntax_table -let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = +let load_syntax_constant i ((sp,kn),(_local,syndef)) = if Nametab.exists_cci sp then user_err ~hdr:"cache_syntax_constant" (Id.print (basename sp) ++ str " already exists"); - add_syntax_constant kn pat onlyparse; + add_syntax_constant kn syndef; Nametab.push_syndef (Nametab.Until i) sp kn let is_alias_of_already_visible_name sp = function @@ -42,30 +46,29 @@ let is_alias_of_already_visible_name sp = function | _ -> false -let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = +let open_syntax_constant i ((sp,kn),(_local,syndef)) = + let pat = syndef.syndef_pattern in if not (Int.equal i 1 && is_alias_of_already_visible_name sp pat) then begin Nametab.push_syndef (Nametab.Exactly i) sp kn; - match onlyparse with - | None -> + if not syndef.syndef_onlyparsing then (* Redeclare it to be used as (short) name in case an other (distfix) notation was declared in between *) Notation.declare_uninterpretation (Notation.SynDefRule kn) pat - | _ -> () end let cache_syntax_constant d = load_syntax_constant 1 d; open_syntax_constant 1 d -let subst_syntax_constant (subst,(local,pat,onlyparse)) = - (local,Notation_ops.subst_interpretation subst pat,onlyparse) +let subst_syntax_constant (subst,(local,syndef)) = + let syndef_pattern = Notation_ops.subst_interpretation subst syndef.syndef_pattern in + (local, { syndef with syndef_pattern }) -let classify_syntax_constant (local,_,_ as o) = +let classify_syntax_constant (local,_ as o) = if local then Dispose else Substitute o -let in_syntax_constant - : bool * interpretation * Flags.compat_version option -> obj = - declare_object {(default_object "SYNTAXCONSTANT") with +let in_syntax_constant : (bool * syndef) -> obj = + declare_object {(default_object "SYNDEF") with cache_function = cache_syntax_constant; load_function = load_syntax_constant; open_function = open_syntax_constant; @@ -79,36 +82,31 @@ type syndef_interpretation = (Id.t * subscopes) list * notation_constr let in_pat (ids,ac) = (List.map (fun (id,sc) -> (id,((Constrexpr.InConstrEntrySomeLevel,sc),NtnTypeConstr))) ids,ac) let out_pat (ids,ac) = (List.map (fun (id,((_,sc),typ)) -> (id,sc)) ids,ac) -let declare_syntactic_definition local id onlyparse pat = - let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in () - -let pr_syndef kn = pr_qualid (Nametab.shortest_qualid_of_syndef Id.Set.empty kn) - -let pr_compat_warning (kn, def, v) = - let pp_def = match def with - | [], NRef r -> spc () ++ str "is" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r - | _ -> strbrk " is a compatibility notation" +let declare_syntactic_definition ~local deprecation id ~onlyparsing pat = + let syndef = + { syndef_pattern = in_pat pat; + syndef_onlyparsing = onlyparsing; + syndef_deprecation = deprecation; + } in - pr_syndef kn ++ pp_def + let _ = add_leaf id (in_syntax_constant (local,syndef)) in () -let warn_compatibility_notation = - CWarnings.(create ~name:"compatibility-notation" - ~category:"deprecated" ~default:Enabled pr_compat_warning) +let pr_syndef kn = pr_qualid (Nametab.shortest_qualid_of_syndef Id.Set.empty kn) -let verbose_compat ?loc kn def = function - | Some v when Flags.version_strictly_greater v -> - warn_compatibility_notation ?loc (kn, def, v) - | _ -> () +let warn_deprecated_syntactic_definition = + Deprecation.create_warning ~object_name:"Notation" ~warning_name:"deprecated-syntactic-definition" + pr_syndef let search_syntactic_definition ?loc kn = - let pat,v = KNmap.find kn !syntax_table in - let def = out_pat pat in - verbose_compat ?loc kn def v; + let syndef = KNmap.find kn !syntax_table in + let def = out_pat syndef.syndef_pattern in + Option.iter (fun d -> warn_deprecated_syntactic_definition (kn,d)) syndef.syndef_deprecation; def let search_filtered_syntactic_definition ?loc filter kn = - let pat,v = KNmap.find kn !syntax_table in - let def = out_pat pat in + let syndef = KNmap.find kn !syntax_table in + let def = out_pat syndef.syndef_pattern in let res = filter def in - (match res with Some _ -> verbose_compat ?loc kn def v | None -> ()); + if Option.has_some res then + Option.iter (fun d -> warn_deprecated_syntactic_definition (kn,d)) syndef.syndef_deprecation; res diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index 77873f8f67..e6e3b9cffa 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -15,8 +15,8 @@ open Notation_term type syndef_interpretation = (Id.t * subscopes) list * notation_constr -val declare_syntactic_definition : bool -> Id.t -> - Flags.compat_version option -> syndef_interpretation -> unit +val declare_syntactic_definition : local:bool -> Deprecation.t option -> Id.t -> + onlyparsing:bool -> syndef_interpretation -> unit val search_syntactic_definition : ?loc:Loc.t -> KerName.t -> syndef_interpretation diff --git a/kernel/entries.ml b/kernel/entries.ml index adb3f6bd29..45b11e97ba 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -107,8 +107,3 @@ type module_entry = | MType of module_params_entry * module_struct_entry | MExpr of module_params_entry * module_struct_entry * module_struct_entry option - -(** Not used by the kernel. *) -type side_effect_role = - | Subproof - | Schema of inductive * string diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 824400b4e3..0b0f14eee7 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -232,7 +232,6 @@ type side_effect = { from_env : Declarations.structure_body CEphemeron.key; seff_constant : Constant.t; seff_body : Constr.t Declarations.constant_body; - seff_role : Entries.side_effect_role; } module SideEffects : @@ -536,8 +535,7 @@ type 'a effect_entry = type global_declaration = | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration -type exported_private_constant = - Constant.t * Entries.side_effect_role +type exported_private_constant = Constant.t let add_constant_aux ~in_section senv (kn, cb) = let l = Constant.label kn in @@ -699,7 +697,7 @@ let constant_entry_of_side_effect eff = const_entry_inline_code = cb.const_inline_code } let export_eff eff = - (eff.seff_constant, eff.seff_body, eff.seff_role) + (eff.seff_constant, eff.seff_body) let export_side_effects mb env (b_ctx, eff) = let not_exists e = @@ -750,9 +748,9 @@ let n_univs cb = match cb.const_universes with let export_private_constants ~in_section ce senv = let exported, ce = export_side_effects senv.revstruct senv.env ce in - let map (kn, cb, _) = (kn, map_constant (fun p -> Opaqueproof.create ~univs:(n_univs cb) (Future.from_val (p, Univ.ContextSet.empty))) cb) in + let map (kn, cb) = (kn, map_constant (fun p -> Opaqueproof.create ~univs:(n_univs cb) (Future.from_val (p, Univ.ContextSet.empty))) cb) in let bodies = List.map map exported in - let exported = List.map (fun (kn, _, r) -> (kn, r)) exported in + let exported = List.map (fun (kn, _) -> kn) exported in let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in (ce, exported), senv @@ -762,7 +760,7 @@ let add_recipe ~in_section l r senv = let senv = add_constant_aux ~in_section senv (kn, cb) in kn, senv -let add_constant ?role ~in_section l decl senv = +let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl senv : (Constant.t * a) * safe_environment = let kn = Constant.make2 senv.modpath l in let cb = match decl with @@ -786,9 +784,9 @@ let add_constant ?role ~in_section l decl senv = add_retroknowledge (Retroknowledge.Register_type(t,kn)) senv | _ -> senv in - let eff = match role with - | None -> empty_private_constants - | Some role -> + let eff : a = match side_effect with + | PureEntry -> () + | EffectEntry -> let body, univs = match cb.const_body with | (Primitive _ | Undef _) -> assert false | Def c -> (Def c, cb.const_universes) @@ -808,7 +806,6 @@ let add_constant ?role ~in_section l decl senv = from_env = from_env; seff_constant = kn; seff_body = cb; - seff_role = role; } in SideEffects.add eff empty_private_constants in diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 770caf5406..3e902303c3 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -87,18 +87,16 @@ type 'a effect_entry = type global_declaration = | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration -type exported_private_constant = - Constant.t * Entries.side_effect_role +type exported_private_constant = Constant.t val export_private_constants : in_section:bool -> private_constants Entries.proof_output -> (Constr.constr Univ.in_universe_context_set * exported_private_constant list) safe_transformer -(** returns the main constant plus a list of auxiliary constants (empty - unless one requires the side effects to be exported) *) +(** returns the main constant plus a certificate of its validity *) val add_constant : - ?role:Entries.side_effect_role -> in_section:bool -> Label.t -> global_declaration -> - (Constant.t * private_constants) safe_transformer + side_effect:'a effect_entry -> in_section:bool -> Label.t -> global_declaration -> + (Constant.t * 'a) safe_transformer val add_recipe : in_section:bool -> Label.t -> Cooking.recipe -> Constant.t safe_transformer diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml index 8d5c2fb687..39042e1ab7 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -12,7 +12,9 @@ type discharge = DoDischarge | NoDischarge -type locality = Discharge | Local | Global +type import_status = ImportDefaultBehavior | ImportNeedQualified + +type locality = Discharge | Global of import_status type binding_kind = Explicit | Implicit @@ -46,7 +48,7 @@ type definition_object_kind = | Method | Let -type assumption_object_kind = Definitional | Logical | Conjectural +type assumption_object_kind = Definitional | Logical | Conjectural | Context (* [assumption_kind] diff --git a/library/global.ml b/library/global.ml index d5ffae7716..3f30a63808 100644 --- a/library/global.ml +++ b/library/global.ml @@ -94,7 +94,7 @@ let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) -let add_constant ?role ~in_section id d = globalize (Safe_typing.add_constant ?role ~in_section (i2l id) d) +let add_constant ~side_effect ~in_section id d = globalize (Safe_typing.add_constant ~side_effect ~in_section (i2l id) d) let add_recipe ~in_section id d = globalize (Safe_typing.add_recipe ~in_section (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) diff --git a/library/global.mli b/library/global.mli index eaa76c3117..c36cec3511 100644 --- a/library/global.mli +++ b/library/global.mli @@ -46,7 +46,7 @@ val export_private_constants : in_section:bool -> Constr.constr Univ.in_universe_context_set * Safe_typing.exported_private_constant list val add_constant : - ?role:Entries.side_effect_role -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * Safe_typing.private_constants + side_effect:'a Safe_typing.effect_entry -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * 'a val add_recipe : in_section:bool -> Id.t -> Cooking.recipe -> Constant.t val add_mind : Id.t -> Entries.mutual_inductive_entry -> MutInd.t diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 9c1882dc9a..aad3967f6d 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -12,8 +12,8 @@ open Constr open Context open Context.Named.Declaration -let map_const_entry_body (f:constr->constr) (x:Safe_typing.private_constants Entries.const_entry_body) - : Safe_typing.private_constants Entries.const_entry_body = +let map_const_entry_body (f:constr->constr) (x: Evd.side_effects Entries.const_entry_body) + : Evd.side_effects Entries.const_entry_body = Future.chain x begin fun ((b,ctx),fx) -> (f b , ctx) , fx end @@ -22,11 +22,11 @@ let map_const_entry_body (f:constr->constr) (x:Safe_typing.private_constants Ent (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) -let start_deriving f suchthat lemma = +let start_deriving f suchthat name : Lemmas.t = let env = Global.env () in let sigma = Evd.from_env env in - let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in + let kind = Decl_kinds.(Global ImportDefaultBehavior,false,DefinitionBody Definition) in (* create a sort variable for the type of [f] *) (* spiwack: I don't know what the rigidity flag does, picked the one @@ -48,7 +48,6 @@ let start_deriving f suchthat lemma = (* The terminator handles the registering of constants when the proof is closed. *) let terminator com = - let open Proof_global in (* Extracts the relevant information from the proof. [Admitted] and [Save] result in user errors. [opaque] is [true] if the proof was concluded by [Qed], and [false] if [Defined]. [f_def] @@ -56,10 +55,10 @@ let start_deriving f suchthat lemma = [suchthat], respectively. *) let (opaque,f_def,lemma_def) = match com with - | Admitted _ -> CErrors.user_err Pp.(str "Admitted isn't supported in Derive.") - | Proved (_,Some _,_) -> + | Lemmas.Admitted _ -> CErrors.user_err Pp.(str "Admitted isn't supported in Derive.") + | Lemmas.Proved (_,Some _,_) -> CErrors.user_err Pp.(str "Cannot save a proof of Derive with an explicit name.") - | Proved (opaque, None, obj) -> + | Lemmas.Proved (opaque, None, obj) -> match Proof_global.(obj.entries) with | [_;f_def;lemma_def] -> opaque <> Proof_global.Transparent , f_def , lemma_def @@ -97,12 +96,11 @@ let start_deriving f suchthat lemma = Entries.DefinitionEntry lemma_def , Decl_kinds.(IsProof Proposition) in - ignore (Declare.declare_constant lemma lemma_def) - in + ignore (Declare.declare_constant name lemma_def) + in - let terminator = Proof_global.make_terminator terminator in - let pstate = Proof_global.start_dependent_proof lemma kind goals terminator in - Proof_global.modify_proof begin fun p -> - let p,_,() = Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p in - p - end pstate + let terminator ?hook _ = Lemmas.Internal.make_terminator terminator in + let lemma = Lemmas.start_dependent_lemma name kind goals ~terminator in + Lemmas.pf_map (Proof_global.map_proof begin fun p -> + Util.pi1 @@ Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p + end) lemma diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli index 6bb923118e..ffbc726e22 100644 --- a/plugins/derive/derive.mli +++ b/plugins/derive/derive.mli @@ -12,4 +12,8 @@ (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) -val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> Proof_global.t +val start_deriving + : Names.Id.t + -> Constrexpr.constr_expr + -> Names.Id.t + -> Lemmas.t diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index 526989fdf3..de3fb9f11f 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -18,11 +18,11 @@ DECLARE PLUGIN "derive_plugin" { -let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]),VtLater) +let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[])) } VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } STATE open_proof | [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - { Derive.(start_deriving f suchthat lemma) } + { Derive.start_deriving f suchthat lemma } END diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index c5439ffaf6..4cd34100bc 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -752,13 +752,13 @@ let extract_and_compile l = (* Show the extraction of the current ongoing proof *) let show_extraction ~pstate = init ~inner:true false false; - let prf = Proof_global.give_me_the_proof pstate in + let prf = Proof_global.get_proof pstate in let sigma, env = Pfedit.get_current_context pstate in let trms = Proof.partial_proof prf in let extr_term t = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in - let l = Label.of_id (Proof_global.get_current_proof_name pstate) in + let l = Label.of_id (Proof_global.get_proof_name pstate) in let fake_ref = ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index e38ea992ab..17498c6384 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -33,7 +33,7 @@ let do_observe_tac s tac g = let e = ExplainErr.process_vernac_interp_error e in let goal = begin try (Printer.pr_goal g) with _ -> assert false end in msg_debug (str "observation "++ s++str " raised exception " ++ - Errors.print e ++ str " on goal " ++ goal ); + Errors.print e ++ str " on goal " ++ goal ); raise e;; let observe_tac_stream s tac g = @@ -47,19 +47,19 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g let debug_queue = Stack.create () -let rec print_debug_queue e = - if not (Stack.is_empty debug_queue) +let rec print_debug_queue e = + if not (Stack.is_empty debug_queue) then begin - let lmsg,goal = Stack.pop debug_queue in + let lmsg,goal = Stack.pop debug_queue in let _ = - match e with - | Some e -> - Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) - | None -> - begin - Feedback.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal); - end in + match e with + | Some e -> + Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) + | None -> + begin + Feedback.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal); + end in print_debug_queue None ; end @@ -68,11 +68,11 @@ let observe strm = then Feedback.msg_debug strm else () -let do_observe_tac s tac g = +let do_observe_tac s tac g = let goal = Printer.pr_goal g in - let lmsg = (str "observation : ") ++ s in + let lmsg = (str "observation : ") ++ s in Stack.push (lmsg,goal) debug_queue; - try + try let v = tac g in ignore(Stack.pop debug_queue); v @@ -88,7 +88,7 @@ let observe_tac_stream s tac g = else tac g let observe_tac s = observe_tac_stream (str s) - + let list_chop ?(msg="") n l = try @@ -138,11 +138,11 @@ let is_trivial_eq sigma t = let res = try begin match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - eq_constr sigma t1 t2 - | App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ()) -> - eq_constr sigma t1 t2 && eq_constr sigma a1 a2 - | _ -> false + | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> + eq_constr sigma t1 t2 + | App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma t1 t2 && eq_constr sigma a1 a2 + | _ -> false end with e when CErrors.noncritical e -> false in @@ -157,19 +157,19 @@ let rec incompatible_constructor_terms sigma t1 t2 = isConstruct sigma c1 && isConstruct sigma c2 && ( not (eq_constr sigma c1 c2) || - List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 + List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) let is_incompatible_eq env sigma t = let res = try match EConstr.kind sigma t with - | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> - incompatible_constructor_terms sigma t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) -> - (eq_constr sigma u1 u2 && - incompatible_constructor_terms sigma t1 t2) - | _ -> false + | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> + incompatible_constructor_terms sigma t1 t2 + | App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) -> + (eq_constr sigma u1 u2 && + incompatible_constructor_terms sigma t1 t2) + | _ -> false with e when CErrors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); @@ -182,8 +182,8 @@ let change_hyp_with_using msg hyp_id t tac : tactic = ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) [tclTHENLIST [ - (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); - (* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id])) + (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); + (* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id])) ]] g exception TOREMOVE @@ -195,15 +195,15 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) = [ tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *) (fun g -> - let context_hyps = - fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - (mkApp(constructor,[|type_of_term;term|])):: - (List.map mkVar context_hyps) - in - let to_refine = applist(mkVar h_id,List.rev context_hyps') in - refine to_refine g + let context_hyps = + fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) + in + let context_hyps' = + (mkApp(constructor,[|type_of_term;term|])):: + (List.map mkVar context_hyps) + in + let to_refine = applist(mkVar h_id,List.rev context_hyps') in + refine to_refine g ) ] @@ -244,18 +244,18 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let f_eq,args = destApp sigma t in let constructor,t1,t2,t1_typ = try - if (eq_constr f_eq (Lazy.force eq)) - then - let t1 = (args.(1),args.(0)) - and t2 = (args.(2),args.(0)) - and t1_typ = args.(0) - in - (Lazy.force refl_equal,t1,t2,t1_typ) - else - if (eq_constr f_eq (jmeq ())) - then - (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) - else nochange "not an equality" + if (eq_constr f_eq (Lazy.force eq)) + then + let t1 = (args.(1),args.(0)) + and t2 = (args.(2),args.(0)) + and t1_typ = args.(0) + in + (Lazy.force refl_equal,t1,t2,t1_typ) + else + if (eq_constr f_eq (jmeq ())) + then + (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) + else nochange "not an equality" with e when CErrors.noncritical e -> nochange "not an equality" in if not ((closed0 sigma (fst t1)) && (closed0 sigma (snd t1)))then nochange "not a closed lhs"; @@ -263,60 +263,60 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) if isRel sigma t2 then - let t2 = destRel sigma t2 in - begin - try - let t1' = Int.Map.find t2 sub in - if not (eq_constr t1 t1') then nochange "twice bound variable"; - sub - with Not_found -> - assert (closed0 sigma t1); - Int.Map.add t2 t1 sub - end + let t2 = destRel sigma t2 in + begin + try + let t1' = Int.Map.find t2 sub in + if not (eq_constr t1 t1') then nochange "twice bound variable"; + sub + with Not_found -> + assert (closed0 sigma t1); + Int.Map.add t2 t1 sub + end else if isAppConstruct sigma t1 && isAppConstruct sigma t2 then - begin - let c1,args1 = find_rectype env sigma t1 - and c2,args2 = find_rectype env sigma t2 - in - if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; - List.fold_left2 compute_substitution sub args1 args2 - end + begin + let c1,args1 = find_rectype env sigma t1 + and c2,args2 = find_rectype env sigma t2 + in + if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; + List.fold_left2 compute_substitution sub args1 args2 + end else - if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) "cannot solve (diff)" + if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) "cannot solve (diff)" in let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) let new_end_of_type = (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 - Can be safely replaced by the next comment for Ocaml >= 3.08.4 + Can be safely replaced by the next comment for Ocaml >= 3.08.4 *) let sub = Int.Map.bindings sub in List.fold_left (fun end_of_type (i,t) -> liftn 1 i (substnl [t] (i-1) end_of_type)) - end_of_type_with_pop - sub + end_of_type_with_pop + sub in let old_context_length = List.length context + 1 in let witness_fun = mkLetIn(make_annot Anonymous Sorts.Relevant,make_refl_eq constructor t1_typ (fst t1),t, - mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) - ) + mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) + ) in let new_type_of_hyp,ctxt_size,witness_fun = List.fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) decl -> - try - let witness = Int.Map.find i sub in - if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); + (fun i (end_of_type,ctxt_size,witness_fun) decl -> + try + let witness = Int.Map.find i sub in + if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_annot decl, witness, RelDecl.get_type decl, witness_fun)) - with Not_found -> - (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) - ) - 1 - (new_end_of_type,0,witness_fun) - context + with Not_found -> + (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) + ) + 1 + (new_end_of_type,0,witness_fun) + context in let new_type_of_hyp = Reductionops.nf_betaiota env sigma new_type_of_hyp in @@ -325,31 +325,31 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = in let prove_new_hyp : tactic = tclTHEN - (tclDO ctxt_size (Proofview.V82.of_tactic intro)) - (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids,_ = list_chop ctxt_size all_ids in - let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.type_of g to_refine in - tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g - ) + (tclDO ctxt_size (Proofview.V82.of_tactic intro)) + (fun g -> + let all_ids = pf_ids_of_hyps g in + let new_ids,_ = list_chop ctxt_size all_ids in + let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in + let evm, _ = pf_apply Typing.type_of g to_refine in + tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g + ) in let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) -(* str "removing an equation " ++ fnl ()++ *) -(* str "old_typ_of_hyp :=" ++ *) -(* Printer.pr_lconstr_env *) -(* env *) -(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) -(* ++ fnl () ++ *) -(* str "new_typ_of_hyp := "++ *) -(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) -(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) -(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) -(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) -(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) +(* str "removing an equation " ++ fnl ()++ *) +(* str "old_typ_of_hyp :=" ++ *) +(* Printer.pr_lconstr_env *) +(* env *) +(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) +(* ++ fnl () ++ *) +(* str "new_typ_of_hyp := "++ *) +(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) +(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) +(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) +(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) +(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) (* ); *) new_ctxt,new_end_of_type,simpl_eq_tac @@ -361,8 +361,8 @@ let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = if isVar sigma pte && Array.for_all (closed0 sigma) args then try - let info = Id.Map.find (destVar sigma pte) ptes_info in - info.is_valid full_type_of_hyp + let info = Id.Map.find (destVar sigma pte) ptes_info in + info.is_valid full_type_of_hyp with Not_found -> false else false else false @@ -377,7 +377,7 @@ let h_reduce_with_zeta cl = Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags - with Genredexpr.rDelta = false; + with Genredexpr.rDelta = false; }) cl) @@ -397,12 +397,12 @@ let rewrite_until_var arg_num eq_ids : tactic = then tclIDTAC g else match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property."); - | eq_id::eq_ids -> - tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) - (do_rewrite eq_ids) - g + | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property."); + | eq_id::eq_ids -> + tclTHEN + (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) + (do_rewrite eq_ids) + g in do_rewrite eq_ids @@ -418,129 +418,129 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let reduced_type_of_hyp = Reductionops.nf_betaiotazeta env sigma real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = - decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp + decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp in tclTHENLIST - [ h_reduce_with_zeta (Locusops.onHyp hyp_id); - scan_type new_context new_typ_of_hyp ] + [ h_reduce_with_zeta (Locusops.onHyp hyp_id); + scan_type new_context new_typ_of_hyp ] else if isProd sigma type_of_hyp then begin let (x,t_x,t') = destProd sigma type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in - if is_property sigma ptes_infos t_x actual_real_type_of_hyp then - begin - let pte,pte_args = (destApp sigma t_x) in - let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in - let prove_new_type_of_hyp = - let context_length = List.length context in - tclTHENLIST - [ - tclDO context_length (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps_ids = - fst (list_chop ~msg:"rec hyp : context_hyps" - context_length (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist(mkVar hyp_id, - List.rev_map mkVar (rec_pte_id::context_hyps_ids) - ) - in -(* observe_tac "rec hyp " *) - (tclTHENS - (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) - [ - (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); -(* observe_tac "prove rec hyp" *) - (refine to_refine) - ]) - g - ) - ] - in - tclTHENLIST - [ -(* observe_tac "hyp rec" *) - (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); - scan_type context popped_t' - ] - end - else if eq_constr sigma t_x coq_False then - begin -(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) -(* str " since it has False in its preconds " *) -(* ); *) - raise TOREMOVE; (* False -> .. useless *) - end + let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in + if is_property sigma ptes_infos t_x actual_real_type_of_hyp then + begin + let pte,pte_args = (destApp sigma t_x) in + let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let prove_new_type_of_hyp = + let context_length = List.length context in + tclTHENLIST + [ + tclDO context_length (Proofview.V82.of_tactic intro); + (fun g -> + let context_hyps_ids = + fst (list_chop ~msg:"rec hyp : context_hyps" + context_length (pf_ids_of_hyps g)) + in + let rec_pte_id = pf_get_new_id rec_pte_id g in + let to_refine = + applist(mkVar hyp_id, + List.rev_map mkVar (rec_pte_id::context_hyps_ids) + ) + in +(* observe_tac "rec hyp " *) + (tclTHENS + (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) + [ + (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); +(* observe_tac "prove rec hyp" *) + (refine to_refine) + ]) + g + ) + ] + in + tclTHENLIST + [ +(* observe_tac "hyp rec" *) + (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); + scan_type context popped_t' + ] + end + else if eq_constr sigma t_x coq_False then + begin +(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) +(* str " since it has False in its preconds " *) +(* ); *) + raise TOREMOVE; (* False -> .. useless *) + end else if is_incompatible_eq env sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) - then -(* observe (str "In "++Ppconstr.pr_id hyp_id++ *) -(* str " removing useless precond True" *) -(* ); *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let prove_trivial = - let nb_intro = List.length context in - tclTHENLIST [ - tclDO nb_intro (Proofview.V82.of_tactic intro); - (fun g -> - let context_hyps = - fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) - in - let to_refine = - applist (mkVar hyp_id, - List.rev (coq_I::List.map mkVar context_hyps) - ) - in - refine to_refine g - ) - ] - in - tclTHENLIST[ - change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp - ((* observe_tac "prove_trivial" *) prove_trivial); - scan_type context popped_t' - ] - else if is_trivial_eq sigma t_x - then (* t_x := t = t => we remove this precond *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context - in - let hd,args = destApp sigma t_x in - let get_args hd args = - if eq_constr sigma hd (Lazy.force eq) - then (Lazy.force refl_equal,args.(0),args.(1)) - else (jmeq_refl (),args.(0),args.(1)) - in - tclTHENLIST - [ - change_hyp_with_using - "prove_trivial_eq" - hyp_id - real_type_of_hyp - ((* observe_tac "prove_trivial_eq" *) - (prove_trivial_eq hyp_id context (get_args hd args))); - scan_type context popped_t' - ] - else - begin - try - let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in - tclTHEN - tac - (scan_type new_context new_t') - with NoChange -> - (* Last thing todo : push the rel in the context and continue *) + else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) + then +(* observe (str "In "++Ppconstr.pr_id hyp_id++ *) +(* str " removing useless precond True" *) +(* ); *) + let popped_t' = pop t' in + let real_type_of_hyp = + it_mkProd_or_LetIn popped_t' context + in + let prove_trivial = + let nb_intro = List.length context in + tclTHENLIST [ + tclDO nb_intro (Proofview.V82.of_tactic intro); + (fun g -> + let context_hyps = + fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) + in + let to_refine = + applist (mkVar hyp_id, + List.rev (coq_I::List.map mkVar context_hyps) + ) + in + refine to_refine g + ) + ] + in + tclTHENLIST[ + change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp + ((* observe_tac "prove_trivial" *) prove_trivial); + scan_type context popped_t' + ] + else if is_trivial_eq sigma t_x + then (* t_x := t = t => we remove this precond *) + let popped_t' = pop t' in + let real_type_of_hyp = + it_mkProd_or_LetIn popped_t' context + in + let hd,args = destApp sigma t_x in + let get_args hd args = + if eq_constr sigma hd (Lazy.force eq) + then (Lazy.force refl_equal,args.(0),args.(1)) + else (jmeq_refl (),args.(0),args.(1)) + in + tclTHENLIST + [ + change_hyp_with_using + "prove_trivial_eq" + hyp_id + real_type_of_hyp + ((* observe_tac "prove_trivial_eq" *) + (prove_trivial_eq hyp_id context (get_args hd args))); + scan_type context popped_t' + ] + else + begin + try + let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in + tclTHEN + tac + (scan_type new_context new_t') + with NoChange -> + (* Last thing todo : push the rel in the context and continue *) scan_type (LocalAssum (x,t_x) :: context) t' - end + end end else tclIDTAC @@ -558,25 +558,25 @@ let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) = in let tac,new_hyps = List.fold_left ( - fun (hyps_tac,new_hyps) hyp_id -> - let hyp_tac,new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma - in - (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps + fun (hyps_tac,new_hyps) hyp_id -> + let hyp_tac,new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps ) - (tclIDTAC,[]) - dyn_infos.rec_hyps + (tclIDTAC,[]) + dyn_infos.rec_hyps in let new_infos = { dyn_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps + rec_hyps = new_hyps; + nb_rec_hyps = List.length new_hyps } in tclTHENLIST [ - tac ; - (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) + tac ; + (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) ] g @@ -587,41 +587,41 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in tclTHENLIST [ - (* We first introduce the variables *) - tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))); - (* Then the equation itself *) - Proofview.V82.of_tactic (intro_using heq_id); - onLastHypId (fun heq_id -> tclTHENLIST [ - (* Then the new hypothesis *) + (* We first introduce the variables *) + tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))); + (* Then the equation itself *) + Proofview.V82.of_tactic (intro_using heq_id); + onLastHypId (fun heq_id -> tclTHENLIST [ + (* Then the new hypothesis *) tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; - observe_tac "after_introduction" (fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in - (* compute the new value of the body *) - let new_term_value = - match EConstr.kind (project g') new_term_value_eq with - | App(f,[| _;_;args2 |]) -> args2 - | _ -> - observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_leconstr_env (pf_env g') (project g') new_term_value_eq - ); - anomaly (Pp.str "cannot compute new term value.") - in - let fun_body = + observe_tac "after_introduction" (fun g' -> + (* We get infos on the equations introduced*) + let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in + (* compute the new value of the body *) + let new_term_value = + match EConstr.kind (project g') new_term_value_eq with + | App(f,[| _;_;args2 |]) -> args2 + | _ -> + observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ + pr_leconstr_env (pf_env g') (project g') new_term_value_eq + ); + anomaly (Pp.str "cannot compute new term value.") + in + let fun_body = mkLambda(make_annot Anonymous Sorts.Relevant, - pf_unsafe_type_of g' term, - Termops.replace_term (project g') term (mkRel 1) dyn_infos.info - ) - in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with - info = new_body; - eq_hyps = heq_id::dyn_infos.eq_hyps - } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g' - )]) + pf_unsafe_type_of g' term, + Termops.replace_term (project g') term (mkRel 1) dyn_infos.info + ) + in + let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in + let new_infos = + {dyn_infos with + info = new_body; + eq_hyps = heq_id::dyn_infos.eq_hyps + } + in + clean_goal_with_heq ptes_infos continue_tac new_infos g' + )]) ] g @@ -638,29 +638,29 @@ let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = let instantiate_one_hyp hid = my_orelse ( (* we instantiate the hyp if possible *) - fun g -> - let prov_hid = pf_get_new_id hid g in - let c = mkApp(mkVar hid,args) in - let evm, _ = pf_apply Typing.type_of g c in - tclTHENLIST[ + fun g -> + let prov_hid = pf_get_new_id hid g in + let c = mkApp(mkVar hid,args) in + let evm, _ = pf_apply Typing.type_of g c in + tclTHENLIST[ Refiner.tclEVARS evm; - Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); - thin [hid]; - Proofview.V82.of_tactic (rename_hyp [prov_hid,hid]) - ] g + Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); + thin [hid]; + Proofview.V82.of_tactic (rename_hyp [prov_hid,hid]) + ] g ) ( (* - if not then we are in a mutual function block - and this hyp is a recursive hyp on an other function. + if not then we are in a mutual function block + and this hyp is a recursive hyp on an other function. - We are not supposed to use it while proving this - principle so that we can trash it + We are not supposed to use it while proving this + principle so that we can trash it - *) - (fun g -> -(* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) - thin [hid] g - ) + *) + (fun g -> +(* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) + thin [hid] g + ) ) in if List.is_empty args_id @@ -672,17 +672,17 @@ let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = else tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; + tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; tclMAP instantiate_one_hyp hyps; - (fun g -> - let all_g_hyps_id = - List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty - in - let remaining_hyps = - List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g - ) + (fun g -> + let all_g_hyps_id = + List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty + in + let remaining_hyps = + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps g + ) ] let build_proof @@ -696,152 +696,152 @@ let build_proof let env = pf_env g in let sigma = project g in (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match EConstr.kind sigma dyn_infos.info with - | Case(ci,ct,t,cb) -> - let do_finalize_t dyn_info' = - fun g -> - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = - mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (project g) (pf_concl g) in - let type_of_term = pf_unsafe_type_of g t in - let term_eq = - make_refl_eq (Lazy.force refl_equal) type_of_term t - in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); - thin dyn_infos.rec_hyps; - Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); - (fun g -> observe_tac "toto" ( - tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); - (fun g' -> - let g'_nb_prod = nb_prod (project g') (pf_concl g') in + match EConstr.kind sigma dyn_infos.info with + | Case(ci,ct,t,cb) -> + let do_finalize_t dyn_info' = + fun g -> + let t = dyn_info'.info in + let dyn_infos = {dyn_info' with info = + mkCase(ci,ct,t,cb)} in + let g_nb_prod = nb_prod (project g) (pf_concl g) in + let type_of_term = pf_unsafe_type_of g t in + let term_eq = + make_refl_eq (Lazy.force refl_equal) type_of_term t + in + tclTHENLIST + [ + Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); + thin dyn_infos.rec_hyps; + Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); + (fun g -> observe_tac "toto" ( + tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); + (fun g' -> + let g'_nb_prod = nb_prod (project g') (pf_concl g') in let nb_instantiate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case - ptes_infos + observe_tac "treat_new_case" + (treat_new_case + ptes_infos nb_instantiate_partial (build_proof do_finalize) - t - dyn_infos) - g' - ) - - ]) g - ) - ] - g - in + t + dyn_infos) + g' + ) + + ]) g + ) + ] + g + in build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> - begin - match EConstr.kind sigma (pf_concl g) with - | Prod _ -> - tclTHEN - (Proofview.V82.of_tactic intro) - (fun g' -> + begin + match EConstr.kind sigma (pf_concl g) with + | Prod _ -> + tclTHEN + (Proofview.V82.of_tactic intro) + (fun g' -> let open Context.Named.Declaration in - let id = pf_last_hyp g' |> get_id in - let new_term = - pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) - in - let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = + let id = pf_last_hyp g' |> get_id in + let new_term = + pf_nf_betaiota g' + (mkApp(dyn_infos.info,[|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = build_proof do_finalize - {new_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in -(* observe_tac "Lambda" *) (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' - (* build_proof do_finalize new_infos g' *) - ) g - | _ -> - do_finalize dyn_infos g - end - | Cast(t,_,_) -> + {new_infos with + rec_hyps = new_hyps; + nb_rec_hyps = List.length new_hyps + } + in +(* observe_tac "Lambda" *) (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' + (* build_proof do_finalize new_infos g' *) + ) g + | _ -> + do_finalize dyn_infos g + end + | Cast(t,_,_) -> build_proof do_finalize {dyn_infos with info = t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> - do_finalize dyn_infos g - | App(_,_) -> - let f,args = decompose_app sigma dyn_infos.info in - begin - match EConstr.kind sigma f with + do_finalize dyn_infos g + | App(_,_) -> + let f,args = decompose_app sigma dyn_infos.info in + begin + match EConstr.kind sigma f with | Int _ -> user_err Pp.(str "integer cannot be applied") - | App _ -> assert false (* we have collected all the app in decompose_app *) - | Proj _ -> assert false (*FIXME*) - | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in + | App _ -> assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> + let new_infos = + { dyn_infos with + info = (f,args) + } + in build_proof_args env sigma do_finalize new_infos g - | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in -(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> + let new_infos = + { dyn_infos with + info = (f,args) + } + in +(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) build_proof_args env sigma do_finalize new_infos g - | Const _ -> - do_finalize dyn_infos g - | Lambda _ -> - let new_term = + | Const _ -> + do_finalize dyn_infos g + | Lambda _ -> + let new_term = Reductionops.nf_beta env sigma dyn_infos.info in build_proof do_finalize {dyn_infos with info = new_term} - g - | LetIn _ -> - let new_infos = + g + | LetIn _ -> + let new_infos = { dyn_infos with info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> - h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; + in + + tclTHENLIST + [tclMAP + (fun hyp_id -> + h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps; + h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos - ] - g - | Cast(b,_,_) -> + ] + g + | Cast(b,_,_) -> build_proof do_finalize {dyn_infos with info = b } g - | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = - { dyn_infos with - info = dyn_infos.info,args - } - in + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = + { dyn_infos with + info = dyn_infos.info,args + } + in build_proof_args env sigma do_finalize new_infos - in + in build_proof new_finalize {dyn_infos with info = f } g - end - | Fix _ | CoFix _ -> - user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) + end + | Fix _ | CoFix _ -> + user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) - | Proj _ -> user_err Pp.(str "Prod") - | Prod _ -> do_finalize dyn_infos g - | LetIn _ -> - let new_infos = - { dyn_infos with + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos g + | LetIn _ -> + let new_infos = + { dyn_infos with info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info - } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Locusops.onConcl; + } + in + + tclTHENLIST + [tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps; + h_reduce_with_zeta Locusops.onConcl; build_proof do_finalize new_infos - ] g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + ] g + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) observe_tac_stream (str "build_proof with " ++ pr_leconstr_env (pf_env g) (project g) dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g @@ -849,33 +849,33 @@ let build_proof fun g -> let (f_args',args) = dyn_infos.info in let tac : tactic = - fun g -> - match args with - | [] -> - do_finalize {dyn_infos with info = f_args'} g - | arg::args -> - (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) - (* fnl () ++ *) - (* pr_goal (Tacmach.sig_it g) *) - (* ); *) - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - (* tclTRYD *) + fun g -> + match args with + | [] -> + do_finalize {dyn_infos with info = f_args'} g + | arg::args -> + (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) + (* fnl () ++ *) + (* pr_goal (Tacmach.sig_it g) *) + (* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) (build_proof_args env sigma - do_finalize - {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} - ) - in + do_finalize + {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} + ) + in build_proof do_finalize - {dyn_infos with info = arg } - g + {dyn_infos with info = arg } + g in (* observe_tac "build_proof_args" *) (tac ) g in let do_finish_proof dyn_infos = (* tclTRYD *) (clean_goal_with_heq - ptes_infos - finish_proof dyn_infos) + ptes_infos + finish_proof dyn_infos) in (* observe_tac "build_proof" *) fun g -> @@ -899,14 +899,14 @@ type static_fix_info = let prove_rec_hyp_for_struct fix_info = (fun eq_hyps -> tclTHEN - (rewrite_until_var (fix_info.idx) eq_hyps) - (fun g -> - let _,pte_args = destApp (project g) (pf_concl g) in - let rec_hyp_proof = - mkApp(mkVar fix_info.name,array_get_start pte_args) - in - refine rec_hyp_proof g - )) + (rewrite_until_var (fix_info.idx) eq_hyps) + (fun g -> + let _,pte_args = destApp (project g) (pf_concl g) in + let rec_hyp_proof = + mkApp(mkVar fix_info.name,array_get_start pte_args) + in + refine rec_hyp_proof g + )) let prove_rec_hyp fix_info = { proving_tac = prove_rec_hyp_for_struct fix_info @@ -926,8 +926,8 @@ let generalize_non_dep hyp g = let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep - || Termops.occur_var env (project g) hyp hyp_typ - || Termops.is_section_variable hyp (* should be dangerous *) + || Termops.occur_var env (project g) hyp hyp_typ + || Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (pf_env g) @@ -968,7 +968,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let (type_ctxt,type_of_f),evd = let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f - in + in decompose_prod_n_assum evd (nb_params + nb_args) t,evd in @@ -979,32 +979,30 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let prove_replacement = tclTHENLIST [ - tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro); - observe_tac "" (fun g -> - let rec_id = pf_nth_hyp_id g 1 in - tclTHENLIST - [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); - observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); - (Proofview.V82.of_tactic intros_reflexivity)] g - ) + tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro); + observe_tac "" (fun g -> + let rec_id = pf_nth_hyp_id g 1 in + tclTHENLIST + [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); + observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); + (Proofview.V82.of_tactic intros_reflexivity)] g + ) ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) - let pstate = Lemmas.start_proof + let lemma = Lemmas.start_lemma (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) (mk_equation_id f_id) - (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) + Decl_kinds.(Global ImportDefaultBehavior, false, Proof Theorem) evd lemma_type in - let pstate,_ = Pfedit.by (Proofview.V82.tactic prove_replacement) pstate in - let ontop = Proof_global.push ~ontop:None pstate in - ignore(Lemmas.save_proof_proved ?proof:None ~ontop ~opaque:Proof_global.Transparent ~idopt:None); + let lemma,_ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in + let () = Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:Proof_global.Transparent ~idopt:None in evd - let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try @@ -1013,28 +1011,28 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a with (Not_found | Option.IsNone as e) -> let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma - Ensures by: obvious - i*) + Ensures by: obvious + i*) let equation_lemma_id = (mk_equation_id f_id) in evd := generate_equation_lemma !evd all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = - match e with - | Option.IsNone -> - let finfos = find_Function_infos (fst (destConst !evd f)) in - update_Function - {finfos with - equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with - ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) - } - | _ -> () + match e with + | Option.IsNone -> + let finfos = find_Function_infos (fst (destConst !evd f)) in + update_Function + {finfos with + equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with + ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") + ) + } + | _ -> () in (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) let evd',res = - Evd.fresh_global - (Global.env ()) !evd - (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) + Evd.fresh_global + (Global.env ()) !evd + (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in evd:=evd'; let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in @@ -1045,12 +1043,12 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a tclTHEN (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) ( - fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in + fun g' -> + let just_introduced = nLastDecls nb_intro_to_do g' in let open Context.Named.Declaration in - let just_introduced_id = List.map get_id just_introduced in - tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) - (revert just_introduced_id) g' + let just_introduced_id = List.map get_id just_introduced in + tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) + (revert just_introduced_id) g' ) g @@ -1064,35 +1062,35 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let fresh_id = let avoid = ref (pf_ids_of_hyps g) in (fun na -> - let new_id = - match na with - Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" - in - avoid := new_id :: !avoid; - (Name new_id) + let new_id = + match na with + Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + (Name new_id) ) in let fresh_decl = RelDecl.map_name fresh_id in let princ_info : elim_scheme = { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args + params = List.map fresh_decl princ_info.params; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; + args = List.map fresh_decl princ_info.args } in let get_body const = match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _) -> + | Some (body, _) -> let env = Global.env () in let sigma = Evd.from_env env in - Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) env sigma - (EConstr.of_constr body) - | None -> user_err Pp.(str "Cannot define a principle over an axiom ") + (EConstr.of_constr body) + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in let f_ctxt,f_body = decompose_lam (project g) fbody in @@ -1101,37 +1099,37 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let full_params,princ_params,fbody_with_full_params = if diff_params > 0 then - let princ_params,full_params = - list_chop diff_params princ_info.params - in - (full_params, (* real params *) - princ_params, (* the params of the principle which are not params of the function *) + let princ_params,full_params = + list_chop diff_params princ_info.params + in + (full_params, (* real params *) + princ_params, (* the params of the principle which are not params of the function *) substl (* function instantiated with real params *) - (List.map var_of_decl full_params) - f_body - ) + (List.map var_of_decl full_params) + f_body + ) else - let f_ctxt_other,f_ctxt_params = - list_chop (- diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in - (princ_info.params, (* real params *) - [],(* all params are full params *) + let f_ctxt_other,f_ctxt_params = + list_chop (- diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + (princ_info.params, (* real params *) + [],(* all params are full params *) substl (* function instantiated with real params *) - (List.map var_of_decl princ_info.params) - f_body - ) + (List.map var_of_decl princ_info.params) + f_body + ) in observe (str "full_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - full_params - ); + prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + full_params + ); observe (str "princ_params := " ++ - prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - princ_params - ); + prlist_with_sep spc (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + princ_params + ); observe (str "fbody_with_full_params := " ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params - ); + ); let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs in @@ -1139,232 +1137,232 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let ptes_to_fix,infos = match EConstr.kind (project g) fbody_with_full_params with | Fix((idxs,i),(names,typess,bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> + let bodies_with_all_params = + Array.map + (fun body -> Reductionops.nf_betaiota (pf_env g) (project g) - (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, - List.rev_map var_of_decl princ_params)) - ) - bodies - in - let info_array = - Array.mapi - (fun i types -> - let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in - { idx = idxs.(i) - fix_offset; + (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, + List.rev_map var_of_decl princ_params)) + ) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in + { idx = idxs.(i) - fix_offset; name = Nameops.Name.get_id (fresh_id names.(i).binder_name); - types = types; - offset = fix_offset; - nb_realargs = - List.length - (fst (decompose_lam (project g) bodies.(i))) - fix_offset; - body_with_param = bodies_with_all_params.(i); - num_in_block = i - } - ) - typess - in - let pte_to_fix,rev_info = - List.fold_left_i - (fun i (acc_map,acc_info) decl -> - let pte = RelDecl.get_name decl in - let infos = info_array.(i) in - let type_args,_ = decompose_prod (project g) infos.types in - let nargs = List.length type_args in - let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in - let app_f = mkApp(f,first_args) in - let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in - let body_with_param,num = - let body = get_body fnames.(i) in - let body_with_full_params = + types = types; + offset = fix_offset; + nb_realargs = + List.length + (fst (decompose_lam (project g) bodies.(i))) - fix_offset; + body_with_param = bodies_with_all_params.(i); + num_in_block = i + } + ) + typess + in + let pte_to_fix,rev_info = + List.fold_left_i + (fun i (acc_map,acc_info) decl -> + let pte = RelDecl.get_name decl in + let infos = info_array.(i) in + let type_args,_ = decompose_prod (project g) infos.types in + let nargs = List.length type_args in + let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in + let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in + let app_f = mkApp(f,first_args) in + let pte_args = (Array.to_list first_args)@[app_f] in + let app_pte = applist(mkVar (Nameops.Name.get_id pte),pte_args) in + let body_with_param,num = + let body = get_body fnames.(i) in + let body_with_full_params = Reductionops.nf_betaiota (pf_env g) (project g) ( - applist(body,List.rev_map var_of_decl full_params)) - in - match EConstr.kind (project g) body_with_full_params with + applist(body,List.rev_map var_of_decl full_params)) + in + match EConstr.kind (project g) body_with_full_params with | Fix((_,num),(_,_,bs)) -> Reductionops.nf_betaiota (pf_env g) (project g) ( - (applist - (substl - (List.rev - (Array.to_list all_funs_with_full_params)) - bs.(num), - List.rev_map var_of_decl princ_params)) - ),num - | _ -> user_err Pp.(str "Not a mutual block") - in - let info = - {infos with - types = compose_prod type_args app_pte; - body_with_param = body_with_param; - num_in_block = num - } - in -(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) -(* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info) - ) - 0 - (Id.Map.empty,[]) - (List.rev princ_info.predicates) - in - pte_to_fix,List.rev rev_info - | _ -> - Id.Map.empty,[] + (applist + (substl + (List.rev + (Array.to_list all_funs_with_full_params)) + bs.(num), + List.rev_map var_of_decl princ_params)) + ),num + | _ -> user_err Pp.(str "Not a mutual block") + in + let info = + {infos with + types = compose_prod type_args app_pte; + body_with_param = body_with_param; + num_in_block = num + } + in +(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) +(* str " to " ++ Ppconstr.pr_id info.name); *) + (Id.Map.add (Nameops.Name.get_id pte) info acc_map,info::acc_info) + ) + 0 + (Id.Map.empty,[]) + (List.rev princ_info.predicates) + in + pte_to_fix,List.rev rev_info + | _ -> + Id.Map.empty,[] in let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in match pre_info,infos with - | _,[] -> tclIDTAC - | _, this_fix_info::others_infos -> - let other_fix_infos = - List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) - (pre_info@others_infos) - in - if List.is_empty other_fix_infos - then - if this_fix_info.idx + 1 = 0 - then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) - else + | _,[] -> tclIDTAC + | _, this_fix_info::others_infos -> + let other_fix_infos = + List.map + (fun fi -> fi.name,fi.idx + 1 ,fi.types) + (pre_info@others_infos) + in + if List.is_empty other_fix_infos + then + if this_fix_info.idx + 1 = 0 + then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) + else observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) - else - Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos 0) + else + Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos 0) in let first_tac : tactic = (* every operations until fix creations *) tclTHENLIST - [ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params))); - observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates))); - observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches))); - observe_tac "building fixes" mk_fixes; - ] + [ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params))); + observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates))); + observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches))); + observe_tac "building fixes" mk_fixes; + ] in let intros_after_fixes : tactic = fun gl -> - let ctxt,pte_app = (decompose_prod_assum (project gl) (pf_concl gl)) in - let pte,pte_args = (decompose_app (project gl) pte_app) in - try - let pte = + let ctxt,pte_app = (decompose_prod_assum (project gl) (pf_concl gl)) in + let pte,pte_args = (decompose_app (project gl) pte_app) in + try + let pte = try destVar (project gl) pte with DestKO -> anomaly (Pp.str "Property is not a variable.") in - let fix_info = Id.Map.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in - tclTHENLIST - [ - (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro)); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let fix_body = fix_info.body_with_param in -(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let fix_info = Id.Map.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in + tclTHENLIST + [ + (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro)); + (fun g -> (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let fix_body = fix_info.body_with_param in +(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = + let args_id = List.map get_id args in + let dyn_infos = + { + nb_rec_hyps = -100; + rec_hyps = []; + info = Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fix_body,List.rev_map mkVar args_id)); - eq_hyps = [] - } - in - tclTHENLIST - [ - observe_tac "do_replace" - (do_replace evd - full_params - (fix_info.idx + List.length princ_params) - (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params)) - (all_funs.(fix_info.num_in_block)) - fix_info.num_in_block - all_funs - ); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - observe_tac "cleaning" (clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos) - in -(* observe (str "branches := " ++ *) -(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) -(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - -(* ); *) + (applist(fix_body,List.rev_map mkVar args_id)); + eq_hyps = [] + } + in + tclTHENLIST + [ + observe_tac "do_replace" + (do_replace evd + full_params + (fix_info.idx + List.length princ_params) + (args_id@(List.map (RelDecl.get_name %> Nameops.Name.get_id) princ_params)) + (all_funs.(fix_info.num_in_block)) + fix_info.num_in_block + all_funs + ); + let do_prove = + build_proof + interactive_proof + (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + {dyn_infos with + rec_hyps = branches; + nb_rec_hyps = List.length branches + } + in + observe_tac "cleaning" (clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove + dyn_infos) + in +(* observe (str "branches := " ++ *) +(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) +(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + +(* ); *) (* observe_tac "instancing" *) (instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) - ] - g - ); - ] gl - with Not_found -> - let nb_args = min (princ_info.nargs) (List.length ctxt) in - tclTHENLIST - [ - tclDO nb_args (Proofview.V82.of_tactic intro); - (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) + ] + g + ); + ] gl + with Not_found -> + let nb_args = min (princ_info.nargs) (List.length ctxt) in + tclTHENLIST + [ + tclDO nb_args (Proofview.V82.of_tactic intro); + (fun g -> (* replacement of the function by its body *) + let args = nLastDecls nb_args g in let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = + let args_id = List.map get_id args in + let dyn_infos = + { + nb_rec_hyps = -100; + rec_hyps = []; + info = Reductionops.nf_betaiota (pf_env g) (project g) - (applist(fbody_with_full_params, - (List.rev_map var_of_decl princ_params)@ - (List.rev_map mkVar args_id) - )); - eq_hyps = [] - } - in - let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in - tclTHENLIST - [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos - in + (applist(fbody_with_full_params, + (List.rev_map var_of_decl princ_params)@ + (List.rev_map mkVar args_id) + )); + eq_hyps = [] + } + in + let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in + tclTHENLIST + [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); + let do_prove = + build_proof + interactive_proof + (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + {dyn_infos with + rec_hyps = branches; + nb_rec_hyps = List.length branches + } + in + clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove + dyn_infos + in instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id) - ] - g - ) - ] - gl + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id) + ] + g + ) + ] + gl in tclTHEN first_tac @@ -1393,23 +1391,23 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with | Undefined -> anomaly (Pp.str "No tcc proof !!") | Value lemma -> - fun gls -> -(* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) -(* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENLIST - [ -(* generalize [lemma]; *) -(* h_intro hid; *) -(* Elim.h_decompose_and (mkVar hid); *) - tclTRY(list_rewrite true eqs); -(* (fun g -> *) -(* let ids' = pf_ids_of_hyps g in *) -(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) -(* rewrite *) -(* ) *) - Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) - ] - gls + fun gls -> +(* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) +(* let ids = hid::pf_ids_of_hyps gls in *) + tclTHENLIST + [ +(* generalize [lemma]; *) +(* h_intro hid; *) +(* Elim.h_decompose_and (mkVar hid); *) + tclTRY(list_rewrite true eqs); +(* (fun g -> *) +(* let ids' = pf_ids_of_hyps g in *) +(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) +(* rewrite *) +(* ) *) + Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) + ] + gls | Not_needed -> tclIDTAC let backtrack_eqs_until_hrec hrec eqs : tactic = @@ -1423,10 +1421,10 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = let f = (fst (destApp (project gls) f_app)) in let rec backtrack : tactic = fun g -> - let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in - match EConstr.kind (project g) f_app with - | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g - | _ -> tclTHEN rewrite backtrack g + let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in + match EConstr.kind (project g) f_app with + | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g + | _ -> tclTHEN rewrite backtrack g in backtrack gls @@ -1436,55 +1434,55 @@ let rec rewrite_eqs_in_eqs eqs = | [] -> tclIDTAC | eq::eqs -> - tclTHEN - (tclMAP - (fun id gl -> - observe_tac - (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) - (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences - true (* dep proofs also: *) true id (mkVar eq) false))) - gl - ) - eqs - ) - (rewrite_eqs_in_eqs eqs) + tclTHEN + (tclMAP + (fun id gl -> + observe_tac + (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) + (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences + true (* dep proofs also: *) true id (mkVar eq) false))) + gl + ) + eqs + ) + (rewrite_eqs_in_eqs eqs) let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = fun gls -> (tclTHENLIST [ - backtrack_eqs_until_hrec hrec eqs; - (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) - (tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) - [ tclTHENLIST - [ - (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); - (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); - (fun g -> - if is_mes - then - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g - else tclIDTAC g - ); - observe_tac "rew_and_finish" - (tclTHENLIST - [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs)); - observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); - (observe_tac "finishing using" - ( - tclCOMPLETE( - Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + backtrack_eqs_until_hrec hrec eqs; + (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) + (tclTHENS (* We must have exactly ONE subgoal !*) + (Proofview.V82.of_tactic (apply (mkVar hrec))) + [ tclTHENLIST + [ + (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); + (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); + (fun g -> + if is_mes + then + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g + else tclIDTAC g + ); + observe_tac "rew_and_finish" + (tclTHENLIST + [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs)); + observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); + (observe_tac "finishing using" + ( + tclCOMPLETE( + Eauto.eauto_with_bases + (true,5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] [Hints.Hint_db.empty TransparentState.empty false] - ) - ) - ) - ] - ) - ] - ]) + ) + ) + ) + ] + ) + ] + ]) ]) gls @@ -1504,7 +1502,7 @@ let is_valid_hypothesis sigma predicates_name = is_pte typ || match EConstr.kind sigma typ with | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' - | _ -> false + | _ -> false in is_valid_hypothesis @@ -1517,9 +1515,9 @@ let prove_principle_for_gen let avoid = ref (pf_ids_of_hyps gl) in fun na -> let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; Name new_id @@ -1527,10 +1525,10 @@ let prove_principle_for_gen let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args + params = List.map fresh_decl princ_info.params; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; + args = List.map fresh_decl princ_info.args } in let wf_tac = @@ -1547,8 +1545,8 @@ let prove_principle_for_gen (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) -(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) -(* str "npost_rec_arg := " ++ int npost_rec_arg ); *) +(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) +(* str "npost_rec_arg := " ++ int npost_rec_arg ); *) let (post_rec_arg,pre_rec_arg) = Util.List.chop npost_rec_arg princ_info.args in @@ -1571,18 +1569,18 @@ let prove_principle_for_gen let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = ((* observe_tac "prove_rec_arg_acc" *) - (tclCOMPLETE - (tclTHEN - (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) - ( - (* observe_tac *) -(* "apply wf_thm" *) - Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) - ) - ) - ) + (tclCOMPLETE + (tclTHEN + (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) + (mkApp (delayed_force well_founded,[|input_type;relation|])) + (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) + ( + (* observe_tac *) +(* "apply wf_thm" *) + Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) + ) + ) + ) ) g in @@ -1607,129 +1605,121 @@ let prove_principle_for_gen let start_tac gls = let hyps = pf_ids_of_hyps gls in let hid = - next_ident_away_in_goal - (Id.of_string "prov") - (Id.Set.of_list hyps) + next_ident_away_in_goal + (Id.of_string "prov") + (Id.Set.of_list hyps) in tclTHENLIST - [ - Proofview.V82.of_tactic (generalize [lemma]); - Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); - (fun g -> - let new_hyps = pf_ids_of_hyps g in - tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); - if List.is_empty !tcc_list - then - begin - tcc_list := [hid]; - tclIDTAC g - end - else thin [hid] g - ) - ] - gls + [ + Proofview.V82.of_tactic (generalize [lemma]); + Proofview.V82.of_tactic (Simple.intro hid); + Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); + (fun g -> + let new_hyps = pf_ids_of_hyps g in + tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); + if List.is_empty !tcc_list + then + begin + tcc_list := [hid]; + tclIDTAC g + end + else thin [hid] g + ) + ] + gls in tclTHENLIST [ observe_tac "start_tac" start_tac; h_intros - (List.rev_map (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) - ); + (List.rev_map (get_name %> Nameops.Name.get_id) + (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) + ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by - (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc) + (Name acc_rec_arg_id) + (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + (Proofview.V82.tactic prove_rec_arg_acc) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) -(* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) +(* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); (* observe_tac "finish" *) (fun gl' -> - let body = - let _,args = destApp (project gl') (pf_concl gl') in - Array.last args - in - let body_info rec_hyps = - { - nb_rec_hyps = List.length rec_hyps; - rec_hyps = rec_hyps; - eq_hyps = []; - info = body - } - in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in - let predicates_names = - List.map (get_name %> Nameops.Name.get_id) princ_info.predicates - in - let pte_info = - { proving_tac = - (fun eqs -> -(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) -(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) -(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) -(* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) -(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) - - (* observe_tac "new_prove_with_tcc" *) - (new_prove_with_tcc - is_mes acc_inv fix_id - - (!tcc_list@(List.map - (get_name %> Nameops.Name.get_id) - (princ_info.args@princ_info.params) - )@ ([acc_rec_arg_id])) eqs - ) - - ); - is_valid = is_valid_hypothesis (project gl') predicates_names - } - in - let ptes_info : pte_info Id.Map.t = - List.fold_left - (fun map pte_id -> - Id.Map.add pte_id - pte_info - map - ) - Id.Map.empty - predicates_names - in - let make_proof rec_hyps = - build_proof - false - [f_ref] - ptes_info - (body_info rec_hyps) - in + let body = + let _,args = destApp (project gl') (pf_concl gl') in + Array.last args + in + let body_info rec_hyps = + { + nb_rec_hyps = List.length rec_hyps; + rec_hyps = rec_hyps; + eq_hyps = []; + info = body + } + in + let acc_inv = + lazy ( + mkApp ( + delayed_force acc_inv_id, + [|input_type;relation;mkVar rec_arg_id|] + ) + ) + in + let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in + let predicates_names = + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> +(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) +(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) +(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) +(* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) +(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) + + (* observe_tac "new_prove_with_tcc" *) + (new_prove_with_tcc + is_mes acc_inv fix_id + + (!tcc_list@(List.map + (get_name %> Nameops.Name.get_id) + (princ_info.args@princ_info.params) + )@ ([acc_rec_arg_id])) eqs + ) + + ); + is_valid = is_valid_hypothesis (project gl') predicates_names + } + in + let ptes_info : pte_info Id.Map.t = + List.fold_left + (fun map pte_id -> + Id.Map.add pte_id + pte_info + map + ) + Id.Map.empty + predicates_names + in + let make_proof rec_hyps = + build_proof + false + [f_ref] + ptes_info + (body_info rec_hyps) + in (* observe_tac "instantiate_hyps_with_args" *) (instantiate_hyps_with_args - make_proof - (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) - (List.rev args_ids) - ) - gl' + make_proof + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) + (List.rev args_ids) + ) + gl' ) ] gl - - - - - - - - diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 7b26cb0c74..8af5dc818b 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -51,16 +51,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | [] -> [] | decl :: predicates -> (match Context.Rel.Declaration.get_name decl with - | Name x -> - let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in - Hashtbl.add tbl id x; - RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates - | Anonymous -> anomaly (Pp.str "Anonymous property binder.")) + | Name x -> + let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in + Hashtbl.add tbl id x; + RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates + | Anonymous -> anomaly (Pp.str "Anonymous property binder.")) in let avoid = (Termops.ids_of_context env_with_params ) in let princ_type_info = { princ_type_info with - predicates = change_predicates_names avoid princ_type_info.predicates + predicates = change_predicates_names avoid princ_type_info.predicates } in (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) @@ -85,28 +85,28 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = fst (match princ_type_info.indref with - | Some (Globnames.IndRef ind) -> ind - | _ -> user_err Pp.(str "Not a valid predicate") - ) + | Some (Globnames.IndRef ind) -> ind + | _ -> user_err Pp.(str "Not a valid predicate") + ) in let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in let is_pte = let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in fun t -> match Constr.kind t with - | Var id -> Id.Set.mem id set - | _ -> false + | Var id -> Id.Set.mem id set + | _ -> false in let pre_princ = let open EConstr in it_mkProd_or_LetIn (it_mkProd_or_LetIn - (Option.fold_right - mkProd_or_LetIn - princ_type_info.indarg - princ_type_info.concl - ) - princ_type_info.args + (Option.fold_right + mkProd_or_LetIn + princ_type_info.indarg + princ_type_info.concl + ) + princ_type_info.args ) princ_type_info.branches in @@ -135,105 +135,105 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let rec compute_new_princ_type remove env pre_princ : types*(constr list) = let (new_princ_type,_) as res = match Constr.kind pre_princ with - | Rel n -> - begin - try match Environ.lookup_rel n env with + | Rel n -> + begin + try match Environ.lookup_rel n env with | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved - | _ -> pre_princ,[] - with Not_found -> assert false - end + | _ -> pre_princ,[] + with Not_found -> assert false + end | Prod(x,t,b) -> compute_new_princ_type_for_binder remove mkProd env x t b | Lambda(x,t,b) -> compute_new_princ_type_for_binder remove mkLambda env x t b - | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved - | App(f,args) when is_dom f -> - let var_to_be_removed = destRel (Array.last args) in - let num = get_fun_num f in - raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) - | App(f,args) -> - let args = - if is_pte f && remove - then array_get_start args - else args - in - let new_args,binders_to_remove = - Array.fold_right (compute_new_princ_type_with_acc remove env) - args - ([],[]) - in - let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in - applistc new_f new_args, - list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove + | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved + | App(f,args) when is_dom f -> + let var_to_be_removed = destRel (Array.last args) in + let num = get_fun_num f in + raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) + | App(f,args) -> + let args = + if is_pte f && remove + then array_get_start args + else args + in + let new_args,binders_to_remove = + Array.fold_right (compute_new_princ_type_with_acc remove env) + args + ([],[]) + in + let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in + applistc new_f new_args, + list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove | LetIn(x,v,t,b) -> compute_new_princ_type_for_letin remove env x v t b - | _ -> pre_princ,[] + | _ -> pre_princ,[] in (* let _ = match Constr.kind pre_princ with *) -(* | Prod _ -> *) -(* observe(str "compute_new_princ_type for "++ *) -(* pr_lconstr_env env pre_princ ++ *) -(* str" is "++ *) -(* pr_lconstr_env env new_princ_type ++ fnl ()) *) -(* | _ -> () in *) +(* | Prod _ -> *) +(* observe(str "compute_new_princ_type for "++ *) +(* pr_lconstr_env env pre_princ ++ *) +(* str" is "++ *) +(* pr_lconstr_env env new_princ_type ++ fnl ()) *) +(* | _ -> () in *) res and compute_new_princ_type_for_binder remove bind_fun env x t b = begin try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in + let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_x = map_annot (get_name (Termops.ids_of_context env)) x in let new_env = Environ.push_rel (LocalAssum (x,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b), filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( + let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b + then (pop new_b), filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b + else + ( bind_fun(new_x,new_t,new_b), - list_union_eq - Constr.equal - binders_to_remove_from_t - (List.map pop binders_to_remove_from_b) - ) + list_union_eq + Constr.equal + binders_to_remove_from_t + (List.map pop binders_to_remove_from_b) + ) with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) + | Toberemoved -> +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in + new_b, List.map pop binders_to_remove_from_b + | Toberemoved_with_rel (n,c) -> +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in + new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_for_letin remove env x v t b = begin try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in + let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in + let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in let new_x = map_annot (get_name (Termops.ids_of_context env)) x in let new_env = Environ.push_rel (LocalDef (x,v,t)) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b - else - ( + let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in + if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b + then (pop new_b),filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b + else + ( mkLetIn(new_x,new_v,new_t,new_b), - list_union_eq - Constr.equal - (list_union_eq Constr.equal binders_to_remove_from_t binders_to_remove_from_v) - (List.map pop binders_to_remove_from_b) - ) + list_union_eq + Constr.equal + (list_union_eq Constr.equal binders_to_remove_from_t binders_to_remove_from_v) + (List.map pop binders_to_remove_from_b) + ) with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) + | Toberemoved -> +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in + new_b, List.map pop binders_to_remove_from_b + | Toberemoved_with_rel (n,c) -> +(* observe (str "Decl of "++Ppconstr.Name.print x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in + new_b, list_add_set_eq Constr.equal (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = let new_e,to_remove_from_e = compute_new_princ_type remove env e @@ -256,7 +256,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = LocalAssum (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, t, b)) - new_predicates) + new_predicates) ) (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) @@ -281,8 +281,8 @@ let change_property_sort evd toSort princ princName = let init = let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in mkApp(EConstr.Unsafe.to_constr princName_as_constr, - Array.init nargs - (fun i -> mkRel (nargs - i ))) + Array.init nargs + (fun i -> mkRel (nargs - i ))) in evd, it_mkLambda_or_LetIn (it_mkLambda_or_LetIn init @@ -308,24 +308,24 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in evd := sigma; let hook = Lemmas.mk_hook (hook new_principle_type) in - let pstate = - Lemmas.start_proof + let lemma = + Lemmas.start_lemma new_princ_name - (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) + Decl_kinds.(Global ImportDefaultBehavior,false,Proof Theorem) !evd (EConstr.of_constr new_principle_type) in (* let _tim1 = System.get_time () in *) let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let pstate,_ = Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) pstate in + let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in (* let _tim2 = System.get_time () in *) - (* begin *) - (* let dur1 = System.time_difference tim1 tim2 in *) - (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) - (* end; *) + (* begin *) + (* let dur1 = System.time_difference tim1 tim2 in *) + (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) + (* end; *) let open Proof_global in - let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pstate in + let { id; entries; persistence } = Lemmas.pf_fold (close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x)) lemma in match entries with | [entry] -> (id,(entry,persistence)), hook @@ -350,8 +350,8 @@ let generate_functional_principle (evd: Evd.evar_map ref) match new_princ_name with | Some (id) -> id,id | None -> - let id_of_f = Label.to_id (Constant.label (fst f)) in - id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) + let id_of_f = Label.to_id (Constant.label (fst f)) in + id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) in let names = ref [new_princ_name] in let hook = @@ -369,13 +369,13 @@ let generate_functional_principle (evd: Evd.evar_map ref) let univs = Evd.univ_entry ~poly:false evd' in let ce = Declare.definition_entry ~univs value in ignore( - Declare.declare_constant - name - (DefinitionEntry ce, - Decl_kinds.IsDefinition (Decl_kinds.Scheme)) - ); - Declare.definition_message name; - names := name :: !names + Declare.declare_constant + name + (DefinitionEntry ce, + Decl_kinds.IsDefinition (Decl_kinds.Scheme)) + ); + Declare.definition_message name; + names := name :: !names in register_with_sort InProp; register_with_sort InSet @@ -398,31 +398,31 @@ let get_funs_constant mp = let get_funs_constant const e : (Names.Constant.t*int) array = match Constr.kind ((strip_lam e)) with | Fix((_,(na,_,_))) -> - Array.mapi - (fun i na -> + Array.mapi + (fun i na -> match na.binder_name with - | Name id -> + | Name id -> let const = Constant.make2 mp (Label.of_id id) in - const,i - | Anonymous -> - anomaly (Pp.str "Anonymous fix.") - ) - na + const,i + | Anonymous -> + anomaly (Pp.str "Anonymous fix.") + ) + na | _ -> [|const,0|] in function const -> let find_constant_body const = match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _) -> - let body = Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.from_env (Global.env ())) - (EConstr.of_constr body) - in - let body = EConstr.Unsafe.to_constr body in - body - | None -> user_err Pp.(str ( "Cannot define a principle over an axiom ")) + | Some (body, _) -> + let body = Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + (Global.env ()) + (Evd.from_env (Global.env ())) + (EConstr.of_constr body) + in + let body = EConstr.Unsafe.to_constr body in + body + | None -> user_err Pp.(str ( "Cannot define a principle over an axiom ")) in let f = find_constant_body const in let l_const = get_funs_constant const f in @@ -436,34 +436,34 @@ let get_funs_constant mp = let _check_params = let first_params = List.hd l_params in List.iter - (fun params -> + (fun params -> if not (List.equal (fun (n1, c1) (n2, c2) -> eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) - then user_err Pp.(str "Not a mutal recursive block") - ) - l_params + then user_err Pp.(str "Not a mutal recursive block") + ) + l_params in (* The bodies has to be very similar *) let _check_bodies = try - let extract_info is_first body = - match Constr.kind body with + let extract_info is_first body = + match Constr.kind body with | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && Int.equal (List.length l_bodies) 1 - then raise Not_Rec - else user_err Pp.(str "Not a mutal recursive block") - in - let first_infos = extract_info true (List.hd l_bodies) in - let check body = (* Hope this is correct *) + | _ -> + if is_first && Int.equal (List.length l_bodies) 1 + then raise Not_Rec + else user_err Pp.(str "Not a mutal recursive block") + in + let first_infos = extract_info true (List.hd l_bodies) in + let check body = (* Hope this is correct *) let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = Array.equal Int.equal ia1 ia2 && Array.equal (eq_annot Name.equal) na1 na2 && Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 - in - if not (eq_infos first_infos (extract_info false body)) - then user_err Pp.(str "Not a mutal recursive block") - in - List.iter check l_bodies + in + if not (eq_infos first_infos (extract_info false body)) + then user_err Pp.(str "Not a mutal recursive block") + in + List.iter check l_bodies with Not_Rec -> () in l_const @@ -471,7 +471,7 @@ let get_funs_constant mp = exception No_graph_found exception Found_type of int -let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_constants definition_entry list = +let make_scheme evd (fas : (pconstant*Sorts.family) list) : Evd.side_effects definition_entry list = let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in @@ -493,15 +493,15 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let ind_list = List.map (fun (idx) -> - let ind = first_fun_kn,idx in - (ind,snd first_fun),true,prop_sort + let ind = first_fun_kn,idx in + (ind,snd first_fun),true,prop_sort ) funs_indexes in - let sigma, schemes = + let sigma, schemes = Indrec.build_mutual_induction_scheme env !evd ind_list in - let _ = evd := sigma in + let _ = evd := sigma in let l_schemes = List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes in @@ -516,17 +516,17 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ (* We create the first principle by tactic *) let first_type,other_princ_types = match l_schemes with - s::l_schemes -> s,l_schemes + s::l_schemes -> s,l_schemes | _ -> anomaly (Pp.str "") in let ((_,(const,_)),_) = try build_functional_principle evd false - first_type - (Array.of_list sorts) - this_block_funs - 0 - (prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) + first_type + (Array.of_list sorts) + this_block_funs + 0 + (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) @@ -557,49 +557,49 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let (idxs,_),(_,ta,_ as decl) = destFix fix in let other_result = List.map (* we can now compute the other principles *) - (fun scheme_type -> - incr i; + (fun scheme_type -> + incr i; observe (Printer.pr_lconstr_env env sigma scheme_type); - let type_concl = (strip_prod_assum scheme_type) in - let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in - let f = fst (decompose_app applied_f) in - try (* we search the number of the function in the fix block (name of the function) *) - Array.iteri - (fun j t -> - let t = (strip_prod_assum t) in - let applied_g = List.hd (List.rev (snd (decompose_app t))) in - let g = fst (decompose_app applied_g) in - if Constr.equal f g - then raise (Found_type j); + let type_concl = (strip_prod_assum scheme_type) in + let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in + let f = fst (decompose_app applied_f) in + try (* we search the number of the function in the fix block (name of the function) *) + Array.iteri + (fun j t -> + let t = (strip_prod_assum t) in + let applied_g = List.hd (List.rev (snd (decompose_app t))) in + let g = fst (decompose_app applied_g) in + if Constr.equal f g + then raise (Found_type j); observe (Printer.pr_lconstr_env env sigma f ++ str " <> " ++ Printer.pr_lconstr_env env sigma g) - ) - ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method - *) + ) + ta; + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method + *) let ((_,(const,_)),_) = - build_functional_principle - evd - false - (List.nth other_princ_types (!i - 1)) - (Array.of_list sorts) - this_block_funs - !i - (prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) + build_functional_principle + evd + false + (List.nth other_princ_types (!i - 1)) + (Array.of_list sorts) + this_block_funs + !i + (prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) (fun _ _ _ _ _ -> ()) - in - const - with Found_type i -> - let princ_body = - Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt - in - {const with - const_entry_body = - (Future.from_val (Safe_typing.mk_pure_proof princ_body)); - const_entry_type = Some scheme_type - } + in + const + with Found_type i -> + let princ_body = + Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt + in + {const with + const_entry_body = + (Future.from_val ((princ_body, Univ.ContextSet.empty), Evd.empty_side_effects)); + const_entry_type = Some scheme_type + } ) other_fun_princ_types in @@ -608,16 +608,16 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let build_scheme fas = let evd = (ref (Evd.from_env (Global.env ()))) in let pconstants = (List.map - (fun (_,f,sort) -> - let f_as_constant = - try - Smartlocate.global_with_alias f - with Not_found -> + (fun (_,f,sort) -> + let f_as_constant = + try + Smartlocate.global_with_alias f + with Not_found -> user_err ~hdr:"FunInd.build_scheme" (str "Cannot find " ++ Libnames.pr_qualid f) - in + in let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in - let _ = evd := evd' in + let _ = evd := evd' in let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in evd := sigma; let c, u = @@ -627,18 +627,18 @@ let build_scheme fas = in (c, EConstr.EInstance.kind !evd u), sort ) - fas - ) in + fas + ) in let bodies_types = - make_scheme evd pconstants + make_scheme evd pconstants in List.iter2 (fun (princ_id,_,_) def_entry -> ignore - (Declare.declare_constant - princ_id - (DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); + (Declare.declare_constant + princ_id + (DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); Declare.definition_message princ_id ) fas @@ -671,10 +671,10 @@ let build_case_scheme fa = List.assoc_f Constant.equal funs this_block_funs_indexes in let (ind, sf) = - let ind = first_fun_kn,funs_indexes in - (ind,Univ.Instance.empty)(*FIXME*),prop_sort + let ind = first_fun_kn,funs_indexes in + (ind,Univ.Instance.empty)(*FIXME*),prop_sort in - let (sigma, scheme) = + let (sigma, scheme) = Indrec.build_case_analysis_scheme_default env sigma ind sf in let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in @@ -687,8 +687,8 @@ let build_case_scheme fa = let princ_name = (fun (x,_,_) -> x) fa in let _ = (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ - pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs - ); + pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs + ); *) generate_functional_principle (ref (Evd.from_env (Global.env ()))) @@ -701,5 +701,5 @@ let build_case_scheme fa = (prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) in () - + diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 97f9acdb3a..759c522820 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -34,7 +34,7 @@ val generate_functional_principle : exception No_graph_found val make_scheme : Evd.evar_map ref -> - (pconstant*Sorts.family) list -> Safe_typing.private_constants Entries.definition_entry list + (pconstant*Sorts.family) list -> Evd.side_effects Entries.definition_entry list val build_scheme : (Id.t*Libnames.qualid*Sorts.family) list -> unit val build_case_scheme : (Id.t*Libnames.qualid*Sorts.family) -> unit diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 833ff9f1ed..c217ed8b1d 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -186,14 +186,14 @@ let classify_as_Fixpoint recsl = let classify_funind recsl = match classify_as_Fixpoint recsl with - | Vernacextend.VtSideff ids, _ + | Vernacextend.VtSideff (ids, _) when is_proof_termination_interactively_checked recsl -> - Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) + Vernacextend.(VtStartProof (GuaranteesOpacity, ids)) | x -> x let is_interactive recsl = match classify_funind recsl with - | Vernacextend.VtStartProof _, _ -> true + | Vernacextend.VtStartProof _ -> true | _ -> false } @@ -243,7 +243,7 @@ let warning_error names e = VERNAC COMMAND EXTEND NewFunctionalScheme | ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] - => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } + => { Vernacextend.(VtSideff(List.map pi1 fas, VtLater)) } -> { begin try @@ -275,7 +275,7 @@ END VERNAC COMMAND EXTEND NewFunctionalCase | ["Functional" "Case" fun_scheme_arg(fas) ] - => { Vernacextend.(VtSideff[pi1 fas], VtLater) } + => { Vernacextend.(VtSideff([pi1 fas], VtLater)) } -> { Functional_principles_types.build_case_scheme fas } END diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 241da053b7..ecf953bef1 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -20,7 +20,7 @@ let is_rec_info sigma scheme_info = let test_branche min acc decl = acc || ( let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in let free_rels_in_br = Termops.free_rels sigma new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br @@ -40,57 +40,57 @@ let functional_induction with_clean c princl pat = let princ,bindings, princ_type,g' = match princl with | None -> (* No principle is given let's find the good one *) - begin - match EConstr.kind sigma f with - | Const (c',u) -> - let princ_option = - let finfo = (* we first try to find out a graph on f *) - try find_Function_infos c' - with Not_found -> - user_err (str "Cannot find induction information on "++ + begin + match EConstr.kind sigma f with + | Const (c',u) -> + let princ_option = + let finfo = (* we first try to find out a graph on f *) + try find_Function_infos c' + with Not_found -> + user_err (str "Cannot find induction information on "++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) - in + in match Tacticals.elimination_sort_of_goal g with | InSProp -> finfo.sprop_lemma - | InProp -> finfo.prop_lemma - | InSet -> finfo.rec_lemma - | InType -> finfo.rect_lemma - in - let princ,g' = (* then we get the principle *) - try - let g',princ = - Tacmach.pf_eapply (Evd.fresh_global) g (Globnames.ConstRef (Option.get princ_option )) in - princ,g' - with Option.IsNone -> - (*i If there is not default lemma defined then, - we cross our finger and try to find a lemma named f_ind - (or f_rec, f_rect) i*) - let princ_name = - Indrec.make_elimination_ident - (Label.to_id (Constant.label c')) - (Tacticals.elimination_sort_of_goal g) - in - try - let princ_ref = const_of_id princ_name in - let (a,b) = Tacmach.pf_eapply (Evd.fresh_global) g princ_ref in - (b,a) - (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) - with Not_found -> (* This one is neither defined ! *) - user_err (str "Cannot find induction principle for " + | InProp -> finfo.prop_lemma + | InSet -> finfo.rec_lemma + | InType -> finfo.rect_lemma + in + let princ,g' = (* then we get the principle *) + try + let g',princ = + Tacmach.pf_eapply (Evd.fresh_global) g (Globnames.ConstRef (Option.get princ_option )) in + princ,g' + with Option.IsNone -> + (*i If there is not default lemma defined then, + we cross our finger and try to find a lemma named f_ind + (or f_rec, f_rect) i*) + let princ_name = + Indrec.make_elimination_ident + (Label.to_id (Constant.label c')) + (Tacticals.elimination_sort_of_goal g) + in + try + let princ_ref = const_of_id princ_name in + let (a,b) = Tacmach.pf_eapply (Evd.fresh_global) g princ_ref in + (b,a) + (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) + with Not_found -> (* This one is neither defined ! *) + user_err (str "Cannot find induction principle for " ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) - in + in (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') - | _ -> raise (UserError(None,str "functional induction must be used with a function" )) - end + | _ -> raise (UserError(None,str "functional induction must be used with a function" )) + end | Some ((princ,binding)) -> - princ,binding,Tacmach.pf_unsafe_type_of g princ,g + princ,binding,Tacmach.pf_unsafe_type_of g princ,g in let sigma = Tacmach.project g' in let princ_infos = Tactics.compute_elim_sig (Tacmach.project g') princ_type in let args_as_induction_constr = let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] + if princ_infos.Tactics.farg_in_concl + then [c] else [] in if List.length args + List.length c_list = 0 then user_err Pp.(str "Cannot recognize a valid functional scheme" ); @@ -109,35 +109,35 @@ let functional_induction with_clean c princl pat = let princ' = Some (princ,bindings) in let princ_vars = List.fold_right - (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) - args - Id.Set.empty + (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) + args + Id.Set.empty in let old_idl = List.fold_right Id.Set.add (Tacmach.pf_ids_of_hyps g) Id.Set.empty in let old_idl = Id.Set.diff old_idl princ_vars in let subst_and_reduce g = if with_clean then - let idl = - List.filter (fun id -> not (Id.Set.mem id old_idl)) - (Tacmach.pf_ids_of_hyps g) - in - let flag = - Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - } - in - Tacticals.tclTHEN - (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl ) - (Proofview.V82.of_tactic (Tactics.reduce flag Locusops.allHypsAndConcl)) - g + let idl = + List.filter (fun id -> not (Id.Set.mem id old_idl)) + (Tacmach.pf_ids_of_hyps g) + in + let flag = + Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + } + in + Tacticals.tclTHEN + (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl ) + (Proofview.V82.of_tactic (Tactics.reduce flag Locusops.allHypsAndConcl)) + g else Tacticals.tclIDTAC g in Tacticals.tclTHEN (Proofview.V82.of_tactic (choose_dest_or_ind - princ_infos - (args_as_induction_constr,princ'))) + princ_infos + (args_as_induction_constr,princ'))) subst_and_reduce g' in res @@ -185,13 +185,13 @@ let build_newrecursive in recdef,rec_impls -let build_newrecursive l = - let l' = List.map - (fun ((fixna,_,bll,ar,body_opt),lnot) -> - match body_opt with - | Some body -> - (fixna,bll,ar,body) - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") +let build_newrecursive l = + let l' = List.map + (fun ((fixna,_,bll,ar,body_opt),lnot) -> + match body_opt with + | Some body -> + (fixna,bll,ar,body) + | None -> user_err ~hdr:"Function" (str "Body of Function must be given") ) l in build_newrecursive l' @@ -208,23 +208,23 @@ let is_rec names = | GCast(b,_) -> lookup names b | GRec _ -> error "GRec not handled" | GIf(b,_,lhs,rhs) -> - (lookup names b) || (lookup names lhs) || (lookup names rhs) + (lookup names b) || (lookup names lhs) || (lookup names rhs) | GProd(na,_,t,b) | GLambda(na,_,t,b) -> - lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b + lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b | GLetIn(na,b,t,c) -> - lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c + lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c | GLetTuple(nal,_,t,b) -> lookup names t || - lookup - (List.fold_left - (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) - names - nal - ) - b + lookup + (List.fold_left + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) + names + nal + ) + b | GApp(f,args) -> List.exists (lookup names) (f::args) | GCases(_,_,el,brl) -> - List.exists (fun (e,_) -> lookup names e) el || - List.exists (lookup_br names) brl + List.exists (fun (e,_) -> lookup names e) el || + List.exists (lookup_br names) brl and lookup_br names {CAst.v=(idl,_,rt)} = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt @@ -254,19 +254,19 @@ let warn_funind_cannot_build_inversion = let derive_inversion fix_names = try - let evd' = Evd.from_env (Global.env ()) in + let evd' = Evd.from_env (Global.env ()) in (* we first transform the fix_names identifier into their corresponding constant *) let evd',fix_names_as_constant = List.fold_right - (fun id (evd,l) -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in + (fun id (evd,l) -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in let (cst, u) = destConst evd c in - evd, (cst, EInstance.kind evd u) :: l - ) - fix_names - (evd',[]) + evd, (cst, EInstance.kind evd u) :: l + ) + fix_names + (evd',[]) in (* Then we check that the graphs have been defined @@ -276,22 +276,22 @@ let derive_inversion fix_names = List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; try let evd', lind = - List.fold_right - (fun id (evd,l) -> - let evd,id = - Evd.fresh_global - (Global.env ()) evd - (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) - in + List.fold_right + (fun id (evd,l) -> + let evd,id = + Evd.fresh_global + (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) + in evd,(fst (destInd evd id))::l - ) - fix_names - (evd',[]) + ) + fix_names + (evd',[]) in Invfun.derive_correctness - Functional_principles_types.make_scheme - fix_names_as_constant - lind; + Functional_principles_types.make_scheme + fix_names_as_constant + lind; with e when CErrors.noncritical e -> let e' = process_vernac_interp_error e in warn_funind_cannot_build_inversion e' @@ -313,15 +313,15 @@ let warning_error names e = let e = process_vernac_interp_error e in let e_explain e = match e with - | ToShow e -> - let e = process_vernac_interp_error e in - spc () ++ CErrors.print e - | _ -> - if do_observe () - then - let e = process_vernac_interp_error e in - (spc () ++ CErrors.print e) - else mt () + | ToShow e -> + let e = process_vernac_interp_error e in + spc () ++ CErrors.print e + | _ -> + if do_observe () + then + let e = process_vernac_interp_error e in + (spc () ++ CErrors.print e) + else mt () in match e with | Building_graph e -> @@ -341,10 +341,10 @@ let error_error names e = in match e with | Building_graph e -> - user_err - (str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - e_explain e) + user_err + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + e_explain e) | _ -> raise e let generate_principle (evd:Evd.evar_map ref) pconstants on_error @@ -361,51 +361,51 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error if do_built then begin - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : do_built - i*) + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : do_built + i*) let f_R_mut = qualid_of_ident @@ mk_rel_id (List.nth names 0) in - let ind_kn = - fst (locate_with_msg + let ind_kn = + fst (locate_with_msg (pr_qualid f_R_mut++str ": Not an inductive type!") - locate_ind - f_R_mut) - in - let fname_kn (((fname,_),_,_,_,_),_) = + locate_ind + f_R_mut) + in + let fname_kn (((fname,_),_,_,_,_),_) = let f_ref = qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in locate_with_msg (pr_qualid f_ref++str ": Not an inductive type!") - locate_constant - f_ref - in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = - List.map_i - (fun i x -> + locate_constant + f_ref + in + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = + List.map_i + (fun i x -> let env = Global.env () in let princ = Indrec.lookup_eliminator env (ind_kn,i) (InProp) in - let evd = ref (Evd.from_env env) in - let evd',uprinc = Evd.fresh_global env !evd princ in - let _ = evd := evd' in + let evd = ref (Evd.from_env env) in + let evd',uprinc = Evd.fresh_global env !evd princ in + let _ = evd := evd' in let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in evd := sigma; - let princ_type = EConstr.Unsafe.to_constr princ_type in - Functional_principles_types.generate_functional_principle - evd - interactive_proof - princ_type - None - None - (Array.of_list pconstants) - (* funs_kn *) - i - (continue_proof 0 [|funs_kn.(i)|]) - ) - 0 - fix_rec_l - in - Array.iter (add_Function is_general) funs_kn; - () + let princ_type = EConstr.Unsafe.to_constr princ_type in + Functional_principles_types.generate_functional_principle + evd + interactive_proof + princ_type + None + None + (Array.of_list pconstants) + (* funs_kn *) + i + (continue_proof 0 [|funs_kn.(i)|]) + ) + 0 + fix_rec_l + in + Array.iter (add_Function is_general) funs_kn; + () end with e when CErrors.noncritical e -> on_error names e @@ -413,40 +413,40 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [(({CAst.v=fname},pl),_,bl,ret_type,body),_] when not is_rec -> - let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in ComDefinition.do_definition ~program_mode:false - fname - (Decl_kinds.Global,false,Decl_kinds.Definition) pl + fname + Decl_kinds.(Global ImportDefaultBehavior,false,Definition) pl bl None body (Some ret_type); let evd,rev_pconstants = - List.fold_left + List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in let (cst, u) = destConst evd c in let u = EInstance.kind evd u in evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) - fixpoint_exprl + ) + (Evd.from_env (Global.env ()),[]) + fixpoint_exprl in None, evd,List.rev rev_pconstants | _ -> - ComFixpoint.do_fixpoint Global false fixpoint_exprl; + ComFixpoint.do_fixpoint (Global ImportDefaultBehavior) false fixpoint_exprl; let evd,rev_pconstants = - List.fold_left + List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in let (cst, u) = destConst evd c in let u = EInstance.kind evd u in evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) - fixpoint_exprl + ) + (Evd.from_env (Global.env ()),[]) + fixpoint_exprl in None,evd,List.rev rev_pconstants @@ -467,34 +467,34 @@ let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf let names = List.map CAst.(with_val (fun x -> x)) - (Constrexpr_ops.names_of_local_assums args) + (Constrexpr_ops.names_of_local_assums args) in - List.index Name.equal (Name wf_arg) names + List.index Name.equal (Name wf_arg) names in let unbounded_eq = let f_app_args = CAst.make @@ Constrexpr.CAppExpl( (None,qualid_of_ident fname,None) , - (List.map - (function + (List.map + (function | {CAst.v=Anonymous} -> assert false | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) - ) - (Constrexpr_ops.names_of_local_assums args) - ) - ) + ) + (Constrexpr_ops.names_of_local_assums args) + ) + ) in CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (qualid_of_string "Logic.eq")), - [(f_app_args,None);(body,None)]) + [(f_app_args,None);(body,None)]) in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type nb_args relation = try pre_hook [fconst] - (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes - functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - ); + (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes + functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation + ); derive_inversion [fname] with e when CErrors.noncritical e -> (* No proof done *) @@ -514,215 +514,215 @@ let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt w let wf_arg_type,wf_arg = match wf_arg with | None -> - begin - match args with + begin + match args with | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x - | _ -> error "Recursive argument must be specified" - end + | _ -> error "Recursive argument must be specified" + end | Some wf_args -> - try - match - List.find - (function - | Constrexpr.CLocalAssum(l,k,t) -> - List.exists + try + match + List.find + (function + | Constrexpr.CLocalAssum(l,k,t) -> + List.exists (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) - l - | _ -> false - ) - args - with - | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args - | _ -> assert false - with Not_found -> assert false + l + | _ -> false + ) + args + with + | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args + | _ -> assert false + with Not_found -> assert false in - let wf_rel_from_mes,is_mes = - match wf_rel_expr_opt with + let wf_rel_from_mes,is_mes = + match wf_rel_expr_opt with | None -> - let ltof = - let make_dir l = DirPath.make (List.rev_map Id.of_string l) in + let ltof = + let make_dir l = DirPath.make (List.rev_map Id.of_string l) in Libnames.qualid_of_path (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) in - let fun_from_mes = - let applied_mes = - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in + let fun_from_mes = + let applied_mes = + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) - in - let wf_rel_from_mes = - Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) - in - wf_rel_from_mes,true - | Some wf_rel_expr -> - let wf_rel_with_mes = - let a = Names.Id.of_string "___a" in - let b = Names.Id.of_string "___b" in - Constrexpr_ops.mkLambdaC( + in + let wf_rel_from_mes = + Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) + in + wf_rel_from_mes,true + | Some wf_rel_expr -> + let wf_rel_with_mes = + let a = Names.Id.of_string "___a" in + let b = Names.Id.of_string "___b" in + Constrexpr_ops.mkLambdaC( [CAst.make @@ Name a; CAst.make @@ Name b], - Constrexpr.Default Explicit, - wf_arg_type, - Constrexpr_ops.mkAppC(wf_rel_expr, - [ - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) - ]) - ) - in - wf_rel_with_mes,false - in + Constrexpr.Default Explicit, + wf_arg_type, + Constrexpr_ops.mkAppC(wf_rel_expr, + [ + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) + ]) + ) + in + wf_rel_with_mes,false + in register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg using_lemmas args ret_type body -let map_option f = function - | None -> None +let map_option f = function + | None -> None | Some v -> Some (f v) open Constrexpr let rec rebuild_bl aux bl typ = - match bl,typ with - | [], _ -> List.rev aux,typ - | (CLocalAssum(nal,bk,_))::bl',typ -> - rebuild_nal aux bk bl' nal typ - | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> - rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) - bl' typ' - | _ -> assert false + match bl,typ with + | [], _ -> List.rev aux,typ + | (CLocalAssum(nal,bk,_))::bl',typ -> + rebuild_nal aux bk bl' nal typ + | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> + rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) + bl' typ' + | _ -> assert false and rebuild_nal aux bk bl' nal typ = - match nal,typ with - | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ - | [], _ -> rebuild_bl aux bl' typ + match nal,typ with + | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ + | [], _ -> rebuild_bl aux bl' typ | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) - then - let assum = CLocalAssum([na],bk,nal't) in + then + let assum = CLocalAssum([na],bk,nal't) in let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - nal - (CAst.make @@ CProdN(new_rest,typ')) - else - let assum = CLocalAssum([na'],bk,nal't) in + rebuild_nal + (assum::aux) + bk + bl' + nal + (CAst.make @@ CProdN(new_rest,typ')) + else + let assum = CLocalAssum([na'],bk,nal't) in let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - (na::nal) - (CAst.make @@ CProdN(new_rest,typ')) - | _ -> - assert false + rebuild_nal + (assum::aux) + bk + bl' + (na::nal) + (CAst.make @@ CProdN(new_rest,typ')) + | _ -> + assert false let rebuild_bl aux bl typ = rebuild_bl aux bl typ -let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = +let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = ComFixpoint.extract_fixpoint_components ~structonly:false fixpoint_exprl in let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in let constr_expr_typel = with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in - let fixpoint_exprl_with_new_bl = + let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,rec_order_opt,bl,ret_typ,opt_body),notation_list) fix_typ -> - - let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in + + let new_bl',new_ret_type = rebuild_bl [] bl fix_typ in (((lna,rec_order_opt,new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) - fixpoint_exprl constr_expr_typel - in + fixpoint_exprl constr_expr_typel + in fixpoint_exprl_with_new_bl - + let do_generate_principle_aux pconstants on_error register_built interactive_proof - (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.t option = + (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Lemmas.t option = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; - let pstate, _is_struct = + let lemma, _is_struct = match fixpoint_exprl with | [((_,Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = - match recompute_binder_list [fixpoint_expr] with - | [e] -> e - | _ -> assert false - in - let fixpoint_exprl = [fixpoint_expr] in - let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let using_lemmas = [] in - let pre_hook pconstants = - generate_principle - (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in + let pre_hook pconstants = + generate_principle + (ref (Evd.from_env (Global.env ()))) + pconstants + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built then register_wf interactive_proof name rec_impls wf_rel wf_x.CAst.v using_lemmas args types body pre_hook, false else None, false |[((_,Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},_),_,args,types,body)),_) as fixpoint_expr = - match recompute_binder_list [fixpoint_expr] with - | [e] -> e - | _ -> assert false - in - let fixpoint_exprl = [fixpoint_expr] in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let using_lemmas = [] in - let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - let pre_hook pconstants = - generate_principle - (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in + let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in + let pre_hook pconstants = + generate_principle + (ref (Evd.from_env (Global.env ()))) + pconstants + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built then register_mes interactive_proof name rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas args types body pre_hook, true else None, true | _ -> List.iter (function ((_na,ord,_args,_body,_type),_not) -> - match ord with + match ord with | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> - error - ("Cannot use mutual definition with well-founded recursion or measure") - | _ -> () - ) - fixpoint_exprl; - let fixpoint_exprl = recompute_binder_list fixpoint_exprl in - let fix_names = + error + ("Cannot use mutual definition with well-founded recursion or measure") + | _ -> () + ) + fixpoint_exprl; + let fixpoint_exprl = recompute_binder_list fixpoint_exprl in + let fix_names = List.map (function ((({CAst.v=name},_),_,_,_,_),_) -> name) fixpoint_exprl - in - (* ok all the expressions are structural *) - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let is_rec = List.exists (is_rec fix_names) recdefs in - let pstate,evd,pconstants = - if register_built + in + (* ok all the expressions are structural *) + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let is_rec = List.exists (is_rec fix_names) recdefs in + let lemma,evd,pconstants = + if register_built then register_struct is_rec fixpoint_exprl else None, Evd.from_env (Global.env ()), pconstants - in - let evd = ref evd in - generate_principle - (ref !evd) - pconstants - on_error - false - register_built - fixpoint_exprl - recdefs - interactive_proof - (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); + in + let evd = ref evd in + generate_principle + (ref !evd) + pconstants + on_error + false + register_built + fixpoint_exprl + recdefs + interactive_proof + (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); if register_built then begin derive_inversion fix_names; end; - pstate, true + lemma, true in - pstate + lemma let rec add_args id new_args = CAst.map (function | CRef (qid,_) as b -> @@ -734,12 +734,12 @@ let rec add_args id new_args = CAst.map (function CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) + add_args id new_args b1) | CLambdaN(nal,b1) -> CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) + add_args id new_args b1) | CLetIn(na,b1,t,b2) -> CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) | CAppExpl((pf,qid,us),exprl) -> @@ -748,26 +748,26 @@ let rec add_args id new_args = CAst.map (function else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) | CApp((pf,b),bl) -> CApp((pf,add_args id new_args b), - List.map (fun (e,o) -> add_args id new_args e,o) bl) + List.map (fun (e,o) -> add_args id new_args e,o) bl) | CCases(sty,b_option,cel,cal) -> CCases(sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,na,b_option) -> - add_args id new_args b, - na, b_option) cel, + List.map (fun (b,na,b_option) -> + add_args id new_args b, + na, b_option) cel, List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal - ) + ) | CLetTuple(nal,(na,b_option),b1,b2) -> CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), - add_args id new_args b1, - add_args id new_args b2 - ) + add_args id new_args b1, + add_args id new_args b2 + ) | CIf(b1,(na,b_option),b2,b3) -> CIf(add_args id new_args b1, - (na,Option.map (add_args id new_args) b_option), - add_args id new_args b2, - add_args id new_args b3 - ) + (na,Option.map (add_args id new_args) b_option), + add_args id new_args b2, + add_args id new_args b3 + ) | CHole _ | CPatVar _ | CEvar _ @@ -794,35 +794,35 @@ let rec chop_n_arrow n t = else (* If not we check the form of [t] *) match t.CAst.v with | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible : - either we need to discard more than the number of arrows contained - in this product declaration then we just recall [chop_n_arrow] on - the remaining number of arrow to chop and [t'] we discard it and - recall [chop_n_arrow], either this product contains more arrows - than the number we need to chop and then we return the new type - *) - begin - try - let new_n = - let rec aux (n:int) = function - [] -> n + either we need to discard more than the number of arrows contained + in this product declaration then we just recall [chop_n_arrow] on + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows + than the number we need to chop and then we return the new type + *) + begin + try + let new_n = + let rec aux (n:int) = function + [] -> n | CLocalAssum(nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in - if n >= nal_l - then - aux (n - nal_l) nal_ta' - else - let new_t' = CAst.make @@ - Constrexpr.CProdN( + let nal_l = List.length nal in + if n >= nal_l + then + aux (n - nal_l) nal_ta' + else + let new_t' = CAst.make @@ + Constrexpr.CProdN( CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') - in - raise (Stop new_t') + in + raise (Stop new_t') | _ -> anomaly (Pp.str "Not enough products.") - in - aux n nal_ta' - in - chop_n_arrow new_n t' - with Stop t -> t - end + in + aux n nal_ta' + in + chop_n_arrow new_n t' + with Stop t -> t + end | _ -> anomaly (Pp.str "Not enough products.") @@ -830,11 +830,11 @@ let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = match b.CAst.v with | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> - begin + begin let n = List.length nal in let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in d :: nal_tas, b'',t'' - end + end | Constrexpr.CLambdaN ([], b) -> [],b,t | _ -> [],b,t @@ -855,15 +855,15 @@ let make_graph (f_ref : GlobRef.t) = | None -> error "Cannot build a graph over an axiom!" | Some (body, _) -> let env = Global.env () in - let extern_body,extern_type = - with_full_print (fun () -> - (Constrextern.extern_constr false env sigma (EConstr.of_constr body), - Constrextern.extern_type false env sigma + let extern_body,extern_type = + with_full_print (fun () -> + (Constrextern.extern_constr false env sigma (EConstr.of_constr body), + Constrextern.extern_type false env sigma (EConstr.of_constr (*FIXME*) c_body.const_type) - ) - ) - () - in + ) + ) + () + in let (nal_tas,b,t) = get_args extern_body extern_type in let expr_list = match b.CAst.v with @@ -897,32 +897,32 @@ let make_graph (f_ref : GlobRef.t) = fixexprl in l - | _ -> - let id = Label.to_id (Constant.label c) in + | _ -> + let id = Label.to_id (Constant.label c) in [((CAst.make id,None),None,nal_tas,t,Some b),[]] - in + in let mp = Constant.modpath c in let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in assert (Option.is_empty pstate); - (* We register the infos *) - List.iter + (* We register the infos *) + List.iter (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) expr_list) (* *************** statically typed entrypoints ************************* *) -let do_generate_principle_interactive fixl : Proof_global.t = +let do_generate_principle_interactive fixl : Lemmas.t = match do_generate_principle_aux [] warning_error true true fixl with - | Some pstate -> pstate + | Some lemma -> lemma | None -> - CErrors.anomaly - (Pp.str"indfun: leaving no open proof in interactive mode") + CErrors.anomaly + (Pp.str"indfun: leaving no open proof in interactive mode") let do_generate_principle fixl : unit = match do_generate_principle_aux [] warning_error true false fixl with - | Some _pstate -> - CErrors.anomaly - (Pp.str"indfun: leaving a goal open in non-interactive mode") + | Some _lemma -> + CErrors.anomaly + (Pp.str"indfun: leaving a goal open in non-interactive mode") | None -> () diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 1ba245a45d..3bc52272ac 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -10,7 +10,7 @@ val do_generate_principle : val do_generate_principle_interactive : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - Proof_global.t + Lemmas.t val functional_induction : bool -> diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 48cf040919..7683ce1757 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -49,10 +49,10 @@ let filter_map filter f = let rec it = function | [] -> [] | e::l -> - if filter e - then - (f e) :: it l - else it l + if filter e + then + (f e) :: it l + else it l in it @@ -62,12 +62,12 @@ let chop_rlambda_n = if n == 0 then List.rev acc,rt else - match DAst.get rt with - | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b - | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b - | _ -> - raise (CErrors.UserError(Some "chop_rlambda_n", - str "chop_rlambda_n: Not enough Lambdas")) + match DAst.get rt with + | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b + | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b + | _ -> + raise (CErrors.UserError(Some "chop_rlambda_n", + str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] @@ -76,9 +76,9 @@ let chop_rprod_n = if n == 0 then List.rev acc,rt else - match DAst.get rt with - | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) + match DAst.get rt with + | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b + | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -124,26 +124,20 @@ open Declare let definition_message = Declare.definition_message -let get_locality = function -| Discharge -> true -| Local -> true -| Global -> false - let save id const ?hook uctx (locality,_,kind) = let fix_exn = Future.fix_exn_of const.const_entry_body in - let l,r = match locality with - | Discharge when Lib.sections_are_opened () -> + let r = match locality with + | Discharge -> let k = Kindops.logical_kind_of_goal_kind kind in - let c = SectionLocalDef const in - let _ = declare_variable id (Lib.cwd(), c, k) in - (Local, VarRef id) - | Discharge | Local | Global -> - let local = get_locality locality in + let c = SectionLocalDef const in + let _ = declare_variable id (Lib.cwd(), c, k) in + VarRef id + | Global local -> let k = Kindops.logical_kind_of_goal_kind kind in let kn = declare_constant id ~local (DefinitionEntry const, k) in - (locality, ConstRef kn) + ConstRef kn in - Lemmas.call_hook ?hook ~fix_exn uctx [] l r; + Lemmas.call_hook ?hook ~fix_exn uctx [] locality r; definition_message id let with_full_print f a = @@ -172,14 +166,14 @@ let with_full_print f a = res with | reraise -> - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Flags.raw_print := old_rawprint; - Constrextern.print_universes := old_printuniverses; + Impargs.make_implicit_args old_implicit_args; + Impargs.make_strict_implicit_args old_strict_implicit_args; + Impargs.make_contextual_implicit_args old_contextual_implicit_args; + Flags.raw_print := old_rawprint; + Constrextern.print_universes := old_printuniverses; Detyping.print_allow_match_default_clause := old_printallowmatchdefaultclause; - Dumpglob.continue (); - raise reraise + Dumpglob.continue (); + raise reraise @@ -219,8 +213,8 @@ let rec do_cache_info finfo = function else if finfo'.function_constant = finfo.function_constant then finfo::finfos else - let res = do_cache_info finfo finfos in - if res == finfos then l else finfo'::l + let res = do_cache_info finfo finfos in + if res == finfos then l else finfo'::l let cache_Function (_,(finfos)) = @@ -324,7 +318,7 @@ let find_Function_of_graph ind = let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) Lib.add_anonymous_leaf (in_Function finfo) - + let add_Function is_general f = let f_id = Label.to_id (Constant.label f) in @@ -362,7 +356,7 @@ let functional_induction_rewrite_dependent_proofs = ref true let function_debug = ref false open Goptions -let functional_induction_rewrite_dependent_proofs_sig = +let functional_induction_rewrite_dependent_proofs_sig = { optdepr = false; optname = "Functional Induction Rewrite Dependent"; @@ -386,7 +380,7 @@ let function_debug_sig = let () = declare_bool_option function_debug_sig -let do_observe () = !function_debug +let do_observe () = !function_debug diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 9670cf1fa7..4078c34331 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -44,7 +44,7 @@ val jmeq_refl : unit -> EConstr.constr val save : Id.t - -> Safe_typing.private_constants Entries.definition_entry + -> Evd.side_effects Entries.definition_entry -> ?hook:Lemmas.declaration_hook -> UState.t -> Decl_kinds.goal_kind diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 03568fc6c7..376e1cb2cc 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -56,7 +56,7 @@ let do_observe_tac s tac g = let reraise = CErrors.push reraise in let e = ExplainErr.process_vernac_interp_error reraise in observe (hov 0 (str "observation "++ s++str " raised exception " ++ - CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal )); + CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal )); iraise reraise;; let observe_tac s tac g = @@ -115,8 +115,8 @@ let generate_type evd g_to_f f graph i = in (*i We need to name the vars [res] and [fv] i*) let filter = fun decl -> match RelDecl.get_name decl with - | Name id -> Some id - | Anonymous -> None + | Name id -> Some id + | Anonymous -> None in let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in @@ -232,12 +232,12 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i (* and built the intro pattern for each of them *) let intro_pats = List.map - (fun decl -> - List.map + (fun decl -> + List.map (fun id -> CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) - ) - branches + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) + ) + branches in (* before building the full intro pattern for the principle *) let eq_ind = make_eq () in @@ -249,113 +249,113 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i let prove_branche i g = (* We get the identifiers of this branch *) let pre_args = - List.fold_right + List.fold_right (fun {CAst.v=pat} acc -> - match pat with + match pat with | IntroNaming (Namegen.IntroIdentifier id) -> id::acc - | _ -> anomaly (Pp.str "Not an identifier.") - ) - (List.nth intro_pats (pred i)) - [] + | _ -> anomaly (Pp.str "Not an identifier.") + ) + (List.nth intro_pats (pred i)) + [] in (* and get the real args of the branch by unfolding the defined constant *) (* - We can then recompute the arguments of the constructor. - For each [hid] introduced by this branch, if [hid] has type - $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are - [ fv (hid fv (refl_equal fv)) ]. - If [hid] has another type the corresponding argument of the constructor is [hid] + We can then recompute the arguments of the constructor. + For each [hid] introduced by this branch, if [hid] has type + $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are + [ fv (hid fv (refl_equal fv)) ]. + If [hid] has another type the corresponding argument of the constructor is [hid] *) let constructor_args g = - List.fold_right - (fun hid acc -> - let type_of_hid = pf_unsafe_type_of g (mkVar hid) in - let sigma = project g in - match EConstr.kind sigma type_of_hid with + List.fold_right + (fun hid acc -> + let type_of_hid = pf_unsafe_type_of g (mkVar hid) in + let sigma = project g in + match EConstr.kind sigma type_of_hid with | Prod(_,_,t') -> - begin - match EConstr.kind sigma t' with + begin + match EConstr.kind sigma t' with | Prod(_,t'',t''') -> - begin - match EConstr.kind sigma t'',EConstr.kind sigma t''' with - | App(eq,args), App(graph',_) - when - (EConstr.eq_constr sigma eq eq_ind) && - Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> - (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::acc) - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - ) pre_args [] + begin + match EConstr.kind sigma t'',EConstr.kind sigma t''' with + | App(eq,args), App(graph',_) + when + (EConstr.eq_constr sigma eq eq_ind) && + Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> + (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) + ::acc) + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + ) pre_args [] in (* in fact we must also add the parameters to the constructor args *) let constructor_args g = - let params_id = fst (List.chop princ_infos.nparams args_names) in - (List.map mkVar params_id)@((constructor_args g)) + let params_id = fst (List.chop princ_infos.nparams args_names) in + (List.map mkVar params_id)@((constructor_args g)) in (* We then get the constructor corresponding to this branch and - modifies the references has needed i.e. - if the constructor is the last one of the current inductive then - add one the number of the inductive to take and add the number of constructor of the previous - graph to the minimal constructor number + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number *) let constructor = - let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then - begin - (kn,!ind_number),constructor_num - end - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length ; - (kn,!ind_number),1 - end + let constructor_num = i - !min_constr_number in + let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then + begin + (kn,!ind_number),constructor_num + end + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length ; + (kn,!ind_number),1 + end in (* we can then build the final proof term *) let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in (* an apply the tactic *) let res,hres = - match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with - | [res;hres] -> res,hres - | _ -> assert false + match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with + | [res;hres] -> res,hres + | _ -> assert false in (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) ( - tclTHENLIST - [ - observe_tac("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)); - (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false ; - Genredexpr.rConst = [] - } - ) - Locusops.onConcl); - observe_tac ("toto ") tclIDTAC; - + tclTHENLIST + [ + observe_tac("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in + match l with + | [] -> tclIDTAC + | _ -> Proofview.V82.of_tactic (intro_patterns false l)); + (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false ; + Genredexpr.rConst = [] + } + ) + Locusops.onConcl); + observe_tac ("toto ") tclIDTAC; + (* introducing the result of the graph and the equality hypothesis *) - observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); - (* replacing [res] with its value *) - observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); - (* Conclusion *) - observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) - ] + observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); + (* replacing [res] with its value *) + observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); + (* Conclusion *) + observe_tac "exact" (fun g -> + Proofview.V82.of_tactic (exact_check (app_constructor g)) g) + ] ) - g + g in (* end of branche proof *) let lemmas = @@ -379,44 +379,44 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i *) let bindings = let params_bindings,avoid = - List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - p::bindings,id::avoid - ) - ([],pf_ids_of_hyps g) - princ_infos.params - (List.rev params) + List.fold_left2 + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in + p::bindings,id::avoid + ) + ([],pf_ids_of_hyps g) + princ_infos.params + (List.rev params) in let lemmas_bindings = - List.rev (fst (List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in + List.rev (fst (List.fold_left2 + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) - ([],avoid) - princ_infos.predicates - (lemmas))) + ([],avoid) + princ_infos.predicates + (lemmas))) in (params_bindings@lemmas_bindings) in tclTHENLIST - [ - observe_tac "principle" (Proofview.V82.of_tactic (assert_by - (Name principle_id) - princ_type - (exact_check f_principle))); - observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); - (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) - observe_tac "idtac" tclIDTAC; - tclTHEN_i - (observe_tac - "functional_induction" ( - (fun gl -> - let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in - Proofview.V82.of_tactic (apply term) gl') - )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) + [ + observe_tac "principle" (Proofview.V82.of_tactic (assert_by + (Name principle_id) + princ_type + (exact_check f_principle))); + observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); + (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC; + tclTHEN_i + (observe_tac + "functional_induction" ( + (fun gl -> + let term = mkApp (mkVar principle_id,Array.of_list bindings) in + let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in + Proofview.V82.of_tactic (apply term) gl') + )) + (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) ] g @@ -431,7 +431,7 @@ let generalize_dependent_of x hyp g = tclMAP (function | LocalAssum ({binder_name=id},t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) + (Termops.occur_var (pf_env g) (project g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -458,99 +458,99 @@ and intros_with_rewrite_aux : Tacmach.tactic = let sigma = project g in match EConstr.kind sigma (pf_concl g) with | Prod(_,t,t') -> - begin - match EConstr.kind sigma t with - | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(1) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(1)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] - g - else if isVar sigma args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(2)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); - intros_with_rewrite - ] - g - else - begin - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST[ - Proofview.V82.of_tactic (Simple.intro id); - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] g - end + begin + match EConstr.kind sigma t with + | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> + if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g + else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) + then tclTHENLIST[ + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) + (pf_ids_of_hyps g); + intros_with_rewrite + ] g + else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) + then tclTHENLIST[ + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) + (pf_ids_of_hyps g); + intros_with_rewrite + ] g + else if isVar sigma args.(1) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); + generalize_dependent_of (destVar sigma args.(1)) id; + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); + intros_with_rewrite + ] + g + else if isVar sigma args.(2) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); + generalize_dependent_of (destVar sigma args.(2)) id; + tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); + intros_with_rewrite + ] + g + else + begin + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST[ + Proofview.V82.of_tactic (Simple.intro id); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); + intros_with_rewrite + ] g + end | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> - Proofview.V82.of_tactic tauto g - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - intros_with_rewrite - ] g - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g - end - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> tclIDTAC g + Proofview.V82.of_tactic tauto g + | Case(_,_,v,_) -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_case v); + intros_with_rewrite + ] g + | LetIn _ -> + tclTHENLIST[ + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + }) + Locusops.onConcl) + ; + intros_with_rewrite + ] g + | _ -> + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g + end + | LetIn _ -> + tclTHENLIST[ + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + }) + Locusops.onConcl) + ; + intros_with_rewrite + ] g + | _ -> tclIDTAC g let rec reflexivity_with_destruct_cases g = let destruct_case () = try match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - Proofview.V82.of_tactic intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases - ] + | Case(_,_,v,_) -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_case v); + Proofview.V82.of_tactic intros; + observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases + ] | _ -> Proofview.V82.of_tactic reflexivity with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in @@ -563,27 +563,27 @@ let rec reflexivity_with_destruct_cases g = let discr_inject = Tacticals.onAllHypsAndConcl ( fun sc g -> - match sc with - None -> tclIDTAC g - | Some id -> - match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with - | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 - then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g - else tclIDTAC g - | _ -> tclIDTAC g + match sc with + None -> tclIDTAC g + | Some id -> + match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with + | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> + if Equality.discriminable (pf_env g) (project g) t1 t2 + then Proofview.V82.of_tactic (Equality.discrHyp id) g + else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g + else tclIDTAC g + | _ -> tclIDTAC g ) in (tclFIRST [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); (* We reach this point ONLY if - the same value is matched (at least) two times - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing *) observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) ]) @@ -626,7 +626,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti let lemmas = Array.map (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn concl ctxt)) - lemmas_types_infos + lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in @@ -642,8 +642,8 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti (* and fresh names for res H and the principle (cf bug bug #1174) *) let res,hres,graph_principle_id = match generate_fresh_id (Id.of_string "z") ids 3 with - | [res;hres;graph_principle_id] -> res,hres,graph_principle_id - | _ -> assert false + | [res;hres;graph_principle_id] -> res,hres,graph_principle_id + | _ -> assert false in let ids = res::hres::graph_principle_id::ids in (* we also compute fresh names for each hyptohesis of each branch @@ -651,12 +651,12 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti let branches = List.rev princ_infos.branches in let intro_pats = List.map - (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (RelDecl.get_type decl))) - ) - branches + (fun decl -> + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (RelDecl.get_type decl))) + ) + branches in (* We will need to change the function by its body using [f_equation] if it is recursive (that is the graph is infinite @@ -671,25 +671,25 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs then - let eq_lemma = - try Option.get (infos).equation_lemma - with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma.") - in - tclTHENLIST[ - tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); - (* Don't forget to $\zeta$ normlize the term since the principles + let eq_lemma = + try Option.get (infos).equation_lemma + with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma.") + in + tclTHENLIST[ + tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; + Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); + (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - Proofview.V82.of_tactic (generalize (List.map mkVar ids)); - thin ids - ] + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + }) + Locusops.onConcl) + ; + Proofview.V82.of_tactic (generalize (List.map mkVar ids)); + thin ids + ] else Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) in @@ -699,39 +699,39 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti let prove_branche i g = (* we fist compute the inductive corresponding to the branch *) let this_ind_number = - let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then !ind_number - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end + let constructor_num = i - !min_constr_number in + let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then !ind_number + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end in let this_branche_ids = List.nth intro_pats (pred i) in tclTHENLIST[ - (* we expand the definition of the function *) + (* we expand the definition of the function *) observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); - (* introduce hypothesis with some rewrite *) + (* introduce hypothesis with some rewrite *) observe_tac "intros_with_rewrite (all)" intros_with_rewrite; - (* The proof is (almost) complete *) + (* The proof is (almost) complete *) observe_tac "reflexivity" (reflexivity_with_destruct_cases) ] - g + g in let params_names = fst (List.chop princ_infos.nparams args_names) in let open EConstr in let params = List.map mkVar params_names in tclTHENLIST [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); - observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); - Proofview.V82.of_tactic (Simple.intro graph_principle_id); - observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) + observe_tac "h_generalize" + (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); + Proofview.V82.of_tactic (Simple.intro graph_principle_id); + observe_tac "" (tclTHEN_i + (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) + (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g @@ -752,105 +752,105 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list funind_purify (fun () -> let env = Global.env () in - let evd = ref (Evd.from_env env) in + let evd = ref (Evd.from_env env) in let graphs_constr = Array.map mkInd graphs in let lemmas_types_infos = Util.Array.map2_i - (fun i f_constr graph -> - (* let const_of_f,u = destConst f_constr in *) - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd false f_constr graph i - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in + (fun i f_constr graph -> + (* let const_of_f,u = destConst f_constr in *) + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd false f_constr graph i + in + let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in evd := sigma; let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr + observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); + type_of_lemma,type_info + ) + funs_constr + graphs_constr in let schemes = (* The functional induction schemes are computed and not saved if there is more that one function - if the block contains only one function we can safely reuse [f_rect] + if the block contains only one function we can safely reuse [f_rect] *) try - if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; - [| find_induction_principle evd funs_constr.(0) |] + if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; + [| find_induction_principle evd funs_constr.(0) |] with Not_found -> - ( - - Array.of_list - (List.map - (fun entry -> - (EConstr.of_constr (fst (fst(Future.force entry.Entries.const_entry_body))), EConstr.of_constr (Option.get entry.Entries.const_entry_type )) - ) - (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) - ) - ) + ( + + Array.of_list + (List.map + (fun entry -> + (EConstr.of_constr (fst (fst(Future.force entry.Entries.const_entry_body))), EConstr.of_constr (Option.get entry.Entries.const_entry_type )) + ) + (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) + ) + ) in let proving_tac = prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_correct_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_correct_id f_id in + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_correct_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_correct_id f_id in let (typ,_) = lemmas_types_infos.(i) in - let pstate = Lemmas.start_proof - lem_id - (Decl_kinds.Global,false,((Decl_kinds.Proof Decl_kinds.Theorem))) + let lemma = Lemmas.start_lemma + lem_id + Decl_kinds.(Global ImportDefaultBehavior,false,Proof Theorem) !evd typ in - let pstate = fst @@ Pfedit.by - (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") - (proving_tac i))) pstate in - let () = Lemmas.save_pstate_proved ~pstate ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = find_Function_infos (fst f_as_constant) in - (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in + let lemma = fst @@ Lemmas.by + (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") + (proving_tac i))) lemma in + let () = Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let finfo = find_Function_infos (fst f_as_constant) in + (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) + let _,lem_cst_constr = Evd.fresh_global + (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with correctness_lemma = Some lem_cst}; + update_Function {finfo with correctness_lemma = Some lem_cst}; ) funs; let lemmas_types_infos = Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd true f_constr graph i - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = - EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt - in + (fun i f_constr graph -> + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd true f_constr graph i + in + let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + in let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr + type_of_lemma,type_info + ) + funs_constr + graphs_constr in let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in let mib,mip = Global.lookup_inductive graph_ind in - let sigma, scheme = - (Indrec.build_mutual_induction_scheme (Global.env ()) !evd - (Array.to_list - (Array.mapi - (fun i _ -> ((kn,i), EInstance.kind !evd u),true,InType) - mib.Declarations.mind_packets - ) - ) - ) + let sigma, scheme = + (Indrec.build_mutual_induction_scheme (Global.env ()) !evd + (Array.to_list + (Array.mapi + (fun i _ -> ((kn,i), EInstance.kind !evd u),true,InType) + mib.Declarations.mind_packets + ) + ) + ) in let schemes = Array.of_list scheme @@ -860,23 +860,23 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list in Array.iteri (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_complete_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_complete_id f_id in - let pstate = Lemmas.start_proof lem_id - (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) sigma + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_complete_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_complete_id f_id in + let lemma = Lemmas.start_lemma lem_id + Decl_kinds.(Global ImportDefaultBehavior,false,Proof Theorem) sigma (fst lemmas_types_infos.(i)) in - let pstate = fst (Pfedit.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i))) pstate) in - let () = Lemmas.save_pstate_proved ~pstate ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = find_Function_infos (fst f_as_constant) in - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in + let lemma = fst (Lemmas.by + (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") + (proving_tac i))) lemma) in + let () = Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let finfo = find_Function_infos (fst f_as_constant) in + let _,lem_cst_constr = Evd.fresh_global + (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with completeness_lemma = Some lem_cst} + update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) () @@ -894,31 +894,31 @@ let revert_graph kn post_tac hid g = let typ = pf_unsafe_type_of g (mkVar hid) in match EConstr.kind sigma typ with | App(i,args) when isInd sigma i -> - let ((kn',num) as ind'),u = destInd sigma i in - if MutInd.equal kn kn' - then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = - try find_Function_of_graph ind' - with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) - anomaly (Pp.str "Cannot retrieve infos about a mutual block.") - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing - *) - match info.completeness_lemma with - | None -> tclIDTAC g - | Some f_complete -> - let f_args,res = Array.chop (Array.length args - 1) args in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]); - thin [hid]; - Proofview.V82.of_tactic (Simple.intro hid); - post_tac hid - ] - g - - else tclIDTAC g + let ((kn',num) as ind'),u = destInd sigma i in + if MutInd.equal kn kn' + then (* We have generated a graph hypothesis so that we must change it if we can *) + let info = + try find_Function_of_graph ind' + with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) + anomaly (Pp.str "Cannot retrieve infos about a mutual block.") + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing + *) + match info.completeness_lemma with + | None -> tclIDTAC g + | Some f_complete -> + let f_args,res = Array.chop (Array.length args - 1) args in + tclTHENLIST + [ + Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]); + thin [hid]; + Proofview.V82.of_tactic (Simple.intro hid); + post_tac hid + ] + g + + else tclIDTAC g | _ -> tclIDTAC g @@ -946,25 +946,25 @@ let functional_inversion kn hid fconst f_correct : Tacmach.tactic = let type_of_h = pf_unsafe_type_of g (mkVar hid) in match EConstr.kind sigma type_of_h with | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - let pre_tac,f_args,res = - match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with - | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> - ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) - |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) - | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) - in - tclTHENLIST [ - pre_tac hid; - Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); - thin [hid]; - Proofview.V82.of_tactic (Simple.intro hid); + let pre_tac,f_args,res = + match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with + | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> + ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) + |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> + ((fun hid -> tclIDTAC),f_args,args.(1)) + | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) + in + tclTHENLIST [ + pre_tac hid; + Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); + thin [hid]; + Proofview.V82.of_tactic (Simple.intro hid); Proofview.V82.of_tactic (Inv.inv Inv.FullInversion None (NamedHyp hid)); - (fun g -> - let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in - tclMAP (revert_graph kn pre_tac) (hid::new_ids) g - ); - ] g + (fun g -> + let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in + tclMAP (revert_graph kn pre_tac) (hid::new_ids) g + ); + ] g | _ -> tclFAIL 1 (mt ()) g @@ -994,46 +994,46 @@ let invfun qhyp f g = | Some f -> invfun qhyp f g | None -> Proofview.V82.of_tactic begin - Tactics.try_intros_until - (fun hid -> Proofview.V82.tactic begin fun g -> + Tactics.try_intros_until + (fun hid -> Proofview.V82.tactic begin fun g -> let sigma = project g in - let hyp_typ = pf_unsafe_type_of g (mkVar hid) in - match EConstr.kind sigma hyp_typ with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - begin - let f1,_ = decompose_app sigma args.(1) in - try - if not (isConst sigma f1) then raise NoFunction; - let finfos = find_Function_infos (fst (destConst sigma f1)) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f1 f_correct g - with | NoFunction | Option.IsNone | Not_found -> - try - let f2,_ = decompose_app sigma args.(2) in - if not (isConst sigma f2) then raise NoFunction; - let finfos = find_Function_infos (fst (destConst sigma f2)) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f2 f_correct g - with - | NoFunction -> - user_err (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") - | Option.IsNone -> - if do_observe () - then - error "Cannot use equivalence with graph for any side of the equality" - else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Not_found -> - if do_observe () - then - error "No graph found for any side of equality" - else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - end - | _ -> user_err (Ppconstr.pr_id hid ++ str " must be an equality ") - end) - qhyp + let hyp_typ = pf_unsafe_type_of g (mkVar hid) in + match EConstr.kind sigma hyp_typ with + | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> + begin + let f1,_ = decompose_app sigma args.(1) in + try + if not (isConst sigma f1) then raise NoFunction; + let finfos = find_Function_infos (fst (destConst sigma f1)) in + let f_correct = mkConst(Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f1 f_correct g + with | NoFunction | Option.IsNone | Not_found -> + try + let f2,_ = decompose_app sigma args.(2) in + if not (isConst sigma f2) then raise NoFunction; + let finfos = find_Function_infos (fst (destConst sigma f2)) in + let f_correct = mkConst(Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f2 f_correct g + with + | NoFunction -> + user_err (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") + | Option.IsNone -> + if do_observe () + then + error "Cannot use equivalence with graph for any side of the equality" + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + | Not_found -> + if do_observe () + then + error "No graph found for any side of equality" + else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + end + | _ -> user_err (Ppconstr.pr_id hid ++ str " must be an equality ") + end) + qhyp end - g + g diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index e2321d233c..2b5c0a01db 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -34,7 +34,6 @@ open Declare open Decl_kinds open Tacred open Goal -open Pfedit open Glob_term open Pretyping open Termops @@ -72,17 +71,18 @@ let declare_fun f_id kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined pstate = Lemmas.save_pstate_proved ~pstate ~opaque:Proof_global.Transparent ~idopt:None +let defined lemma = + Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:Proof_global.Transparent ~idopt:None let def_of_const t = match (Constr.kind t) with Const sp -> (try (match constant_opt_value_in (Global.env ()) sp with | Some c -> c - | _ -> raise Not_found) + | _ -> raise Not_found) with Not_found -> - anomaly (str "Cannot find definition of constant " ++ - (Id.print (Label.to_id (Constant.label (fst sp)))) ++ str ".") + anomaly (str "Cannot find definition of constant " ++ + (Id.print (Label.to_id (Constant.label (fst sp)))) ++ str ".") ) |_ -> assert false @@ -129,8 +129,8 @@ let lt = function () -> (coq_init_constant "lt") let le = function () -> (Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules "le") let ex = function () -> (coq_init_constant "ex") let nat = function () -> (coq_init_constant "nat") -let iter_ref () = - try find_reference ["Recdef"] "iter" +let iter_ref () = + try find_reference ["Recdef"] "iter" with Not_found -> user_err Pp.(str "module Recdef not loaded") let iter_rd = function () -> (constr_of_monomorphic_global (delayed_force iter_ref)) let eq = function () -> (coq_init_constant "eq") @@ -169,13 +169,13 @@ let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = fun al fterm -> let rev_x_id_l = ( - List.fold_left - (fun x_id_l _ -> - let x_id = next_ident_away_in_goal x_id x_id_l in - x_id::x_id_l - ) - [] - al + List.fold_left + (fun x_id_l _ -> + let x_id = next_ident_away_in_goal x_id x_id_l in + x_id::x_id_l + ) + [] + al ) in let context = List.map @@ -185,13 +185,13 @@ let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = let glob_body = DAst.make @@ GCases - (RegularStyle,None, - [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l), - (Anonymous,None)], + (RegularStyle,None, + [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l), + (Anonymous,None)], [CAst.make ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), - [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], + [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], Anonymous)], - DAst.make @@ GVar v_id)]) + DAst.make @@ GVar v_id)]) in let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in let body = EConstr.Unsafe.to_constr body in @@ -206,17 +206,17 @@ let (declare_f : Id.t -> logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t (* Debugging mechanism *) let debug_queue = Stack.create () -let print_debug_queue b e = - if not (Stack.is_empty debug_queue) +let print_debug_queue b e = + if not (Stack.is_empty debug_queue) then begin - let lmsg,goal = Stack.pop debug_queue in - if b then - Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) + let lmsg,goal = Stack.pop debug_queue in + if b then + Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) else - begin - Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); - end; + begin + Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); + end; (* print_debug_queue false e; *) end @@ -226,14 +226,14 @@ let observe strm = else () -let do_observe_tac s tac g = +let do_observe_tac s tac g = let goal = Printer.pr_goal g in let s = s (pf_env g) (project g) in - let lmsg = (str "recdef : ") ++ s in + let lmsg = (str "recdef : ") ++ s in observe (s++fnl()); Stack.push (lmsg,goal) debug_queue; - try - let v = tac g in + try + let v = tac g in ignore(Stack.pop debug_queue); v with reraise -> @@ -258,7 +258,7 @@ let observe_tclTHENLIST s tacl = in aux 0 tacl else tclTHENLIST tacl - + (* Conclusion tactics *) (* The boolean value is_mes expresses that the termination is expressed @@ -275,10 +275,10 @@ let tclUSER tac is_mes l g = if is_mes then observe_tclTHENLIST (fun _ _ -> str "tclUSER2") [ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force Indfun_common.ltof_ref))]); tac - ] + ] else tac ] g @@ -290,19 +290,19 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = - + (* Traveling term. - Both definitions of [f_terminate] and [f_equation] use the same generic + Both definitions of [f_terminate] and [f_equation] use the same generic traveling mechanism. *) -(* [check_not_nested forbidden e] checks that [e] does not contains any variable +(* [check_not_nested forbidden e] checks that [e] does not contains any variable of [forbidden] *) let check_not_nested env sigma forbidden e = - let rec check_not_nested e = - match EConstr.kind sigma e with + let rec check_not_nested e = + match EConstr.kind sigma e with | Rel _ -> () | Int _ -> () | Var x -> @@ -319,18 +319,18 @@ let check_not_nested env sigma forbidden e = | Const _ -> () | Ind _ -> () | Construct _ -> () - | Case(_,t,e,a) -> - check_not_nested t;check_not_nested e;Array.iter check_not_nested a + | Case(_,t,e,a) -> + check_not_nested t;check_not_nested e;Array.iter check_not_nested a | Fix _ -> user_err Pp.(str "check_not_nested : Fix") | CoFix _ -> user_err Pp.(str "check_not_nested : Fix") in - try - check_not_nested e - with UserError(_,p) -> + try + check_not_nested e + with UserError(_,p) -> user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) -type 'a infos = +type 'a infos = { nb_arg : int; (* function number of arguments *) concl_tac : tactic; (* final tactic to finish proofs *) rec_arg_id : Id.t; (*name of the declared recursive argument *) @@ -343,8 +343,8 @@ type 'a infos = info : 'a; is_main_branch : bool; (* on the main branch or on a matched expression *) is_final : bool; (* final first order term or not *) - values_and_bounds : (Id.t*Id.t) list; - eqs : Id.t list; + values_and_bounds : (Id.t*Id.t) list; + eqs : Id.t list; forbidden_ids : Id.t list; acc_inv : constr lazy_t; acc_id : Id.t; @@ -352,166 +352,166 @@ type 'a infos = } -type ('a,'b) journey_info_tac = +type ('a,'b) journey_info_tac = 'a -> (* the arguments of the constructor *) 'b infos -> (* infos of the caller *) ('b infos -> tactic) -> (* the continuation tactic of the caller *) 'b infos -> (* argument of the tactic *) tactic - + (* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) -type journey_info = +type journey_info = { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; lambdA : ((Name.t*types*constr),constr) journey_info_tac; - casE : ((constr infos -> tactic) -> constr infos -> tactic) -> - ((case_info * constr * constr * constr array),constr) journey_info_tac; + casE : ((constr infos -> tactic) -> constr infos -> tactic) -> + ((case_info * constr * constr * constr array),constr) journey_info_tac; otherS : (unit,constr) journey_info_tac; apP : (constr*(constr list),constr) journey_info_tac; app_reC : (constr*(constr list),constr) journey_info_tac; message : string } - -let add_vars sigma forbidden e = + +let add_vars sigma forbidden e = let rec aux forbidden e = - match EConstr.kind sigma e with - | Var x -> x::forbidden + match EConstr.kind sigma e with + | Var x -> x::forbidden | _ -> EConstr.fold sigma aux forbidden e in aux forbidden e -let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = - fun g -> +let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = + fun g -> let rev_context,b = decompose_lam_n (project g) nb_lam e in let ids = List.fold_left (fun acc (na,_) -> - let pre_id = + let pre_id = match na.binder_name with - | Name x -> x - | Anonymous -> ano_id + | Name x -> x + | Anonymous -> ano_id in pre_id::acc - ) [] rev_context in - let rev_ids = pf_get_new_ids (List.rev ids) g in - let new_b = substl (List.map mkVar rev_ids) b in + ) [] rev_context in + let rev_ids = pf_get_new_ids (List.rev ids) g in + let new_b = substl (List.map mkVar rev_ids) b in observe_tclTHENLIST (fun _ _ -> str "treat_case1") [ - h_intros (List.rev rev_ids); - Proofview.V82.of_tactic (intro_using teq_id); - onLastHypId (fun heq -> + h_intros (List.rev rev_ids); + Proofview.V82.of_tactic (intro_using teq_id); + onLastHypId (fun heq -> observe_tclTHENLIST (fun _ _ -> str "treat_case2")[ - Proofview.V82.of_tactic (clear to_intros); - h_intros to_intros; - (fun g' -> - let ty_teq = pf_unsafe_type_of g' (mkVar heq) in - let teq_lhs,teq_rhs = - let _,args = try destApp (project g') ty_teq with DestKO -> assert false in - args.(1),args.(2) - in - let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in - let new_infos = { - infos with - info = new_b'; - eqs = heq::infos.eqs; - forbidden_ids = - if forbid_new_ids - then add_vars (project g') infos.forbidden_ids new_b' - else infos.forbidden_ids - } in - finalize_tac new_infos g' - ) - ] - ) + Proofview.V82.of_tactic (clear to_intros); + h_intros to_intros; + (fun g' -> + let ty_teq = pf_unsafe_type_of g' (mkVar heq) in + let teq_lhs,teq_rhs = + let _,args = try destApp (project g') ty_teq with DestKO -> assert false in + args.(1),args.(2) + in + let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in + let new_infos = { + infos with + info = new_b'; + eqs = heq::infos.eqs; + forbidden_ids = + if forbid_new_ids + then add_vars (project g') infos.forbidden_ids new_b' + else infos.forbidden_ids + } in + finalize_tac new_infos g' + ) + ] + ) ] g let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = let sigma = project g in let env = pf_env g in - match EConstr.kind sigma expr_info.info with + match EConstr.kind sigma expr_info.info with | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") | Proj _ -> user_err Pp.(str "Function cannot treat projections") | LetIn(na,b,t,e) -> begin - let new_continuation_tac = + let new_continuation_tac = jinfo.letiN (na.binder_name,b,t,e) expr_info continuation_tac - in - travel jinfo new_continuation_tac - {expr_info with info = b; is_final=false} g + in + travel jinfo new_continuation_tac + {expr_info with info = b; is_final=false} g end | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Prod _ -> + | Prod _ -> begin - try + try check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Lambda(n,t,b) -> begin - try + try check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> + jinfo.otherS () expr_info continuation_tac expr_info g + with e when CErrors.noncritical e -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end - | Case(ci,t,a,l) -> + | Case(ci,t,a,l) -> begin - let continuation_tac_a = - jinfo.casE - (travel jinfo) (ci,t,a,l) - expr_info continuation_tac in - travel - jinfo continuation_tac_a - {expr_info with info = a; is_main_branch = false; - is_final = false} g + let continuation_tac_a = + jinfo.casE + (travel jinfo) (ci,t,a,l) + expr_info continuation_tac in + travel + jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; + is_final = false} g end - | App _ -> - let f,args = decompose_app sigma expr_info.info in - if EConstr.eq_constr sigma f (expr_info.f_constr) + | App _ -> + let f,args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f (expr_info.f_constr) then jinfo.app_reC (f,args) expr_info continuation_tac expr_info g else begin - match EConstr.kind sigma f with - | App _ -> assert false (* f is coming from a decompose_app *) - | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ - | Sort _ | Prod _ | Var _ -> - let new_infos = {expr_info with info=(f,args)} in - let new_continuation_tac = - jinfo.apP (f,args) expr_info continuation_tac in - travel_args jinfo - expr_info.is_main_branch new_continuation_tac new_infos g + match EConstr.kind sigma f with + | App _ -> assert false (* f is coming from a decompose_app *) + | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ + | Sort _ | Prod _ | Var _ -> + let new_infos = {expr_info with info=(f,args)} in + let new_continuation_tac = + jinfo.apP (f,args) expr_info continuation_tac in + travel_args jinfo + expr_info.is_main_branch new_continuation_tac new_infos g | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env env sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env env sigma expr_info.info ++ Pp.str ".") end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> - let new_continuation_tac = - jinfo.otherS () expr_info continuation_tac in + let new_continuation_tac = + jinfo.otherS () expr_info continuation_tac in new_continuation_tac expr_info g -and travel_args jinfo is_final continuation_tac infos = - let (f_args',args) = infos.info in - match args with - | [] -> +and travel_args jinfo is_final continuation_tac infos = + let (f_args',args) = infos.info in + match args with + | [] -> continuation_tac {infos with info = f_args'; is_final = is_final} - | arg::args' -> - let new_continuation_tac new_infos = - let new_arg = new_infos.info in - travel_args jinfo is_final - continuation_tac - {new_infos with info = (mkApp(f_args',[|new_arg|]),args')} + | arg::args' -> + let new_continuation_tac new_infos = + let new_arg = new_infos.info in + travel_args jinfo is_final + continuation_tac + {new_infos with info = (mkApp(f_args',[|new_arg|]),args')} in - travel jinfo new_continuation_tac - {infos with info=arg;is_final=false} + travel jinfo new_continuation_tac + {infos with info=arg;is_final=false} and travel jinfo continuation_tac expr_info = observe_tac (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) (travel_aux jinfo continuation_tac expr_info) -(* Termination proof *) +(* Termination proof *) -let rec prove_lt hyple g = +let rec prove_lt hyple g = let sigma = project g in begin try @@ -520,125 +520,125 @@ let rec prove_lt hyple g = | _ -> assert false in let h = - List.find (fun id -> + List.find (fun id -> match decompose_app sigma (pf_unsafe_type_of g (mkVar id)) with | _, t::_ -> EConstr.eq_constr sigma t varx | _ -> false - ) hyple + ) hyple in let y = - List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in + List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ - Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); + Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] - with Not_found -> + with Not_found -> ( - ( + ( observe_tclTHENLIST (fun _ _ -> str "prove_lt2")[ - Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); + Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); (observe_tac (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) - ]) + ]) ) end g -let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = - match lbounds with - | [] -> - let ids = pf_ids_of_hyps g in - let s_max = mkApp(delayed_force coq_S, [|bound|]) in +let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = + match lbounds with + | [] -> + let ids = pf_ids_of_hyps g in + let s_max = mkApp(delayed_force coq_S, [|bound|]) in let k = next_ident_away_in_goal k_id ids in let ids = k::ids in let h' = next_ident_away_in_goal (h'_id) ids in let ids = h'::ids in let def = next_ident_away_in_goal def_id ids in observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux1")[ - Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); - Proofview.V82.of_tactic (intro_then - (fun id -> + Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); + Proofview.V82.of_tactic (intro_then + (fun id -> Proofview.V82.tactic begin observe_tac (fun _ _ -> str "destruct_bounds_aux") - (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) - [ + (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) + [ observe_tclTHENLIST (fun _ _ -> str "")[Proofview.V82.of_tactic (intro_using h_id); - Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); - Proofview.V82.of_tactic default_full_auto]; + Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); + Proofview.V82.of_tactic default_full_auto]; observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux2")[ observe_tac (fun _ _ -> str "clearing k ") (Proofview.V82.of_tactic (clear [id])); - h_intros [k;h';def]; + h_intros [k;h';def]; observe_tac (fun _ _ -> str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference infos.func)])); - ( + (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference infos.func)])); + ( observe_tclTHENLIST (fun _ _ -> str "test")[ - list_rewrite true - (List.fold_right - (fun e acc -> (mkVar e,true)::acc) - infos.eqs - (List.map (fun e -> (e,true)) rechyps) - ); - (* list_rewrite true *) - (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) - (* ; *) - + list_rewrite true + (List.fold_right + (fun e acc -> (mkVar e,true)::acc) + infos.eqs + (List.map (fun e -> (e,true)) rechyps) + ); + (* list_rewrite true *) + (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) + (* ; *) + (observe_tac (fun _ _ -> str "finishing") - (tclORELSE - (Proofview.V82.of_tactic intros_reflexivity) + (tclORELSE + (Proofview.V82.of_tactic intros_reflexivity) (observe_tac (fun _ _ -> str "calling prove_lt") (prove_lt hyple))))]) - ] - ] - )end)) - ] g - | (_,v_bound)::l -> + ] + ] + )end)) + ] g + | (_,v_bound)::l -> observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux3")[ - Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); - Proofview.V82.of_tactic (clear [v_bound]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 - (fun p_hyp -> - (onNthHypId 2 - (fun p -> + Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); + Proofview.V82.of_tactic (clear [v_bound]); + tclDO 2 (Proofview.V82.of_tactic intro); + onNthHypId 1 + (fun p_hyp -> + (onNthHypId 2 + (fun p -> observe_tclTHENLIST (fun _ _ -> str "destruct_bounds_aux4")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - [hle2;hle1;pmax] -> - destruct_bounds_aux infos - ((mkVar pmax), - hle1::hle2::hyple,(mkVar p_hyp)::rechyps) - l - | _ -> assert false) ; - ] - ) - ) - ) + Proofview.V82.of_tactic (simplest_elim + (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); + tclDO 3 (Proofview.V82.of_tactic intro); + onNLastHypsId 3 (fun lids -> + match lids with + [hle2;hle1;pmax] -> + destruct_bounds_aux infos + ((mkVar pmax), + hle1::hle2::hyple,(mkVar p_hyp)::rechyps) + l + | _ -> assert false) ; + ] + ) + ) + ) ] g -let destruct_bounds infos = +let destruct_bounds infos = destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds -let terminate_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then +let terminate_app f_and_args expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch + then observe_tclTHENLIST (fun _ _ -> str "terminate_app1")[ - continuation_tac infos; + continuation_tac infos; observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos -let terminate_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch - then +let terminate_others _ expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch + then observe_tclTHENLIST (fun _ _ -> str "terminate_others")[ - continuation_tac infos; + continuation_tac infos; observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) ] else continuation_tac infos @@ -646,24 +646,24 @@ let terminate_others _ expr_info continuation_tac infos = let terminate_letin (na,b,t,e) expr_info continuation_tac info g = let sigma = project g in let env = pf_env g in - let new_e = subst1 info.info e in - let new_forbidden = - let forbid = - try + let new_e = subst1 info.info e in + let new_forbidden = + let forbid = + try check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids) b; - true + true with e when CErrors.noncritical e -> false in - if forbid - then + if forbid + then match na with - | Anonymous -> info.forbidden_ids - | Name id -> id::info.forbidden_ids - else info.forbidden_ids + | Anonymous -> info.forbidden_ids + | Name id -> id::info.forbidden_ids + else info.forbidden_ids in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g -let pf_type c tac gl = +let pf_type c tac gl = let evars, ty = Typing.type_of (pf_env gl) (project gl) c in tclTHEN (Refiner.tclEVARS evars) (tac ty) gl @@ -704,7 +704,6 @@ let mkDestructEq : Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert - let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let sigma = project g in let env = pf_env g in @@ -721,104 +720,104 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = info = mkCase(ci,t,a',l); is_main_branch = expr_info.is_main_branch; is_final = expr_info.is_final} in - let destruct_tac,rev_to_thin_intro = - mkDestructEq [expr_info.rec_arg_id] a' g in - let to_thin_intro = List.rev rev_to_thin_intro in + let destruct_tac,rev_to_thin_intro = + mkDestructEq [expr_info.rec_arg_id] a' g in + let to_thin_intro = List.rev rev_to_thin_intro in observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') (try (tclTHENS - destruct_tac + destruct_tac (List.map_i (fun i e -> observe_tac (fun _ _ -> str "do treat case") (treat_case f_is_present to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) - )) - with - | UserError(Some "Refiner.thensn_tac3",_) + )) + with + | UserError(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> (observe_tac (fun _ _ -> str "is computable " ++ Printer.pr_leconstr_env env sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) - )) + )) g - + let terminate_app_rec (f,args) expr_info continuation_tac _ g = let sigma = project g in let env = pf_env g in List.iter (check_not_nested env sigma (expr_info.f_id::expr_info.forbidden_ids)) args; begin - try + try let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in - let new_infos = {expr_info with info = v} in + let new_infos = {expr_info with info = v} in observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then + continuation_tac new_infos; + if expr_info.is_final && expr_info.is_main_branch + then observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec1")[ observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); observe_tac (fun _ _ -> str "destruct_bounds (3)") - (destruct_bounds new_infos) - ] - else - tclIDTAC + (destruct_bounds new_infos) + ] + else + tclIDTAC ] g - with Not_found -> + with Not_found -> observe_tac (fun _ _ -> str "terminate_app_rec not found") (tclTHENS - (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) - [ + (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) + [ observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2")[ - Proofview.V82.of_tactic (intro_using rec_res_id); - Proofview.V82.of_tactic intro; - onNthHypId 1 - (fun v_bound -> - (onNthHypId 2 - (fun v -> - let new_infos = { expr_info with - info = (mkVar v); - values_and_bounds = - (v,v_bound)::expr_info.values_and_bounds; - args_assoc=(args,mkVar v)::expr_info.args_assoc - } in + Proofview.V82.of_tactic (intro_using rec_res_id); + Proofview.V82.of_tactic intro; + onNthHypId 1 + (fun v_bound -> + (onNthHypId 2 + (fun v -> + let new_infos = { expr_info with + info = (mkVar v); + values_and_bounds = + (v,v_bound)::expr_info.values_and_bounds; + args_assoc=(args,mkVar v)::expr_info.args_assoc + } in observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec3")[ - continuation_tac new_infos; - if expr_info.is_final && expr_info.is_main_branch - then + continuation_tac new_infos; + if expr_info.is_final && expr_info.is_main_branch + then observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec4")[ observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); observe_tac (fun _ _ -> str "destruct_bounds (2)") - (destruct_bounds new_infos) - ] - else - tclIDTAC - ] - ) - ) - ) - ]; + (destruct_bounds new_infos) + ] + else + tclIDTAC + ] + ) + ) + ) + ]; observe_tac (fun _ _ -> str "proving decreasing") ( - tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) - [ + tclTHENS (* proof of args < formal args *) + (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) + [ observe_tac (fun _ _ -> str "assumption") (Proofview.V82.of_tactic assumption); observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec5") - [ - tclTRY(list_rewrite true - (List.map - (fun e -> mkVar e,true) - expr_info.eqs - ) - ); - tclUSER expr_info.concl_tac true - (Some ( - expr_info.ih::expr_info.acc_id:: - (fun (x,y) -> y) - (List.split expr_info.values_and_bounds) - ) - ); - ] - ]) - ]) g + [ + tclTRY(list_rewrite true + (List.map + (fun e -> mkVar e,true) + expr_info.eqs + ) + ); + tclUSER expr_info.concl_tac true + (Some ( + expr_info.ih::expr_info.acc_id:: + (fun (x,y) -> y) + (List.split expr_info.values_and_bounds) + ) + ); + ] + ]) + ]) g end -let terminate_info = +let terminate_info = { message = "prove_terminate with term "; letiN = terminate_letin; lambdA = (fun _ _ _ _ -> assert false); @@ -833,15 +832,15 @@ let prove_terminate = travel terminate_info (* Equation proof *) -let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = +let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = observe_tac (fun _ _ -> str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) -let rec prove_le g = +let rec prove_le g = let sigma = project g in - let x,z = - let _,args = decompose_app sigma (pf_concl g) in + let x,z = + let _,args = decompose_app sigma (pf_concl g) in (List.hd args,List.hd (List.tl args)) - in + in tclFIRST[ Proofview.V82.of_tactic assumption; Proofview.V82.of_tactic (apply (delayed_force le_n)); @@ -856,151 +855,151 @@ let rec prove_le g = in let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in let h = h.binder_name in - let y = - let _,args = decompose_app sigma t in - List.hd (List.tl args) - in + let y = + let _,args = decompose_app sigma t in + List.hd (List.tl args) + in observe_tclTHENLIST (fun _ _ -> str "prove_le")[ - Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); + Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); observe_tac (fun _ _ -> str "prove_le (rec)") (prove_le) - ] + ] with Not_found -> tclFAIL 0 (mt()) end; ] g -let rec make_rewrite_list expr_info max = function +let rec make_rewrite_list expr_info max = function | [] -> tclIDTAC - | (_,p,hp)::l -> + | (_,p,hp)::l -> observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( - (fun g -> + (fun g -> let sigma = project g in - let t_eq = compute_renamed_type g (mkVar hp) in - let k,def = + let t_eq = compute_renamed_type g (mkVar hp) in + let k,def = let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in let def_na,_,_ = destProd sigma t in Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in - Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, + in + Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences + true (* dep proofs also: *) true + (mkVar hp, ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list")[ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); + Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ] ) -let make_rewrite expr_info l hp max = +let make_rewrite expr_info l hp max = tclTHENFIRST (observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS - (fun g -> + (fun g -> let sigma = project g in - let t_eq = compute_renamed_type g (mkVar hp) in - let k,def = + let t_eq = compute_renamed_type g (mkVar hp) in + let k,def = let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in let def_na,_,_ = destProd sigma t in Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name - in + in observe_tac (fun _ _ -> str "general_rewrite_bindings") - (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences - true (* dep proofs also: *) true - (mkVar hp, + (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences + true (* dep proofs also: *) true + (mkVar hp, ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) [observe_tac(fun _ _ -> str "make_rewrite finalize") ( - (* tclORELSE( h_reflexivity) *) + (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (fun _ _ -> str "make_rewrite")[ - Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); + Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference expr_info.func)])); - - (list_rewrite true - (List.map (fun e -> mkVar e,true) expr_info.eqs)); + (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference expr_info.func)])); + + (list_rewrite true + (List.map (fun e -> mkVar e,true) expr_info.eqs)); (observe_tac (fun _ _ -> str "h_reflexivity") - (Proofview.V82.of_tactic intros_reflexivity) - ) - ])) + (Proofview.V82.of_tactic intros_reflexivity) + ) + ])) ; observe_tclTHENLIST (fun _ _ -> str "make_rewrite1")[ (* x < S (S max) proof *) - Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); observe_tac (fun _ _ -> str "prove_le (3)") prove_le - ] - ]) + ] + ]) ) -let rec compute_max rew_tac max l = - match l with +let rec compute_max rew_tac max l = + match l with | [] -> rew_tac max - | (_,p,_)::l -> + | (_,p,_)::l -> observe_tclTHENLIST (fun _ _ -> str "compute_max")[ - Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| max; mkVar p|]))); - tclDO 3 (Proofview.V82.of_tactic intro); - onNLastHypsId 3 (fun lids -> - match lids with - | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l - | _ -> assert false - )] - -let rec destruct_hex expr_info acc l = - match l with - | [] -> + Proofview.V82.of_tactic (simplest_elim + (mkApp(delayed_force max_constr, [| max; mkVar p|]))); + tclDO 3 (Proofview.V82.of_tactic intro); + onNLastHypsId 3 (fun lids -> + match lids with + | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l + | _ -> assert false + )] + +let rec destruct_hex expr_info acc l = + match l with + | [] -> begin - match List.rev acc with - | [] -> tclIDTAC - | (_,p,hp)::tl -> + match List.rev acc with + | [] -> tclIDTAC + | (_,p,hp)::tl -> observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) end - | (v,hex)::l -> + | (v,hex)::l -> observe_tclTHENLIST (fun _ _ -> str "destruct_hex")[ - Proofview.V82.of_tactic (simplest_case (mkVar hex)); - Proofview.V82.of_tactic (clear [hex]); - tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hp -> - onNthHypId 2 (fun p -> - observe_tac + Proofview.V82.of_tactic (simplest_case (mkVar hex)); + Proofview.V82.of_tactic (clear [hex]); + tclDO 2 (Proofview.V82.of_tactic intro); + onNthHypId 1 (fun hp -> + onNthHypId 2 (fun p -> + observe_tac (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) - (destruct_hex expr_info ((v,p,hp)::acc) l) - ) - ) + (destruct_hex expr_info ((v,p,hp)::acc) l) + ) + ) ] - -let rec intros_values_eq expr_info acc = + +let rec intros_values_eq expr_info acc = tclORELSE( observe_tclTHENLIST (fun _ _ -> str "intros_values_eq")[ tclDO 2 (Proofview.V82.of_tactic intro); - onNthHypId 1 (fun hex -> - (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) + onNthHypId 1 (fun hex -> + (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) ) ]) (tclCOMPLETE ( destruct_hex expr_info [] acc )) -let equation_others _ expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch +let equation_others _ expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch then observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) - (tclTHEN - (continuation_tac infos) + (tclTHEN + (continuation_tac infos) (observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) else observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) -let equation_app f_and_args expr_info continuation_tac infos = - if expr_info.is_final && expr_info.is_main_branch +let equation_app f_and_args expr_info continuation_tac infos = + if expr_info.is_final && expr_info.is_main_branch then ((observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []))) else continuation_tac infos - -let equation_app_rec (f,args) expr_info continuation_tac info g = + +let equation_app_rec (f,args) expr_info continuation_tac info g = let sigma = project g in begin try @@ -1008,21 +1007,21 @@ let equation_app_rec (f,args) expr_info continuation_tac info g = let new_infos = {expr_info with info = v} in observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g with Not_found -> - if expr_info.is_final && expr_info.is_main_branch - then + if expr_info.is_final && expr_info.is_main_branch + then observe_tclTHENLIST (fun _ _ -> str "equation_app_rec") - [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); - continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; + [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); + continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; observe_tac (fun _ _ -> str "app_rec intros_values_eq") (intros_values_eq expr_info []) - ] g - else + ] g + else observe_tclTHENLIST (fun _ _ -> str "equation_app_rec1")[ - Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); + Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); observe_tac (fun _ _ -> str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) - ] g + ] g end -let equation_info = +let equation_info = {message = "prove_equation with term "; letiN = (fun _ -> assert false); lambdA = (fun _ _ _ _ -> assert false); @@ -1031,7 +1030,7 @@ let equation_info = apP = equation_app; app_reC = equation_app_rec } - + let prove_eq = travel equation_info (* wrappers *) @@ -1045,12 +1044,12 @@ let compute_terminate_type nb_args func = let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = mkApp(delayed_force iter_rd, - Array.of_list - (lift 5 a_arrow_b:: mkRel 3:: + Array.of_list + (lift 5 a_arrow_b:: mkRel 3:: constr_of_monomorphic_global func::mkRel 1:: - List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) - ) - ) + List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) + ) + ) in let right = mkRel 5 in let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in @@ -1059,14 +1058,14 @@ let compute_terminate_type nb_args func = let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in let nb_iter = mkApp(delayed_force ex, - [|delayed_force nat; - (mkLambda + [|delayed_force nat; + (mkLambda (make_annot (Name p_id) Sorts.Relevant, - delayed_force nat, + delayed_force nat, (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, mkArrow cond Sorts.Relevant result))))|])in let value = mkApp(constr_of_monomorphic_global (Util.delayed_force coq_sig_ref), - [|b; + [|b; (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in compose_prod rev_args value @@ -1077,74 +1076,74 @@ let termination_proof_header is_mes input_type ids args_id relation fun g -> let nargs = List.length args_id in let pre_rec_args = - List.rev_map - mkVar (fst (List.chop (rec_arg_num - 1) args_id)) + List.rev_map + mkVar (fst (List.chop (rec_arg_num - 1) args_id)) in let relation = substl pre_rec_args relation in let input_type = substl pre_rec_args input_type in let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in let wf_rec_arg = - next_ident_away_in_goal - (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) - (wf_thm::ids) + next_ident_away_in_goal + (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))) + (wf_thm::ids) in let hrec = next_ident_away_in_goal hrec_id - (wf_rec_arg::wf_thm::ids) in + (wf_rec_arg::wf_thm::ids) in let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) + lazy ( + mkApp ( + delayed_force acc_inv_id, + [|input_type;relation;mkVar rec_arg_id|] + ) + ) in tclTHEN - (h_intros args_id) - (tclTHENS - (observe_tac + (h_intros args_id) + (tclTHENS + (observe_tac (fun _ _ -> str "first assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_rec_arg) - (mkApp (delayed_force acc_rel, - [|input_type;relation;mkVar rec_arg_id|]) - ) - )) - ) - [ - (* accesibility proof *) - tclTHENS - (observe_tac + (Proofview.V82.of_tactic (assert_before + (Name wf_rec_arg) + (mkApp (delayed_force acc_rel, + [|input_type;relation;mkVar rec_arg_id|]) + ) + )) + ) + [ + (* accesibility proof *) + tclTHENS + (observe_tac (fun _ _ -> str "second assert") - (Proofview.V82.of_tactic (assert_before - (Name wf_thm) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - )) - ) - [ - (* interactive proof that the relation is well_founded *) + (Proofview.V82.of_tactic (assert_before + (Name wf_thm) + (mkApp (delayed_force well_founded,[|input_type;relation|])) + )) + ) + [ + (* interactive proof that the relation is well_founded *) observe_tac (fun _ _ -> str "wf_tac") (wf_tac is_mes (Some args_id)); - (* this gives the accessibility argument *) - observe_tac + (* this gives the accessibility argument *) + observe_tac (fun _ _ -> str "apply wf_thm") - (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) - ) - ] - ; - (* rest of the proof *) + (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) + ) + ] + ; + (* rest of the proof *) observe_tclTHENLIST (fun _ _ -> str "rest of proof") [observe_tac (fun _ _ -> str "generalize") - (onNLastHypsId (nargs+1) - (tclMAP (fun id -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) - )) - ; + (onNLastHypsId (nargs+1) + (tclMAP (fun id -> + tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) + )) + ; observe_tac (fun _ _ -> str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); - h_intros args_id; - Proofview.V82.of_tactic (Simple.intro wf_rec_arg); + h_intros args_id; + Proofview.V82.of_tactic (Simple.intro wf_rec_arg); observe_tac (fun _ _ -> str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) - ] - ] - ) g + ] + ] + ) g end @@ -1166,62 +1165,62 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let (f_name, _, body1) = destLambda sigma func_body in let f_id = match f_name.binder_name with - | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function.") + | Name f_id -> next_ident_away_in_goal f_id ids + | Anonymous -> anomaly (Pp.str "Anonymous function.") in let n_names_types,_ = decompose_lam_n sigma nb_args body1 in let n_ids,ids = - List.fold_left + List.fold_left (fun (n_ids,ids) (n_name,_) -> match n_name.binder_name with - | Name id -> - let n_id = next_ident_away_in_goal id ids in - n_id::n_ids,n_id::ids - | _ -> anomaly (Pp.str "anonymous argument.") - ) - ([],(f_id::ids)) - n_names_types + | Name id -> + let n_id = next_ident_away_in_goal id ids in + n_id::n_ids,n_id::ids + | _ -> anomaly (Pp.str "anonymous argument.") + ) + ([],(f_id::ids)) + n_names_types in let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in let expr = instantiate_lambda sigma func_body (mkVar f_id::(List.map mkVar n_ids)) in termination_proof_header - is_mes - input_type - ids - n_ids - relation - rec_arg_num - rec_arg_id - (fun rec_arg_id hrec acc_id acc_inv g -> - (prove_terminate (fun infos -> tclIDTAC) - { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *) - is_final = true; (* and on leaf (more or less) *) - f_terminate = delayed_force coq_O; - nb_arg = nb_args; - concl_tac = concl_tac; - rec_arg_id = rec_arg_id; - is_mes = is_mes; - ih = hrec; - f_id = f_id; - f_constr = mkVar f_id; - func = func; - info = expr; - acc_inv = acc_inv; - acc_id = acc_id; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - args_assoc = [] - } - ) - g - ) - (tclUSER_if_not_mes concl_tac) - g + is_mes + input_type + ids + n_ids + relation + rec_arg_num + rec_arg_id + (fun rec_arg_id hrec acc_id acc_inv g -> + (prove_terminate (fun infos -> tclIDTAC) + { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *) + is_final = true; (* and on leaf (more or less) *) + f_terminate = delayed_force coq_O; + nb_arg = nb_args; + concl_tac = concl_tac; + rec_arg_id = rec_arg_id; + is_mes = is_mes; + ih = hrec; + f_id = f_id; + f_constr = mkVar f_id; + func = func; + info = expr; + acc_inv = acc_inv; + acc_id = acc_id; + values_and_bounds = []; + eqs = []; + forbidden_ids = []; + args_assoc = [] + } + ) + g + ) + (tclUSER_if_not_mes concl_tac) + g end let get_current_subgoals_types pstate = - let p = Proof_global.give_me_the_proof pstate in + let p = Proof_global.get_proof pstate in let Proof.{ goals=sgs; sigma; _ } = Proof.data p in sigma, List.map (Goal.V82.abstract_type sigma) sgs @@ -1231,32 +1230,32 @@ let build_and_l sigma l = let conj_constr = Coqlib.build_coq_conj () in let mk_and p1 p2 = mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in - let rec is_well_founded t = - match EConstr.kind sigma t with + let rec is_well_founded t = + match EConstr.kind sigma t with | Prod(_,_,t') -> is_well_founded t' - | App(_,_) -> - let (f,_) = decompose_app sigma t in - EConstr.eq_constr sigma f (well_founded ()) - | _ -> - false + | App(_,_) -> + let (f,_) = decompose_app sigma t in + EConstr.eq_constr sigma f (well_founded ()) + | _ -> + false in - let compare t1 t2 = - let b1,b2= is_well_founded t1,is_well_founded t2 in + let compare t1 t2 = + let b1,b2= is_well_founded t1,is_well_founded t2 in if (b1&&b2) || not (b1 || b2) then 0 else if b1 && not b2 then 1 else -1 in - let l = List.sort compare l in + let l = List.sort compare l in let rec f = function | [] -> raise EmptySubgoals | [p] -> p,tclIDTAC,1 | p1::pl -> - let c,tac,nb = f pl in - mk_and p1 c, - tclTHENS + let c,tac,nb = f pl in + mk_and p1 c, + tclTHENS (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) - [tclIDTAC; - tac - ],nb+1 + [tclIDTAC; + tac + ],nb+1 in f l @@ -1266,23 +1265,23 @@ let is_rec_res id = try String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name with Invalid_argument _ -> false - + let clear_goals sigma = let rec clear_goal t = match EConstr.kind sigma t with | Prod({binder_name=Name id} as na,t',b) -> - let b' = clear_goal b in - if noccurn sigma 1 b' && (is_rec_res id) - then Vars.lift (-1) b' - else if b' == b then t + let b' = clear_goal b in + if noccurn sigma 1 b' && (is_rec_res id) + then Vars.lift (-1) b' + else if b' == b then t else mkProd(na,t',b') | _ -> EConstr.map sigma clear_goal t in List.map clear_goal -let build_new_goal_type pstate = - let sigma, sub_gls_types = get_current_subgoals_types pstate in +let build_new_goal_type lemma = + let sigma, sub_gls_types = Lemmas.pf_fold get_current_subgoals_types lemma in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) @@ -1297,14 +1296,14 @@ let is_opaque_constant c = | Declarations.Def _ -> Proof_global.Transparent | Declarations.Primitive _ -> Proof_global.Opaque -let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Proof_global.get_current_proof_name pstate in + let current_proof_name = Lemmas.pf_fold Proof_global.get_proof_name lemma in let name = match goal_name with | Some s -> s | None -> - try add_suffix current_proof_name "_subproof" - with e when CErrors.noncritical e -> + try add_suffix current_proof_name "_subproof" + with e when CErrors.noncritical e -> anomaly (Pp.str "open_new_goal with an unnamed theorem.") in let na = next_global_ident_away name Id.Set.empty in @@ -1315,87 +1314,87 @@ let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type let na_ref = qualid_of_ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with - ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") + ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Value (EConstr.Unsafe.to_constr lemma); let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in - let pstate = build_proof env (Evd.from_env env) + let lemma = build_proof env (Evd.from_env env) ( fun gls -> - let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in + let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in observe_tclTHENLIST (fun _ _ -> str "") - [ - Proofview.V82.of_tactic (generalize [lemma]); - Proofview.V82.of_tactic (Simple.intro hid); - (fun g -> - let ids = pf_ids_of_hyps g in - tclTHEN - (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid))) - (fun g -> - let ids' = pf_ids_of_hyps g in - lid := List.rev (List.subtract Id.equal ids' ids); - if List.is_empty !lid then lid := [hid]; - tclIDTAC g - ) - g - ); - ] gls) + [ + Proofview.V82.of_tactic (generalize [lemma]); + Proofview.V82.of_tactic (Simple.intro hid); + (fun g -> + let ids = pf_ids_of_hyps g in + tclTHEN + (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid))) + (fun g -> + let ids' = pf_ids_of_hyps g in + lid := List.rev (List.subtract Id.equal ids' ids); + if List.is_empty !lid then lid := [hid]; + tclIDTAC g + ) + g + ); + ] gls) (fun g -> let sigma = project g in - match EConstr.kind sigma (pf_concl g) with - | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> - Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g - | _ -> - incr h_num; + match EConstr.kind sigma (pf_concl g) with + | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> + Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g + | _ -> + incr h_num; (observe_tac (fun _ _ -> str "finishing using") - ( - tclCOMPLETE( - tclFIRST[ - tclTHEN - (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) - (Proofview.V82.of_tactic e_assumption); - Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] + ( + tclCOMPLETE( + tclFIRST[ + tclTHEN + (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) + (Proofview.V82.of_tactic e_assumption); + Eauto.eauto_with_bases + (true,5) + [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] [Hints.Hint_db.empty TransparentState.empty false] - ] - ) - ) - ) - g) + ] + ) + ) + ) + g) in - Lemmas.save_pstate_proved ~pstate ~opaque:opacity ~idopt:None + Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:opacity ~idopt:None in - let pstate = Lemmas.start_proof + let lemma = Lemmas.start_lemma na - (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) + Decl_kinds.(Global ImportDefaultBehavior, false (* FIXME *), Proof Lemma) sigma gls_type ~hook:(Lemmas.mk_hook hook) in - let pstate = if Indfun_common.is_strict_tcc () + let lemma = if Indfun_common.is_strict_tcc () then - fst @@ by (Proofview.V82.tactic (tclIDTAC)) pstate - else - fst @@ by (Proofview.V82.tactic begin - fun g -> - tclTHEN - (decompose_and_tac) - (tclORELSE - (tclFIRST - (List.map - (fun c -> - Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST - [intros; + fst @@ Lemmas.by (Proofview.V82.tactic (tclIDTAC)) lemma + else + fst @@ Lemmas.by (Proofview.V82.tactic begin + fun g -> + tclTHEN + (decompose_and_tac) + (tclORELSE + (tclFIRST + (List.map + (fun c -> + Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST + [intros; Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); - Tacticals.New.tclCOMPLETE Auto.default_auto - ]) - ) - using_lemmas) - ) tclIDTAC) - g end) pstate + Tacticals.New.tclCOMPLETE Auto.default_auto + ]) + ) + using_lemmas) + ) tclIDTAC) + g end) lemma in - if Proof_global.get_open_goals pstate = 0 then (defined pstate; None) else Some pstate + if Lemmas.(pf_fold Proof_global.get_open_goals) lemma = 0 then (defined lemma; None) else Some lemma let com_terminate interactive_proof @@ -1410,26 +1409,26 @@ let com_terminate nb_args ctx hook = let start_proof env ctx (tac_start:tactic) (tac_end:tactic) = - let pstate = Lemmas.start_proof thm_name - (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) + let lemma = Lemmas.start_lemma thm_name + (Global ImportDefaultBehavior, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook in - let pstate = fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "starting_tac") tac_start)) pstate in - fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num ))) pstate + let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "starting_tac") tac_start)) lemma in + fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref + input_type relation rec_arg_num ))) lemma in - let pstate = start_proof Global.(env ()) ctx tclIDTAC tclIDTAC in + let lemma = start_proof Global.(env ()) ctx tclIDTAC tclIDTAC in try - let sigma, new_goal_type = build_new_goal_type pstate in + let sigma, new_goal_type = build_new_goal_type lemma in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in - open_new_goal pstate start_proof sigma + open_new_goal ~lemma start_proof sigma using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type) with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - if interactive_proof then Some pstate - else (defined pstate; None) + if interactive_proof then Some lemma + else (defined lemma; None) let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = @@ -1451,49 +1450,49 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation let open CVars in let opacity = match terminate_ref with - | ConstRef c -> is_opaque_constant c - | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") + | ConstRef c -> is_opaque_constant c + | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in let evd = Evd.from_ctx uctx in let f_constr = constr_of_monomorphic_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - let pstate = Lemmas.start_proof eq_name (Global, false, Proof Lemma) ~sign evd + let lemma = Lemmas.start_lemma eq_name (Global ImportDefaultBehavior, false, Proof Lemma) ~sign evd (EConstr.of_constr equation_lemma_type) in - let pstate = fst @@ by + let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (start_equation f_ref terminate_ref - (fun x -> - prove_eq (fun _ -> tclIDTAC) - {nb_arg=nb_arg; + (fun x -> + prove_eq (fun _ -> tclIDTAC) + {nb_arg=nb_arg; f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); - f_constr = EConstr.of_constr f_constr; - concl_tac = tclIDTAC; - func=functional_ref; - info=(instantiate_lambda Evd.empty + f_constr = EConstr.of_constr f_constr; + concl_tac = tclIDTAC; + func=functional_ref; + info=(instantiate_lambda Evd.empty (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) - (EConstr.of_constr f_constr::List.map mkVar x) - ); - is_main_branch = true; - is_final = true; - values_and_bounds = []; - eqs = []; - forbidden_ids = []; - acc_inv = lazy (assert false); - acc_id = Id.of_string "____"; - args_assoc = []; - f_id = Id.of_string "______"; - rec_arg_id = Id.of_string "______"; - is_mes = false; - ih = Id.of_string "______"; - } - ) - )) pstate in - let _ = Flags.silently (fun () -> Lemmas.save_pstate_proved ~pstate ~opaque:opacity ~idopt:None) () in + (EConstr.of_constr f_constr::List.map mkVar x) + ); + is_main_branch = true; + is_final = true; + values_and_bounds = []; + eqs = []; + forbidden_ids = []; + acc_inv = lazy (assert false); + acc_id = Id.of_string "____"; + args_assoc = []; + f_id = Id.of_string "______"; + rec_arg_id = Id.of_string "______"; + is_mes = false; + ih = Id.of_string "______"; + } + ) + )) lemma in + let _ = Flags.silently (fun () -> Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:opacity ~idopt:None) () in () (* Pp.msgnl (fun _ _ -> str "eqn finished"); *) let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : Proof_global.t option = + generate_induction_principle using_lemmas : Lemmas.t option = let open Term in let open Constr in let open CVars in @@ -1550,18 +1549,19 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type let stop = (* XXX: What is the correct way to get sign at hook time *) let sign = Environ.named_context_val Global.(env ()) in - try com_eqn sign uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); - false + try + com_eqn sign uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + false with e when CErrors.noncritical e -> - begin - if do_observe () - then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) - else CErrors.user_err ~hdr:"Cannot create equation Lemma" - (str "Cannot create equation lemma." ++ spc () ++ + begin + if do_observe () + then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) + else CErrors.user_err ~hdr:"Cannot create equation Lemma" + (str "Cannot create equation lemma." ++ spc () ++ str "This may be because the function is nested-recursive.") - ; - true - end + ; + true + end in if not stop then @@ -1575,22 +1575,22 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type (nb_prod evd (EConstr.of_constr res)) relation; Flags.if_verbose msgnl (h 1 (Ppconstr.pr_id function_name ++ - spc () ++ str"is defined" )++ fnl () ++ - h 1 (Ppconstr.pr_id equation_id ++ - spc () ++ str"is defined" ) + spc () ++ str"is defined" )++ fnl () ++ + h 1 (Ppconstr.pr_id equation_id ++ + spc () ++ str"is defined" ) ) in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> - let pstate = com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref - (EConstr.of_constr rec_arg_type) - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - evd (Lemmas.mk_hook hook) - in pstate) () + com_terminate + interactive_proof + tcc_lemma_name + tcc_lemma_constr + is_mes functional_ref + (EConstr.of_constr rec_arg_type) + relation rec_arg_num + term_id + using_lemmas + (List.length res_vars) + evd (Lemmas.mk_hook hook)) + () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index b92ac3a0ec..e6aa452def 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,23 +1,21 @@ open Constr -val tclUSER_if_not_mes : +val tclUSER_if_not_mes : Tacmach.tactic -> - bool -> - Names.Id.t list option -> + bool -> + Names.Id.t list option -> Tacmach.tactic -val recursive_definition : - interactive_proof:bool -> - is_mes:bool -> - Names.Id.t -> - Constrintern.internalization_env -> - Constrexpr.constr_expr -> - Constrexpr.constr_expr -> - int -> - Constrexpr.constr_expr -> - (pconstant -> - Indfun_common.tcc_lemma_value ref -> - pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> - Constrexpr.constr_expr list -> - Proof_global.t option +val recursive_definition + : interactive_proof:bool + -> is_mes:bool + -> Names.Id.t + -> Constrintern.internalization_env + -> Constrexpr.constr_expr + -> Constrexpr.constr_expr + -> int + -> Constrexpr.constr_expr + -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) + -> Constrexpr.constr_expr list + -> Lemmas.t option diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 0ded60d9c7..7ba63f1830 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -336,7 +336,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = let add_hints base = add_rew_rules base eqs in List.iter add_hints bases -let classify_hint _ = VtSideff [], VtLater +let classify_hint _ = VtSideff ([], VtLater) } @@ -422,7 +422,7 @@ END open Inv open Leminv -let seff id = VtSideff [id], VtLater +let seff id = VtSideff ([id], VtLater) } @@ -934,7 +934,7 @@ END VERNAC COMMAND EXTEND GrabEvars STATE proof | [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.modify_proof (fun p -> Proof.V82.grab_evars p) pstate } + -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.V82.grab_evars p) pstate } END (* Shelves all the goals under focus. *) @@ -966,7 +966,7 @@ END VERNAC COMMAND EXTEND Unshelve STATE proof | [ "Unshelve" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.modify_proof (fun p -> Proof.unshelve p) pstate } + -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.unshelve p) pstate } END (* Gives up on the goals under focus: the goals are considered solved, diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 960e5b76f8..afdea98ef5 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -376,7 +376,7 @@ let () = declare_int_option { let vernac_solve ~pstate n info tcom b = let open Goal_select in - let pstate, status = Proof_global.with_proof (fun etac p -> + let pstate, status = Proof_global.map_fold_proof_endline (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in let info = Option.append info !print_info_trace in @@ -446,8 +446,7 @@ VERNAC { tactic_mode } EXTEND VernacSolve STATE proof let solving_tac = is_explicit_terminator t in let parallel = `Yes (solving_tac,anon_abstracting_tac) in let pbr = if solving_tac then Some "par" else None in - VtProofStep{ parallel = parallel; proof_block_detection = pbr }, - VtLater + VtProofStep{ parallel = parallel; proof_block_detection = pbr } } -> { let t = rm_abstract t in vernac_solve Goal_select.SelectAll n t def @@ -494,7 +493,7 @@ END VERNAC COMMAND EXTEND VernacTacticNotation | #[ deprecation; locality; ] [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => - { VtSideff [], VtNow } -> + { VtSideff ([], VtNow) } -> { let n = Option.default 0 n in Tacentries.add_tactic_notation (Locality.make_module_locality locality) n ?deprecation r e; @@ -542,7 +541,7 @@ VERNAC COMMAND EXTEND VernacDeclareTacticDefinition | #[ deprecation; locality; ] [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => { VtSideff (List.map (function | TacticDefinition ({CAst.v=r},_) -> r - | TacticRedefinition (qid,_) -> qualid_basename qid) l), VtLater + | TacticRedefinition (qid,_) -> qualid_basename qid) l, VtLater) } -> { Tacentries.register_ltac (Locality.make_module_locality locality) ?deprecation l; } diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 58c8dabd79..62bc2a9259 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -83,7 +83,7 @@ open Obligations let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac -let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]), VtLater) +let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[])) } diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 1a84158df7..1cc333945d 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -277,19 +277,19 @@ VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF add_setoid atts binders a aeq t n } | #[ atts = rewrite_attributes; ] ![ open_proof ] [ "Add" "Morphism" constr(m) ":" ident(n) ] - => { VtStartProof(GuaranteesOpacity, [n]), VtLater } + => { VtStartProof(GuaranteesOpacity, [n]) } -> { if Lib.is_modtype () then CErrors.user_err Pp.(str "Add Morphism cannot be used in a module type. Use Parameter Morphism instead."); add_morphism_interactive atts m n } | #[ atts = rewrite_attributes; ] [ "Declare" "Morphism" constr(m) ":" ident(n) ] - => { VtSideff([n]), VtLater } + => { VtSideff([n], VtLater) } -> { add_morphism_as_parameter atts m n } | #[ atts = rewrite_attributes; ] ![ open_proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { VtStartProof(GuaranteesOpacity,[n]), VtLater } + => { VtStartProof(GuaranteesOpacity,[n]) } -> { add_morphism atts [] m s n } | #[ atts = rewrite_attributes; ] ![ open_proof ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { VtStartProof(GuaranteesOpacity,[n]), VtLater } + => { VtStartProof(GuaranteesOpacity,[n]) } -> { add_morphism atts binders m s n } END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index e0a31e7dba..2da6584aba 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1962,7 +1962,6 @@ let add_setoid atts binders a aeq t n = (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])] - let make_tactic name = let open Tacexpr in let tacqid = Libnames.qualid_of_string name in @@ -1988,14 +1987,14 @@ let add_morphism_as_parameter atts m n : unit = (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst) -let add_morphism_interactive atts m n : Proof_global.t = +let add_morphism_interactive atts m n : Lemmas.t = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in - let kind = Decl_kinds.Global, atts.polymorphic, + let kind = Decl_kinds.Global Decl_kinds.ImportDefaultBehavior, atts.polymorphic, Decl_kinds.DefinitionBody Decl_kinds.Instance in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in @@ -2010,8 +2009,8 @@ let add_morphism_interactive atts m n : Proof_global.t = let hook = Lemmas.mk_hook hook in Flags.silently (fun () -> - let pstate = Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in - fst Pfedit.(by (Tacinterp.interp tac) pstate)) () + let lemma = Lemmas.start_lemma ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in + fst (Lemmas.by (Tacinterp.interp tac) lemma)) () let add_morphism atts binders m s n = init_setoid (); @@ -2023,12 +2022,12 @@ let add_morphism atts binders m s n = [cHole; s; m]) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - let _id, pstate = Classes.new_instance_interactive + let _id, lemma = Classes.new_instance_interactive ~global:atts.global atts.polymorphic instance_name binders instance_t ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in - pstate (* no instance body -> always open proof *) + lemma (* no instance body -> always open proof *) (** Bind to "rewrite" too *) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 3ef33c6dc9..a5c3782b30 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -101,16 +101,16 @@ val add_setoid -> Id.t -> unit -val add_morphism_interactive : rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t +val add_morphism_interactive : rewrite_attributes -> constr_expr -> Id.t -> Lemmas.t val add_morphism_as_parameter : rewrite_attributes -> constr_expr -> Id.t -> unit val add_morphism - : rewrite_attributes + : rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t - -> Proof_global.t + -> Lemmas.t val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 309db539d0..2cc6f9a279 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -12,11 +12,10 @@ open Vernacexpr open Tacexpr -open Attributes (** {5 Tactic Definitions} *) -val register_ltac : locality_flag -> ?deprecation:deprecation -> +val register_ltac : locality_flag -> ?deprecation:Deprecation.t -> Tacexpr.tacdef_body list -> unit (** Adds new Ltac definitions to the environment. *) @@ -36,7 +35,7 @@ type argument = Genarg.ArgT.any Extend.user_symbol leaves. *) val add_tactic_notation : - locality_flag -> int -> ?deprecation:deprecation -> raw_argument + locality_flag -> int -> ?deprecation:Deprecation.t -> raw_argument grammar_tactic_prod_item_expr list -> raw_tactic_expr -> unit (** [add_tactic_notation local level prods expr] adds a tactic notation in the environment at level [level] with locality [local] made of the grammar @@ -49,7 +48,7 @@ val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type - to finding an argument by name (as in {!Genarg}) if there is none matching. *) -val add_ml_tactic_notation : ml_tactic_name -> level:int -> ?deprecation:deprecation -> +val add_ml_tactic_notation : ml_tactic_name -> level:int -> ?deprecation:Deprecation.t -> argument grammar_tactic_prod_item_expr list list -> unit (** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND ML-side macro. *) @@ -80,7 +79,7 @@ type _ ty_sig = type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml val tactic_extend : string -> string -> level:Int.t -> - ?deprecation:deprecation -> ty_ml list -> unit + ?deprecation:Deprecation.t -> ty_ml list -> unit (** {5 ARGUMENT EXTEND} *) diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index d5f22b2c72..3347f594d2 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -55,7 +55,7 @@ type alias = KerName.t type alias_tactic = { alias_args: Id.t list; alias_body: glob_tactic_expr; - alias_deprecation: Attributes.deprecation option; + alias_deprecation: Deprecation.t option; } let alias_map = Summary.ref ~name:"tactic-alias" @@ -121,7 +121,7 @@ type ltac_entry = { tac_for_ml : bool; tac_body : glob_tactic_expr; tac_redef : ModPath.t list; - tac_deprecation : Attributes.deprecation option + tac_deprecation : Deprecation.t option } let mactab = @@ -178,7 +178,7 @@ let subst_md (subst, (local, id, b, t, deprecation)) = let classify_md (local, _, _, _, _ as o) = Substitute o let inMD : bool * ltac_constant option * bool * glob_tactic_expr * - Attributes.deprecation option -> obj = + Deprecation.t option -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index 5b98daf383..2fc45760d1 100644 --- a/plugins/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli @@ -12,7 +12,6 @@ open Names open Libnames open Tacexpr open Geninterp -open Attributes (** This module centralizes the various ways of registering tactics. *) @@ -33,7 +32,7 @@ type alias = KerName.t type alias_tactic = { alias_args: Id.t list; alias_body: glob_tactic_expr; - alias_deprecation: deprecation option; + alias_deprecation: Deprecation.t option; } (** Contents of a tactic notation *) @@ -48,7 +47,7 @@ val check_alias : alias -> bool (** {5 Coq tactic definitions} *) -val register_ltac : bool -> bool -> ?deprecation:deprecation -> Id.t -> +val register_ltac : bool -> bool -> ?deprecation:Deprecation.t -> Id.t -> glob_tactic_expr -> unit (** Register a new Ltac with the given name and body. @@ -57,7 +56,7 @@ val register_ltac : bool -> bool -> ?deprecation:deprecation -> Id.t -> definition. It also puts the Ltac name in the nametab, so that it can be used unqualified. *) -val redefine_ltac : bool -> ?deprecation:deprecation -> KerName.t -> +val redefine_ltac : bool -> ?deprecation:Deprecation.t -> KerName.t -> glob_tactic_expr -> unit (** Replace a Ltac with the given name and body. If the boolean flag is set to true, then this is a local redefinition. *) @@ -68,7 +67,7 @@ val interp_ltac : KerName.t -> glob_tactic_expr val is_ltac_for_ml_tactic : KerName.t -> bool (** Whether the tactic is defined from ML-side *) -val tac_deprecation : KerName.t -> deprecation option +val tac_deprecation : KerName.t -> Deprecation.t option (** The tactic deprecation notice, if any *) type ltac_entry = { @@ -78,7 +77,7 @@ type ltac_entry = { (** The current body of the tactic *) tac_redef : ModPath.t list; (** List of modules redefining the tactic in reverse chronological order *) - tac_deprecation : deprecation option; + tac_deprecation : Deprecation.t option; (** Deprecation notice to be printed when the tactic is used *) } diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index c1f7fab123..7434f81946 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -119,18 +119,13 @@ let intern_constr_reference strict ist qid = (* Internalize an isolated reference in position of tactic *) let warn_deprecated_tactic = - CWarnings.create ~name:"deprecated-tactic" ~category:"deprecated" - (fun (qid,depr) -> str "Tactic " ++ pr_qualid qid ++ - strbrk " is deprecated" ++ - pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ - str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) + Deprecation.create_warning ~object_name:"Tactic" ~warning_name:"deprecated-tactic" + pr_qualid let warn_deprecated_alias = - CWarnings.create ~name:"deprecated-tactic-notation" ~category:"deprecated" - (fun (kn,depr) -> str "Tactic Notation " ++ Pptactic.pr_alias_key kn ++ - strbrk " is deprecated since" ++ - pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ - str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) + Deprecation.create_warning ~object_name:"Tactic Notation" + ~warning_name:"deprecated-tactic-notation" + Pptactic.pr_alias_key let intern_isolated_global_tactic_reference qid = let loc = qid.CAst.loc in diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 66b47a64a7..0662354daf 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -42,11 +42,11 @@ let get_goal_context_gen pf i = (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) let get_goal_context pf i = - let p = Proof_global.give_me_the_proof pf in + let p = Proof_global.get_proof pf in get_goal_context_gen p i let get_current_goal_context pf = - let p = Proof_global.give_me_the_proof pf in + let p = Proof_global.get_proof pf in try get_goal_context_gen p 1 with | NoSuchGoal -> @@ -57,7 +57,7 @@ let get_current_goal_context pf = Evd.from_env env, env let get_current_context pf = - let p = Proof_global.give_me_the_proof pf in + let p = Proof_global.get_proof pf in try get_goal_context_gen p 1 with | NoSuchGoal -> @@ -108,7 +108,7 @@ let solve ?with_end_tac gi info_lvl tac pr = in (p,status) -let by tac = Proof_global.with_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) +let by tac = Proof_global.map_fold_proof (solve (Goal_select.SelectNth 1) None tac) (**********************************************************************) (* Shortcut to build a term using tactics *) @@ -117,15 +117,14 @@ open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n -let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac = +let build_constant_by_tactic id ctx sign ?(goal_kind = Global ImportDefaultBehavior, false, Proof Theorem) typ tac = let evd = Evd.from_ctx ctx in - let terminator = Proof_global.make_terminator (fun _ -> ()) in let goals = [ (Global.env_of_context sign , typ) ] in - let pf = Proof_global.start_proof evd id goal_kind goals terminator in + let pf = Proof_global.start_proof evd id goal_kind goals in try let pf, status = by tac pf in let open Proof_global in - let { entries; universes } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in + let { entries; universes } = close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> let univs = UState.demote_seff_univs entry universes in @@ -139,13 +138,13 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = let id = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in - let gk = Global, poly, Proof Theorem in + let gk = Global ImportDefaultBehavior, poly, Proof Theorem in let ce, status, univs = build_constant_by_tactic id sigma sign ~goal_kind:gk typ tac in - let body = Future.force ce.const_entry_body in + let body, eff = Future.force ce.const_entry_body in let (cb, ctx) = - if side_eff then Safe_typing.inline_private_constants env body - else fst body + if side_eff then Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) + else body in let univs = UState.merge ~sideff:side_eff ~extend:true Evd.univ_rigid univs ctx in cb, status, univs @@ -196,5 +195,6 @@ let refine_by_tactic ~name ~poly env sigma ty tac = other goals that were already present during its invocation, so that those goals rely on effects that are not present anymore. Hopefully, this hack will work in most cases. *) + let neff = neff.Evd.seff_private in let (ans, _) = Safe_typing.inline_private_constants env ((ans, Univ.ContextSet.empty), neff) in ans, sigma diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 77d701b41f..63d5adfcd2 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -61,7 +61,7 @@ val use_unification_heuristics : unit -> bool val build_constant_by_tactic : Id.t -> UState.t -> named_context_val -> ?goal_kind:goal_kind -> EConstr.types -> unit Proofview.tactic -> - Safe_typing.private_constants Entries.definition_entry * bool * + Evd.side_effects Entries.definition_entry * bool * UState.t val build_by_tactic : ?side_eff:bool -> env -> UState.t -> ?poly:polymorphic -> diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index b642e8eea7..96d90e9252 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -29,74 +29,31 @@ type lemma_possible_guards = int list list type proof_object = { id : Names.Id.t; - entries : Safe_typing.private_constants Entries.definition_entry list; + entries : Evd.side_effects Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: UState.t; } type opacity_flag = Opaque | Transparent -type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t - | Proved of opacity_flag * - lident option * - proof_object - -type proof_terminator = proof_ending -> unit -type closed_proof = proof_object * proof_terminator - -type t = { - terminator : proof_terminator CEphemeron.key; - endline_tactic : Genarg.glob_generic_argument option; - section_vars : Constr.named_context option; - proof : Proof.t; - universe_decl: UState.universe_decl; - strength : Decl_kinds.goal_kind; -} - -(* The head of [t] is the actual current proof, the other ones are - to be resumed when the current proof is closed or aborted. *) -type stack = t * t list - -let pstate_map f (pf, pfl) = (f pf, List.map f pfl) - -let make_terminator f = f -let apply_terminator f = f - -let get_current_pstate (ps,_) = ps - -(* combinators for the current_proof lists *) -let push ~ontop a = - match ontop with - | None -> a , [] - | Some (l,ls) -> a, (l :: ls) - -let maybe_push ~ontop = function - | Some pstate -> Some (push ~ontop pstate) - | None -> ontop +type t = + { endline_tactic : Genarg.glob_generic_argument option + ; section_vars : Constr.named_context option + ; proof : Proof.t + ; universe_decl: UState.universe_decl + ; strength : Decl_kinds.goal_kind + } (*** Proof Global manipulation ***) -let get_all_proof_names (pf : stack) = - let (pn, pns) = pstate_map Proof.(function pf -> (data pf.proof).name) pf in - pn :: pns - -let give_me_the_proof ps = ps.proof -let get_current_proof_name ps = (Proof.data ps.proof).Proof.name -let get_current_persistence ps = ps.strength - -let with_current_pstate f (ps,psl) = - let ps, ret = f ps in - (ps, psl), ret +let get_proof ps = ps.proof +let get_proof_name ps = (Proof.data ps.proof).Proof.name +let get_persistence ps = ps.strength -let modify_current_pstate f (ps,psl) = - f ps, psl +let map_proof f p = { p with proof = f p.proof } +let map_fold_proof f p = let proof, res = f p.proof in { p with proof }, res -let modify_proof f ps = - let proof = f ps.proof in - {ps with proof} - -let with_proof f ps = +let map_fold_proof_endline f ps = let et = match ps.endline_tactic with | None -> Proofview.tclUNIT () @@ -111,37 +68,13 @@ let with_proof f ps = let ps = { ps with proof = newpr } in ps, ret -let with_current_proof f (ps,rest) = - let ps, ret = with_proof f ps in - (ps, rest), ret - -let simple_with_current_proof f pf = - let p, () = with_current_proof (fun t p -> f t p , ()) pf in p - -let simple_with_proof f ps = - let ps, () = with_proof (fun t ps -> f t ps, ()) ps in ps - -let compact_the_proof pf = simple_with_proof (fun _ -> Proof.compact) pf +let compact_the_proof pf = map_proof Proof.compact pf (* Sets the tactic to be used when a tactic line is closed with [...] *) let set_endline_tactic tac ps = { ps with endline_tactic = Some tac } -let pf_name_eq id ps = - let Proof.{ name } = Proof.data ps.proof in - Id.equal name id - -let discard {CAst.loc;v=id} (ps, psl) = - match List.filter (fun pf -> not (pf_name_eq id pf)) (ps :: psl) with - | [] -> None - | ps :: psl -> Some (ps, psl) - -let discard_current (_, psl) = - match psl with - | [] -> None - | ps :: psl -> Some (ps, psl) - -(** [start_proof sigma id pl str goals terminator] starts a proof of name +(** [start_proof sigma id pl str goals] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is (spiwack: for potential printing, I believe is used only by @@ -149,21 +82,21 @@ let discard_current (_, psl) = end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator = - { terminator = CEphemeron.create terminator; - proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; - endline_tactic = None; - section_vars = None; - universe_decl = pl; - strength = kind } - -let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = - { terminator = CEphemeron.create terminator; - proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; - endline_tactic = None; - section_vars = None; - universe_decl = pl; - strength = kind } +let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals = + { proof = Proof.start ~name ~poly:(pi2 kind) sigma goals + ; endline_tactic = None + ; section_vars = None + ; universe_decl = pl + ; strength = kind + } + +let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals = + { proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals + ; endline_tactic = None + ; section_vars = None + ; universe_decl = pl + ; strength = kind + } let get_used_variables pf = pf.section_vars let get_universe_decl pf = pf.universe_decl @@ -201,7 +134,7 @@ let get_open_goals ps = (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + List.length shelf -type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t +type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t let private_poly_univs = let b = ref true in @@ -217,7 +150,7 @@ let private_poly_univs = let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now (fpl : closed_proof_output Future.computation) ps = - let { section_vars; proof; terminator; universe_decl; strength } = ps in + let { section_vars; proof; universe_decl; strength } = ps in let Proof.{ name; poly; entry; initial_euctx } = Proof.data proof in let opaque = match opaque with Opaque -> true | Transparent -> false in let constrain_variables ctx = @@ -239,7 +172,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now let body = c in let allow_deferred = not poly && (keep_body_ucst_separate || - not (Safe_typing.empty_private_constants = eff)) + not (Safe_typing.empty_private_constants = eff.Evd.seff_private)) in let typ = if allow_deferred then t else nf t in let used_univs_body = Vars.universes_of_constr body in @@ -312,8 +245,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now in let entries = Future.map2 entry_fn fpl Proofview.(initial_goals entry) in { id = name; entries = entries; persistence = strength; - universes }, - fun pr_ending -> CEphemeron.get terminator pr_ending + universes } let return_proof ?(allow_partial=false) ps = let { proof } = ps in @@ -351,22 +283,9 @@ let close_proof ~opaque ~keep_body_ucst_separate fix_exn ps = close_proof ~opaque ~keep_body_ucst_separate ~now:true (Future.from_val ~fix_exn (return_proof ps)) ps -(** Gets the current terminator without checking that the proof has - been completed. Useful for the likes of [Admitted]. *) -let get_terminator ps = CEphemeron.get ps.terminator -let set_terminator hook ps = - { ps with terminator = CEphemeron.create hook } - -let copy_terminators ~src ~tgt = - let (ps, psl), (ts,tsl) = src, tgt in - assert(List.length psl = List.length tsl); - {ts with terminator = ps.terminator}, List.map2 (fun op p -> { p with terminator = op.terminator }) psl tsl - -let update_global_env pf = - let res, () = - with_proof (fun _ p -> - Proof.in_proof p (fun sigma -> - let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in - let (p,(status,info),()) = Proof.run_tactic (Global.env ()) tac p in - (p, ()))) pf - in res +let update_global_env = + map_proof (fun p -> + Proof.in_proof p (fun sigma -> + let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in + let p,(status,info),_ = Proof.run_tactic (Global.env ()) tac p in + p)) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index aff48b9636..f84ec27df7 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,18 +13,16 @@ environment. *) type t -type stack -val get_current_pstate : stack -> t - -val get_current_proof_name : t -> Names.Id.t -val get_current_persistence : t -> Decl_kinds.goal_kind -val get_all_proof_names : stack -> Names.Id.t list +(* Should be moved into a proper view *) +val get_proof : t -> Proof.t +val get_proof_name : t -> Names.Id.t +val get_persistence : t -> Decl_kinds.goal_kind +val get_used_variables : t -> Constr.named_context option -val discard : Names.lident -> stack -> stack option -val discard_current : stack -> stack option +(** Get the universe declaration associated to the current proof. *) +val get_universe_decl : t -> UState.universe_decl -val give_me_the_proof : t -> Proof.t val compact_the_proof : t -> t (** When a proof is closed, it is reified into a [proof_object], where @@ -37,30 +35,14 @@ type lemma_possible_guards = int list list type proof_object = { id : Names.Id.t; - entries : Safe_typing.private_constants Entries.definition_entry list; + entries : Evd.side_effects Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: UState.t; } type opacity_flag = Opaque | Transparent -type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * - UState.t - | Proved of opacity_flag * - Names.lident option * - proof_object -type proof_terminator -type closed_proof = proof_object * proof_terminator - -val make_terminator : (proof_ending -> unit) -> proof_terminator -val apply_terminator : proof_terminator -> proof_ending -> unit - -val push : ontop:stack option -> t -> stack - -val maybe_push : ontop:stack option -> t option -> stack option - -(** [start_proof ~ontop id str pl goals terminator] starts a proof of name +(** [start_proof id str pl goals] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is; [terminator] is used at the end of the proof to close the proof @@ -68,16 +50,22 @@ val maybe_push : ontop:stack option -> t option -> stack option morphism). The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -val start_proof : - Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> - Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> - proof_terminator -> t +val start_proof + : Evd.evar_map + -> Names.Id.t + -> ?pl:UState.universe_decl + -> Decl_kinds.goal_kind + -> (Environ.env * EConstr.types) list + -> t (** Like [start_proof] except that there may be dependencies between initial goals. *) -val start_dependent_proof : - Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> - Proofview.telescope -> proof_terminator -> t +val start_dependent_proof + : Names.Id.t + -> ?pl:UState.universe_decl + -> Decl_kinds.goal_kind + -> Proofview.telescope + -> t (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes @@ -86,40 +74,25 @@ val update_global_env : t -> t (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> - t -> closed_proof +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> t -> proof_object (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be * chained with a computation that completed the proof *) -type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t +type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) val return_proof : ?allow_partial:bool -> t -> closed_proof_output val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> t -> - closed_proof_output Future.computation -> closed_proof + closed_proof_output Future.computation -> proof_object -(** Gets the current terminator without checking that the proof has - been completed. Useful for the likes of [Admitted]. *) -val get_terminator : t -> proof_terminator -val set_terminator : proof_terminator -> t -> t val get_open_goals : t -> int -(** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is - no current proof. - The return boolean is set to [false] if an unsafe tactic has been used. *) -val with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> stack -> stack * 'a -val simple_with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t) -> stack -> stack - -val with_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a -val modify_proof : (Proof.t -> Proof.t) -> t -> t - -val with_current_pstate : (t -> t * 'a) -> stack -> stack * 'a -val modify_current_pstate : (t -> t) -> stack -> stack +val map_proof : (Proof.t -> Proof.t) -> t -> t +val map_fold_proof : (Proof.t -> Proof.t * 'a) -> t -> t * 'a +val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a (** Sets the tactic to be used when a tactic line is closed with [...] *) val set_endline_tactic : Genarg.glob_generic_argument -> t -> t @@ -129,10 +102,3 @@ val set_endline_tactic : Genarg.glob_generic_argument -> t -> t * ids to be cleared *) val set_used_variables : t -> Names.Id.t list -> (Constr.named_context * Names.lident list) * t - -val get_used_variables : t -> Constr.named_context option - -(** Get the universe declaration associated to the current proof. *) -val get_universe_decl : t -> UState.universe_decl - -val copy_terminators : src:stack -> tgt:stack -> stack diff --git a/proofs/refine.ml b/proofs/refine.ml index 4a9404aa96..d0e89183a8 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -60,7 +60,7 @@ let generic_refine ~typecheck f gl = let evs = Evd.save_future_goals sigma in (* Redo the effects in sigma in the monad's env *) let privates_csts = Evd.eval_side_effects sigma in - let env = Safe_typing.push_private_constants env privates_csts in + let env = Safe_typing.push_private_constants env privates_csts.Evd.seff_private in (* Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in @@ -116,9 +116,6 @@ let lift c = let make_refine_enter ~typecheck f gl = generic_refine ~typecheck (lift f) gl -let refine_one ~typecheck f = - Proofview.Goal.enter_one (make_refine_enter ~typecheck f) - let refine ~typecheck f = let f evd = let (evd,c) = f evd in (evd,((), c)) diff --git a/proofs/refine.mli b/proofs/refine.mli index b8948a92f3..93fd9d7a64 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -27,9 +27,6 @@ val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> uni raised during the interpretation of [t] are caught and result in tactic failures. If [typecheck] is [true] [t] is type-checked beforehand. *) -val refine_one : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr.t)) -> 'a tactic -(** A variant of [refine] which assumes exactly one goal under focus *) - val generic_refine : typecheck:bool -> ('a * EConstr.t) tactic -> Proofview.Goal.t -> 'a tactic (** The general version of refine. *) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 799f4a380b..557f428be9 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -129,9 +129,6 @@ let tclTHENSLASTn tac1 tac taci = tclTHENS3PARTS tac1 [||] tac taci let tclTHEN_i tac taci gls = finish_tac (thensi_tac taci (then_tac tac (start_tac gls))) -let tclTHENLASTn tac1 taci = tclTHENSLASTn tac1 tclIDTAC taci -let tclTHENFIRSTn tac1 taci = tclTHENSFIRSTn tac1 taci tclIDTAC - (* [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) let tclTHEN tac1 tac2 = tclTHENS3PARTS tac1 [||] tac2 [||] @@ -253,46 +250,9 @@ let rec tclFIRST = function | [] -> tclFAIL_s "No applicable tactic." | t::rest -> tclORELSE0 t (tclFIRST rest) -let ite_gen tcal tac_if continue tac_else gl= - let success=ref false in - let tac_if0 gl= - let result=tac_if gl in - success:=true;result in - let tac_else0 e gl= - if !success then - iraise e - else - try - tac_else gl - with - e' when CErrors.noncritical e' -> iraise e in - try - tcal tac_if0 continue gl - with (* Breakpoint *) - | e when CErrors.noncritical e -> - let e = CErrors.push e in catch_failerror e; tac_else0 e gl - -(* Try the first tactic and, if it succeeds, continue with - the second one, and if it fails, use the third one *) - -let tclIFTHENELSE=ite_gen tclTHEN - -(* Idem with tclTHENS and tclTHENSV *) - -let tclIFTHENSELSE=ite_gen tclTHENS - -let tclIFTHENSVELSE=ite_gen tclTHENSV - -let tclIFTHENTRYELSEMUST tac1 tac2 gl = - tclIFTHENELSE tac1 (tclTRY tac2) tac2 gl - (* Fails if a tactic did not solve the goal *) let tclCOMPLETE tac = tclTHEN tac (tclFAIL_s "Proof is not complete.") -(* Try the first that solves the current goal *) -let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) - - (* Iteration tacticals *) let tclDO n t = @@ -311,22 +271,7 @@ let rec tclREPEAT t g = let tclAT_LEAST_ONCE t = (tclTHEN t (tclREPEAT t)) -(* Repeat on the first subgoal (no failure if no more subgoal) *) -let rec tclREPEAT_MAIN t g = - (tclORELSE (tclTHEN_i t (fun i -> if Int.equal i 1 then (tclREPEAT_MAIN t) else - tclIDTAC)) tclIDTAC) g - (* Change evars *) let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} - -let tclEVARUNIVCONTEXT ctx gls = tclIDTAC {gls with sigma= Evd.set_universe_context gls.sigma ctx} - -(* Push universe context *) -let tclPUSHCONTEXT rigid ctx tac gl = - tclTHEN (tclEVARS (Evd.merge_context_set rigid (project gl) ctx)) tac gl - let tclPUSHEVARUNIVCONTEXT ctx gl = tclEVARS (Evd.merge_universe_context (project gl) ctx) gl - -let tclPUSHCONSTRAINTS cst gl = - tclEVARS (Evd.add_constraints (project gl) cst) gl diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 52cbf7658b..0f34a79c49 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -32,12 +32,8 @@ val tclIDTAC_MESSAGE : Pp.t -> tactic (** [tclEVARS sigma] changes the current evar map *) val tclEVARS : evar_map -> tactic -val tclEVARUNIVCONTEXT : UState.t -> tactic - -val tclPUSHCONTEXT : Evd.rigid -> Univ.ContextSet.t -> tactic -> tactic val tclPUSHEVARUNIVCONTEXT : UState.t -> tactic -val tclPUSHCONSTRAINTS : Univ.Constraint.t -> tactic (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) @@ -86,16 +82,6 @@ val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic [tac2] for the remaining last subgoals (previously called tclTHENST) *) val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic -(** [tclTHENLASTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then, - applies [t1],...,[tn] on the last [n] resulting subgoals and leaves - unchanged the other subgoals *) -val tclTHENLASTn : tactic -> tactic array -> tactic - -(** [tclTHENFIRSTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then, - applies [t1],...,[tn] on the first [n] resulting subgoals and leaves - unchanged the other subgoals (previously called [tclTHENSI]) *) -val tclTHENFIRSTn : tactic -> tactic array -> tactic - (** A special exception for levels for the Fail tactic *) exception FailError of int * Pp.t Lazy.t @@ -106,9 +92,7 @@ val catch_failerror : Exninfo.iexn -> unit val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclREPEAT : tactic -> tactic -val tclREPEAT_MAIN : tactic -> tactic val tclFIRST : tactic list -> tactic -val tclSOLVE : tactic list -> tactic val tclTRY : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclCOMPLETE : tactic -> tactic @@ -118,16 +102,3 @@ val tclFAIL_lazy : int -> Pp.t Lazy.t -> tactic val tclDO : int -> tactic -> tactic val tclPROGRESS : tactic -> tactic val tclSHOWHYPS : tactic -> tactic - -(** [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then, - if it succeeds, applies [tac2] to the resulting subgoals, - and if not applies [tac3] to the initial goal [gls] *) -val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic -val tclIFTHENSELSE : tactic -> tactic list -> tactic ->tactic -val tclIFTHENSVELSE : tactic -> tactic array -> tactic ->tactic - -(** [tclIFTHENTRYELSEMUST tac1 tac2 gls] applies [tac1] then [tac2]. If [tac1] - has been successful, then [tac2] may fail. Otherwise, [tac2] must succeed. - Equivalent to [(tac1;try tac2)||tac2] *) - -val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 93031c2202..d7b4f729cb 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -81,12 +81,10 @@ let pf_type_of = pf_reduce type_of let pf_get_type_of = pf_reduce Retyping.get_type_of let pf_conv_x gl = pf_reduce test_conversion gl Reduction.CONV -let pf_conv_x_leq gl = pf_reduce test_conversion gl Reduction.CUMUL let pf_const_value = pf_reduce (fun env _ c -> EConstr.of_constr (constant_value_in env c)) let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind - let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls (* Pretty-printers *) @@ -181,14 +179,7 @@ module New = struct let pf_hnf_type_of gl t = pf_whd_all gl (pf_get_type_of gl t) - let pf_whd_all gl t = pf_apply whd_all gl t let pf_compute gl t = pf_apply compute gl t let pf_nf_evar gl t = nf_evar (project gl) t - - let pf_undefined_evars gl = - let sigma = Proofview.Goal.sigma gl in - let ev = Proofview.Goal.goal gl in - let evi = Evd.find sigma ev in - Evarutil.filtered_undefined_evars_of_evar_info sigma evi end diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 23e1e6f566..195be04986 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -64,7 +64,6 @@ val pf_unfoldn : (occurrences * evaluable_global_reference) list val pf_const_value : Goal.goal sigma -> pconstant -> constr val pf_conv_x : Goal.goal sigma -> constr -> constr -> bool -val pf_conv_x_leq : Goal.goal sigma -> constr -> constr -> bool (** {6 Pretty-printing functions (debug only). } *) val pr_gls : Goal.goal sigma -> Pp.t @@ -109,11 +108,8 @@ module New : sig val pf_hnf_constr : Proofview.Goal.t -> constr -> types val pf_hnf_type_of : Proofview.Goal.t -> constr -> types - val pf_whd_all : Proofview.Goal.t -> constr -> constr val pf_compute : Proofview.Goal.t -> constr -> constr val pf_nf_evar : Proofview.Goal.t -> constr -> constr - (** Gathers the undefined evars of the given goal. *) - val pf_undefined_evars : Proofview.Goal.t -> Evar.Set.t end diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index dfa681395a..7ff6ed9dfb 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -48,15 +48,14 @@ let simple_goal sigma g gs = let is_focused_goal_simple ~doc id = match state_of_id ~doc id with | `Expired | `Error _ | `Valid None -> `Not - | `Valid (Some { Vernacstate.proof }) -> - Option.cata (fun proof -> - let proof = Proof_global.get_current_pstate proof in - let proof = Proof_global.give_me_the_proof proof in + | `Valid (Some { Vernacstate.lemmas }) -> + Option.cata (Lemmas.Stack.with_top_pstate ~f:(fun proof -> + let proof = Proof_global.get_proof proof in let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in if List.for_all (fun x -> simple_goal sigma x rest) focused then `Simple focused - else `Not) `Not proof + else `Not)) `Not lemmas type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] diff --git a/stm/stm.ml b/stm/stm.ml index 5baa6ce251..d77e37c910 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -881,7 +881,7 @@ end = struct (* {{{ *) let invalidate_cur_state () = cur_id := Stateid.dummy type proof_part = - Proof_global.stack option * + Lemmas.Stack.t option * int * (* Evarutil.meta_counter_summary_tag *) int * (* Evd.evar_counter_summary_tag *) Obligations.program_info Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) @@ -890,9 +890,9 @@ end = struct (* {{{ *) [ `Full of Vernacstate.t | `ProofOnly of Stateid.t * proof_part ] - let proof_part_of_frozen { Vernacstate.proof; system } = + let proof_part_of_frozen { Vernacstate.lemmas; system } = let st = States.summary_of_state system in - proof, + lemmas, Summary.project_from_summary st Util.(pi1 summary_pstate), Summary.project_from_summary st Util.(pi2 summary_pstate), Summary.project_from_summary st Util.(pi3 summary_pstate) @@ -956,17 +956,17 @@ end = struct (* {{{ *) try let prev = (VCS.visit id).next in if is_cached_and_valid prev - then { s with proof = + then { s with lemmas = PG_compat.copy_terminators - ~src:((get_cached prev).proof) ~tgt:s.proof } + ~src:((get_cached prev).lemmas) ~tgt:s.lemmas } else s with VCS.Expired -> s in VCS.set_state id (FullState s) | `ProofOnly(ontop,(pstate,c1,c2,c3)) -> if is_cached_and_valid ontop then let s = get_cached ontop in - let s = { s with proof = - PG_compat.copy_terminators ~src:s.proof ~tgt:pstate } in + let s = { s with lemmas = + PG_compat.copy_terminators ~src:s.lemmas ~tgt:pstate } in let s = { s with system = States.replace_summary s.system begin @@ -1168,9 +1168,7 @@ end = struct (* {{{ *) let get_proof ~doc id = match state_of_id ~doc id with - | `Valid (Some vstate) -> - Option.map (fun p -> Proof_global.(give_me_the_proof (get_current_pstate p))) - vstate.Vernacstate.proof + | `Valid (Some vstate) -> Option.map (Lemmas.Stack.with_top_pstate ~f:Proof_global.get_proof) vstate.Vernacstate.lemmas | _ -> None let undo_vernac_classifier v ~doc = @@ -1565,7 +1563,7 @@ end = struct (* {{{ *) let perform_states query = if query = [] then [] else let is_tac e = match Vernac_classifier.classify_vernac e with - | VtProofStep _, _ -> true + | VtProofStep _ -> true | _ -> false in let initial = @@ -1675,14 +1673,17 @@ end = struct (* {{{ *) let _proof = PG_compat.return_proof ~allow_partial:true () in `OK_ADMITTED else begin - (* The original terminator, a hook, has not been saved in the .vio*) - PG_compat.set_terminator (Lemmas.standard_proof_terminator []); - let opaque = Proof_global.Opaque in - let proof = + + (* The original terminator, a hook, has not been saved in the .vio*) + let pterm, _invalid_terminator = PG_compat.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in + + let proof = pterm , Lemmas.standard_proof_terminator [] in + (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) + Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false start; (* STATE SPEC: * - start: First non-expired state! [This looks very fishy] @@ -1939,7 +1940,7 @@ end = struct (* {{{ *) "goals only")) else begin let (i, ast) = r_ast in - PG_compat.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); + PG_compat.map_proof (fun p -> Proof.focus focus_cond () i p); (* STATE SPEC: * - start : id * - return: id @@ -1995,7 +1996,7 @@ end = struct (* {{{ *) stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> TaskQueue.with_n_workers nworkers (fun queue -> - PG_compat.simple_with_current_proof (fun _ p -> + PG_compat.map_proof (fun p -> let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> @@ -2310,8 +2311,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = Proofview.give_up else Proofview.tclUNIT () end in match (VCS.get_info base_state).state with - | FullState { Vernacstate.proof } -> - Option.iter PG_compat.unfreeze proof; + | FullState { Vernacstate.lemmas } -> + Option.iter PG_compat.unfreeze lemmas; PG_compat.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); @@ -2859,12 +2860,12 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) " classified as: " ^ Vernac_classifier.string_of_vernac_classification c); match c with (* Meta *) - | VtMeta, _ -> + | VtMeta -> let id = Backtrack.undo_vernac_classifier expr ~doc in process_back_meta_command ~newtip ~head id x (* Query *) - | VtQuery, w -> + | VtQuery -> let id = VCS.new_node ~id:newtip proof_mode () in let queue = if VCS.is_vio_doc () && @@ -2874,10 +2875,10 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) else `MainQueue in VCS.commit id (mkTransCmd x [] false queue); VCS.set_parsing_state id head_parsing; - Backtrack.record (); assert (w == VtLater); `Ok + Backtrack.record (); `Ok (* Proof *) - | VtStartProof (guarantee, names), w -> + | VtStartProof (guarantee, names) -> if not (get_allow_nested_proofs ()) && VCS.proof_nesting () > 0 then "Nested proofs are not allowed unless you turn option Nested Proofs Allowed on." @@ -2899,9 +2900,9 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) VCS.merge id ~ours:(Fork (x, bname, guarantee, names)) head end; VCS.set_parsing_state id head_parsing; - Backtrack.record (); assert (w == VtLater); `Ok + Backtrack.record (); `Ok - | VtProofStep { parallel; proof_block_detection = cblock }, w -> + | VtProofStep { parallel; proof_block_detection = cblock } -> let id = VCS.new_node ~id:newtip proof_mode () in let queue = match parallel with @@ -2913,18 +2914,18 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) detection should occur here. detect_proof_block id cblock; *) VCS.set_parsing_state id head_parsing; - Backtrack.record (); assert (w == VtLater); `Ok + Backtrack.record (); `Ok - | VtQed keep, w -> + | VtQed keep -> let valid = VCS.get_branch_pos head in let rc = merge_proof_branch ~valid ~id:newtip x keep head in VCS.checkout_shallowest_proof_branch (); - Backtrack.record (); assert (w == VtLater); + Backtrack.record (); rc (* Side effect in a (still open) proof is replayed on all branches*) - | VtSideff l, w -> + | VtSideff (l, w) -> let id = VCS.new_node ~id:newtip proof_mode () in let new_ids = match (VCS.get_branch head).VCS.kind with @@ -2960,15 +2961,13 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) VCS.set_parsing_state id parsing_state) new_ids; `Ok - | VtProofMode pm, VtNow -> + | VtProofMode pm -> let proof_mode = Pvernac.lookup_proof_mode pm in let id = VCS.new_node ~id:newtip proof_mode () in VCS.commit id (mkTransCmd x [] false `MainQueue); VCS.set_parsing_state id head_parsing; Backtrack.record (); `Ok - | VtProofMode _, VtLater -> - anomaly(str"classifier: VtProofMode must imply VtNow.") end in let pr_rc rc = match rc with | `Ok -> Pp.(seq [str "newtip ("; str (Stateid.to_string (VCS.cur_tip ())); str ")"]) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index aa16f9535d..cfeca1fa62 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -20,9 +20,13 @@ let string_of_parallel = function "par" ^ if solve then "solve" else "" ^ if abs then "abs" else "" | `No -> "" -let string_of_vernac_type = function +let string_of_vernac_when = function + | VtLater -> "Later" + | VtNow -> "Now" + +let string_of_vernac_classification = function | VtStartProof _ -> "StartProof" - | VtSideff _ -> "Sideff" + | VtSideff (_,w) -> "Sideff"^" "^(string_of_vernac_when w) | VtQed (VtKeep VtKeepAxiom) -> "Qed(admitted)" | VtQed (VtKeep (VtKeepOpaque | VtKeepDefined)) -> "Qed(keep)" | VtQed VtDrop -> "Qed(drop)" @@ -33,13 +37,6 @@ let string_of_vernac_type = function | VtMeta -> "Meta " | VtProofMode _ -> "Proof Mode" -let string_of_vernac_when = function - | VtLater -> "Later" - | VtNow -> "Now" - -let string_of_vernac_classification (t,w) = - string_of_vernac_type t ^ " " ^ string_of_vernac_when w - let vtkeep_of_opaque = let open Proof_global in function | Opaque -> VtKeepOpaque | Transparent -> VtKeepDefined @@ -67,15 +64,15 @@ let classify_vernac e = | VernacSetOption (_, l,_) when CList.exists (CList.equal String.equal l) options_affecting_stm_scheduling -> - VtSideff [], VtNow + VtSideff ([], VtNow) (* Qed *) - | VernacAbort _ -> VtQed VtDrop, VtLater - | VernacEndProof Admitted -> VtQed (VtKeep VtKeepAxiom), VtLater - | VernacEndProof (Proved (opaque,_)) -> VtQed (VtKeep (vtkeep_of_opaque opaque)), VtLater - | VernacExactProof _ -> VtQed (VtKeep VtKeepOpaque), VtLater + | VernacAbort _ -> VtQed VtDrop + | VernacEndProof Admitted -> VtQed (VtKeep VtKeepAxiom) + | VernacEndProof (Proved (opaque,_)) -> VtQed (VtKeep (vtkeep_of_opaque opaque)) + | VernacExactProof _ -> VtQed (VtKeep VtKeepOpaque) (* Query *) | VernacShow _ | VernacPrint _ | VernacSearch _ | VernacLocate _ - | VernacCheckMayEval _ -> VtQuery, VtLater + | VernacCheckMayEval _ -> VtQuery (* ProofStep *) | VernacProof _ | VernacFocus _ | VernacUnfocus @@ -83,27 +80,25 @@ let classify_vernac e = | VernacCheckGuard | VernacUnfocused | VernacSolveExistential _ -> - VtProofStep { parallel = `No; proof_block_detection = None }, VtLater + VtProofStep { parallel = `No; proof_block_detection = None } | VernacBullet _ -> - VtProofStep { parallel = `No; proof_block_detection = Some "bullet" }, - VtLater + VtProofStep { parallel = `No; proof_block_detection = Some "bullet" } | VernacEndSubproof -> VtProofStep { parallel = `No; - proof_block_detection = Some "curly" }, - VtLater + proof_block_detection = Some "curly" } (* StartProof *) | VernacDefinition ((Decl_kinds.DoDischarge,_),({v=i},_),ProveBody _) -> - VtStartProof(Doesn'tGuaranteeOpacity, idents_of_name i), VtLater + VtStartProof(Doesn'tGuaranteeOpacity, idents_of_name i) | VernacDefinition (_,({v=i},_),ProveBody _) -> let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof(guarantee, idents_of_name i), VtLater + VtStartProof(guarantee, idents_of_name i) | VernacStartTheoremProof (_,l) -> let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let ids = List.map (fun (({v=i}, _), _) -> i) l in let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof (guarantee,ids), VtLater + VtStartProof (guarantee,ids) | VernacFixpoint (discharge,l) -> let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let guarantee = @@ -114,8 +109,8 @@ let classify_vernac e = List.fold_left (fun (l,b) ((({v=id},_),_,_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (guarantee,ids), VtLater - else VtSideff ids, VtLater + then VtStartProof (guarantee,ids) + else VtSideff (ids, VtLater) | VernacCoFixpoint (discharge,l) -> let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let guarantee = @@ -126,15 +121,15 @@ let classify_vernac e = List.fold_left (fun (l,b) ((({v=id},_),_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (guarantee,ids), VtLater - else VtSideff ids, VtLater + then VtStartProof (guarantee,ids) + else VtSideff (ids, VtLater) (* Sideff: apply to all open branches. usually run on master only *) | VernacAssumption (_,_,l) -> let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map (fun (id, _) -> id.v) l) l) in - VtSideff ids, VtLater + VtSideff (ids, VtLater) | VernacPrimitive (id,_,_) -> - VtSideff [id.CAst.v], VtLater - | VernacDefinition (_,({v=id},_),DefineBody _) -> VtSideff (idents_of_name id), VtLater + VtSideff ([id.CAst.v], VtLater) + | VernacDefinition (_,({v=id},_),DefineBody _) -> VtSideff (idents_of_name id, VtLater) | VernacInductive (_, _,_,l) -> let ids = List.map (fun (((_,({v=id},_)),_,_,_,cl),_) -> id :: match cl with | Constructors l -> List.map (fun (_,({v=id},_)) -> id) l @@ -142,12 +137,12 @@ let classify_vernac e = CList.map_filter (function | AssumExpr({v=Names.Name n},_), _ -> Some n | _ -> None) l) l in - VtSideff (List.flatten ids), VtLater + VtSideff (List.flatten ids, VtLater) | VernacScheme l -> let ids = List.map (fun {v}->v) (CList.map_filter (fun (x,_) -> x) l) in - VtSideff ids, VtLater - | VernacCombinedScheme ({v=id},_) -> VtSideff [id], VtLater - | VernacBeginSection {v=id} -> VtSideff [id], VtLater + VtSideff (ids, VtLater) + | VernacCombinedScheme ({v=id},_) -> VtSideff ([id], VtLater) + | VernacBeginSection {v=id} -> VtSideff ([id], VtLater) | VernacUniverse _ | VernacConstraint _ | VernacCanonical _ | VernacCoercion _ | VernacIdentityCoercion _ | VernacAddLoadPath _ | VernacRemoveLoadPath _ | VernacAddMLPath _ @@ -166,17 +161,17 @@ let classify_vernac e = | VernacRegister _ | VernacNameSectionHypSet _ | VernacComments _ - | VernacDeclareInstance _ -> VtSideff [], VtLater + | VernacDeclareInstance _ -> VtSideff ([], VtLater) (* Who knows *) - | VernacLoad _ -> VtSideff [], VtNow + | VernacLoad _ -> VtSideff ([], VtNow) (* (Local) Notations have to disappear *) - | VernacEndSegment _ -> VtSideff [], VtNow + | VernacEndSegment _ -> VtSideff ([], VtNow) (* Modules with parameters have to be executed: can import notations *) | VernacDeclareModule (exp,{v=id},bl,_) | VernacDefineModule (exp,{v=id},bl,_,_) -> - VtSideff [id], if bl = [] && exp = None then VtLater else VtNow + VtSideff ([id], if bl = [] && exp = None then VtLater else VtNow) | VernacDeclareModuleType ({v=id},bl,_,_) -> - VtSideff [id], if bl = [] then VtLater else VtNow + VtSideff ([id], if bl = [] then VtLater else VtNow) (* These commands alter the parser *) | VernacDeclareCustomEntry _ | VernacOpenCloseScope _ | VernacDeclareScope _ @@ -186,40 +181,39 @@ let classify_vernac e = | VernacSyntacticDefinition _ | VernacRequire _ | VernacImport _ | VernacInclude _ | VernacDeclareMLModule _ - | VernacContext _ (* TASSI: unsure *) -> VtSideff [], VtNow - | VernacProofMode pm -> VtProofMode pm, VtNow + | VernacContext _ (* TASSI: unsure *) -> VtSideff ([], VtNow) + | VernacProofMode pm -> VtProofMode pm | VernacInstance ((name,_),_,_,None,_) when not (Attributes.parse_drop_extra Attributes.program atts) -> let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in - VtStartProof (guarantee, idents_of_name name.CAst.v), VtLater + VtStartProof (guarantee, idents_of_name name.CAst.v) | VernacInstance ((name,_),_,_,_,_) -> - VtSideff (idents_of_name name.CAst.v), VtLater + VtSideff (idents_of_name name.CAst.v, VtLater) (* Stm will install a new classifier to handle these *) | VernacBack _ | VernacAbortAll | VernacUndoTo _ | VernacUndo _ | VernacResetName _ | VernacResetInitial - | VernacBackTo _ | VernacRestart -> VtMeta, VtNow + | VernacBackTo _ | VernacRestart -> VtMeta (* What are these? *) | VernacRestoreState _ - | VernacWriteState _ -> VtSideff [], VtNow + | VernacWriteState _ -> VtSideff ([], VtNow) (* Plugins should classify their commands *) | VernacExtend (s,l) -> try Vernacextend.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in let rec static_control_classifier v = v |> CAst.with_val (function - | VernacExpr (atts, e) -> - static_classifier ~atts e - | VernacTimeout (_,e) -> static_control_classifier e - | VernacTime (_,e) | VernacRedirect (_, e) -> - static_control_classifier e - | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) + | VernacExpr (atts, e) -> + static_classifier ~atts e + | VernacTimeout (_,e) -> static_control_classifier e + | VernacTime (_,e) | VernacRedirect (_, e) -> + static_control_classifier e + | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) + (* XXX why is Fail not always Query? *) (match static_control_classifier e with - | ( VtQuery | VtProofStep _ | VtSideff _ - | VtMeta), _ as x -> x - | VtQed _, _ -> - VtProofStep { parallel = `No; proof_block_detection = None }, - VtLater - | (VtStartProof _ | VtProofMode _), _ -> VtQuery, VtLater)) + | VtQuery | VtProofStep _ | VtSideff _ + | VtMeta as x -> x + | VtQed _ -> VtProofStep { parallel = `No; proof_block_detection = None } + | VtStartProof _ | VtProofMode _ -> VtQuery)) in static_control_classifier e diff --git a/tactics/abstract.ml b/tactics/abstract.ml index a5b2f99457..967b0ef418 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -103,8 +103,8 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = question, how does abstract behave when discharge is local for example? *) let goal_kind, suffix = if opaque - then (Global,poly,Proof Theorem), "_subproof" - else (Global,poly,DefinitionBody Definition), "_subterm" in + then (Global ImportDefaultBehavior,poly,Proof Theorem), "_subproof" + else (Global ImportDefaultBehavior,poly,DefinitionBody Definition), "_subterm" in let id, goal_kind = name_op_to_name ~name_op ~name ~goal_kind suffix in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -158,7 +158,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = (* do not compute the implicit arguments, it may be costly *) let () = Impargs.make_implicit_args false in (* ppedrot: seems legit to have abstracted subproofs as local*) - Declare.declare_private_constant ~role:Entries.Subproof ~internal:Declare.InternalTacticRequest ~local:true id decl + Declare.declare_private_constant ~internal:Declare.InternalTacticRequest ~local:ImportNeedQualified id decl in let cst, eff = Impargs.with_implicit_protection cst () in let inst = match const.Entries.const_entry_universes with @@ -173,8 +173,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = in let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in - let open Safe_typing in - let effs = concat_private eff + let effs = Evd.concat_side_effects eff Entries.(snd (Future.force const.const_entry_body)) in let solve = Proofview.tclEFFECTS effs <*> diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 8ead050262..06449c38a8 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -51,7 +51,7 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = else let sigma, pind = Evd.fresh_inductive_instance env sigma ind in let sigma, c = build_induction_scheme env sigma pind dep sort in - (c, Evd.evar_universe_context sigma), Safe_typing.empty_private_constants + (c, Evd.evar_universe_context sigma), Evd.empty_side_effects let build_induction_scheme_in_type dep sort ind = let env = Global.env () in @@ -62,15 +62,15 @@ let build_induction_scheme_in_type dep sort ind = let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" - (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type false InType x, Evd.empty_side_effects) let rect_scheme_kind_from_prop = declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" - (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type false InType x, Evd.empty_side_effects) let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" - (fun _ x -> build_induction_scheme_in_type true InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type true InType x, Evd.empty_side_effects) let rec_scheme_kind_from_type = declare_individual_scheme_object "_rec_nodep" ~aux:"_rec_nodep_from_type" @@ -90,7 +90,7 @@ let ind_scheme_kind_from_type = let sind_scheme_kind_from_type = declare_individual_scheme_object "_sind_nodep" - (fun _ x -> build_induction_scheme_in_type false InSProp x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type false InSProp x, Evd.empty_side_effects) let ind_dep_scheme_kind_from_type = declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" @@ -98,7 +98,7 @@ let ind_dep_scheme_kind_from_type = let sind_dep_scheme_kind_from_type = declare_individual_scheme_object "_sind" ~aux:"_sind_from_type" - (fun _ x -> build_induction_scheme_in_type true InSProp x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type true InSProp x, Evd.empty_side_effects) let ind_scheme_kind_from_prop = declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" @@ -106,7 +106,7 @@ let ind_scheme_kind_from_prop = let sind_scheme_kind_from_prop = declare_individual_scheme_object "_sind" ~aux:"_sind_from_prop" - (fun _ x -> build_induction_scheme_in_type false InSProp x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type false InSProp x, Evd.empty_side_effects) let nondep_elim_scheme from_kind to_kind = match from_kind, to_kind with @@ -130,24 +130,24 @@ let build_case_analysis_scheme_in_type dep sort ind = let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" - (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Evd.empty_side_effects) let case_scheme_kind_from_prop = declare_individual_scheme_object "_case" ~aux:"_case_from_prop" - (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Evd.empty_side_effects) let case_dep_scheme_kind_from_type = declare_individual_scheme_object "_case" ~aux:"_case_from_type" - (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Evd.empty_side_effects) let case_dep_scheme_kind_from_type_in_prop = declare_individual_scheme_object "_casep_dep" - (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Evd.empty_side_effects) let case_dep_scheme_kind_from_prop = declare_individual_scheme_object "_case_dep" - (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Evd.empty_side_effects) let case_dep_scheme_kind_from_prop_in_prop = declare_individual_scheme_object "_casep" - (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Evd.empty_side_effects) diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index f60e6c137a..2b8a053cc0 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -18,7 +18,7 @@ val optimize_non_type_induction_scheme : Sorts.family -> 'b -> Names.inductive -> - (Constr.constr * UState.t) * Safe_typing.private_constants + (Constr.constr * UState.t) * Evd.side_effects val rect_scheme_kind_from_prop : individual scheme_kind val ind_scheme_kind_from_prop : individual scheme_kind diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 3fdd97616f..d66ae9cb24 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -229,7 +229,7 @@ let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" (fun _ ind -> let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in - (c, ctx), Safe_typing.empty_private_constants) + (c, ctx), Evd.empty_side_effects) (**********************************************************************) (* Build the involutivity of symmetry for an inductive type *) @@ -455,7 +455,7 @@ let build_l2r_rew_scheme dep env ind kind = else main_body)))))) in (c, UState.of_context_set ctx), - Safe_typing.concat_private eff' eff + Evd.concat_side_effects eff' eff (**********************************************************************) (* Build the left-to-right rewriting lemma for hypotheses associated *) @@ -708,7 +708,7 @@ let rew_l2r_dep_scheme_kind = (**********************************************************************) let rew_r2l_dep_scheme_kind = declare_individual_scheme_object "_rew_dep" - (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) + (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Evd.empty_side_effects) (**********************************************************************) (* Dependent rewrite from right-to-left in hypotheses *) @@ -718,7 +718,7 @@ let rew_r2l_dep_scheme_kind = (**********************************************************************) let rew_r2l_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_dep" - (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) + (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Evd.empty_side_effects) (**********************************************************************) (* Dependent rewrite from left-to-right in hypotheses *) @@ -728,7 +728,7 @@ let rew_r2l_forward_dep_scheme_kind = (**********************************************************************) let rew_l2r_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_r_dep" - (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) + (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Evd.empty_side_effects) (**********************************************************************) (* Non-dependent rewrite from either left-to-right in conclusion or *) @@ -742,7 +742,7 @@ let rew_l2r_forward_dep_scheme_kind = let rew_l2r_scheme_kind = declare_individual_scheme_object "_rew_r" (fun _ ind -> fix_r2l_forward_rew_scheme - (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Safe_typing.empty_private_constants) + (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Evd.empty_side_effects) (**********************************************************************) (* Non-dependent rewrite from either right-to-left in conclusion or *) @@ -752,7 +752,7 @@ let rew_l2r_scheme_kind = (**********************************************************************) let rew_r2l_scheme_kind = declare_individual_scheme_object "_rew" - (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Safe_typing.empty_private_constants) + (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Evd.empty_side_effects) (* End of rewriting schemes *) @@ -836,4 +836,4 @@ let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun _ ind -> (* May fail if equality is not defined *) build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, - Safe_typing.empty_private_constants) + Evd.empty_side_effects) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 4749aebd96..c15fa146d4 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -27,7 +27,7 @@ val rew_r2l_scheme_kind : individual scheme_kind val build_r2l_rew_scheme : bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context val build_l2r_rew_scheme : bool -> env -> inductive -> Sorts.family -> - constr Evd.in_evar_universe_context * Safe_typing.private_constants + constr Evd.in_evar_universe_context * Evd.side_effects val build_r2l_forward_rew_scheme : bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context val build_l2r_forward_rew_scheme : @@ -39,7 +39,7 @@ val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind val build_sym_involutive_scheme : env -> inductive -> - constr Evd.in_evar_universe_context * Safe_typing.private_constants + constr Evd.in_evar_universe_context * Evd.side_effects val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) diff --git a/tactics/hints.ml b/tactics/hints.ml index cc56c1c425..6fcb37d87c 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1518,7 +1518,7 @@ let pr_hint_term env sigma cl = (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint pf = let env = Global.env () in - let pts = Proof_global.give_me_the_proof pf in + let pts = Proof_global.get_proof pf in let Proof.{goals;sigma} = Proof.data pts in match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index b9485b8823..539fe31416 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -31,9 +31,9 @@ open Pp (* Registering schemes in the environment *) type mutual_scheme_object_function = - internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants + internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Evd.side_effects type individual_scheme_object_function = - internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Evd.side_effects type 'a scheme_kind = string @@ -124,7 +124,7 @@ let define internal role id c poly univs = let entry = { const_entry_body = Future.from_val ((c,Univ.ContextSet.empty), - Safe_typing.empty_private_constants); + Evd.empty_side_effects); const_entry_secctx = None; const_entry_type = None; const_entry_universes = univs; @@ -145,10 +145,10 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in - let role = Entries.Schema (ind, kind) in + let role = Evd.Schema (ind, kind) in let const, neff = define mode role id c (Declareops.inductive_is_polymorphic mib) ctx in declare_scheme kind [|ind,const|]; - const, Safe_typing.concat_private neff eff + const, Evd.concat_side_effects neff eff let define_individual_scheme kind mode names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with @@ -163,9 +163,9 @@ let define_mutual_scheme_base kind suff f mode names mind = try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in let fold i effs id cl = - let role = Entries.Schema ((mind, i), kind)in + let role = Evd.Schema ((mind, i), kind)in let cst, neff = define mode role id cl (Declareops.inductive_is_polymorphic mib) ctx in - (Safe_typing.concat_private neff effs, cst) + (Evd.concat_side_effects neff effs, cst) in let (eff, consts) = Array.fold_left2_map_i fold eff ids cl in let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in @@ -180,7 +180,7 @@ let define_mutual_scheme kind mode names mind = let find_scheme_on_env_too kind ind = let s = String.Map.find kind (Indmap.find ind !scheme_map) in - s, Safe_typing.empty_private_constants + s, Evd.empty_side_effects let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) = try find_scheme_on_env_too kind ind diff --git a/tactics/ind_tables.mli b/tactics/ind_tables.mli index 0eb4e47aeb..460b1f1b07 100644 --- a/tactics/ind_tables.mli +++ b/tactics/ind_tables.mli @@ -22,9 +22,9 @@ type individual type 'a scheme_kind type mutual_scheme_object_function = - internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants + internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Evd.side_effects type individual_scheme_object_function = - internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Evd.side_effects (** Main functions to register a scheme builder *) @@ -39,13 +39,13 @@ val declare_individual_scheme_object : string -> ?aux:string -> val define_individual_scheme : individual scheme_kind -> internal_flag (** internal *) -> - Id.t option -> inductive -> Constant.t * Safe_typing.private_constants + Id.t option -> inductive -> Constant.t * Evd.side_effects val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) -> - (int * Id.t) list -> MutInd.t -> Constant.t array * Safe_typing.private_constants + (int * Id.t) list -> MutInd.t -> Constant.t array * Evd.side_effects (** Main function to retrieve a scheme in the cache or to generate it *) -val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> Constant.t * Safe_typing.private_constants +val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> Constant.t * Evd.side_effects val check_scheme : 'a scheme_kind -> inductive -> bool diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 59fd8b37d6..81700986ea 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -43,12 +43,8 @@ let tclTHENS = Refiner.tclTHENS let tclTHENSV = Refiner.tclTHENSV let tclTHENSFIRSTn = Refiner.tclTHENSFIRSTn let tclTHENSLASTn = Refiner.tclTHENSLASTn -let tclTHENFIRSTn = Refiner.tclTHENFIRSTn -let tclTHENLASTn = Refiner.tclTHENLASTn let tclREPEAT = Refiner.tclREPEAT -let tclREPEAT_MAIN = Refiner.tclREPEAT_MAIN let tclFIRST = Refiner.tclFIRST -let tclSOLVE = Refiner.tclSOLVE let tclTRY = Refiner.tclTRY let tclCOMPLETE = Refiner.tclCOMPLETE let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE @@ -58,10 +54,6 @@ let tclDO = Refiner.tclDO let tclPROGRESS = Refiner.tclPROGRESS let tclSHOWHYPS = Refiner.tclSHOWHYPS let tclTHENTRY = Refiner.tclTHENTRY -let tclIFTHENELSE = Refiner.tclIFTHENELSE -let tclIFTHENSELSE = Refiner.tclIFTHENSELSE -let tclIFTHENSVELSE = Refiner.tclIFTHENSVELSE -let tclIFTHENTRYELSEMUST = Refiner.tclIFTHENTRYELSEMUST (************************************************************************) (* Tacticals applying on hypotheses *) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 201b7801c3..a9ccda527f 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -31,13 +31,9 @@ val tclTHENLAST : tactic -> tactic -> tactic val tclTHENS : tactic -> tactic list -> tactic val tclTHENSV : tactic -> tactic array -> tactic val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic -val tclTHENLASTn : tactic -> tactic array -> tactic val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic -val tclTHENFIRSTn : tactic -> tactic array -> tactic val tclREPEAT : tactic -> tactic -val tclREPEAT_MAIN : tactic -> tactic val tclFIRST : tactic list -> tactic -val tclSOLVE : tactic list -> tactic val tclTRY : tactic -> tactic val tclCOMPLETE : tactic -> tactic val tclAT_LEAST_ONCE : tactic -> tactic @@ -49,11 +45,6 @@ val tclSHOWHYPS : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclMAP : ('a -> tactic) -> 'a list -> tactic -val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic -val tclIFTHENSELSE : tactic -> tactic list -> tactic -> tactic -val tclIFTHENSVELSE : tactic -> tactic array -> tactic -> tactic -val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic - (** {6 Tacticals applying to hypotheses } *) val onNthHypId : int -> (Id.t -> tactic) -> tactic diff --git a/test-suite/bugs/closed/bug_4798.v b/test-suite/bugs/closed/bug_4798.v deleted file mode 100644 index f238086633..0000000000 --- a/test-suite/bugs/closed/bug_4798.v +++ /dev/null @@ -1,5 +0,0 @@ -(* DO NOT MODIFY THIS FILE DIRECTLY *) -(* It is autogenerated by dev/tools/update-compat.py. *) -Check match 2 with 0 => 0 | S n => n end. -Notation "|" := 1 (compat "8.8"). -Check match 2 with 0 => 0 | S n => n end. (* fails *) diff --git a/test-suite/bugs/closed/bug_8725.v b/test-suite/bugs/closed/bug_8725.v new file mode 100644 index 0000000000..c888b9e96d --- /dev/null +++ b/test-suite/bugs/closed/bug_8725.v @@ -0,0 +1,2 @@ +Set Warnings "+local-declaration". +Fail Let foo : True. diff --git a/test-suite/bugs/closed/bug_9166.v b/test-suite/bugs/closed/bug_9166.v index 21cd770cbb..cd594c660f 100644 --- a/test-suite/bugs/closed/bug_9166.v +++ b/test-suite/bugs/closed/bug_9166.v @@ -1,8 +1,7 @@ -(* DO NOT MODIFY THIS FILE DIRECTLY *) -(* It is autogenerated by dev/tools/update-compat.py. *) Set Warnings "+deprecated". -Notation bar := option (compat "8.8"). +#[deprecated(since = "X", note = "Y")] +Notation bar := option. Definition foo (x: nat) : nat := match x with diff --git a/test-suite/success/LocalDefinition.v b/test-suite/success/LocalDefinition.v new file mode 100644 index 0000000000..22fb09526d --- /dev/null +++ b/test-suite/success/LocalDefinition.v @@ -0,0 +1,53 @@ +(* Test consistent behavior of Local Definition (#8722) *) + +(* Test consistent behavior of Local Definition wrt Admitted *) + +Module TestAdmittedVisibility. + Module A. + Let a1 : nat. Admitted. (* Suppose to behave like a "Local Definition" *) + Local Definition b1 : nat. Admitted. (* Told to be a "Local Definition" *) + Local Definition c1 := 0. + Local Parameter d1 : nat. + Section S. + Let a2 : nat. Admitted. (* Told to be turned into a toplevel assumption *) + Local Definition b2 : nat. Admitted. (* Told to be a "Local Definition" *) + Local Definition c2 := 0. + Local Parameter d2 : nat. + End S. + End A. + Import A. + Fail Check a1. (* used to be accepted *) + Fail Check b1. (* used to be accepted *) + Fail Check c1. + Fail Check d1. + Fail Check a2. (* used to be accepted *) + Fail Check b2. (* used to be accepted *) + Fail Check c2. + Fail Check d2. +End TestAdmittedVisibility. + +(* Test consistent behavior of Local Definition wrt automatic declaration of instances *) + +Module TestVariableAsInstances. + Module Test1. + Set Typeclasses Axioms Are Instances. + Class U. + Local Parameter b : U. + Definition testU := _ : U. (* _ resolved *) + + Class T. + Variable a : T. (* warned to be the same as "Local Parameter" *) + Definition testT := _ : T. (* _ resolved *) + End Test1. + + Module Test2. + Unset Typeclasses Axioms Are Instances. + Class U. + Local Parameter b : U. + Fail Definition testU := _ : U. (* _ unresolved *) + + Class T. + Variable a : T. (* warned to be the same as "Local Parameter" thus should not be an instance *) + Fail Definition testT := _ : T. (* used to succeed *) + End Test2. +End TestVariableAsInstances. diff --git a/test-suite/success/NotationDeprecation.v b/test-suite/success/NotationDeprecation.v new file mode 100644 index 0000000000..d313ba0aa4 --- /dev/null +++ b/test-suite/success/NotationDeprecation.v @@ -0,0 +1,62 @@ +Module Syndefs. + +#[deprecated(since = "8.8", note = "Do not use.")] +Notation foo := Prop. + +Notation bar := Prop (compat "8.8"). + +Fail +#[deprecated(since = "8.8", note = "Do not use.")] +Notation zar := Prop (compat "8.8"). + +Check foo. +Check bar. + +Set Warnings "+deprecated". + +Fail Check foo. +Fail Check bar. + +End Syndefs. + +Module Notations. + +#[deprecated(since = "8.8", note = "Do not use.")] +Notation "!!" := Prop. + +Notation "##" := Prop (compat "8.8"). + +Fail +#[deprecated(since = "8.8", note = "Do not use.")] +Notation "**" := Prop (compat "8.8"). + +Check !!. +Check ##. + +Set Warnings "+deprecated". + +Fail Check !!. +Fail Check ##. + +End Notations. + +Module Infix. + +#[deprecated(since = "8.8", note = "Do not use.")] +Infix "!!" := plus (at level 1). + +Infix "##" := plus (at level 1, compat "8.8"). + +Fail +#[deprecated(since = "8.8", note = "Do not use.")] +Infix "**" := plus (at level 1, compat "8.8"). + +Check (_ !! _). +Check (_ ## _). + +Set Warnings "+deprecated". + +Fail Check (_ !! _). +Fail Check (_ ## _). + +End Infix. diff --git a/test-suite/success/goal_selector.v b/test-suite/success/goal_selector.v index 0951c5c8d4..ae834e7696 100644 --- a/test-suite/success/goal_selector.v +++ b/test-suite/success/goal_selector.v @@ -13,13 +13,15 @@ Goal two false /\ two true /\ two false /\ two true /\ two true /\ two true. Proof. do 2 dup. - repeat split. - 2, 4-99, 100-3:idtac. + Fail 7:idtac. + Fail 2-1:idtac. + 1,2,4-6:idtac. 2-5:exact One. par:exact Zero. - repeat split. 3-6:swap 1 4. 1-5:swap 1 5. - 0-4:exact One. + 1-4:exact One. all:exact Zero. - repeat split. 1, 3:exact Zero. @@ -34,7 +36,7 @@ Qed. Goal True -> True. Proof. - intros y; only 1-2 : repeat idtac. + intros y. 1-1:match goal with y : _ |- _ => let x := y in idtac x end. Fail 1-1:let x := y in idtac x. 1:let x := y in idtac x. diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 4576ff4cbe..bb4ed10bc9 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -149,6 +149,7 @@ apply AC_IF. Qed. -Notation classical_proof_irrelevence := classical_proof_irrelevance (compat "8.8"). +#[deprecated(since = "8.8", note = "Use classical_proof_irrelevance instead.")] +Notation classical_proof_irrelevence := classical_proof_irrelevance. End Berardis_paradox. diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 4ef31c73b7..9180cae389 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -184,6 +184,10 @@ let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") +let warn_deprecated_simple_require = + CWarnings.create ~name:"deprecated-boot" ~category:"deprecated" + (fun () -> Pp.strbrk "The -require option is deprecated, please use -require-import instead.") + let set_inputstate opts s = warn_deprecated_inputstate (); { opts with inputstate = Some s } @@ -416,7 +420,22 @@ let parse_args ~help ~init arglist : t * string list = Flags.profile_ltac_cutoff := get_float opt (next ()); oval - |"-require" -> add_vo_require oval (next ()) None (Some false) + |"-rfrom" -> + let from = next () in add_vo_require oval (next ()) (Some from) None + + |"-require" -> + warn_deprecated_simple_require (); + add_vo_require oval (next ()) None (Some false) + + |"-require-import" | "-ri" -> add_vo_require oval (next ()) None (Some false) + + |"-require-export" | "-re" -> add_vo_require oval (next ()) None (Some true) + + |"-require-import-from" | "-rifrom" -> + let from = next () in add_vo_require oval (next ()) (Some from) (Some false) + + |"-require-export-from" | "-refrom" -> + let from = next () in add_vo_require oval (next ()) (Some from) (Some true) |"-top" -> let topname = Libnames.dirpath_of_string (next ()) in diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 29948d50b2..84d3992f5c 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -44,10 +44,23 @@ let print_usage_common co command = \n -load-ml-source f load ML file f\ \n -load-vernac-source f load Coq file f.v (Load \"f\".)\ \n -l f (idem)\ -\n -require path load Coq library path and import it (Require Import path.)\ \n -load-vernac-source-verbose f load Coq file f.v (Load Verbose \"f\".)\ \n -lv f (idem)\ -\n -load-vernac-object path load Coq library path (Require path)\ +\n -load-vernac-object lib, -r lib\ +\n load Coq library lib (Require lib)\ +\n -rfrom root lib load Coq library lib (From root Require lib.)\ +\n -require-import lib, -ri lib\ +\n load and import Coq library lib\ +\n (equivalent to Require Import lib.)\ +\n -require-export lib, -re lib\ +\n load and transitively import Coq library lib\ +\n (equivalent to Require Export lib.)\ +\n -require-import-from root lib, -rifrom lib\ +\n load and import Coq library lib\ +\n (equivalent to From root Require Import lib.)\ +\n -require-export-from root lib, -refrom lib\ +\n load and transitively import Coq library lib\ +\n (equivalent to From root Require Export lib.)\ \n\ \n -where print Coq's standard library location and exit\ \n -config, --config print Coq's configuration information and exit\ diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index bd1f925486..930be257e3 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -884,7 +884,7 @@ END { let classify_ltac2 = function -| StrSyn _ -> Vernacextend.(VtSideff [], VtNow) +| StrSyn _ -> Vernacextend.(VtSideff ([], VtNow)) | StrMut _ | StrVal _ | StrPrm _ | StrTyp _ -> Vernacextend.classify_as_sideeff } diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 246fe47c4a..3ab82b6e9b 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -751,7 +751,7 @@ let perform_eval ~pstate e = Goal_select.SelectAll, Proof.start ~name ~poly sigma [] | Some pstate -> Goal_select.get_default_goal_selector (), - Proof_global.give_me_the_proof pstate + Proof_global.get_proof pstate in let v = match selector with | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v @@ -856,7 +856,7 @@ let print_ltac qid = (** Calling tactics *) let solve ~pstate default tac = - let pstate, status = Proof_global.with_proof begin fun etac p -> + let pstate, status = Proof_global.map_fold_proof_endline begin fun etac p -> let with_end_tac = if default then Some etac else None in let g = Goal_select.get_default_goal_selector () in let (p, status) = Pfedit.solve g None tac ?with_end_tac p in diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 1ad5862d5d..ab14974598 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -73,11 +73,6 @@ module Notations = struct end open Notations -type deprecation = { since : string option ; note : string option } - -let mk_deprecation ?(since=None) ?(note=None) () = - { since ; note } - let assert_empty k v = if v <> VernacFlagEmpty then user_err Pp.(str "Attribute " ++ str k ++ str " does not accept arguments") @@ -213,19 +208,16 @@ let polymorphic = universe_transform ~warn_unqualified:true >> qualify_attribute ukey polymorphic_base -let deprecation_parser : deprecation key_parser = fun orig args -> +let deprecation_parser : Deprecation.t key_parser = fun orig args -> assert_once ~name:"deprecation" orig; match args with | VernacFlagList [ "since", VernacFlagLeaf since ; "note", VernacFlagLeaf note ] | VernacFlagList [ "note", VernacFlagLeaf note ; "since", VernacFlagLeaf since ] -> - let since = Some since and note = Some note in - mk_deprecation ~since ~note () + Deprecation.make ~since ~note () | VernacFlagList [ "since", VernacFlagLeaf since ] -> - let since = Some since in - mk_deprecation ~since () + Deprecation.make ~since () | VernacFlagList [ "note", VernacFlagLeaf note ] -> - let note = Some note in - mk_deprecation ~note () + Deprecation.make ~note () | _ -> CErrors.user_err (Pp.str "Ill formed “deprecated” attribute") let deprecation = attribute_of_list ["deprecated",deprecation_parser] diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 44688ddafc..53caf49efd 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -43,15 +43,11 @@ end (** Definitions for some standard attributes. *) -type deprecation = { since : string option ; note : string option } - -val mk_deprecation : ?since: string option -> ?note: string option -> unit -> deprecation - val polymorphic : bool attribute val program : bool attribute val template : bool option attribute val locality : bool option attribute -val deprecation : deprecation option attribute +val deprecation : Deprecation.t option attribute val canonical : bool attribute val program_mode_option_name : string list diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 5aec5cac2c..2e84c3275b 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -195,7 +195,7 @@ let build_beq_scheme mode kn = let (c,a) = Reductionops.whd_betaiota_stack Evd.empty EConstr.(of_constr c) in let (c,a) = EConstr.Unsafe.(to_constr c, List.map to_constr a) in match Constr.kind c with - | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants + | Rel x -> mkRel (x-nlist+ndx), Evd.empty_side_effects | Var x -> (* Support for working in a context with "eq_x : x -> x -> bool" *) let eid = Id.of_string ("eq_"^(Id.to_string x)) in @@ -203,11 +203,11 @@ let build_beq_scheme mode kn = try ignore (Environ.lookup_named eid env) with Not_found -> raise (ParameterWithoutEquality (VarRef x)) in - mkVar eid, Safe_typing.empty_private_constants + mkVar eid, Evd.empty_side_effects | Cast (x,_,_) -> aux (Term.applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> - if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Safe_typing.empty_private_constants + if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Evd.empty_side_effects else begin try let eq, eff = @@ -216,7 +216,7 @@ let build_beq_scheme mode kn = let eqa, eff = let eqa, effs = List.split (List.map aux a) in Array.of_list eqa, - List.fold_left Safe_typing.concat_private eff (List.rev effs) + List.fold_left Evd.concat_side_effects eff (List.rev effs) in let args = Array.append @@ -239,7 +239,7 @@ let build_beq_scheme mode kn = let kneq = Constant.change_label kn eq_lbl in try let _ = Environ.constant_opt_value_in env (kneq, u) in Term.applist (mkConst kneq,a), - Safe_typing.empty_private_constants + Evd.empty_side_effects with Not_found -> raise (ParameterWithoutEquality (ConstRef kn))) | Proj _ -> raise (EqUnknown "projection") | Construct _ -> raise (EqUnknown "constructor") @@ -270,7 +270,7 @@ let build_beq_scheme mode kn = let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in let ar = Array.make n (ff ()) in - let eff = ref Safe_typing.empty_private_constants in + let eff = ref Evd.empty_side_effects in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in let ar2 = Array.make n (ff ()) in @@ -288,7 +288,7 @@ let build_beq_scheme mode kn = (nb_cstr_args+ndx+1) cc in - eff := Safe_typing.concat_private eff' !eff; + eff := Evd.concat_side_effects eff' !eff; Array.set eqs ndx (mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] @@ -320,7 +320,7 @@ let build_beq_scheme mode kn = let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in - let eff = ref Safe_typing.empty_private_constants in + let eff = ref Evd.empty_side_effects in let u = Univ.Instance.empty in for i=0 to (nb_ind-1) do names.(i) <- make_annot (Name (Id.of_string (rec_name i))) Sorts.Relevant; @@ -328,7 +328,7 @@ let build_beq_scheme mode kn = (mkArrow (mkFullInd ((kn,i),u) 1) Sorts.Relevant (bb ())); let c, eff' = make_one_eq i in cores.(i) <- c; - eff := Safe_typing.concat_private eff' !eff + eff := Evd.concat_side_effects eff' !eff done; (Array.init nb_ind (fun i -> let kelim = Inductive.elim_sort (mib,mib.mind_packets.(i)) in @@ -938,7 +938,7 @@ let compute_dec_tact ind lnamesparrec nparrec = Not_found -> Tacticals.New.tclZEROMSG (str "Error during the decidability part, leibniz to boolean equality is required.") end >>= fun (lbI,eff'') -> - let eff = (Safe_typing.concat_private eff'' (Safe_typing.concat_private eff' eff)) in + let eff = (Evd.concat_side_effects eff'' (Evd.concat_side_effects eff' eff)) in Tacticals.New.tclTHENLIST [ Proofview.tclEFFECTS eff; intros_using fresh_first_intros; @@ -1005,7 +1005,7 @@ let make_eq_decidability mode mind = (EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) (compute_dec_tact ind lnamesparrec nparrec) in - ([|ans|], ctx), Safe_typing.empty_private_constants + ([|ans|], ctx), Evd.empty_side_effects let eq_dec_scheme_kind = declare_mutual_scheme_object "_eq_dec" make_eq_decidability diff --git a/vernac/class.ml b/vernac/class.ml index f3a279eab1..58cef5db4f 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -358,9 +358,9 @@ let try_add_new_coercion_with_source ref ~local poly ~source = let add_coercion_hook poly _uctx _trans local ref = let local = match local with - | Discharge - | Local -> true - | Global -> false + | Discharge -> assert false (* Local Coercion in section behaves like Local Definition *) + | Global ImportNeedQualified -> true + | Global ImportDefaultBehavior -> false in let () = try_add_new_coercion ref ~local poly in let msg = Nametab.pr_global_env Id.Set.empty ref ++ str " is now a coercion" in @@ -370,9 +370,9 @@ let add_coercion_hook poly = Lemmas.mk_hook (add_coercion_hook poly) let add_subclass_hook poly _uctx _trans local ref = let stre = match local with - | Local -> true - | Global -> false - | Discharge -> assert false + | Discharge -> assert false (* Local Subclass in section behaves like Local Definition *) + | Global ImportNeedQualified -> true + | Global ImportDefaultBehavior -> false in let cl = class_of_global ref in try_add_new_coercion_subclass cl ~local:stre poly diff --git a/vernac/classes.ml b/vernac/classes.ml index 9cc8467c57..b64af52b6e 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -367,7 +367,7 @@ let declare_instance_program env sigma ~global ~poly id pri imps decl term termt let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context sigma in ignore(Obligations.add_definition id ?term:constr - ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls) + ~univdecl:decl typ ctx ~kind:(Global ImportDefaultBehavior,poly,Instance) ~hook obls) let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl ids term termtype = @@ -377,12 +377,12 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl ids te the refinement manually.*) let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in - let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in - let pstate = Lemmas.start_proof id ~pl:decl kind sigma (EConstr.of_constr termtype) + let kind = Decl_kinds.(Global ImportDefaultBehavior, poly, DefinitionBody Instance) in + let lemma = Lemmas.start_lemma id ~pl:decl kind sigma (EConstr.of_constr termtype) ~hook:(Lemmas.mk_hook (fun _ _ _ -> instance_hook pri global imps ?hook)) in (* spiwack: I don't know what to do with the status here. *) - let pstate = + let lemma = if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ @@ -391,18 +391,18 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl ids te Tactics.New.reduce_after_refine; ] in - let pstate, _ = Pfedit.by init_refine pstate in - pstate + let lemma, _ = Lemmas.by init_refine lemma in + lemma else - let pstate, _ = Pfedit.by (Tactics.auto_intros_tac ids) pstate in - pstate + let lemma, _ = Lemmas.by (Tactics.auto_intros_tac ids) lemma in + lemma in match tac with | Some tac -> - let pstate, _ = Pfedit.by tac pstate in - pstate + let lemma, _ = Lemmas.by tac lemma in + lemma | None -> - pstate + lemma let do_instance_subst_constructor_and_ty subst k u ctx = let subst = diff --git a/vernac/classes.mli b/vernac/classes.mli index e61935c87a..ace9096469 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -31,8 +31,8 @@ val declare_instance : ?warn:bool -> env -> Evd.evar_map -> val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) -val new_instance_interactive : - ?global:bool (** Not global by default. *) +val new_instance_interactive + : ?global:bool (** Not global by default. *) -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list @@ -41,10 +41,10 @@ val new_instance_interactive : -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr - -> Id.t * Proof_global.t + -> Id.t * Lemmas.t -val new_instance : - ?global:bool (** Not global by default. *) +val new_instance + : ?global:bool (** Not global by default. *) -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list @@ -55,8 +55,8 @@ val new_instance : -> Hints.hint_info_expr -> Id.t -val new_instance_program : - ?global:bool (** Not global by default. *) +val new_instance_program + : ?global:bool (** Not global by default. *) -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index c37e90650a..591e4b130f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -37,15 +37,15 @@ let () = optwrite = (:=) axiom_into_instance; } let should_axiom_into_instance = function - | Discharge -> + | Context -> (* The typeclass behaviour of Variable and Context doesn't depend on section status *) true - | Global | Local -> !axiom_into_instance + | Definitional | Logical | Conjectural -> !axiom_into_instance let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = match local with -| Discharge when Lib.sections_are_opened () -> +| Discharge -> let ctx = match ctx with | Monomorphic_entry ctx -> ctx | Polymorphic_entry (_, ctx) -> Univ.ContextSet.of_context ctx @@ -61,9 +61,8 @@ match local with let () = if is_coe then Class.try_add_new_coercion r ~local:true false in (r,Univ.Instance.empty,true) -| Global | Local | Discharge -> - let do_instance = should_axiom_into_instance local in - let local = DeclareDef.get_locality ident ~kind:"axiom" local in +| Global local -> + let do_instance = should_axiom_into_instance kind in let inl = let open Declaremods in match nl with | NoInline -> None | DefaultInline -> Some (Flags.get_inline_level()) @@ -78,6 +77,7 @@ match local with let env = Global.env () in let sigma = Evd.from_env env in let () = if do_instance then Classes.declare_instance env sigma None false gr in + let local = match local with ImportNeedQualified -> true | ImportDefaultBehavior -> false in let () = if is_coe then Class.try_add_new_coercion gr ~local p in let inst = match ctx with | Polymorphic_entry (_, ctx) -> Univ.UContext.instance ctx @@ -124,7 +124,7 @@ let process_assumptions_udecls kind l = | (_, ([], _))::_ | [] -> assert false in let () = match kind, udecl with - | (Discharge, _, _), Some _ when Lib.sections_are_opened () -> + | (Discharge, _, _), Some _ -> let loc = first_id.CAst.loc in let msg = Pp.str "Section variables cannot be polymorphic." in user_err ?loc msg @@ -288,7 +288,9 @@ let context poly l = | _ -> false in let impl = List.exists test impls in - let decl = (Discharge, poly, Definitional) in + let persistence = + if Lib.sections_are_opened () then Discharge else Global ImportDefaultBehavior in + let decl = (persistence, poly, Context) in let nstatus = match b with | None -> pi3 (declare_assumption false decl (t, univs) UnivNames.empty_binders [] impl diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 4cae4b8a74..1046e354a7 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -86,7 +86,7 @@ let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = if program_mode then let env = Global.env () in let (c,ctx), sideff = Future.force ce.const_entry_body in - assert(Safe_typing.empty_private_constants = sideff); + assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); assert(Univ.ContextSet.is_empty ctx); Obligations.check_evars env evd; let c = EConstr.of_constr c in diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index fa4860b079..0d9df47ee8 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -33,7 +33,13 @@ val do_definition (************************************************************************) (** Not used anywhere. *) -val interp_definition : program_mode:bool -> - universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> - constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * - UState.universe_decl * Impargs.manual_implicits +val interp_definition + : program_mode:bool + -> universe_decl_expr option + -> local_binder_expr list + -> polymorphic + -> red_expr option + -> constr_expr + -> constr_expr option + -> Evd.side_effects definition_entry * + Evd.evar_map * UState.universe_decl * Impargs.manual_implicits diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 7a4e6d8698..6068cd90f1 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -267,10 +267,10 @@ let declare_fixpoint_interactive local poly ((fixnames,fixrs,fixdefs,fixtypes),p Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - let pstate = Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) + let lemma = Lemmas.start_lemma_with_initialization (local,poly,DefinitionBody Fixpoint) evd pl (Some(false,indexes,init_tac)) thms None in declare_fixpoint_notations ntns; - pstate + lemma let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = (* We shortcut the proof process *) @@ -286,7 +286,8 @@ let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximp let evd = Evd.restrict_universe_context evd vars in let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + let mk_pure c = (c, Univ.ContextSet.empty), Evd.empty_side_effects in + let fixdecls = List.map mk_pure fixdecls in ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) @@ -304,11 +305,11 @@ let declare_cofixpoint_interactive local poly ((fixnames,fixrs,fixdefs,fixtypes) Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - let pstate = Lemmas.start_proof_with_initialization - (Global,poly, DefinitionBody CoFixpoint) + let lemma = Lemmas.start_lemma_with_initialization + (Global ImportDefaultBehavior,poly, DefinitionBody CoFixpoint) evd pl (Some(true,[],init_tac)) thms None in declare_cofixpoint_notations ntns; - pstate + lemma let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = (* We shortcut the proof process *) @@ -316,7 +317,8 @@ let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fixi let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let vars = Vars.universes_of_constr (List.hd fixdecls) in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + let mk_pure c = (c, Univ.ContextSet.empty), Evd.empty_side_effects in + let fixdecls = List.map mk_pure fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index c8d617da5f..a31f3c34e0 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -19,13 +19,13 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint_interactive : - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Lemmas.t val do_fixpoint : locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit val do_cofixpoint_interactive : - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Lemmas.t val do_cofixpoint : locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index bdda3314ca..652dbf0858 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -14,27 +14,13 @@ open Entries open Globnames open Impargs -let warn_local_declaration = - CWarnings.create ~name:"local-declaration" ~category:"scope" - Pp.(fun (id,kind) -> - Names.Id.print id ++ strbrk " is declared as a local " ++ str kind) - -let get_locality id ~kind = function -| Discharge -> - (* If a Let is defined outside a section, then we consider it as a local definition *) - warn_local_declaration (id,kind); - true -| Local -> true -| Global -> false - let declare_definition ident (local, p, k) ?hook_data ce pl imps = let fix_exn = Future.fix_exn_of ce.const_entry_body in let gr = match local with - | Discharge when Lib.sections_are_opened () -> + | Discharge -> let _ = declare_variable ident (Lib.cwd(), SectionLocalDef ce, IsDefinition k) in VarRef ident - | Discharge | Local | Global -> - let local = get_locality ident ~kind:"definition" local in + | Global local -> let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in let gr = ConstRef kn in let () = Declare.declare_univ_binders gr pl in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index c4500d0a6b..909aa41a30 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -11,13 +11,11 @@ open Names open Decl_kinds -val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool - val declare_definition : Id.t -> definition_kind -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) - -> Safe_typing.private_constants Entries.definition_entry + -> Evd.side_effects Entries.definition_entry -> UnivNames.universe_binders -> Impargs.manual_implicits -> GlobRef.t @@ -29,7 +27,7 @@ val declare_fix -> UnivNames.universe_binders -> Entries.universes_entry -> Id.t - -> Safe_typing.private_constants Entries.proof_output + -> Evd.side_effects Entries.proof_output -> Constr.types -> Impargs.manual_implicits -> GlobRef.t @@ -38,7 +36,7 @@ val prepare_definition : allow_evars:bool -> ?opaque:bool -> ?inline:bool -> poly:bool -> Evd.evar_map -> UState.universe_decl -> types:EConstr.t option -> body:EConstr.t -> - Evd.evar_map * Safe_typing.private_constants Entries.definition_entry + Evd.evar_map * Evd.side_effects Entries.definition_entry val prepare_parameter : allow_evars:bool -> poly:bool -> Evd.evar_map -> UState.universe_decl -> EConstr.types -> diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index de7d2fd49a..f18cf17bf9 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -414,7 +414,7 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = let declare decl fi lrecref = let decltype = Retyping.get_type_of env0 sigma (EConstr.of_constr decl) in let decltype = EConstr.to_constr sigma decltype in - let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Evd.empty_side_effects) in let cst = define ~poly fi UserIndividualRequest sigma proof_output (Some decltype) in ConstRef cst :: lrecref in @@ -536,7 +536,7 @@ let do_combined_scheme name schemes = schemes in let sigma,body,typ = build_combined_scheme (Global.env ()) csts in - let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Evd.empty_side_effects) in (* It is possible for the constants to have different universe polymorphism from each other, however that is only when the user manually defined at least one of them (as Scheme would pick the diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index d14c7ddf8f..a7366b2c56 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -26,7 +26,6 @@ open Decl_kinds open Declare open Pretyping open Termops -open Namegen open Reductionops open Constrintern open Impargs @@ -46,6 +45,44 @@ let call_hook ?hook ?fix_exn uctx trans l c = let e = Option.cata (fun fix -> fix e) e fix_exn in iraise e +(* Support for terminators and proofs with an associated constant + [that can be saved] *) + +type proof_ending = + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t + | Proved of Proof_global.opacity_flag * + lident option * + Proof_global.proof_object + +type proof_terminator = (proof_ending -> unit) CEphemeron.key + +(* Proofs with a save constant function *) +type t = + { proof : Proof_global.t + ; terminator : proof_terminator + } + +let pf_map f { proof; terminator} = { proof = f proof; terminator } +let pf_fold f ps = f ps.proof + +let set_endline_tactic t = pf_map (Proof_global.set_endline_tactic t) + +(* To be removed *) +module Internal = struct + +let make_terminator f = CEphemeron.create f +let apply_terminator f = CEphemeron.get f + +(** Gets the current terminator without checking that the proof has + been completed. Useful for the likes of [Admitted]. *) +let get_terminator ps = ps.terminator + +end + +let by tac { proof; terminator } = + let proof, res = Pfedit.by tac proof in + { proof; terminator}, res + (* Support for mutually proved theorems *) let retrieve_first_recthm uctx = function @@ -75,7 +112,7 @@ let adjust_guardness_conditions const = function List.interval 0 (List.length ((lam_assum c)))) lemma_guard (Array.to_list fixdefs) in *) - let env = Safe_typing.push_private_constants env eff in + let env = Safe_typing.push_private_constants env eff.Evd.seff_private in let indexes = search_guard env possible_indexes fixdecls in @@ -178,18 +215,14 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook universes let k = Kindops.logical_kind_of_goal_kind kind in let should_suggest = const.const_entry_opaque && Option.is_empty const.const_entry_secctx in let r = match locality with - | Discharge when Lib.sections_are_opened () -> + | Discharge -> let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in let () = if should_suggest then Proof_using.suggest_variable (Global.env ()) id in VarRef id - | Local | Global | Discharge -> - let local = match locality with - | Local | Discharge -> true - | Global -> false - in + | Global local -> let kn = declare_constant ?export_seff id ~local (DefinitionEntry const, k) in let () = if should_suggest @@ -207,13 +240,10 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook universes let default_thm_id = Id.of_string "Unnamed_thm" -let fresh_name_for_anonymous_theorem () = - next_global_ident_away default_thm_id Id.Set.empty - let check_name_freshness locality {CAst.loc;v=id} : unit = (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || - locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) + locality <> Discharge && Nametab.exists_cci (Lib.make_path_except_section id) then user_err ?loc (Id.print id ++ str " already exists.") @@ -233,16 +263,12 @@ let save_remaining_recthms env sigma (locality,p,kind) norm univs body opaq i (i in let c = SectionLocalAssum ((t_i, univs),p,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in - (Discharge, VarRef id,imps) - | Local | Global -> - let local = match locality with - | Local -> true - | Global -> false - | Discharge -> assert false - in + (VarRef id,imps) + | Global local -> + let k = IsAssumption Conjectural in let decl = (ParameterEntry (None,(t_i,univs),None), k) in let kn = declare_constant id ~local decl in - (locality,ConstRef kn,imps)) + (ConstRef kn,imps)) | Some body -> let body = norm body in let k = Kindops.logical_kind_of_goal_kind kind in @@ -260,45 +286,39 @@ let save_remaining_recthms env sigma (locality,p,kind) norm univs body opaq i (i let const = definition_entry ~types:t_i ~opaque:opaq ~univs body_i in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in - (Discharge,VarRef id,imps) - | Local | Global -> - let local = match locality with - | Local -> true - | Global -> false - | Discharge -> assert false - in + (VarRef id,imps) + | Global local -> let const = Declare.definition_entry ~types:t_i ~univs ~opaque:opaq body_i in let kn = declare_constant id ~local (DefinitionEntry const, k) in - (locality,ConstRef kn,imps) + (ConstRef kn,imps) let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then user_err Pp.(str "This command can only be used for unnamed theorem.") (* Admitted *) - let warn_let_as_axiom = CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" (fun id -> strbrk "Let definition" ++ spc () ++ Id.print id ++ - spc () ++ strbrk "declared as an axiom.") + spc () ++ strbrk "declared as a local axiom.") let admit ?hook ctx (id,k,e) pl () = - let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in - let () = match k with - | Global, _, _ -> () - | Local, _, _ | Discharge, _, _ -> warn_let_as_axiom id + let local = match k with + | Global local, _, _ -> local + | Discharge, _, _ -> warn_let_as_axiom id; ImportNeedQualified in + let kn = declare_constant id ~local (ParameterEntry e, IsAssumption Conjectural) in let () = assumption_message id in Declare.declare_univ_binders (ConstRef kn) pl; - call_hook ?hook ctx [] Global (ConstRef kn) + call_hook ?hook ctx [] (Global local) (ConstRef kn) (* Starting a goal *) let standard_proof_terminator ?(hook : declaration_hook option) compute_guard = let open Proof_global in - make_terminator begin function + CEphemeron.create begin function | Admitted (id,k,pe,ctx) -> let () = admit ?hook ctx (id,k,pe) (UState.universe_binders ctx) () in Feedback.feedback Feedback.AddedAxiom @@ -325,7 +345,41 @@ let initialize_named_context_for_proof () = let d = if variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val -let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = +module Stack = struct + + type lemma = t + type nonrec t = t * t list + + let map f (pf, pfl) = (f pf, List.map f pfl) + + let map_top ~f (pf, pfl) = (f pf, pfl) + let map_top_pstate ~f (pf, pfl) = (pf_map f pf, pfl) + + let pop (ps, p) = match p with + | [] -> ps, None + | pp :: p -> ps, Some (pp, p) + + let with_top (p, _) ~f = f p + let with_top_pstate (p, _) ~f = f p.proof + + let push ontop a = + match ontop with + | None -> a , [] + | Some (l,ls) -> a, (l :: ls) + + let get_all_proof_names (pf : t) = + let prj x = Proof_global.get_proof x in + let (pn, pns) = map Proof.(function pf -> (data (prj pf.proof)).name) pf in + pn :: pns + + let copy_terminators ~src ~tgt = + let (ps, psl), (ts,tsl) = src, tgt in + assert(List.length psl = List.length tsl); + {ts with terminator = ps.terminator}, List.map2 (fun op p -> { p with terminator = op.terminator }) psl tsl + +end + +let start_lemma id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = let terminator = match terminator with | None -> standard_proof_terminator ?hook compute_guard | Some terminator -> terminator ?hook compute_guard @@ -336,7 +390,16 @@ let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c | None -> initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in - Proof_global.start_proof sigma id ?pl kind goals terminator + let proof = Proof_global.start_proof sigma id ?pl kind goals in + { proof ; terminator } + +let start_dependent_lemma id ?pl kind ?terminator ?sign ?(compute_guard=[]) ?hook telescope = + let terminator = match terminator with + | None -> standard_proof_terminator ?hook compute_guard + | Some terminator -> terminator ?hook compute_guard + in + let proof = Proof_global.start_dependent_proof id ?pl kind telescope in + { proof ; terminator } let rec_tac_initializer finite guard thms snl = if finite then @@ -352,7 +415,7 @@ let rec_tac_initializer finite guard thms snl = | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = +let start_lemma_with_initialization ?hook kind sigma decl recguard thms snl = let intro_tac (_, (_, (ids, _))) = Tactics.auto_intros_tac ids in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> @@ -380,18 +443,18 @@ let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = let uctx = UState.check_univ_decl ~poly:(pi2 kind) ctx decl in let env = Global.env () in List.map_i (save_remaining_recthms env sigma kind norm uctx body opaq) 1 other_thms in - let thms_data = (strength,ref,imps)::other_thms_data in - List.iter (fun (strength,ref,imps) -> + let thms_data = (ref,imps)::other_thms_data in + List.iter (fun (ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook ?hook ctx [] strength ref) thms_data in - let pstate = start_proof id ~pl:decl kind sigma t ~hook ~compute_guard:guard in - let pstate = Proof_global.modify_proof (fun p -> + let lemma = start_lemma id ~pl:decl kind sigma t ~hook ~compute_guard:guard in + let lemma = pf_map (Proof_global.map_proof (fun p -> match init_tac with | None -> p - | Some tac -> pi1 @@ Proof.run_tactic Global.(env ()) tac p) pstate in - pstate + | Some tac -> pi1 @@ Proof.run_tactic Global.(env ()) tac p)) lemma in + lemma -let start_proof_com ~program_mode ?inference_hook ?hook kind thms = +let start_lemma_com ~program_mode ?inference_hook ?hook kind thms = let env0 = Global.env () in let decl = fst (List.hd thms) in let evd, decl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in @@ -423,7 +486,7 @@ let start_proof_com ~program_mode ?inference_hook ?hook kind thms = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_proof_with_initialization ?hook kind evd decl recguard thms snl + start_lemma_with_initialization ?hook kind evd decl recguard thms snl (* Saving a proof *) @@ -438,7 +501,7 @@ let () = optread = (fun () -> !keep_admitted_vars); optwrite = (fun b -> keep_admitted_vars := b) } -let save_proof_admitted ?proof ~pstate = +let save_lemma_admitted ?proof ~(lemma : t) = let pe = let open Proof_global in match proof with @@ -453,8 +516,8 @@ let save_proof_admitted ?proof ~pstate = let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in Admitted(id, k, (sec_vars, (typ, ctx), None), universes) | None -> - let pftree = Proof_global.give_me_the_proof pstate in - let gk = Proof_global.get_current_persistence pstate in + let pftree = Proof_global.get_proof lemma.proof in + let gk = Proof_global.get_persistence lemma.proof in let Proof.{ name; poly; entry } = Proof.data pftree in let typ = match Proofview.initial_goals entry with | [typ] -> snd typ @@ -466,10 +529,10 @@ let save_proof_admitted ?proof ~pstate = let universes = Proof.((data pftree).initial_euctx) in (* This will warn if the proof is complete *) let pproofs, _univs = - Proof_global.return_proof ~allow_partial:true pstate in + Proof_global.return_proof ~allow_partial:true lemma.proof in let sec_vars = if not !keep_admitted_vars then None - else match Proof_global.get_used_variables pstate, pproofs with + else match Proof_global.get_used_variables lemma.proof, pproofs with | Some _ as x, _ -> x | None, (pproof, _) :: _ -> let env = Global.env () in @@ -477,32 +540,23 @@ let save_proof_admitted ?proof ~pstate = let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) | _ -> None in - let decl = Proof_global.get_universe_decl pstate in + let decl = Proof_global.get_universe_decl lemma.proof in let ctx = UState.check_univ_decl ~poly universes decl in Admitted(name,gk,(sec_vars, (typ, ctx), None), universes) in - Proof_global.apply_terminator (Proof_global.get_terminator pstate) pe - -let save_pstate_proved ~pstate ~opaque ~idopt = - let obj, terminator = Proof_global.close_proof ~opaque - ~keep_body_ucst_separate:false (fun x -> x) pstate - in - Proof_global.(apply_terminator terminator (Proved (opaque, idopt, obj))) + CEphemeron.get lemma.terminator pe -let save_proof_proved ?proof ?ontop ~opaque ~idopt = +let save_lemma_proved ?proof ?lemma ~opaque ~idopt = (* Invariant (uh) *) - if Option.is_empty ontop && Option.is_empty proof then + if Option.is_empty lemma && Option.is_empty proof then user_err (str "No focused proof (No proof-editing in progress)."); let (proof_obj,terminator) = match proof with | None -> (* XXX: The close_proof and proof state API should be refactored so it is possible to insert proofs properly into the state *) - let pstate = Proof_global.get_current_pstate @@ Option.get ontop in - Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pstate + let { proof; terminator } = Option.get lemma in + Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) proof, terminator | Some proof -> proof in - (* if the proof is given explicitly, nothing has to be deleted *) - let ontop = if Option.is_empty proof then Proof_global.discard_current Option.(get ontop) else ontop in - Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))); - ontop + CEphemeron.get terminator (Proved (opaque,idopt,proof_obj)) diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 3df543156d..ac647af8b5 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -11,6 +11,7 @@ open Names open Decl_kinds +(* Declaration hooks *) type declaration_hook (* Hooks allow users of the API to perform arbitrary actions at @@ -37,53 +38,120 @@ val call_hook -> ?fix_exn:Future.fix_exn -> hook_type -val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> - ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator) -> - ?sign:Environ.named_context_val -> - ?compute_guard:Proof_global.lemma_possible_guards -> - ?hook:declaration_hook -> EConstr.types -> Proof_global.t +(* Proofs that define a constant + terminators *) +type t +type proof_terminator -val start_proof_com +module Stack : sig + + type lemma = t + type t + + val pop : t -> lemma * t option + val push : t option -> lemma -> t + + val map_top : f:(lemma -> lemma) -> t -> t + val map_top_pstate : f:(Proof_global.t -> Proof_global.t) -> t -> t + + val with_top : t -> f:(lemma -> 'a ) -> 'a + val with_top_pstate : t -> f:(Proof_global.t -> 'a ) -> 'a + + val get_all_proof_names : t -> Names.Id.t list + + val copy_terminators : src:t -> tgt:t -> t + (** Gets the current terminator without checking that the proof has + been completed. Useful for the likes of [Admitted]. *) + +end + +val standard_proof_terminator + : ?hook:declaration_hook + -> Proof_global.lemma_possible_guards + -> proof_terminator + +val set_endline_tactic : Genarg.glob_generic_argument -> t -> t +val pf_map : (Proof_global.t -> Proof_global.t) -> t -> t +val pf_fold : (Proof_global.t -> 'a) -> t -> 'a + +val by : unit Proofview.tactic -> t -> t * bool + +(* Start of high-level proofs with an associated constant *) + +val start_lemma + : Id.t + -> ?pl:UState.universe_decl + -> goal_kind + -> Evd.evar_map + -> ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> proof_terminator) + -> ?sign:Environ.named_context_val + -> ?compute_guard:Proof_global.lemma_possible_guards + -> ?hook:declaration_hook + -> EConstr.types + -> t + +val start_dependent_lemma + : Id.t + -> ?pl:UState.universe_decl + -> goal_kind + -> ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> proof_terminator) + -> ?sign:Environ.named_context_val + -> ?compute_guard:Proof_global.lemma_possible_guards + -> ?hook:declaration_hook + -> Proofview.telescope + -> t + +val start_lemma_com : program_mode:bool -> ?inference_hook:Pretyping.inference_hook -> ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list - -> Proof_global.t - -val start_proof_with_initialization : - ?hook:declaration_hook -> - goal_kind -> Evd.evar_map -> UState.universe_decl -> - (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> - (Id.t (* name of thm *) * - (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list - -> int list option -> Proof_global.t + -> t -val standard_proof_terminator : - ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> - Proof_global.proof_terminator +val start_lemma_with_initialization + : ?hook:declaration_hook + -> goal_kind -> Evd.evar_map -> UState.universe_decl + -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option + -> (Id.t (* name of thm *) * + (EConstr.types (* type of thm *) * + (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list + -> int list option + -> t -val fresh_name_for_anonymous_theorem : unit -> Id.t +val default_thm_id : Names.Id.t (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) val initialize_named_context_for_proof : unit -> Environ.named_context_val -(** {6 ... } *) +(** {6 Saving proofs } *) -val save_proof_admitted - : ?proof:Proof_global.closed_proof - -> pstate:Proof_global.t +val save_lemma_admitted + : ?proof:(Proof_global.proof_object * proof_terminator) + -> lemma:t -> unit -val save_proof_proved - : ?proof:Proof_global.closed_proof - -> ?ontop:Proof_global.stack - -> opaque:Proof_global.opacity_flag - -> idopt:Names.lident option - -> Proof_global.stack option - -val save_pstate_proved - : pstate:Proof_global.t +val save_lemma_proved + : ?proof:(Proof_global.proof_object * proof_terminator) + -> ?lemma:t -> opaque:Proof_global.opacity_flag -> idopt:Names.lident option -> unit + +(* API to build a terminator, should go away *) +type proof_ending = + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t + | Proved of Proof_global.opacity_flag * + Names.lident option * + Proof_global.proof_object + +(** This stuff is internal and will be removed in the future. *) +module Internal : sig + + (** Only needed due to the Proof_global compatibility layer. *) + val get_terminator : t -> proof_terminator + + (** Only needed by obligations, should be reified soon *) + val make_terminator : (proof_ending -> unit) -> proof_terminator + val apply_terminator : proof_terminator -> proof_ending -> unit + +end diff --git a/vernac/locality.ml b/vernac/locality.ml index 21be73b39c..465f04bc6e 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -12,10 +12,9 @@ open Decl_kinds (** * Managing locality *) -let local_of_bool = function - | true -> Local - | false -> Global - +let importability_of_bool = function + | true -> ImportNeedQualified + | false -> ImportDefaultBehavior (** Positioning locality for commands supporting discharging and export outside of modules *) @@ -28,10 +27,22 @@ let make_non_locality = function Some false -> false | _ -> true let make_locality = function Some true -> true | _ -> false +let warn_local_declaration = + CWarnings.create ~name:"local-declaration" ~category:"scope" + Pp.(fun () -> + Pp.strbrk "Interpreting this declaration as if " ++ + strbrk "a global declaration prefixed by \"Local\", " ++ + strbrk "i.e. as a global declaration which shall not be " ++ + strbrk "available without qualification when imported.") + let enforce_locality_exp locality_flag discharge = match locality_flag, discharge with - | Some b, NoDischarge -> local_of_bool b - | None, NoDischarge -> Global + | Some b, NoDischarge -> Global (importability_of_bool b) + | None, NoDischarge -> Global ImportDefaultBehavior + | None, DoDischarge when not (Lib.sections_are_opened ()) -> + (* If a Let/Variable is defined outside a section, then we consider it as a local definition *) + warn_local_declaration (); + Global ImportNeedQualified | None, DoDischarge -> Discharge | Some true, DoDischarge -> CErrors.user_err Pp.(str "Local not allowed in this case") | Some false, DoDischarge -> CErrors.user_err Pp.(str "Global not allowed in this case") diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 50914959dc..b96f500beb 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -732,13 +732,8 @@ type syntax_extension = { synext_notgram : notation_grammar; synext_unparsing : unparsing list; synext_extra : (string * string) list; - synext_compat : Flags.compat_version option; } -let is_active_compat = function -| None -> true -| Some v -> 0 <= Flags.version_compare v !Flags.compat_version - type syntax_extension_obj = locality_flag * syntax_extension let check_and_extend_constr_grammar ntn rule = @@ -759,7 +754,7 @@ let cache_one_syntax_extension se = let oldprec = Notgram_ops.level_of_notation ~onlyprint ntn in if not (Notgram_ops.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec; with Not_found -> - if is_active_compat se.synext_compat then begin + begin (* Reserve the notation level *) Notgram_ops.declare_notation_level ntn prec ~onlyprint; (* Declare the parsing rule *) @@ -934,10 +929,6 @@ let is_only_printing mods = let test = function SetOnlyPrinting -> true | _ -> false in List.exists test mods -let get_compat_version mods = - let test = function SetCompatVersion v -> Some v | _ -> None in - try Some (List.find_map test mods) with Not_found -> None - (* Compute precedences from modifiers (or find default ones) *) let set_entry_type from etyps (x,typ) = @@ -1177,7 +1168,7 @@ module SynData = struct (* Fields coming from the vernac-level modifiers *) only_parsing : bool; only_printing : bool; - compat : Flags.compat_version option; + deprecation : Deprecation.t option; format : lstring option; extra : (string * string) list; @@ -1222,12 +1213,32 @@ let check_locality_compatibility local custom i_typs = strbrk " which is local.")) (List.uniquize allcustoms) -let compute_syntax_data local df modifiers = +let warn_deprecated_compat = + CWarnings.create ~name:"deprecated-compat" ~category:"deprecated" + (fun () -> Pp.(str"The \"compat\" modifier is deprecated." ++ spc () ++ + str"Please use the \"deprecated\" attributed instead.")) + +(* Returns the new deprecation and the onlyparsing status. This should be +removed together with the compat syntax modifier. *) +let merge_compat_deprecation compat deprecation = + match compat, deprecation with + | Some Flags.Current, _ -> deprecation, true + | Some _, Some _ -> + CErrors.user_err Pp.(str"The \"compat\" modifier cannot be used with the \"deprecated\" attribute." + ++ spc () ++ str"Please use only the latter.") + | Some v, None -> + warn_deprecated_compat (); + Some (Deprecation.make ~since:(Flags.pr_version v) ()), true + | None, Some _ -> deprecation, true + | None, None -> deprecation, false + +let compute_syntax_data ~local deprecation df modifiers = let open SynData in let open NotationMods in let mods = interp_modifiers modifiers in let onlyprint = mods.only_printing in let onlyparse = mods.only_parsing in + let deprecation, _ = merge_compat_deprecation mods.compat deprecation in if onlyprint && onlyparse then user_err (str "A notation cannot be both 'only printing' and 'only parsing'."); let assoc = Option.append mods.assoc (Some Gramlib.Gramext.NonA) in let (recvars,mainvars,symbols) = analyze_notation_tokens ~onlyprint df in @@ -1265,7 +1276,7 @@ let compute_syntax_data local df modifiers = only_parsing = mods.only_parsing; only_printing = mods.only_printing; - compat = mods.compat; + deprecation; format = mods.format; extra = mods.extra; @@ -1281,9 +1292,9 @@ let compute_syntax_data local df modifiers = not_data = sy_fulldata; } -let compute_pure_syntax_data local df mods = +let compute_pure_syntax_data ~local df mods = let open SynData in - let sd = compute_syntax_data local df mods in + let sd = compute_syntax_data ~local None df mods in let msgs = if sd.only_parsing then (Feedback.msg_warning ?loc:None, @@ -1301,7 +1312,7 @@ type notation_obj = { notobj_coercion : entry_coercion_kind option; notobj_onlyparse : bool; notobj_onlyprint : bool; - notobj_compat : Flags.compat_version option; + notobj_deprecation : Deprecation.t option; notobj_notation : notation * notation_location; } @@ -1323,11 +1334,11 @@ let open_notation i (_, nobj) = let (ntn, df) = nobj.notobj_notation in let pat = nobj.notobj_interp in let onlyprint = nobj.notobj_onlyprint in + let deprecation = nobj.notobj_deprecation in let fresh = not (Notation.exists_notation_in_scope scope ntn onlyprint pat) in - let active = is_active_compat nobj.notobj_compat in - if Int.equal i 1 && fresh && active then begin + if Int.equal i 1 && fresh then begin (* Declare the interpretation *) - let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint in + let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint deprecation in (* Declare the uninterpretation *) if not nobj.notobj_onlyparse then Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat; @@ -1388,7 +1399,6 @@ let recover_notation_syntax ntn = synext_notgram = pa_rule; synext_unparsing = pp_rule; synext_extra = pp_extra_rules; - synext_compat = None; } with Not_found -> raise NoSyntaxRule @@ -1437,7 +1447,6 @@ let make_syntax_rules (sd : SynData.syn_data) = let open SynData in synext_notgram = { notgram_onlyprinting = sd.only_printing; notgram_rules = pa_rule }; synext_unparsing = pp_rule; synext_extra = sd.extra; - synext_compat = sd.compat; } (**********************************************************************) @@ -1447,9 +1456,9 @@ let to_map l = let fold accu (x, v) = Id.Map.add x v accu in List.fold_left fold Id.Map.empty l -let add_notation_in_scope local df env c mods scope = +let add_notation_in_scope ~local deprecation df env c mods scope = let open SynData in - let sd = compute_syntax_data local df mods in + let sd = compute_syntax_data ~local deprecation df mods in (* Prepare the interpretation *) (* Prepare the parsing and printing rules *) let sy_rules = make_syntax_rules sd in @@ -1470,7 +1479,7 @@ let add_notation_in_scope local df env c mods scope = notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = sd.only_printing; - notobj_compat = sd.compat; + notobj_deprecation = sd.deprecation; notobj_notation = sd.info; } in (* Ready to change the global state *) @@ -1479,7 +1488,7 @@ let add_notation_in_scope local df env c mods scope = Lib.add_anonymous_leaf (inNotation notation); sd.info -let add_notation_interpretation_core local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = +let add_notation_interpretation_core ~local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint deprecation = let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint df in (* Recover types of variables and pa/pp rules; redeclare them if needed *) let level, i_typs, onlyprint = if not (is_numeral symbs) then begin @@ -1510,7 +1519,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = onlyprint; - notobj_compat = compat; + notobj_deprecation = deprecation; notobj_notation = df'; } in Lib.add_anonymous_leaf (inNotation notation); @@ -1518,41 +1527,40 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ (* Notations without interpretation (Reserved Notation) *) -let add_syntax_extension local ({CAst.loc;v=df},mods) = let open SynData in - let psd = compute_pure_syntax_data local df mods in - let sy_rules = make_syntax_rules {psd with compat = None} in +let add_syntax_extension ~local ({CAst.loc;v=df},mods) = let open SynData in + let psd = compute_pure_syntax_data ~local df mods in + let sy_rules = make_syntax_rules {psd with deprecation = None} in Flags.if_verbose (List.iter (fun (f,x) -> f x)) psd.msgs; Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) (* Notations with only interpretation *) let add_notation_interpretation env ({CAst.loc;v=df},c,sc) = - let df' = add_notation_interpretation_core false df env c sc false false None in + let df' = add_notation_interpretation_core ~local:false df env c sc false false None in Dumpglob.dump_notation (loc,df') sc true let set_notation_for_interpretation env impls ({CAst.v=df},c,sc) = (try ignore - (Flags.silently (fun () -> add_notation_interpretation_core false df env ~impls c sc false false None) ()); + (Flags.silently (fun () -> add_notation_interpretation_core ~local:false df env ~impls c sc false false None) ()); with NoSyntaxRule -> user_err Pp.(str "Parsing rule for this notation has to be previously declared.")); Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc (* Main entry point *) -let add_notation local env c ({CAst.loc;v=df},modifiers) sc = +let add_notation ~local deprecation env c ({CAst.loc;v=df},modifiers) sc = let df' = if no_syntax_modifiers modifiers then (* No syntax data: try to rely on a previously declared rule *) let onlyparse = is_only_parsing modifiers in let onlyprint = is_only_printing modifiers in - let compat = get_compat_version modifiers in - try add_notation_interpretation_core local df env c sc onlyparse onlyprint compat + try add_notation_interpretation_core ~local df env c sc onlyparse onlyprint deprecation with NoSyntaxRule -> (* Try to determine a default syntax rule *) - add_notation_in_scope local df env c modifiers sc + add_notation_in_scope ~local deprecation df env c modifiers sc else (* Declare both syntax and interpretation *) - add_notation_in_scope local df env c modifiers sc + add_notation_in_scope ~local deprecation df env c modifiers sc in Dumpglob.dump_notation (loc,df') sc true @@ -1566,7 +1574,7 @@ let add_notation_extra_printing_rule df k v = let inject_var x = CAst.make @@ CRef (qualid_of_ident x,None) -let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = +let add_infix ~local deprecation env ({CAst.loc;v=inf},modifiers) pr sc = check_infix_modifiers modifiers; (* check the precedence *) let vars = names_of_constr_expr pr in @@ -1575,7 +1583,7 @@ let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = let metas = [inject_var x; inject_var y] in let c = mkAppC (pr,metas) in let df = CAst.make ?loc @@ Id.to_string x ^" "^(quote_notation_token inf)^" "^Id.to_string y in - add_notation local env c (df,modifiers) sc + add_notation ~local deprecation env c (df,modifiers) sc (**********************************************************************) (* Scopes, delimiters and classes bound to scopes *) @@ -1651,7 +1659,7 @@ let try_interp_name_alias = function | [], { CAst.v = CRef (ref,_) } -> intern_reference ref | _ -> raise Not_found -let add_syntactic_definition env ident (vars,c) local onlyparse = +let add_syntactic_definition ~local deprecation env ident (vars,c) compat = let vars,reversibility,pat = try [], APrioriReversible, NRef (try_interp_name_alias (vars,c)) with Not_found -> @@ -1665,11 +1673,9 @@ let add_syntactic_definition env ident (vars,c) local onlyparse = let map id = let (_,sc) = Id.Map.find id nvars in (id, sc) in List.map map vars, reversibility, pat in - let onlyparse = match onlyparse with - | None when fst (printability None false reversibility pat) -> Some Flags.Current - | p -> p - in - Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) + let deprecation, onlyparsing = merge_compat_deprecation compat deprecation in + let onlyparsing = onlyparsing || fst (printability None false reversibility pat) in + Syntax_def.declare_syntactic_definition ~local deprecation ident ~onlyparsing (vars,pat) (**********************************************************************) (* Declaration of custom entry *) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index 6435df23c7..6532cee367 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -19,10 +19,10 @@ val add_token_obj : string -> unit (** Adding a (constr) notation in the environment*) -val add_infix : locality_flag -> env -> (lstring * syntax_modifier list) -> +val add_infix : local:bool -> Deprecation.t option -> env -> (lstring * syntax_modifier list) -> constr_expr -> scope_name option -> unit -val add_notation : locality_flag -> env -> constr_expr -> +val add_notation : local:bool -> Deprecation.t option -> env -> constr_expr -> (lstring * syntax_modifier list) -> scope_name option -> unit val add_notation_extra_printing_rule : string -> string -> string -> unit @@ -47,12 +47,12 @@ val set_notation_for_interpretation : env -> Constrintern.internalization_env -> (** Add only the parsing/printing rule of a notation *) val add_syntax_extension : - locality_flag -> (lstring * syntax_modifier list) -> unit + local:bool -> (lstring * syntax_modifier list) -> unit (** Add a syntactic definition (as in "Notation f := ...") *) -val add_syntactic_definition : env -> Id.t -> Id.t list * constr_expr -> - bool -> Flags.compat_version option -> unit +val add_syntactic_definition : local:bool -> Deprecation.t option -> env -> + Id.t -> Id.t list * constr_expr -> Flags.compat_version option -> unit (** Print the Camlp5 state of a grammar *) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 0d93e19723..50d24c20c9 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -497,7 +497,7 @@ let compute_possible_guardness_evidences n fixbody fixtype = let ctx = fst (decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx -let mk_proof c = ((c, Univ.ContextSet.empty), Safe_typing.empty_private_constants) +let mk_proof c = ((c, Univ.ContextSet.empty), Evd.empty_side_effects) let declare_mutual_definition l = let len = List.length l in @@ -632,7 +632,7 @@ let declare_obligation prg obl body ty uctx = if get_shrink_obligations () && not poly then shrink_body body ty else [], body, ty, [||] in - let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + let body = ((body,Univ.ContextSet.empty), Evd.empty_side_effects) in let ce = { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body; const_entry_secctx = None; @@ -643,7 +643,7 @@ let declare_obligation prg obl body ty uctx = const_entry_feedback = None; } in (* ppedrot: seems legit to have obligations as local *) - let constant = Declare.declare_constant obl.obl_name ~local:true + let constant = Declare.declare_constant obl.obl_name ~local:ImportNeedQualified (DefinitionEntry ce,IsProof Property) in if not opaque then add_hint (Locality.make_section_locality None) prg constant; @@ -787,9 +787,11 @@ let dependencies obls n = obls; !res -let goal_kind poly = Decl_kinds.Local, poly, Decl_kinds.DefinitionBody Decl_kinds.Definition +let goal_kind poly = + Decl_kinds.(Global ImportNeedQualified, poly, DefinitionBody Definition) -let goal_proof_kind poly = Decl_kinds.Local, poly, Decl_kinds.Proof Decl_kinds.Lemma +let goal_proof_kind poly = + Decl_kinds.(Global ImportNeedQualified, poly, Proof Lemma) let kind_of_obligation poly o = match o with @@ -820,8 +822,8 @@ let solve_by_tac ?loc name evi t poly ctx = Pfedit.build_constant_by_tactic id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps evi.evar_concl t in let env = Global.env () in - let body = Future.force entry.const_entry_body in - let body = Safe_typing.inline_private_constants env body in + let (body, eff) = Future.force entry.const_entry_body in + let body = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard env ctx' (EConstr.of_constr (fst body)); Some (fst body, entry.const_entry_type, Evd.evar_universe_context ctx') @@ -839,14 +841,15 @@ let solve_by_tac ?loc name evi t poly ctx = let obligation_terminator ?hook name num guard auto pf = let open Proof_global in - let term = Lemmas.standard_proof_terminator ?hook guard in + let open Lemmas in + let term = standard_proof_terminator ?hook guard in match pf with - | Admitted _ -> apply_terminator term pf + | Admitted _ -> Internal.apply_terminator term pf | Proved (opq, id, { entries=[entry]; universes=uctx } ) -> begin let env = Global.env () in let ty = entry.Entries.const_entry_type in - let body = Future.force entry.const_entry_body in - let (body, cstr) = Safe_typing.inline_private_constants env body in + let body, eff = Future.force entry.const_entry_body in + let (body, cstr) = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in let sigma = Evd.from_ctx uctx in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); @@ -962,13 +965,13 @@ let rec solve_obligation prg num tac = let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n tac oblset = auto_solve_obligations n ~oblset tac in let terminator ?hook guard = - Proof_global.make_terminator + Lemmas.Internal.make_terminator (obligation_terminator prg.prg_name num guard ?hook auto) in let hook = Lemmas.mk_hook (obligation_hook prg obl num auto) in - let pstate = Lemmas.start_proof ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in - let pstate = fst @@ Pfedit.by !default_tactic pstate in - let pstate = Option.cata (fun tac -> Proof_global.set_endline_tactic tac pstate) pstate tac in - pstate + let lemma = Lemmas.start_lemma ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in + let lemma = fst @@ Lemmas.by !default_tactic lemma in + let lemma = Option.cata (fun tac -> Lemmas.set_endline_tactic tac lemma) lemma tac in + lemma and obligation (user_num, name, typ) tac = let num = pred user_num in @@ -1102,7 +1105,7 @@ let show_term n = ++ Printer.pr_constr_env env sigma prg.prg_body) let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) - ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic + ?(implicits=[]) ?(kind=Global ImportDefaultBehavior,false,Definition) ?tactic ?(reduce=reduce) ?hook ?(opaque = false) obls = let sign = Lemmas.initialize_named_context_for_proof () in let info = Id.print n ++ str " has type-checked" in @@ -1122,7 +1125,7 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) | _ -> res) let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic - ?(kind=Global,false,Definition) ?(reduce=reduce) + ?(kind=Global ImportDefaultBehavior,false,Definition) ?(reduce=reduce) ?hook ?(opaque = false) notations fixkind = let sign = Lemmas.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in @@ -1153,7 +1156,7 @@ let admit_prog prg = | None -> let x = subst_deps_obl obls x in let ctx = UState.univ_entry ~poly:false prg.prg_ctx in - let kn = Declare.declare_constant x.obl_name ~local:true + let kn = Declare.declare_constant x.obl_name ~local:ImportNeedQualified (ParameterEntry (None,(x.obl_type,ctx),None), IsAssumption Conjectural) in assumption_message x.obl_name; diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 3b77039de5..8734d82970 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -86,14 +86,14 @@ val add_mutual_definitions : fixpoint_kind -> unit val obligation - : int * Names.Id.t option * Constrexpr.constr_expr option + : int * Names.Id.t option * Constrexpr.constr_expr option -> Genarg.glob_generic_argument option - -> Proof_global.t + -> Lemmas.t val next_obligation - : Names.Id.t option + : Names.Id.t option -> Genarg.glob_generic_argument option - -> Proof_global.t + -> Lemmas.t val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress (* Number of remaining obligations to be solved for this program *) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 02af1904fd..fda1e2afea 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -359,6 +359,8 @@ open Pputils keyword (if many then "Variables" else "Variable") | (DoDischarge,Conjectural) -> anomaly (Pp.str "Don't know how to beautify a local conjecture.") + | (_,Context) -> + anomaly (Pp.str "Context is used only internally.") let pr_params pr_c (xl,(c,t)) = hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++ diff --git a/vernac/record.ml b/vernac/record.ml index 6101e13edd..c777ef2c2b 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -344,7 +344,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name flags f try let entry = { const_entry_body = - Future.from_val (Safe_typing.mk_pure_proof proj); + Future.from_val ((proj, Univ.ContextSet.empty), Evd.empty_side_effects); const_entry_secctx = None; const_entry_type = Some projtyp; const_entry_universes = ctx; diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 8668f01053..112c4b6451 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -38,28 +38,24 @@ module NamedDecl = Context.Named.Declaration let (f_interp_redexp, interp_redexp_hook) = Hook.make () let debug = false + (* XXX Should move to a common library *) let vernac_pperr_endline pp = if debug then Format.eprintf "@[%a@]@\n%!" Pp.pp_with (pp ()) else () -(* Misc *) - -let there_are_pending_proofs ~pstate = - not Option.(is_empty pstate) +(* Utility functions, at some point they should all disappear and + instead enviroment/state selection should be done at the Vernac DSL + level. *) -(* EJGA: Only used in close_proof 2, can remove once ?proof hack is away *) -let vernac_require_open_proof ~pstate f = - match pstate with - | Some pstate -> f ~pstate +(* EJGA: Only used in close_proof, can remove once the ?proof hack is no more *) +let vernac_require_open_lemma ~stack f = + match stack with + | Some stack -> f ~stack | None -> user_err Pp.(str "Command not supported (No proof-editing in progress)") -let with_pstate ~pstate f = - vernac_require_open_proof ~pstate - (fun ~pstate -> f ~pstate:(Proof_global.get_current_pstate pstate)) - - let modify_pstate ~pstate f = - vernac_require_open_proof ~pstate (fun ~pstate -> - Some (Proof_global.modify_current_pstate (fun pstate -> f ~pstate) pstate)) +let with_pstate ~stack f = + vernac_require_open_lemma ~stack + (fun ~stack -> Stack.with_top_pstate stack ~f:(fun pstate -> f ~pstate)) let get_current_or_global_context ~pstate = match pstate with @@ -85,7 +81,7 @@ module DefAttributes = struct locality : bool option; polymorphic : bool; program : bool; - deprecated : deprecation option; + deprecated : Deprecation.t option; } let parse f = @@ -96,6 +92,8 @@ module DefAttributes = struct { polymorphic; program; locality; deprecated } end +let module_locality = Attributes.Notations.(locality >>= fun l -> return (make_module_locality l)) + let with_locality ~atts f = let local = Attributes.(parse locality atts) in f ~local @@ -106,8 +104,7 @@ let with_section_locality ~atts f = f ~section_local let with_module_locality ~atts f = - let local = Attributes.(parse locality atts) in - let module_local = make_module_locality local in + let module_local = Attributes.(parse module_locality atts) in f ~module_local let with_def_attributes ~atts f = @@ -122,7 +119,7 @@ let show_proof ~pstate = (* spiwack: this would probably be cooler with a bit of polishing. *) try let pstate = Option.get pstate in - let p = Proof_global.give_me_the_proof pstate in + let p = Proof_global.get_proof pstate in let sigma, env = Pfedit.get_current_context pstate in let pprf = Proof.partial_proof p in Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf @@ -132,24 +129,21 @@ let show_proof ~pstate = | Option.IsNone -> user_err (str "No goals to show.") -let show_top_evars ~pstate = +let show_top_evars ~proof = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) - let pfts = Proof_global.give_me_the_proof pstate in - let Proof.{goals;shelf;given_up;sigma} = Proof.data pfts in + let Proof.{goals;shelf;given_up;sigma} = Proof.data proof in pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) -let show_universes ~pstate = - let pfts = Proof_global.give_me_the_proof pstate in - let Proof.{goals;sigma} = Proof.data pfts in +let show_universes ~proof = + let Proof.{goals;sigma} = Proof.data proof in let ctx = Evd.universe_context_set (Evd.minimize_universes sigma) in Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++ str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx (* Simulate the Intro(s) tactic *) -let show_intro ~pstate all = +let show_intro ~proof all = let open EConstr in - let pf = Proof_global.give_me_the_proof pstate in - let Proof.{goals;sigma} = Proof.data pf in + let Proof.{goals;sigma} = Proof.data proof in if not (List.is_empty goals) then begin let gl = {Evd.it=List.hd goals ; sigma = sigma; } in let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (pf_concl gl)) in @@ -511,7 +505,7 @@ let dump_global r = let vernac_syntax_extension ~module_local infix l = if infix then Metasyntax.check_infix_modifiers (snd l); - Metasyntax.add_syntax_extension module_local l + Metasyntax.add_syntax_extension ~local:module_local l let vernac_declare_scope ~module_local sc = Metasyntax.declare_scope module_local sc @@ -530,11 +524,13 @@ let vernac_open_close_scope ~section_local (b,s) = let vernac_arguments_scope ~section_local r scl = Notation.declare_arguments_scope section_local (smart_global r) scl -let vernac_infix ~module_local = - Metasyntax.add_infix module_local (Global.env()) +let vernac_infix ~atts = + let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in + Metasyntax.add_infix ~local:module_local deprecation (Global.env()) -let vernac_notation ~module_local = - Metasyntax.add_notation module_local (Global.env()) +let vernac_notation ~atts = + let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in + Metasyntax.add_notation ~local:module_local deprecation (Global.env()) let vernac_custom_entry ~module_local s = Metasyntax.declare_custom_entry module_local s @@ -586,7 +582,7 @@ let start_proof_and_print ~program_mode ?hook k l = in Some hook else None in - start_proof_com ~program_mode ?inference_hook ?hook k l + start_lemma_com ~program_mode ?inference_hook ?hook k l let vernac_definition_hook p = function | Coercion -> @@ -597,6 +593,9 @@ let vernac_definition_hook p = function Some (Class.add_subclass_hook p) | _ -> None +let fresh_name_for_anonymous_theorem () = + Namegen.next_global_ident_away Lemmas.default_thm_id Id.Set.empty + let vernac_definition_name lid local = let lid = match lid with @@ -606,7 +605,7 @@ let vernac_definition_name lid local = let () = match local with | Discharge -> Dumpglob.dump_definition lid true "var" - | Local | Global -> Dumpglob.dump_definition lid false "def" + | Global _ -> Dumpglob.dump_definition lid false "def" in lid @@ -641,30 +640,39 @@ let vernac_start_proof ~atts kind l = List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; start_proof_and_print ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l -let vernac_end_proof ?pstate:ontop ?proof = function +let vernac_end_proof ?stack ?proof = let open Vernacexpr in function | Admitted -> - with_pstate ~pstate:ontop (save_proof_admitted ?proof); - ontop + vernac_require_open_lemma ~stack (fun ~stack -> + let lemma, stack = Stack.pop stack in + save_lemma_admitted ?proof ~lemma; + stack) | Proved (opaque,idopt) -> - save_proof_proved ?ontop ?proof ~opaque ~idopt + let lemma, stack = match stack with + | None -> None, None + | Some stack -> + let lemma, stack = Stack.pop stack in + Some lemma, stack + in + save_lemma_proved ?lemma ?proof ~opaque ~idopt; + stack -let vernac_exact_proof ~pstate c = +let vernac_exact_proof ~lemma c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the beginning of a proof. *) - let pstate, status = Pfedit.by (Tactics.exact_proof c) pstate in - let () = save_pstate_proved ~pstate ~opaque:Proof_global.Opaque ~idopt:None in + let lemma, status = Lemmas.by (Tactics.exact_proof c) lemma in + let () = save_lemma_proved ?proof:None ~lemma ~opaque:Proof_global.Opaque ~idopt:None in if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in - let global = local == Global in let kind = local, atts.polymorphic, kind in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then List.iter (fun (lid, _) -> - if global then Dumpglob.dump_definition lid false "ax" - else Dumpglob.dump_definition lid true "var") idl) l; + match local with + | Global _ -> Dumpglob.dump_definition lid false "ax" + | Discharge -> Dumpglob.dump_definition lid true "var") idl) l; let status = ComAssumption.do_assumptions ~program_mode:atts.program kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom @@ -1157,7 +1165,7 @@ let focus_command_cond = Proof.no_cond command_focus all tactics fail if there are no further goals to prove. *) let vernac_solve_existential ~pstate n com = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> let intern env sigma = Constrintern.intern_constr env sigma com in Proof.V82.instantiate_evar (Global.env ()) n intern p) pstate @@ -1167,15 +1175,14 @@ let vernac_set_end_tac ~pstate tac = (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) Proof_global.set_endline_tactic tac pstate -let vernac_set_used_variables ~(pstate : Proof_global.t) e : Proof_global.t = +let vernac_set_used_variables ~pstate e : Proof_global.t = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in - let tys = - List.map snd (initial_goals (Proof_global.give_me_the_proof pstate)) in + let tys = List.map snd (initial_goals (Proof_global.get_proof pstate)) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in - List.iter (fun id -> + List.iter (fun id -> if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ Id.print id)) @@ -1261,9 +1268,10 @@ let vernac_hints ~atts dbnames h = let local = enforce_module_locality local in Hints.add_hints ~local dbnames (Hints.interp_hints poly h) -let vernac_syntactic_definition ~module_local lid x y = +let vernac_syntactic_definition ~atts lid x compat = + let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in Dumpglob.dump_definition lid false "syndef"; - Metasyntax.add_syntactic_definition (Global.env()) lid.v x module_local y + Metasyntax.add_syntactic_definition ~local:module_local deprecation (Global.env()) lid.v x compat let cache_bidi_hints (_name, (gr, ohint)) = match ohint with @@ -1878,10 +1886,10 @@ let get_current_context_of_args ~pstate = match pstate with | None -> fun _ -> let env = Global.env () in Evd.(from_env env, env) - | Some pstate -> + | Some lemma -> function - | Some n -> Pfedit.get_goal_context pstate n - | None -> Pfedit.get_current_context pstate + | Some n -> Pfedit.get_goal_context lemma n + | None -> Pfedit.get_current_context lemma let query_command_selector ?loc = function | None -> None @@ -1946,7 +1954,7 @@ let vernac_global_check c = let get_nth_goal ~pstate n = - let pf = Proof_global.give_me_the_proof pstate in + let pf = Proof_global.get_proof pstate in let Proof.{goals;sigma} = Proof.data pf in let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl @@ -2022,9 +2030,9 @@ let vernac_print ~pstate ~atts = | PrintHintGoal -> begin match pstate with | Some pstate -> - Hints.pr_applicable_hint pstate + Hints.pr_applicable_hint pstate | None -> - str "No proof in progress" + str "No proof in progress" end | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s | PrintHintDb -> Hints.pr_searchtable env sigma @@ -2176,7 +2184,7 @@ let vernac_register qid r = (* Proof management *) let vernac_focus ~pstate gln = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> match gln with | None -> Proof.focus focus_command_cond () 1 p | Some 0 -> @@ -2187,19 +2195,18 @@ let vernac_focus ~pstate gln = (* Unfocuses one step in the focus stack. *) let vernac_unfocus ~pstate = - Proof_global.modify_proof + Proof_global.map_proof (fun p -> Proof.unfocus command_focus p ()) pstate (* Checks that a proof is fully unfocused. Raises an error if not. *) let vernac_unfocused ~pstate = - let p = Proof_global.give_me_the_proof pstate in + let p = Proof_global.get_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." else user_err Pp.(str "The proof is not fully unfocused.") - (* "{" focuses on the first goal, "n: {" focuses on the n-th goal "}" unfocuses, provided that the proof of the goal has been completed. *) @@ -2207,7 +2214,7 @@ let subproof_kind = Proof.new_focus_kind () let subproof_cond = Proof.done_cond subproof_kind let vernac_subproof gln ~pstate = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> match gln with | None -> Proof.focus subproof_cond () 1 p | Some (Goal_select.SelectNth n) -> Proof.focus subproof_cond () n p @@ -2217,12 +2224,12 @@ let vernac_subproof gln ~pstate = pstate let vernac_end_subproof ~pstate = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> Proof.unfocus subproof_kind p ()) pstate let vernac_bullet (bullet : Proof_bullet.t) ~pstate = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> Proof_bullet.put p bullet) pstate (* Stack is needed due to show proof names, should deprecate / remove @@ -2239,25 +2246,26 @@ let vernac_show ~pstate = end (* Show functions that require a proof state *) | Some pstate -> + let proof = Proof_global.get_proof pstate in begin function | ShowGoal goalref -> - let proof = Proof_global.give_me_the_proof pstate in begin match goalref with | OpenSubgoals -> pr_open_subgoals ~proof | NthGoal n -> pr_nth_open_subgoal ~proof n | GoalId id -> pr_goal_by_id ~proof id end - | ShowExistentials -> show_top_evars ~pstate - | ShowUniverses -> show_universes ~pstate + | ShowExistentials -> show_top_evars ~proof + | ShowUniverses -> show_universes ~proof + (* Deprecate *) | ShowProofNames -> - Id.print (Proof_global.get_current_proof_name pstate) - | ShowIntros all -> show_intro ~pstate all + Id.print (Proof_global.get_proof_name pstate) + | ShowIntros all -> show_intro ~proof all | ShowProof -> show_proof ~pstate:(Some pstate) | ShowMatch id -> show_match id end let vernac_check_guard ~pstate = - let pts = Proof_global.give_me_the_proof pstate in + let pts = Proof_global.get_proof pstate in let pfterm = List.hd (Proof.partial_proof pts) in let message = try @@ -2322,30 +2330,31 @@ let locate_if_not_already ?loc (e, info) = exception End_of_input -let interp_typed_vernac c ~pstate = - let open Proof_global in +let interp_typed_vernac c ~stack = let open Vernacextend in match c with - | VtDefault f -> f (); pstate + | VtDefault f -> f (); stack | VtNoProof f -> - if there_are_pending_proofs ~pstate then + if Option.has_some stack then user_err Pp.(str "Command not supported (Open proofs remain)"); let () = f () in - pstate + stack | VtCloseProof f -> - vernac_require_open_proof ~pstate (fun ~pstate -> - f ~pstate:(Proof_global.get_current_pstate pstate); - Proof_global.discard_current pstate) + vernac_require_open_lemma ~stack (fun ~stack -> + let lemma, stack = Stack.pop stack in + f ~lemma; + stack) | VtOpenProof f -> - Some (push ~ontop:pstate (f ())) + Some (Stack.push stack (f ())) | VtModifyProof f -> - modify_pstate f ~pstate + Option.map (Stack.map_top_pstate ~f:(fun pstate -> f ~pstate)) stack | VtReadProofOpt f -> - f ~pstate:(Option.map get_current_pstate pstate); - pstate + let pstate = Option.map (Stack.with_top_pstate ~f:(fun x -> x)) stack in + f ~pstate; + stack | VtReadProof f -> - with_pstate ~pstate f; - pstate + with_pstate ~stack f; + stack (* We interpret vernacular commands to a DSL that specifies their allowed actions on proof states *) @@ -2374,9 +2383,9 @@ let translate_vernac ~atts v = let open Vernacextend in match v with | VernacOpenCloseScope (b, s) -> VtDefault(fun () -> with_section_locality ~atts vernac_open_close_scope (b,s)) | VernacInfix (mv,qid,sc) -> - VtDefault(fun () -> with_module_locality ~atts vernac_infix mv qid sc) + VtDefault(fun () -> vernac_infix ~atts mv qid sc) | VernacNotation (c,infpl,sc) -> - VtDefault(fun () -> with_module_locality ~atts vernac_notation c infpl sc) + VtDefault(fun () -> vernac_notation ~atts c infpl sc) | VernacNotationAddFormat(n,k,v) -> VtDefault(fun () -> unsupported_attributes atts; @@ -2398,9 +2407,9 @@ let translate_vernac ~atts v = let open Vernacextend in match v with | VernacStartTheoremProof (k,l) -> VtOpenProof(fun () -> with_def_attributes ~atts vernac_start_proof k l) | VernacExactProof c -> - VtCloseProof(fun ~pstate -> + VtCloseProof (fun ~lemma -> unsupported_attributes atts; - vernac_exact_proof ~pstate c) + vernac_exact_proof ~lemma c) | VernacDefineModule (export,lid,bl,mtys,mexprl) -> let i () = @@ -2554,8 +2563,7 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtDefault(fun () -> vernac_hints ~atts dbnames hints) | VernacSyntacticDefinition (id,c,b) -> - VtDefault(fun () -> - with_module_locality ~atts vernac_syntactic_definition id c b) + VtDefault(fun () -> vernac_syntactic_definition ~atts id c b) | VernacArguments (qid, args, more_implicits, nargs, bidi, flags) -> VtDefault(fun () -> with_section_locality ~atts (vernac_arguments qid args more_implicits nargs bidi flags)) @@ -2671,7 +2679,7 @@ let translate_vernac ~atts v = let open Vernacextend in match v with * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) let rec interp_expr ?proof ~atts ~st c = - let pstate = st.Vernacstate.proof in + let stack = st.Vernacstate.lemmas in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -2699,11 +2707,11 @@ let rec interp_expr ?proof ~atts ~st c = (* Special: ?proof parameter doesn't allow for uniform pstate pop :S *) | VernacEndProof e -> unsupported_attributes atts; - vernac_end_proof ?proof ?pstate e + vernac_end_proof ?proof ?stack e | v -> let fv = translate_vernac ~atts v in - interp_typed_vernac ~pstate fv + interp_typed_vernac ~stack fv (* XXX: This won't properly set the proof mode, as of today, it is controlled by the STM. Thus, we would need access information from @@ -2712,8 +2720,9 @@ let rec interp_expr ?proof ~atts ~st c = without a considerable amount of refactoring. *) and vernac_load ~verbosely ~st fname = - let pstate = st.Vernacstate.proof in - if there_are_pending_proofs ~pstate then + let there_are_pending_proofs ~stack = not Option.(is_empty stack) in + let stack = st.Vernacstate.lemmas in + if there_are_pending_proofs ~stack then CErrors.user_err Pp.(str "Load is not supported inside proofs."); (* Open the file *) let fname = @@ -2730,29 +2739,29 @@ and vernac_load ~verbosely ~st fname = match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with | Some x -> x | None -> raise End_of_input) in - let rec load_loop ~pstate = + let rec load_loop ~stack = try - let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) pstate in - let pstate = - v_mod (interp_control ?proof:None ~st:{ st with Vernacstate.proof = pstate }) + let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) stack in + let stack = + v_mod (interp_control ?proof:None ~st:{ st with Vernacstate.lemmas = stack }) (parse_sentence proof_mode input) in - load_loop ~pstate + load_loop ~stack with End_of_input -> - pstate + stack in - let pstate = load_loop ~pstate in + let stack = load_loop ~stack in (* If Load left a proof open, we fail too. *) - if there_are_pending_proofs ~pstate then + if there_are_pending_proofs ~stack then CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); - pstate + stack and interp_control ?proof ~st v = match v with | { v=VernacExpr (atts, cmd) } -> interp_expr ?proof ~atts ~st cmd | { v=VernacFail v } -> with_fail ~st (fun () -> interp_control ?proof ~st v); - st.Vernacstate.proof + st.Vernacstate.lemmas | { v=VernacTimeout (timeout,v) } -> vernac_timeout ~timeout (interp_control ?proof ~st) v | { v=VernacRedirect (s, v) } -> @@ -2774,8 +2783,8 @@ let interp ?(verbosely=true) ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; try vernac_timeout (fun st -> let v_mod = if verbosely then Flags.verbosely else Flags.silently in - let pstate = v_mod (interp_control ?proof ~st) cmd in - Vernacstate.Proof_global.set pstate [@ocaml.warning "-3"]; + let ontop = v_mod (interp_control ?proof ~st) cmd in + Vernacstate.Proof_global.set ontop [@ocaml.warning "-3"]; Vernacstate.freeze_interp_state ~marshallable:false ) st with exn -> diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index d94ddc1aaf..f1c8b29313 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -22,7 +22,7 @@ val vernac_require : (** The main interpretation function of vernacular expressions *) val interp : ?verbosely:bool -> - ?proof:Proof_global.closed_proof -> + ?proof:(Proof_global.proof_object * Lemmas.proof_terminator) -> st:Vernacstate.t -> Vernacexpr.vernac_control -> Vernacstate.t (** Prepare a "match" template for a given inductive type. @@ -41,13 +41,6 @@ val command_focus : unit Proof.focus_kind val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t -(** Helper *) -val vernac_require_open_proof : pstate:Proof_global.stack option -> (pstate:Proof_global.stack -> 'a) -> 'a - -val with_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.t -> 'a) -> 'a - -val modify_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.t -> Proof_global.t) -> Proof_global.stack option - (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) val test_mode : bool ref diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 6f8a4e8a3c..c7008c2a84 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -16,7 +16,11 @@ type vernac_keep_as = VtKeepAxiom | VtKeepDefined | VtKeepOpaque type vernac_qed_type = VtKeep of vernac_keep_as | VtDrop -type vernac_type = +type vernac_when = + | VtNow + | VtLater + +type vernac_classification = (* Start of a proof *) | VtStartProof of vernac_start (* Command altering the global state, bad for parallel @@ -37,7 +41,7 @@ type vernac_type = (* To be removed *) | VtMeta and vernac_start = opacity_guarantee * Names.Id.t list -and vernac_sideff_type = Names.Id.t list +and vernac_sideff_type = Names.Id.t list * vernac_when and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) @@ -48,16 +52,12 @@ and anon_abstracting_tac = bool (** abstracting anonymously its result *) and proof_block_name = string (** open type of delimiters *) -type vernac_when = - | VtNow - | VtLater -type vernac_classification = vernac_type * vernac_when - type typed_vernac = | VtDefault of (unit -> unit) + | VtNoProof of (unit -> unit) - | VtCloseProof of (pstate:Proof_global.t -> unit) - | VtOpenProof of (unit -> Proof_global.t) + | VtCloseProof of (lemma:Lemmas.t -> unit) + | VtOpenProof of (unit -> Lemmas.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) | VtReadProofOpt of (pstate:Proof_global.t option -> unit) | VtReadProof of (pstate:Proof_global.t -> unit) @@ -129,9 +129,9 @@ let get_vernac_classifier (name, i) args = let declare_vernac_classifier name f = classifiers := String.Map.add name f !classifiers -let classify_as_query = VtQuery, VtLater -let classify_as_sideeff = VtSideff [], VtLater -let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None}, VtLater +let classify_as_query = VtQuery +let classify_as_sideeff = VtSideff ([], VtLater) +let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None} type (_, _) ty_sig = | TyNil : (vernac_command, vernac_classification) ty_sig diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 60e371a6d9..fd59d77237 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -32,7 +32,11 @@ type vernac_keep_as = VtKeepAxiom | VtKeepDefined | VtKeepOpaque type vernac_qed_type = VtKeep of vernac_keep_as | VtDrop -type vernac_type = +type vernac_when = + | VtNow + | VtLater + +type vernac_classification = (* Start of a proof *) | VtStartProof of vernac_start (* Command altering the global state, bad for parallel @@ -53,7 +57,7 @@ type vernac_type = (* To be removed *) | VtMeta and vernac_start = opacity_guarantee * Names.Id.t list -and vernac_sideff_type = Names.Id.t list +and vernac_sideff_type = Names.Id.t list * vernac_when and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) @@ -64,18 +68,13 @@ and anon_abstracting_tac = bool (** abstracting anonymously its result *) and proof_block_name = string (** open type of delimiters *) -type vernac_when = - | VtNow - | VtLater -type vernac_classification = vernac_type * vernac_when - (** Interpretation of extended vernac phrases. *) type typed_vernac = | VtDefault of (unit -> unit) | VtNoProof of (unit -> unit) - | VtCloseProof of (pstate:Proof_global.t -> unit) - | VtOpenProof of (unit -> Proof_global.t) + | VtCloseProof of (lemma:Lemmas.t -> unit) + | VtOpenProof of (unit -> Lemmas.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) | VtReadProofOpt of (pstate:Proof_global.t option -> unit) | VtReadProof of (pstate:Proof_global.t -> unit) diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 0fbde1ade5..c51d3c30f4 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -30,18 +30,16 @@ end type t = { parsing : Parser.state; system : States.state; (* summary + libstack *) - proof : Proof_global.stack option; (* proof state *) + lemmas : Lemmas.Stack.t option; (* proofs of lemmas currently opened *) shallow : bool (* is the state trimmed down (libstack) *) } -let pstate st = Option.map Proof_global.get_current_pstate st.proof - let s_cache = ref None -let s_proof = ref None +let s_lemmas = ref None let invalidate_cache () = s_cache := None; - s_proof := None + s_lemmas := None let update_cache rf v = rf := Some v; v @@ -57,14 +55,14 @@ let do_if_not_cached rf f v = let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); - proof = !s_proof; + lemmas = !s_lemmas; shallow = false; parsing = Parser.cur_state (); } -let unfreeze_interp_state { system; proof; parsing } = +let unfreeze_interp_state { system; lemmas; parsing } = do_if_not_cached s_cache States.unfreeze system; - s_proof := proof; + s_lemmas := lemmas; Pcoq.unfreeze parsing let make_shallow st = @@ -77,11 +75,16 @@ let make_shallow st = (* Compatibility module *) module Proof_global = struct - let get () = !s_proof - let set x = s_proof := x + type t = Lemmas.Stack.t + + let get () = !s_lemmas + let set x = s_lemmas := x + + let get_pstate () = + Option.map (Lemmas.Stack.with_top ~f:(Lemmas.pf_fold (fun x -> x))) !s_lemmas let freeze ~marshallable:_ = get () - let unfreeze x = s_proof := Some x + let unfreeze x = s_lemmas := Some x exception NoCurrentProof @@ -92,53 +95,62 @@ module Proof_global = struct | _ -> raise CErrors.Unhandled end + open Lemmas open Proof_global - let cc f = match !s_proof with + let cc f = match !s_lemmas with | None -> raise NoCurrentProof - | Some x -> f x - - let cc1 f = cc (fun p -> f (Proof_global.get_current_pstate p)) + | Some x -> Stack.with_top_pstate ~f x - let dd f = match !s_proof with + let cc_lemma f = match !s_lemmas with | None -> raise NoCurrentProof - | Some x -> s_proof := Some (f x) + | Some x -> Stack.with_top ~f x - let dd1 f = dd (fun p -> Proof_global.modify_current_pstate f p) + let cc_stack f = match !s_lemmas with + | None -> raise NoCurrentProof + | Some x -> f x - let there_are_pending_proofs () = !s_proof <> None - let get_open_goals () = cc1 get_open_goals + let dd f = match !s_lemmas with + | None -> raise NoCurrentProof + | Some x -> s_lemmas := Some (Stack.map_top_pstate ~f x) - let set_terminator x = dd1 (set_terminator x) - let give_me_the_proof_opt () = Option.map (fun p -> give_me_the_proof (Proof_global.get_current_pstate p)) !s_proof - let give_me_the_proof () = cc1 give_me_the_proof - let get_current_proof_name () = cc1 get_current_proof_name + let there_are_pending_proofs () = !s_lemmas <> None + let get_open_goals () = cc get_open_goals - let simple_with_current_proof f = - dd (simple_with_current_proof f) + let give_me_the_proof_opt () = Option.map (Stack.with_top_pstate ~f:get_proof) !s_lemmas + let give_me_the_proof () = cc get_proof + let get_current_proof_name () = cc get_proof_name + let map_proof f = dd (map_proof f) let with_current_proof f = - let pf, res = cc (with_current_proof f) in - s_proof := Some pf; res + match !s_lemmas with + | None -> raise NoCurrentProof + | Some stack -> + let pf, res = Stack.with_top_pstate stack ~f:(map_fold_proof_endline f) in + let stack = Stack.map_top_pstate stack ~f:(fun _ -> pf) in + s_lemmas := Some stack; + res + + type closed_proof = Proof_global.proof_object * Lemmas.proof_terminator - let install_state s = s_proof := Some s - let return_proof ?allow_partial () = - cc1 (return_proof ?allow_partial) + let return_proof ?allow_partial () = cc (return_proof ?allow_partial) let close_future_proof ~opaque ~feedback_id pf = - cc1 (fun st -> close_future_proof ~opaque ~feedback_id st pf) + cc_lemma (fun pt -> pf_fold (fun st -> close_future_proof ~opaque ~feedback_id st pf) pt, + Internal.get_terminator pt) let close_proof ~opaque ~keep_body_ucst_separate f = - cc1 (close_proof ~opaque ~keep_body_ucst_separate f) + cc_lemma (fun pt -> pf_fold ((close_proof ~opaque ~keep_body_ucst_separate f)) pt, + Internal.get_terminator pt) - let discard_all () = s_proof := None - let update_global_env () = dd1 update_global_env + let discard_all () = s_lemmas := None + let update_global_env () = dd (update_global_env) - let get_current_context () = cc1 Pfedit.get_current_context + let get_current_context () = cc Pfedit.get_current_context let get_all_proof_names () = - try cc get_all_proof_names + try cc_stack Lemmas.Stack.get_all_proof_names with NoCurrentProof -> [] let copy_terminators ~src ~tgt = @@ -146,6 +158,6 @@ module Proof_global = struct | None, None -> None | Some _ , None -> None | None, Some x -> Some x - | Some src, Some tgt -> Some (copy_terminators ~src ~tgt) + | Some src, Some tgt -> Some (Stack.copy_terminators ~src ~tgt) end diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index b0f3c572e5..9f4e366e1c 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -18,14 +18,12 @@ module Parser : sig end -type t = { - parsing : Parser.state; - system : States.state; (* summary + libstack *) - proof : Proof_global.stack option; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) -} - -val pstate : t -> Proof_global.t option +type t = + { parsing : Parser.state + ; system : States.state (* summary + libstack *) + ; lemmas : Lemmas.Stack.t option (* proofs of lemmas currently opened *) + ; shallow : bool (* is the state trimmed down (libstack) *) + } val freeze_interp_state : marshallable:bool -> t val unfreeze_interp_state : t -> unit @@ -38,41 +36,29 @@ val invalidate_cache : unit -> unit (* Compatibility module: Do Not Use *) module Proof_global : sig - open Proof_global - - (* Low-level stuff *) - val get : unit -> stack option - val set : stack option -> unit - - val freeze : marshallable:bool -> stack option - val unfreeze : stack -> unit - exception NoCurrentProof val there_are_pending_proofs : unit -> bool val get_open_goals : unit -> int - val set_terminator : proof_terminator -> unit val give_me_the_proof : unit -> Proof.t val give_me_the_proof_opt : unit -> Proof.t option val get_current_proof_name : unit -> Names.Id.t - val simple_with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit - + val map_proof : (Proof.t -> Proof.t) -> unit val with_current_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a - val install_state : stack -> unit + val return_proof : ?allow_partial:bool -> unit -> Proof_global.closed_proof_output - val return_proof : ?allow_partial:bool -> unit -> closed_proof_output + type closed_proof = Proof_global.proof_object * Lemmas.proof_terminator val close_future_proof : - opaque:opacity_flag -> + opaque:Proof_global.opacity_flag -> feedback_id:Stateid.t -> - closed_proof_output Future.computation -> closed_proof + Proof_global.closed_proof_output Future.computation -> closed_proof - val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof + val close_proof : opaque:Proof_global.opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof val discard_all : unit -> unit val update_global_env : unit -> unit @@ -81,7 +67,19 @@ module Proof_global : sig val get_all_proof_names : unit -> Names.Id.t list - val copy_terminators : src:stack option -> tgt:stack option -> stack option + val copy_terminators : src:Lemmas.Stack.t option -> tgt:Lemmas.Stack.t option -> Lemmas.Stack.t option + + (* Handling of the imperative state *) + type t = Lemmas.Stack.t + + (* Low-level stuff *) + val get : unit -> t option + val set : t option -> unit + + val get_pstate : unit -> Proof_global.t option + + val freeze : marshallable:bool -> t option + val unfreeze : t -> unit end [@@ocaml.deprecated "This module is internal and should not be used, instead, thread the proof state"] |