diff options
124 files changed, 4426 insertions, 3736 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8cf26ffaa6..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" @@ -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/ci-iris-lambda-rust.sh b/dev/ci/ci-iris-lambda-rust.sh index 95f143bb95..d99e140bce 100755 --- a/dev/ci/ci-iris-lambda-rust.sh +++ b/dev/ci/ci-iris-lambda-rust.sh @@ -8,14 +8,14 @@ install_ssreflect # Setup lambdaRust first git_download lambdaRust -# Extract required version of Iris -Iris_CI_REF=$(grep -F coq-iris < "${CI_BUILD_DIR}/lambdaRust/opam" | sed 's/.*"dev\.[0-9.-]\+\.\([0-9a-z]\+\)".*/\1/') +# Extract required version of Iris (avoiding "+" which does not work on MacOS :( *) +Iris_CI_REF=$(grep -F coq-iris < "${CI_BUILD_DIR}/lambdaRust/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') # Setup Iris git_download Iris # Extract required version of std++ -stdpp_CI_REF=$(grep -F coq-stdpp < "${CI_BUILD_DIR}/Iris/opam" | sed 's/.*"dev\.[0-9.-]\+\.\([0-9a-z]\+\)".*/\1/') +stdpp_CI_REF=$(grep -F coq-stdpp < "${CI_BUILD_DIR}/Iris/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') # Setup std++ git_download stdpp 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/10231-herbelin-master+locating-warning-different-implicit-term-type.sh b/dev/ci/user-overlays/10231-herbelin-master+locating-warning-different-implicit-term-type.sh new file mode 100644 index 0000000000..c8cf85e73e --- /dev/null +++ b/dev/ci/user-overlays/10231-herbelin-master+locating-warning-different-implicit-term-type.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "10231" ] || [ "$CI_BRANCH" = "master+locating-warning-different-implicit-term-type" ]; then + + equations_CI_REF=master+fix-manual-implicit-pr10231 + equations_CI_GITURL=https://github.com/herbelin/Coq-Equations + + mtac2_CI_REF=master+fix-manual-implicit-pr10231 + mtac2_CI_GITURL=https://github.com/herbelin/Mtac2 + +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/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/12-misc/10019-PG-proof-diffs.rst b/doc/changelog/12-misc/10019-PG-proof-diffs.rst deleted file mode 100644 index b2d191be26..0000000000 --- a/doc/changelog/12-misc/10019-PG-proof-diffs.rst +++ /dev/null @@ -1,3 +0,0 @@ -- Proof General can now display Coq-generated diffs between proof steps - in color. (`#10019 <https://github.com/coq/coq/pull/10019>`_ and (in Proof General) - `#421 <https://github.com/ProofGeneral/PG/pull/421>`_, by Jim Fehrle). diff --git a/doc/plugin_tutorial/tuto2/_CoqProject b/doc/plugin_tutorial/tuto2/_CoqProject index cf9cb5cc26..0d7a644271 100644 --- a/doc/plugin_tutorial/tuto2/_CoqProject +++ b/doc/plugin_tutorial/tuto2/_CoqProject @@ -1,6 +1,15 @@ --R theories/ Tuto +-R theories Tuto2 -I src -theories/Test.v -src/demo.mlg -src/demo_plugin.mlpack +theories/Loader.v +theories/Demo.v +theories/Count.v + +src/custom.ml +src/custom.mli +src/counter.ml +src/counter.mli +src/persistent_counter.ml +src/persistent_counter.mli +src/g_tuto2.mlg +src/tuto2_plugin.mlpack diff --git a/doc/plugin_tutorial/tuto2/src/counter.ml b/doc/plugin_tutorial/tuto2/src/counter.ml new file mode 100644 index 0000000000..8721090d42 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/counter.ml @@ -0,0 +1,22 @@ +(* + * This file defines our counter, which we use in the Count command. + *) + +(* + * Our counter is simply a reference called "counter" to an integer. + * + * Summary.ref behaves like ref, but also registers a summary to Coq. + *) +let counter = Summary.ref ~name:"counter" 0 + +(* + * We can increment our counter: + *) +let increment () = + counter := succ !counter + +(* + * We can also read the value of our counter: + *) +let value () = + !counter diff --git a/doc/plugin_tutorial/tuto2/src/counter.mli b/doc/plugin_tutorial/tuto2/src/counter.mli new file mode 100644 index 0000000000..984bc1d2cc --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/counter.mli @@ -0,0 +1,13 @@ +(* + * This file defines our counter, which we use in the Count command. + *) + +(* + * Increment the counter + *) +val increment : unit -> unit + +(* + * Determine the value of the counter + *) +val value : unit -> int diff --git a/doc/plugin_tutorial/tuto2/src/custom.ml b/doc/plugin_tutorial/tuto2/src/custom.ml new file mode 100644 index 0000000000..648786d3bd --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/custom.ml @@ -0,0 +1,5 @@ +(* + * This file defines a custom type for the PassCustom command. + *) + +type custom_type = Foo | Bar diff --git a/doc/plugin_tutorial/tuto2/src/custom.mli b/doc/plugin_tutorial/tuto2/src/custom.mli new file mode 100644 index 0000000000..648786d3bd --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/custom.mli @@ -0,0 +1,5 @@ +(* + * This file defines a custom type for the PassCustom command. + *) + +type custom_type = Foo | Bar diff --git a/doc/plugin_tutorial/tuto2/src/demo.mlg b/doc/plugin_tutorial/tuto2/src/demo.mlg deleted file mode 100644 index 966c05acdc..0000000000 --- a/doc/plugin_tutorial/tuto2/src/demo.mlg +++ /dev/null @@ -1,375 +0,0 @@ -(* -------------------------------------------------------------------------- *) -(* *) -(* Initial ritual dance *) -(* *) -(* -------------------------------------------------------------------------- *) - -DECLARE PLUGIN "demo_plugin" - -(* - Use this macro before any of the other OCaml macros. - - Each plugin has a unique name. - We have decided to name this plugin as "demo_plugin". - That means that: - - (1) If we want to load this particular plugin to Coq toplevel, - we must use the following command. - - Declare ML Module "demo_plugin". - - (2) The above command will succeed only if there is "demo_plugin.cmxs" - in some of the directories that Coq is supposed to look - (i.e. the ones we specified via "-I ..." command line options). - - (3) The file "demo_plugin.mlpack" lists the OCaml modules to be linked in - "demo_plugin.cmxs". - - (4) The file "demo_plugin.mlpack" as well as all .ml, .mli and .mlg files - are listed in the "_CoqProject" file. -*) - -(* -------------------------------------------------------------------------- *) -(* *) -(* How to define a new Vernacular command? *) -(* *) -(* -------------------------------------------------------------------------- *) - -VERNAC COMMAND EXTEND Cmd1 CLASSIFIED AS QUERY -| [ "Cmd1" ] -> { () } -END - -(* - These: - - VERNAC COMMAND EXTEND - - and - - END - - mark the beginning and the end of the definition of a new Vernacular command. - - Cmd1 is a unique identifier (which must start with an upper-case letter) - associated with the new Vernacular command we are defining. - - CLASSIFIED AS QUERY tells Coq that the new Vernacular command: - - changes neither the global environment - - nor does it modify the plugin's state. - - If the new command could: - - change the global environment - - or modify a plugin's state - then one would have to use CLASSIFIED AS SIDEFF instead. - - This: - - [ "Cmd1" ] -> { () } - - defines: - - the parsing rule - - the interpretation rule - - The parsing rule and the interpretation rule are separated by -> token. - - The parsing rule, in this case, is: - - [ "Cmd1" ] - - By convention, all vernacular command start with an upper-case letter. - - The [ and ] characters mark the beginning and the end of the parsing rule. - The parsing rule itself says that the syntax of the newly defined command - is composed from a single terminal Cmd1. - - The interpretation rule, in this case, is: - - { () } - - Similarly to the case of the parsing rule, - { and } characters mark the beginning and the end of the interpretation rule. - In this case, the following Ocaml expression: - - () - - defines the effect of the Vernacular command we have just defined. - That is, it behaves is no-op. -*) - -(* -------------------------------------------------------------------------- *) -(* *) -(* How to define a new Vernacular command with some terminal parameters? *) -(* *) -(* -------------------------------------------------------------------------- *) - -VERNAC COMMAND EXTEND Cmd2 CLASSIFIED AS QUERY -| [ "Cmd2" "With" "Some" "Terminal" "Parameters" ] -> { () } -END - -(* - As shown above, the Vernacular command can be composed from - any number of terminals. - - By convention, each of these terminals starts with an upper-case letter. -*) - -(* -------------------------------------------------------------------------- *) -(* *) -(* How to define a new Vernacular command with some non-terminal parameter? *) -(* *) -(* -------------------------------------------------------------------------- *) - -{ - -open Stdarg - -} - -VERNAC COMMAND EXTEND Cmd3 CLASSIFIED AS QUERY -| [ "Cmd3" int(i) ] -> { () } -END - -(* - This: - - open Stdarg - - is needed as some identifiers in the Ocaml code generated by the - - VERNAC COMMAND EXTEND ... END - - macros are not fully qualified. - - This: - - int(i) - - means that the new command is expected to be followed by an integer. - The integer is bound in the parsing rule to variable i. - This variable i then can be used in the interpretation rule. - - To see value of which Ocaml types can be bound this way, - look at the wit_* function declared in interp/stdarg.mli - (in the Coq's codebase). - - If we drop the wit_ prefix, we will get the token - that we can use in the parsing rule. - That is, since there exists wit_int, we know that - we can write: - - int(i) - - By looking at the signature of the wit_int function: - - val wit_int : int uniform_genarg_type - - we also know that variable i will have the type int. - - The types of wit_* functions are either: - - 'c uniform_genarg_type - - or - - ('a,'b,'c) genarg_type - - In both cases, the bound variable will have type 'c. -*) - -(* -------------------------------------------------------------------------- *) -(* *) -(* How to define a new Vernacular command with variable number of arguments? *) -(* *) -(* -------------------------------------------------------------------------- *) - -VERNAC COMMAND EXTEND Cmd4 CLASSIFIED AS QUERY -| [ "Cmd4" int_list(l) ] -> { () } -END - -(* - This: - - int_list(l) - - means that the new Vernacular command is expected to be followed - by a (whitespace separated) list of integers. - This list of integers is bound to the indicated l. - - In this case, as well as in the cases we point out below, instead of int - in int_list we could use any other supported type, e.g. ident, bool, ... - - To see which other Ocaml type constructors (in addition to list) - are supported, have a look at the parse_user_entry function defined - in grammar/q_util.mlp file. - - E.g.: - - ne_int_list(x) would represent a non-empty list of integers, - - int_list(x) would represent a list of integers, - - int_opt(x) would represent a value of type int option, - - ··· -*) - -(* -------------------------------------------------------------------------- *) -(* *) -(* How to define a new Vernacular command that takes values of a custom type? *) -(* *) -(* -------------------------------------------------------------------------- *) - -{ - -open Ltac_plugin - -} - -(* - If we want to avoid a compilation failure - - "no implementation available for Tacenv" - - then we have to open the Ltac_plugin module. -*) - -(* - Pp module must be opened because some of the macros that are part of the API - do not expand to fully qualified names. -*) - -{ - -type type_5 = Foo_5 | Bar_5 - -} - -(* - We define a type of values that we want to pass to our Vernacular command. -*) - -(* - By default, we are able to define new Vernacular commands that can take - parameters of some of the supported types. Which types are supported, - that was discussed earlier. - - If we want to be able to define Vernacular command that takes parameters - of a type that is not supported by default, we must use the following macro: -*) - -{ - -open Pp - -} - -VERNAC ARGUMENT EXTEND custom5 -| [ "Foo_5" ] -> { Foo_5 } -| [ "Bar_5" ] -> { Bar_5 } -END - -(* - where: - - custom5 - - indicates that, from now on, in our parsing rules we can write: - - custom5(some_variable) - - in those places where we expect user to provide an input - that can be parsed by the parsing rules above - (and interpreted by the interpretations rules above). -*) - -(* Here: *) - -VERNAC COMMAND EXTEND Cmd5 CLASSIFIED AS QUERY -| [ "Cmd5" custom5(x) ] -> { () } -END - -(* - we define a new Vernacular command whose parameters, provided by the user, - can be mapped to values of type_5. -*) - -(* -------------------------------------------------------------------------- *) -(* *) -(* How to give a feedback to the user? *) -(* *) -(* -------------------------------------------------------------------------- *) - -VERNAC COMMAND EXTEND Cmd6 CLASSIFIED AS QUERY -| [ "Cmd6" ] -> { Feedback.msg_notice (Pp.str "Everything is awesome!") } -END - -(* - The following functions: - - - Feedback.msg_info : Pp.t -> unit - - Feedback.msg_notice : Pp.t -> unit - - Feedback.msg_warning : Pp.t -> unit - - Feedback.msg_error : Pp.t -> unit - - Feedback.msg_debug : Pp.t -> unit - - enable us to give user a textual feedback. - - Pp module enable us to represent and construct pretty-printing instructions. - The concepts defined and the services provided by the Pp module are in - various respects related to the concepts and services provided - by the Format module that is part of the Ocaml standard library. -*) - -(* -------------------------------------------------------------------------- *) -(* *) -(* How to implement a Vernacular command with (undoable) side-effects? *) -(* *) -(* -------------------------------------------------------------------------- *) - -{ - -open Summary.Local - -} - -(* - By opening Summary.Local module we shadow the original functions - that we traditionally use for implementing stateful behavior. - - ref - ! - := - - are now shadowed by their counterparts in Summary.Local. *) - -{ - -let counter = ref ~name:"counter" 0 - -} - -VERNAC COMMAND EXTEND Cmd7 CLASSIFIED AS SIDEFF -| [ "Cmd7" ] -> { counter := succ !counter; - Feedback.msg_notice (Pp.str "counter = " ++ Pp.str (string_of_int (!counter))) } -END - -TACTIC EXTEND tactic1 -| [ "tactic1" ] -> { Proofview.tclUNIT () } -END - -(* ---- *) - -{ - -type custom = Foo_2 | Bar_2 - -let pr_custom _ _ _ = function - | Foo_2 -> Pp.str "Foo_2" - | Bar_2 -> Pp.str "Bar_2" - -} - -ARGUMENT EXTEND custom2 PRINTED BY { pr_custom } -| [ "Foo_2" ] -> { Foo_2 } -| [ "Bar_2" ] -> { Bar_2 } -END - -TACTIC EXTEND tactic2 -| [ "tactic2" custom2(x) ] -> { Proofview.tclUNIT () } -END diff --git a/doc/plugin_tutorial/tuto2/src/demo_plugin.mlpack b/doc/plugin_tutorial/tuto2/src/demo_plugin.mlpack deleted file mode 100644 index 4f0b8480b5..0000000000 --- a/doc/plugin_tutorial/tuto2/src/demo_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -Demo diff --git a/doc/plugin_tutorial/tuto2/src/dune b/doc/plugin_tutorial/tuto2/src/dune index f2bc405455..68ddd13947 100644 --- a/doc/plugin_tutorial/tuto2/src/dune +++ b/doc/plugin_tutorial/tuto2/src/dune @@ -4,6 +4,6 @@ (libraries coq.plugins.ltac)) (rule - (targets demo.ml) - (deps (:pp-file demo.mlg) ) + (targets g_tuto2.ml) + (deps (:pp-file g_tuto2.mlg) ) (action (run coqpp %{pp-file}))) diff --git a/doc/plugin_tutorial/tuto2/src/g_tuto2.mlg b/doc/plugin_tutorial/tuto2/src/g_tuto2.mlg new file mode 100644 index 0000000000..a3ce60d432 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/g_tuto2.mlg @@ -0,0 +1,618 @@ +(* -------------------------------------------------------------------------- *) +(* *) +(* Initial ritual dance *) +(* *) +(* -------------------------------------------------------------------------- *) + +DECLARE PLUGIN "tuto2_plugin" + +(* + Use this macro before any of the other OCaml macros. + + Each plugin has a unique name. + We have decided to name this plugin as "tuto2_plugin". + That means that: + + (1) We write the following command in a file called Loader.v: + + Declare ML Module "tuto2_plugin". + + to load this command into the Coq top-level. + + (2) Users can then load our plugin in other Coq files by writing: + + From Tuto2 Require Import Loader. + + where Loader is the name of the file that declares "tuto2_plugin", + and where Tuto2 is the name passed to the -R argument in our _CoqProject. + + (3) The above commands will succeed only if there is "tuto2_plugin.cmxs" + in some of the directories where Coq is supposed to look + (i.e. the ones we specified via "-I ..." command line options in + _CoqProject). As long as this is listed in our _CoqProject, the + Makefile takes care of placing it in the right directory. + + (4) The file "tuto2_plugin.mlpack" lists the OCaml modules to be linked in + "tuto2_plugin.cmxs". + + (5) The file "tuto2_plugin.mlpack" as well as all .ml, .mli and .mlg files + are listed in the "_CoqProject" file. + *) + +(* -------------------------------------------------------------------------- *) +(* *) +(* Importing OCaml dependencies *) +(* *) +(* -------------------------------------------------------------------------- *) + +(* + * This .mlg file is parsed into a .ml file. You can put OCaml in this file + * inside of curly braces. It's best practice to use this only to import + * other modules, and include most of your functionality in those modules. + * + * Here we list all of the dependencies that these commands have, and explain + * why. We also refer to the first command that uses them, where further + * explanation can be found in context. + *) +{ + (*** Dependencies from Coq ***) + + (* + * This lets us take non-terminal arguments to a command (for example, + * the PassInt command that takes an integer argument needs this + * this dependency). + * + * First used by: PassInt + *) + open Stdarg + + (* + * This is Coq's pretty-printing module. Here, we need it to use some + * useful syntax for pretty-printing. + * + * First use by: Count + *) + open Pp +} + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command? *) +(* *) +(* -------------------------------------------------------------------------- *) + +(* + This command does nothing: +*) +VERNAC COMMAND EXTEND NoOp CLASSIFIED AS QUERY +| [ "Nothing" ] -> { () } +END + +(* + --- Defining a Command --- + + These: + + VERNAC COMMAND EXTEND + + and + + END + + mark the beginning and the end of the definition of a new Vernacular command. + + --- Assigning a Command a Unique Identifier --- + + NoOp is a unique identifier (which must start with an upper-case letter) + associated with the new Vernacular command we are defining. It is good + to make this identifier descriptive. + + --- Classifying a Command --- + + CLASSIFIED AS QUERY tells Coq that the new Vernacular command neither: + - changes the global environment, nor + - modifies the plugin's state. + + If the new command could: + - change the global environment + - or modify a plugin's state + then one would have to use CLASSIFIED AS SIDEFF instead. + + --- Defining Parsing and Interpretation Rules --- + + This: + + [ "Nothing" ] -> { () } + + defines: + - the parsing rule (left) + - the interpretation rule (right) + + The parsing rule and the interpretation rule are separated by -> token. + + The parsing rule, in this case, is: + + [ "Nothing" ] + + By convention, all vernacular command start with an upper-case letter. + + The '[' and ']' characters mark the beginning and the end of the parsing + rule, respectively. The parsing rule itself says that the syntax of the + newly defined command is composed from a single terminal Nothing. + + The interpretation rule, in this case, is: + + { () } + + Similarly to the case of the parsing rule, the + '{' and '}' characters mark the beginning and the end of the interpretation + rule. In this case, the following Ocaml expression: + + () + + defines the effect of the Vernacular command we have just defined. + That is, it behaves is no-op. + + --- Calling a Command --- + + In Demo.v, we call this command by writing: + + Nothing. + + since our parsing rule is "Nothing". This does nothing, since our + interpretation rule is (). +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command with some terminal parameters? *) +(* *) +(* -------------------------------------------------------------------------- *) + +(* + This command takes some terminal parameters and does nothing. +*) +VERNAC COMMAND EXTEND NoOpTerminal CLASSIFIED AS QUERY +| [ "Command" "With" "Some" "Terminal" "Parameters" ] -> { () } +END + +(* + --- Defining a Command with Terminal Parameters --- + + As shown above, the Vernacular command can be composed from + any number of terminals. + + By convention, each of these terminals starts with an upper-case letter. + + --- Calling a Command with Terminal Parameters --- + + In Demo.v, we call this command by writing: + + Command With Some Terminal Parameters. + + to match our parsing rule. As expected, this does nothing. + + --- Recognizing Syntax Errors --- + + Note that if we were to omit any of these terminals, for example by writing: + + Command. + + it would fail to parse (as expected), showing this error to the user: + + Syntax error: illegal begin of vernac. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command with some non-terminal parameter? *) +(* *) +(* -------------------------------------------------------------------------- *) + +(* + This command takes an integer argument and does nothing. +*) +VERNAC COMMAND EXTEND PassInt CLASSIFIED AS QUERY +| [ "Pass" int(i) ] -> { () } +END + +(* + --- Dependencies --- + + Since this command takes a non-terminal argument, it is the first + to depend on Stdarg (opened at the top of this file). + + --- Defining a Command with Non-Terminal Arguments --- + + This: + + int(i) + + means that the new command is expected to be followed by an integer. + The integer is bound in the parsing rule to variable i. + This variable i then can be used in the interpretation rule. + + To see value of which Ocaml types can be bound this way, + look at the wit_* function declared in interp/stdarg.mli + (in the Coq's codebase). There are more examples in tuto1. + + If we drop the wit_ prefix, we will get the token + that we can use in the parsing rule. + That is, since there exists wit_int, we know that + we can write: + + int(i) + + By looking at the signature of the wit_int function: + + val wit_int : int uniform_genarg_type + + we also know that variable i will have the type int. + + --- Recognizing Build Errors --- + + The mapping from int(i) to wit_int is automatic. + This is why, if we forget to open Stdarg, we will get this error: + + Unbound value wit_int + + when we try to build our plugin. It is good to recognize this error, + since this is a common mistake in plugin development, and understand + that the fix is to open the file (Stdarg) where wit_int is defined. + + --- Calling a Command with Terminal Arguments --- + + We call this command in Demo.v by writing: + + Pass 42. + + We could just as well pass any other integer. As expected, this command + does nothing. + + --- Recognizing Syntax Errors --- + + As in our previous command, if we were to omit the arguments to the command, + for example by writing: + + Pass. + + it would fail to parse (as expected), showing this error to the user: + + Syntax error: [prim:integer] expected after 'Pass' (in [vernac:command]). + + The same thing would happen if we passed the wrong argument type: + + Pass True. + + If we pass too many arguments: + + Pass 15 20. + + we will get a different syntax error: + + Syntax error: '.' expected after [vernac:command] (in [vernac_aux]). + + It is good to recognize these errors, since doing so can help you + catch mistakes you make defining your parser rules during plugin + development. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command with variable number of arguments? *) +(* *) +(* -------------------------------------------------------------------------- *) + +(* + This command takes a list of integers and does nothing: +*) +VERNAC COMMAND EXTEND AcceptIntList CLASSIFIED AS QUERY +| [ "Accept" int_list(l) ] -> { () } +END + +(* + --- Dependencies --- + + Much like PassInt, this command depends on Stdarg. + + --- Defining a Command that Takes a Variable Number of Arguments --- + + This: + + int_list(l) + + means that the new Vernacular command is expected to be followed + by a (whitespace separated) list of integers. + This list of integers is bound to the indicated l. + + In this case, as well as in the cases we point out below, instead of int + in int_list we could use any other supported type, e.g. ident, bool, ... + + --- Other Ways to Take a Variable Number of Arguments --- + + To see which other Ocaml type constructors (in addition to list) + are supported, have a look at the parse_user_entry function defined + in the coqpp/coqpp_parse.mly file. + + E.g.: + - ne_int_list(x) would represent a non-empty list of integers, + - int_list(x) would represent a list of integers, + - int_opt(x) would represent a value of type int option, + - ··· + + Much like with int_list, we could use any other supported type here. + There are some more examples of this in tuto1. + + --- Calling a Command with a Variable Number of Arguments --- + + We call this command in Demo.v by writing: + + Accept 100 200 300 400. + + As expected, this does nothing. + + Since our parser rule uses int_list, the arguments to Accept can be a + list of integers of any length. For example, we can pass the empty list: + + Accept. + + or just one argument: + + Accept 2. + + and so on. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command that takes values of a custom type? *) +(* *) +(* -------------------------------------------------------------------------- *) + +(* + --- Defining Custom Types --- + + Vernacular commands can take custom types in addition to the built-in + ones. The first step to taking these custom types as arguments is + to define them. + + + We define a type of values that we want to pass to our Vernacular command + in custom.ml/custom.mli. The type is very simple: + + type custom_type : Foo | Bar. + + --- Using our New Module --- + + Now that we have a new OCaml module Custom, in order to use it, we must + do the following: + + 1. Add src/custom.ml and src/custom.mli to our _CoqProject + 2. Add Custom to our tuto2_plugin.mlpack + + This workflow will become very familiar to you when you add new modules + to your plugins, so it is worth getting used to. + + --- Depending on our New Module --- + + Now that our new module is listed in both _CoqProject and tuto2_plugin.mlpack, + we can use fully qualified names Custom.Foo and Custom.Bar. + + Alternatively, we could add the dependency on our module: + + open Custom. + + to the top of the file, and then refer to Foo and Bar directly. + + --- Telling Coq About our New Argument Type --- + + By default, we are able to define new Vernacular commands that can take + parameters of some of the supported types. Which types are supported, + that was discussed earlier. + + If we want to be able to define Vernacular command that takes parameters + of a type that is not supported by default, we must use the following macro: +*) +VERNAC ARGUMENT EXTEND custom +| [ "Foo" ] -> { Custom.Foo } +| [ "Bar" ] -> { Custom.Bar } +END + +(* + where: + + custom + + indicates that, from now on, in our parsing rules we can write: + + custom(some_variable) + + in those places where we expect user to provide an input + that can be parsed by the parsing rules above + (and interpreted by the interpretations rules above). +*) + +(* + --- Defining a Command that Takes an Argument of a Custom Type --- + + Now that Coq is aware of our new argument type, we can define a command + that uses it. This command takes an argument Foo or Bar and does nothing: +*) +VERNAC COMMAND EXTEND PassCustom CLASSIFIED AS QUERY +| [ "Foobar" custom(x) ] -> { () } +END + +(* + --- Calling a Command that Takes an Argument of a Custom Type --- + + We call this command in Demo.v by writing: + + Foobar Foo. + Foobar Bar. + + As expected, both of these do nothing. In the first case, x gets + the value Custom.Foo : Custom.custom_type, since our custom parsing + and interpretation rules (VERNAC ARGUMENT EXTEND custom ...) map + the input Foo to Custom.Foo. Similarly, in the second case, x gets + the value Custom.Bar : Custom.custom_type. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to give a feedback to the user? *) +(* *) +(* -------------------------------------------------------------------------- *) + +(* + So far we have defined commands that do nothing. + We can also signal feedback to the user. + + This command tells the user that everything is awesome: +*) +VERNAC COMMAND EXTEND Awesome CLASSIFIED AS QUERY +| [ "Is" "Everything" "Awesome" ] -> + { + Feedback.msg_notice (Pp.str "Everything is awesome!") + } +END + +(* + --- Pretty Printing --- + + User feedback functions like Feedback.msg_notice take a Pp.t as an argument. + Check the Pp module to see which functions are available to construct + a Pp.t. + + The Pp module enable us to represent and construct pretty-printing + instructions. The concepts defined and the services provided by the + Pp module are in various respects related to the concepts and services + provided by the Format module that is part of the Ocaml standard library. + + --- Giving Feedback --- + + Once we have a Pp.t, we can use the following functions: + + - Feedback.msg_info : Pp.t -> unit + - Feedback.msg_notice : Pp.t -> unit + - Feedback.msg_warning : Pp.t -> unit + - Feedback.msg_debug : Pp.t -> unit + + to give user a textual feedback. Examples of some of these can be + found in tuto0. + + --- Signaling Errors --- + + While there is a Feedback.msg_error, when signaling an error, + it is currently better practice to use user_err. There is an example of + this in tuto0. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to implement a Vernacular command with (undoable) side-effects? *) +(* *) +(* -------------------------------------------------------------------------- *) + +(* + This command counts how many times it has been called since importing + our plugin, and signals that information to the user: + *) +VERNAC COMMAND EXTEND Count CLASSIFIED AS SIDEFF +| [ "Count" ] -> + { + Counter.increment (); + let v = Counter.value () in + Feedback.msg_notice (Pp.str "Times Count has been called: " ++ Pp.int v) + } +END + +(* + --- Dependencies --- + + If we want to use the ++ syntax, then we need to depend on Pp explicitly. + This is why, at the top, we write: + + open Pp. + + --- Defining the Counter --- + + We define our counter in the Counter module. Please see counter.ml and + counter.mli for details. + + As with Custom, we must modify our _CoqProject and tuto2_plugin.mlpack + so that we can use Counter in our code. + + --- Classifying the Command --- + + This command has undoable side-effects: When the plugin is first loaded, + the counter is instantiated to 0. After each time we call Count, the value of + the counter increases by 1. + + Thus, we must write CLASSIFIED AS SIDEEFF for this command, rather than + CLASSIFIED AS QUERY. See the explanation from the NoOp command earlier if + you do not remember the distinction. + + --- Calling the Command --- + + We call our command three times in Demo.v by writing: + + Count. + Count. + Count. + + This gives us the following output: + + Times Count has been called: 1 + Times Count has been called: 2 + Times Count has been called: 3 + + Note that when the plugin is first loaded, the counter is 0. It increases + each time Count is called. + + --- Behavior with Imports --- + + Count.v shows the behavior with imports. Note that if we import Demo.v, + the counter is set to 0 from the beginning, even though Demo.v calls + Count three times. + + In other words, this is not persistent! +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to implement a Vernacular command that uses persistent storage? *) +(* *) +(* -------------------------------------------------------------------------- *) + +(* + * This command is like Count, but it is persistent across modules: + *) +VERNAC COMMAND EXTEND CountPersistent CLASSIFIED AS SIDEFF +| [ "Count" "Persistent" ] -> + { + Persistent_counter.increment (); + let v = Persistent_counter.value () in + Feedback.msg_notice (Pp.str "Times Count Persistent has been called: " ++ Pp.int v) + } +END + +(* + --- Persistent Storage --- + + Everything is similar to the Count command, except that we use a counter + that is persistent. See persistent_counter.ml for details. + + The key trick is that we must create a persistent object for our counter + to persist across modules. Coq has some useful APIs for this in Libobject. + We demonstrate these in persistent_counter.ml. + + This is really, really useful if you want, for example, to cache some + results that your plugin computes across modules. A persistent object + can be a hashtable, for example, that maps inputs to outputs your command + has already computed, if you know the result will not change. + + --- Calling the Command --- + + We call the command in Demo.v and in Count.v, just like we did with Count. + Note that this time, the value of the counter from Demo.v persists in Count.v. +*) diff --git a/doc/plugin_tutorial/tuto2/src/persistent_counter.ml b/doc/plugin_tutorial/tuto2/src/persistent_counter.ml new file mode 100644 index 0000000000..868f6ab99b --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/persistent_counter.ml @@ -0,0 +1,56 @@ +(* + * This file defines our persistent counter, which we use in the + * CountPersistent command. + *) + +(* + * At its core, our persistent counter looks exactly the same as + * our non-persistent counter (with a different name to prevent collisions): + *) +let counter = Summary.ref ~name:"persistent_counter" 0 + +(* + * The difference is that we need to declare it as a persistent object + * using Libobject.declare_object. To do that, we define a function that + * saves the value that is passed to it into the reference we have just defined: + *) +let cache_count (_, v) = + counter := v + +(* + * We then use declare_object to create a function that takes an integer value + * (the type our counter refers to) and creates a persistent object from that + * value: + *) +let declare_counter : int -> Libobject.obj = + let open Libobject in + declare_object + { + (default_object "COUNTER") with + cache_function = cache_count; + load_function = (fun _ -> cache_count); + } +(* + * See Libobject for more information on what other information you + * can pass here, and what all of these functions mean. + * + * For example, if we passed the same thing that we pass to load_function + * to open_function, then our last call to Count Persistent in Count.v + * would return 4 and not 6. + *) + +(* + * Incrementing our counter looks almost identical: + *) +let increment () = + Lib.add_anonymous_leaf (declare_counter (succ !counter)) +(* + * except that we must call our declare_counter function to get a persistent + * object. We then pass this object to Lib.add_anonymous_leaf. + *) + +(* + * Reading a value does not change at all: + *) +let value () = + !counter diff --git a/doc/plugin_tutorial/tuto2/src/persistent_counter.mli b/doc/plugin_tutorial/tuto2/src/persistent_counter.mli new file mode 100644 index 0000000000..d3c88e19a6 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/persistent_counter.mli @@ -0,0 +1,14 @@ +(* + * This file defines our persistent counter, which we use in the + * CountPersistent command. + *) + +(* + * Increment the persistent counter + *) +val increment : unit -> unit + +(* + * Determine the value of the persistent counter + *) +val value : unit -> int diff --git a/doc/plugin_tutorial/tuto2/src/tuto2_plugin.mlpack b/doc/plugin_tutorial/tuto2/src/tuto2_plugin.mlpack new file mode 100644 index 0000000000..0bc7402978 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/tuto2_plugin.mlpack @@ -0,0 +1,4 @@ +Custom +Counter +Persistent_counter +G_tuto2 diff --git a/doc/plugin_tutorial/tuto2/theories/Count.v b/doc/plugin_tutorial/tuto2/theories/Count.v new file mode 100644 index 0000000000..3287342b75 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/theories/Count.v @@ -0,0 +1,19 @@ +Require Import Demo. + +(*** Local ***) + +Count. +Count. + +Import Demo. + +Count. + +(*** Persistent ***) + +Count Persistent. +Count Persistent. + +Import Demo. + +Count Persistent. diff --git a/doc/plugin_tutorial/tuto2/theories/Demo.v b/doc/plugin_tutorial/tuto2/theories/Demo.v new file mode 100644 index 0000000000..73b5fcca62 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/theories/Demo.v @@ -0,0 +1,63 @@ +From Tuto2 Require Import Loader. + +(*** A no-op command ***) + +Nothing. + +(*** No-op commands with arguments ***) + +(* + * Terminal parameters: + *) +Command With Some Terminal Parameters. +(* Command. *) (* does not parse *) + +(* + * A single non-terminal argument: + *) +Pass 42. +(* Pass. *) (* does not parse *) +(* Pass True. *) (* does not parse *) +(* Pass 15 20. *) (* does not parse *) + +(* + * A list of non-terminal arguments: + *) +Accept 100 200 300 400. +Accept. +Accept 2. + +(* + * A custom argument: + *) +Foobar Foo. +Foobar Bar. + +(*** Commands that give feedback ***) + +(* + * Simple feedback: + *) +Is Everything Awesome. + +(*** Storage and side effects ***) + +(* + * Local side effects: + *) +Count. +Count. +Count. +(* + * See Count.v for behavior in modules that import this one. + *) + +(* + * Persistent side effects: + *) +Count Persistent. +Count Persistent. +Count Persistent. +(* + * See Count.v for behavior in modules that import this one. + *) diff --git a/doc/plugin_tutorial/tuto2/theories/Loader.v b/doc/plugin_tutorial/tuto2/theories/Loader.v new file mode 100644 index 0000000000..9ce9991c86 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/theories/Loader.v @@ -0,0 +1 @@ +Declare ML Module "tuto2_plugin". diff --git a/doc/plugin_tutorial/tuto2/theories/Test.v b/doc/plugin_tutorial/tuto2/theories/Test.v deleted file mode 100644 index 38e83bfff1..0000000000 --- a/doc/plugin_tutorial/tuto2/theories/Test.v +++ /dev/null @@ -1,19 +0,0 @@ -Declare ML Module "demo_plugin". - -Cmd1. -Cmd2 With Some Terminal Parameters. -Cmd3 42. -Cmd4 100 200 300 400. -Cmd5 Foo_5. -Cmd5 Bar_5. -Cmd6. -Cmd7. -Cmd7. -Cmd7. - -Goal True. -Proof. - tactic1. - tactic2 Foo_2. - tactic2 Bar_2. -Abort. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index db4ebd5e38..e5045c222a 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). @@ -596,6 +604,43 @@ Other changes in 8.10+beta1 with help and ideas from Emilio Jesús Gallego Arias, Gaëtan Gilbert, Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). +Changes in 8.10+beta2 +~~~~~~~~~~~~~~~~~~~~~ + +Many bug fixes and documentation improvements, in particular: + +**SSReflect** + +- Make the ``case E: t`` tactic work together with + :flag:`Universe Polymorphism` and equality in :g:`Type`. + This makes :tacn:`case <case (ssreflect)>` 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) +- Make the ``rewrite /t`` tactic work together with + :flag:`Universe Polymorphism`. + This makes :tacn:`rewrite <rewrite (ssreflect)>` 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) + +**CoqIDE** + +- 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>`_). + +**Miscellaneous** + +- Proof General can now display Coq-generated diffs between proof steps + in color + (`#10019 <https://github.com/coq/coq/pull/10019>`_ and + (in Proof General) `#421 <https://github.com/ProofGeneral/PG/pull/421>`_, + by Jim Fehrle). + + Version 8.9 ----------- @@ -957,6 +1002,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/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.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/interp/constrintern.ml b/interp/constrintern.ml index 63c936fa81..ff0c06e705 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -2434,10 +2434,8 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = let r = Retyping.relevance_of_type env sigma t in let d = LocalAssum (make_annot na r,t) in let impls = - if k == Implicit then - let na = match na with Name n -> Some n | Anonymous -> None in - (ExplByPos (n, na), (true, true, true)) :: impls - else impls + if k == Implicit then CAst.make (Some (na,true)) :: impls + else CAst.make None :: impls in (push_rel d env, sigma, d::params, succ n, impls) | Some b -> @@ -2446,7 +2444,7 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = let d = LocalDef (make_annot na r, c, t) in (push_rel d env, sigma, d::params, n, impls)) (env,sigma,[],k+1,[]) (List.rev bl) - in sigma, ((env, par), impls) + in sigma, ((env, par), List.rev impls) let interp_context_evars ?program_mode ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = let int_env,bl = intern_context global_level env impl_env params in diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 2e4d7479a9..450daea75c 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -61,10 +61,10 @@ type internalization_env = var_internalization_data Id.Map.t val empty_internalization_env : internalization_env val compute_internalization_data : env -> evar_map -> var_internalization_type -> - types -> Impargs.manual_explicitation list -> var_internalization_data + types -> Impargs.manual_implicits -> var_internalization_data val compute_internalization_env : env -> evar_map -> ?impls:internalization_env -> var_internalization_type -> - Id.t list -> types list -> Impargs.manual_explicitation list list -> + Id.t list -> types list -> Impargs.manual_implicits list -> internalization_env type ltac_sign = { diff --git a/interp/declare.ml b/interp/declare.ml index 7de92ded59..17de06ed57 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -42,7 +42,7 @@ type constant_obj = { 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 *) @@ -140,12 +140,12 @@ let register_constant kn kind local = let register_side_effect (c, role) = 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; @@ -154,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 @@ -168,26 +175,39 @@ 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 = 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 = ImportDefaultBehavior) 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) @@ -201,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 @@ -222,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 4120a82ca0..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 @@ -56,7 +56,7 @@ val declare_constant : ?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:import_status -> 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 -> 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/impargs.ml b/interp/impargs.ml index f3cdd64633..112862da18 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -20,7 +20,6 @@ open Lib open Libobject open EConstr open Reductionops -open Constrexpr open Namegen module NamedDecl = Context.Named.Declaration @@ -341,77 +340,30 @@ let rec prepare_implicits f = function Some (id,imp,(set_maximality imps' f.maximal,true)) :: imps' | _::imps -> None :: prepare_implicits f imps -(* -If found, returns Some (x,(b,fi,fo)) and l with the entry removed, -otherwise returns None and l unchanged. - *) -let assoc_by_pos k l = - let rec aux = function - (ExplByPos (k', x), b) :: tl when Int.equal k k' -> Some (x,b), tl - | hd :: tl -> let (x, tl) = aux tl in x, hd :: tl - | [] -> raise Not_found - in try aux l with Not_found -> None, l - -let check_correct_manual_implicits autoimps l = - List.iter (function - | ExplByName id,(b,fi,forced) -> - if not forced then - user_err - (str "Wrong or non-dependent implicit argument name: " ++ Id.print id ++ str ".") - | ExplByPos (i,_id),_t -> - if i<1 || i>List.length autoimps then - user_err - (str "Bad implicit argument number: " ++ int i ++ str ".") - else - user_err - (str "Cannot set implicit argument number " ++ int i ++ - str ": it has no name.")) l - -(* Take a list l of explicitations, and map them to positions. *) -let flatten_explicitations l autoimps = - let rec aux k l = function - | (Name id,_)::imps -> - let value, l' = - try - let eq = Constrexpr_ops.explicitation_eq in - let flags = List.assoc_f eq (ExplByName id) l in - Some (Some id, flags), List.remove_assoc_f eq (ExplByName id) l - with Not_found -> assoc_by_pos k l - in value :: aux (k+1) l' imps - | (Anonymous,_)::imps -> - let value, l' = assoc_by_pos k l - in value :: aux (k+1) l' imps - | [] when List.is_empty l -> [] - | [] -> - check_correct_manual_implicits autoimps l; - [] - in aux 1 l autoimps - let set_manual_implicits flags enriching autoimps l = - if not (List.distinct l) then - user_err Pp.(str "Some parameters are referred more than once."); (* Compare with automatic implicits to recover printing data and names *) let rec merge k autoimps explimps = match autoimps, explimps with | autoimp::autoimps, explimp::explimps -> let imps' = merge (k+1) autoimps explimps in - begin match autoimp, explimp with - | (Name id,_), Some (_, (b, fi, _)) -> - Some (id, Manual, (set_maximality imps' b, fi)) + begin match autoimp, explimp.CAst.v with + | (Name id,_), Some (_,max) -> + Some (id, Manual, (set_maximality imps' max, true)) | (Name id,Some exp), None when enriching -> Some (id, exp, (set_maximality imps' flags.maximal, true)) | (Name _,_), None -> None - | (Anonymous,_), Some (Some id, (b, fi, true)) -> - Some (id,Manual,(b,fi)) - | (Anonymous,_), Some (None, (b, fi, true)) -> + | (Anonymous,_), Some (Name id,max) -> + Some (id,Manual,(max,true)) + | (Anonymous,_), Some (Anonymous,max) -> let id = Id.of_string ("arg_" ^ string_of_int k) in - Some (id,Manual,(b,fi)) - | (Anonymous,_), Some (_, (_, _, false)) -> None + Some (id,Manual,(max,true)) | (Anonymous,_), None -> None end :: imps' | [], [] -> [] - (* flatten_explicitations returns a list of the same length as autoimps *) - | _ -> assert false - in merge 1 autoimps (flatten_explicitations l autoimps) + | [], _ -> assert false + (* possibly more automatic than manual implicit arguments n + when the conclusion is an unfoldable constant *) + | autoimps, [] -> merge k autoimps [CAst.make None] + in merge 1 autoimps l let compute_semi_auto_implicits env sigma f t = if not f.auto then [DefaultImpArgs, []] @@ -642,9 +594,7 @@ let declare_mib_implicits kn = (inImplicits (ImplMutualInductive (kn,flags),List.flatten imps)) (* Declare manual implicits *) -type manual_explicitation = Constrexpr.explicitation * (bool * bool * bool) - -type manual_implicits = manual_explicitation list +type manual_implicits = (Name.t * bool) option CAst.t list let compute_implicits_with_manual env sigma typ enriching l = let autoimpls = compute_auto_implicits env sigma !implicit_args enriching typ in @@ -669,8 +619,6 @@ let projection_implicits env p impls = CList.skipn_at_least npars impls let declare_manual_implicits local ref ?enriching l = - assert (List.for_all (fun (_, (max, fi, fu)) -> fi && fu) l); - assert (List.for_all (fun (ex, _) -> match ex with ExplByPos (_,_) -> true | _ -> false) l); let flags = !implicit_args in let env = Global.env () in let sigma = Evd.from_env env in @@ -685,9 +633,8 @@ let declare_manual_implicits local ref ?enriching l = in add_anonymous_leaf (inImplicits (req,[ref,l])) let maybe_declare_manual_implicits local ref ?enriching l = - match l with - | [] -> () - | _ -> declare_manual_implicits local ref ?enriching l + if List.exists (fun x -> x.CAst.v <> None) l then + declare_manual_implicits local ref ?enriching l (* TODO: either turn these warnings on and document them, or handle these cases sensibly *) @@ -750,12 +697,6 @@ let extract_impargs_data impls = | [] -> [] in aux 0 impls -let lift_implicits n = - List.map (fun x -> - match fst x with - ExplByPos (k, id) -> ExplByPos (k + n, id), snd x - | _ -> x) - let make_implicits_list l = [DefaultImpArgs, l] let rec drop_first_implicits p l = diff --git a/interp/impargs.mli b/interp/impargs.mli index 1099074c63..92b6bdd406 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -84,13 +84,7 @@ val force_inference_of : implicit_status -> bool val positions_of_implicits : implicits_list -> int list -(** A [manual_explicitation] is a tuple of a positional or named explicitation with - maximal insertion, force inference and force usage flags. Forcing usage makes - the argument implicit even if the automatic inference considers it not inferable. *) -type manual_explicitation = Constrexpr.explicitation * - (maximal_insertion * force_inference * bool) - -type manual_implicits = manual_explicitation list +type manual_implicits = (Name.t * bool) option CAst.t list val compute_implicits_with_manual : env -> Evd.evar_map -> types -> bool -> manual_implicits -> implicit_status list @@ -131,8 +125,6 @@ val implicits_of_global : GlobRef.t -> implicits_list list val extract_impargs_data : implicits_list list -> ((int * int) option * implicit_status list) list -val lift_implicits : int -> manual_implicits -> manual_implicits - val make_implicits_list : implicit_status list -> implicits_list list val drop_first_implicits : int -> implicits_list -> implicits_list diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 32290f0430..d7bae6b3fd 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -203,32 +203,23 @@ let warn_ignoring_implicit_status = Name.print na ++ strbrk " and following binders") let implicits_of_glob_constr ?(with_products=true) l = - let add_impl i na bk l = match bk with - | Implicit -> - let name = - match na with - | Name id -> Some id - | Anonymous -> None - in - (ExplByPos (i, name), (true, true, true)) :: l - | _ -> l + let add_impl ?loc na bk l = match bk with + | Implicit -> CAst.make ?loc (Some (na,true)) :: l + | _ -> CAst.make ?loc None :: l in - let rec aux i c = - let abs na bk b = - add_impl i na bk (aux (succ i) b) - in + let rec aux c = match DAst.get c with | GProd (na, bk, t, b) -> - if with_products then abs na bk b + if with_products then add_impl na bk (aux b) else let () = match bk with | Implicit -> warn_ignoring_implicit_status na ?loc:c.CAst.loc | _ -> () in [] - | GLambda (na, bk, t, b) -> abs na bk b - | GLetIn (na, b, t, c) -> aux i c + | GLambda (na, bk, t, b) -> add_impl ?loc:t.CAst.loc na bk (aux b) + | GLetIn (na, b, t, c) -> aux c | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in - List.fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb) + List.fold_right (fun (na,bk,t,_) l -> add_impl ?loc:c.CAst.loc na bk l) args.(nb) (aux bds.(nb)) | _ -> [] - in aux 1 l + in aux l 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/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 79d1c7520f..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 diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index 6c9cd66f96..de3fb9f11f 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -18,7 +18,7 @@ DECLARE PLUGIN "derive_plugin" { -let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[]),VtLater) +let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[])) } diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b8e1286b9e..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,14 +979,14 @@ 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); *) @@ -1011,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 @@ -1043,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 @@ -1062,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 @@ -1099,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 @@ -1137,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 @@ -1391,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 = @@ -1421,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 @@ -1434,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 @@ -1502,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 @@ -1515,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 @@ -1525,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 = @@ -1545,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 @@ -1569,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 @@ -1605,120 +1605,120 @@ 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' ) ] diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d1e540cceb..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 @@ -319,10 +319,10 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in (* let _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 } = Lemmas.pf_fold (close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x)) lemma in @@ -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 d710f4490d..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 + 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 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,124 +514,124 @@ 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) : Lemmas.t option = @@ -640,84 +640,84 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro 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 + 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 + 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; lemma, true @@ -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,15 +897,15 @@ 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) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 6d9690096f..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 [] @@ -129,8 +129,8 @@ let save id const ?hook uctx (locality,_,kind) = 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 + 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 @@ -166,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 @@ -213,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)) = @@ -318,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 @@ -356,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"; @@ -380,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 857b7df96f..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 lemma = Lemmas.start_lemma - lem_id + lem_id Decl_kinds.(Global ImportDefaultBehavior,false,Proof Theorem) !evd typ in let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") + (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 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 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 lemma = fst (Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") + (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 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 17d962f30f..2b5c0a01db 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -79,10 +79,10 @@ let def_of_const t = 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,58 +1165,58 @@ 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 = @@ -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,15 +1265,15 @@ 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 @@ -1303,8 +1302,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type 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,8 +1314,8 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let na_ref = qualid_of_ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with - 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); @@ -1325,47 +1324,47 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let env = Global.env () in 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_lemma_proved ?proof:None ~lemma ~opaque:opacity ~idopt:None in @@ -1376,23 +1375,23 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let lemma = if Indfun_common.is_strict_tcc () then fst @@ Lemmas.by (Proofview.V82.tactic (tclIDTAC)) lemma - else + 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; + 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) + Tacticals.New.tclCOMPLETE Auto.default_auto + ]) + ) + using_lemmas) + ) tclIDTAC) g end) lemma in if Lemmas.(pf_fold Proof_global.get_open_goals) lemma = 0 then (defined lemma; None) else Some lemma @@ -1451,8 +1450,8 @@ 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 @@ -1461,31 +1460,31 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation (EConstr.of_constr equation_lemma_type) in let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (start_equation f_ref terminate_ref - (fun x -> - prove_eq (fun _ -> tclIDTAC) - {nb_arg=nb_arg; + (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 "______"; - } - ) + (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 () @@ -1554,15 +1553,15 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type 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 @@ -1576,9 +1575,9 @@ 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 *) diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 7691ca225e..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) } diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index d10d10a664..afdea98ef5 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -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/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 5df223215d..0662354daf 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -141,10 +141,10 @@ let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = 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 @@ -195,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 8e1d16175f..96d90e9252 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -29,7 +29,7 @@ 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; } @@ -134,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 @@ -172,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 diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index fd0ad6fb50..f84ec27df7 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -35,7 +35,7 @@ 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; } @@ -80,7 +80,7 @@ val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> 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. *) diff --git a/proofs/refine.ml b/proofs/refine.ml index 8439156e65..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 diff --git a/stm/stm.ml b/stm/stm.ml index 1e89d6937c..d77e37c910 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1563,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 = @@ -2860,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 () && @@ -2875,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." @@ -2900,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 @@ -2914,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 @@ -2961,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 e91fe5067c..967b0ef418 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -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:ImportNeedQualified 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/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/test-suite/Makefile b/test-suite/Makefile index 552d007f85..ed4777608a 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -335,16 +335,16 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v arithm $(FAIL); \ fi; \ } > "$@" - @echo "CHECK $<" - $(HIDE){ \ - opts="$(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-I $(shell dirname $<) -norec $(shell basename $< .v))"; \ + @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi + $(HIDE)if ! grep -q -F "Error!" $@; then { \ + opts="$(if $(findstring modules/,$<),-R modules Mods -norec Mods.$(shell basename $< .v),-I $(shell dirname $<) -norec $(shell basename $< .v))"; \ $(coqchk) -silent $(call get_set_impredicativity,$<) $$opts 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ $(FAIL); \ fi; \ - } > "$(shell dirname $<)/$(shell basename $< .v).chk.log" + } > "$(shell dirname $<)/$(shell basename $< .v).chk.log"; fi stm: $(wildcard stm/*.v:%.v=%.v.log) $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v @@ -362,15 +362,15 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v $(FAIL); \ fi; \ } > "$@" - @echo "CHECK $<" - $(HIDE){ \ + @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi + $(HIDE)if ! grep -q -F "Error!" $@; then { \ $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ $(FAIL); \ fi; \ - } > "$(shell dirname $<)/$(shell basename $< .v).chk.log" + } > "$(shell dirname $<)/$(shell basename $< .v).chk.log"; fi $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" @@ -386,15 +386,15 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) $(FAIL); \ fi; \ } > "$@" - @echo "CHECK $<" - $(HIDE){ \ + @if ! grep -q -F "Error!" $@; then echo "CHECK $<"; fi + $(HIDE)if ! grep -q -F "Error!" $@; then { \ $(coqchk) -silent -I $(shell dirname $<) -norec $(shell basename $< .v) 2>&1; R=$$?; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be checked (Error!)" ; \ $(FAIL); \ fi; \ - } > "$(shell dirname $<)/$(shell basename $< .v).chk.log" + } > "$(shell dirname $<)/$(shell basename $< .v).chk.log"; fi $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" 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_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/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/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/user-contrib/Ltac2/Std.v b/user-contrib/Ltac2/Std.v index 6c3f465f33..237ec8b995 100644 --- a/user-contrib/Ltac2/Std.v +++ b/user-contrib/Ltac2/Std.v @@ -145,7 +145,7 @@ Ltac2 @ external set : evar_flag -> (unit -> ident option * constr) -> clause -> Ltac2 @ external remember : evar_flag -> ident option -> (unit -> constr) -> intro_pattern option -> clause -> unit := "ltac2" "tac_remember". Ltac2 @ external destruct : evar_flag -> induction_clause list -> - constr_with_bindings option -> unit := "ltac2" "tac_induction". + constr_with_bindings option -> unit := "ltac2" "tac_destruct". Ltac2 @ external induction : evar_flag -> induction_clause list -> constr_with_bindings option -> unit := "ltac2" "tac_induction". 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/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml index de99fb167f..76556430df 100644 --- a/user-contrib/Ltac2/tac2intern.ml +++ b/user-contrib/Ltac2/tac2intern.ml @@ -367,7 +367,7 @@ let unify_arrow ?loc env ft args = iter ft args true | GTypVar id, (_, t) :: args -> let ft = GTypVar (fresh_id env) in - let () = unify_var env id (GTypArrow (t, ft)) in + let () = unify ?loc env (GTypVar id) (GTypArrow (t, ft)) in iter ft args true | GTypRef _, _ :: _ -> if is_fun then 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/classes.ml b/vernac/classes.ml index 20402ebf95..178387dd17 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -532,8 +532,7 @@ let interp_instance_context ~program_mode env ctx ~generalize pl tclass = in let sigma, (impls, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma ctx in let sigma, (c', imps') = interp_type_evars_impls ~program_mode ~impls env' sigma tclass in - let len = Context.Rel.nhyps ctx in - let imps = imps @ Impargs.lift_implicits len imps' in + let imps = imps @ imps' in let ctx', c = decompose_prod_assum sigma c' in let ctx'' = ctx' @ ctx in let (k, u), args = Typeclasses.dest_class_app (push_rel_context ctx'' env) sigma c in diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 591e4b130f..a27c08d176 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -283,8 +283,8 @@ let context poly l = Classes.declare_instance env sigma (Some Hints.empty_hint_info) true (ConstRef cst); status else - let test (x, _) = match x with - | Constrexpr.ExplByPos (_, Some id') -> Id.equal id id' + let test x = match x.CAst.v with + | Some (Name id',_) -> Id.equal id id' | _ -> false in let impl = List.exists test impls in diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 4cae4b8a74..ae1f55acda 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -27,18 +27,19 @@ let warn_implicits_in_term = CWarnings.create ~name:"implicits-in-term" ~category:"implicits" (fun () -> strbrk "Implicit arguments declaration relies on type." ++ spc () ++ - strbrk "The term declares more implicits than the type here.") + strbrk "Discarding incompatible declaration in term.") let check_imps ~impsty ~impsbody = - let b = - try - List.for_all (fun (key, (va:bool*bool*bool)) -> - (* Pervasives.(=) is OK for this type *) - Pervasives.(=) (List.assoc_f Constrexpr_ops.explicitation_eq key impsty) va) - impsbody - with Not_found -> false - in - if not b then warn_implicits_in_term () + let rec aux impsty impsbody = + match impsty, impsbody with + | a1 :: impsty, a2 :: impsbody -> + (match a1.CAst.v, a2.CAst.v with + | None , None -> aux impsty impsbody + | Some _ , Some _ -> aux impsty impsbody + | _, _ -> warn_implicits_in_term ?loc:a2.CAst.loc ()) + | _ :: _, [] | [], _ :: _ -> (* Information only on one side *) () + | [], [] -> () in + aux impsty impsbody let interp_definition ~program_mode pl bl poly red_option c ctypopt = let env = Global.env() in @@ -56,11 +57,11 @@ let interp_definition ~program_mode pl bl poly red_option c ctypopt = match tyopt with | None -> let evd, (c, impsbody) = interp_constr_evars_impls ~program_mode ~impls env_bl evd c in - evd, c, imps1@Impargs.lift_implicits (Context.Rel.nhyps ctx) impsbody, None + evd, c, imps1@impsbody, None | Some (ty, impsty) -> let evd, (c, impsbody) = interp_casted_constr_evars_impls ~program_mode ~impls env_bl evd c ty in check_imps ~impsty ~impsbody; - evd, c, imps1@Impargs.lift_implicits (Context.Rel.nhyps ctx) impsty, Some ty + evd, c, imps1@impsty, Some ty in (* Do the reduction *) let evd, c = red_constant_body red_option env_bl evd c in @@ -86,7 +87,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 c3575594b6..0d9df47ee8 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -41,5 +41,5 @@ val interp_definition -> red_expr option -> constr_expr -> constr_expr option - -> Safe_typing.private_constants definition_entry * + -> 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 3a25cb496c..0d7ba69955 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -197,7 +197,7 @@ let interp_recursive ~program_mode ~cofix fixl notations = let fixtypes = List.map2 build_fix_type fixctxs fixccls in let fixtypes = List.map (fun c -> nf_evar sigma c) fixtypes in let fiximps = List.map3 - (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (Context.Rel.nhyps ctx) cclimps)) + (fun ctximps cclimps (_,ctx) -> ctximps@cclimps) fixctximps fixcclimps fixctxs in let sigma, rec_sign = List.fold_left2 @@ -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 *) @@ -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 a31f3c34e0..1ded9f3d29 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -57,7 +57,7 @@ val interp_recursive : (* names / defs / types *) (Id.t list * Sorts.relevance list * EConstr.constr option list * EConstr.types list) * (* ctx per mutual def / implicits / struct annotations *) - (EConstr.rel_context * Impargs.manual_explicitation list * int option) list + (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Exported for Funind *) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 5bebf955ec..2f8b12f4c5 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -375,8 +375,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let env_ar_params = EConstr.push_rel_context ctx_params env_ar in (* Compute interpretation metadatas *) - let indimpls = List.map (fun impls -> userimpls @ - lift_implicits (Context.Rel.nhyps ctx_params) impls) indimpls in + let indimpls = List.map (fun impls -> userimpls @ impls) indimpls in let impls = compute_internalization_env env_uparams sigma ~impls (Inductive (params,true)) indnames fullarities indimpls in let ntn_impls = compute_internalization_env env_uparams sigma (Inductive (params,true)) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data sigma env_params params) arities indnames in @@ -402,8 +401,8 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not constructors in let ctx_params = ctx_params @ ctx_uparams in - let userimpls = useruimpls @ (lift_implicits (Context.Rel.nhyps ctx_uparams) userimpls) in - let indimpls = List.map (fun iimpl -> useruimpls @ (lift_implicits (Context.Rel.nhyps ctx_uparams) iimpl)) indimpls in + let userimpls = useruimpls @ userimpls in + let indimpls = List.map (fun iimpl -> useruimpls @ iimpl) indimpls in let fullarities = List.map (fun c -> EConstr.it_mkProd_or_LetIn c ctx_uparams) fullarities in let env_ar = push_types env0 indnames relevances fullarities in let env_ar_params = EConstr.push_rel_context ctx_params env_ar in @@ -450,10 +449,9 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not indl arities arityconcl constructors in let impls = - let len = Context.Rel.nhyps ctx_params in List.map2 (fun indimpls (_,_,cimpls) -> indimpls, List.map (fun impls -> - userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors + userimpls @ impls) cimpls) indimpls constructors in let variance = if poly && cum then Some (InferCumulativity.dummy_variance uctx) else None in (* Build the mutual inductive entry *) @@ -559,8 +557,8 @@ let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie p mind type one_inductive_impls = - Impargs.manual_explicitation list (* for inds *)* - Impargs.manual_explicitation list list (* for constrs *) + Impargs.manual_implicits (* for inds *) * + Impargs.manual_implicits list (* for constrs *) type uniform_inductive_flag = | UniformParameters diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 2b9d9567cd..909aa41a30 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -15,7 +15,7 @@ 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 @@ -27,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 @@ -36,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 4e346a9564..7aba64fb93 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -112,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 @@ -469,7 +469,7 @@ let start_lemma_com ~program_mode ?inference_hook ?hook kind thms = (* XXX: The nf_evar is critical !! *) evd, (id.CAst.v, (Evarutil.nf_evar evd (EConstr.it_mkProd_or_LetIn t' ctx), - (ids, imps @ lift_implicits (Context.Rel.nhyps ctx) imps')))) + (ids, imps @ imps')))) evd thms in let recguard,thms,snl = look_for_possibly_mutual_statements evd thms in let evd = Evd.minimize_universes evd in diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index ac647af8b5..25c5b24e91 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -112,7 +112,7 @@ val start_lemma_with_initialization -> (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 + (Name.t list (* names to pre-introduce *) * Impargs.manual_implicits))) list -> int list option -> t 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 6c9ec95c5f..6ef2f80067 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -307,7 +307,7 @@ type program_info_aux = { prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; - prg_implicits : (Constrexpr.explicitation * (bool * bool * bool)) list; + prg_implicits : Impargs.manual_implicits; prg_notations : notations ; prg_kind : definition_kind; prg_reduce : constr -> constr; @@ -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; @@ -822,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') @@ -848,8 +848,8 @@ let obligation_terminator ?hook name num guard auto 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); diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 8734d82970..18a7e10733 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -57,7 +57,7 @@ val add_definition -> ?term:constr -> types -> UState.t -> ?univdecl:UState.universe_decl (* Universe binders and constraints *) - -> ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list + -> ?implicits:Impargs.manual_implicits -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> ?reduce:(constr -> constr) @@ -74,8 +74,7 @@ type fixpoint_kind = | IsCoFixpoint val add_mutual_definitions : - (Names.Id.t * constr * types * - (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> + (Names.Id.t * constr * types * Impargs.manual_implicits * obligation_info) list -> UState.t -> ?univdecl:UState.universe_decl -> (* Universe binders and constraints *) ?tactic:unit Proofview.tactic -> diff --git a/vernac/record.ml b/vernac/record.ml index 6101e13edd..48cde133a8 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; @@ -476,21 +476,15 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki List.mapi map record_data let implicits_of_context ctx = - List.map_i (fun i name -> - let explname = - match name with - | Name n -> Some n - | Anonymous -> None - in ExplByPos (i, explname), (true, true, true)) - 1 (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) + List.map (fun name -> CAst.make (Some (name,true))) + (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) let declare_class def cum ubinders univs id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) coers priorities = let fieldimpls = (* Make the class implicit in the projections, and the params if applicable. *) - let len = List.length params in let impls = implicits_of_context params in - List.map (fun x -> impls @ Impargs.lift_implicits (succ len) x) fieldimpls + List.map (fun x -> impls @ x) fieldimpls in let binder_name = Namegen.next_ident_away id (Termops.vars_of_env (Global.env())) in let data = @@ -704,7 +698,7 @@ let definition_structure udecl kind ~template cum poly finite records = declare_class def cum ubinders univs id.CAst.v idbuild implpars params arity template implfs fields coers priorities | _ -> - let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in + let map impls = implpars @ [CAst.make None] @ impls in let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in let map (arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = let coe = List.map (fun (_, { rf_subclass ; rf_canonical }) -> diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index d206165e88..112c4b6451 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -81,7 +81,7 @@ module DefAttributes = struct locality : bool option; polymorphic : bool; program : bool; - deprecated : deprecation option; + deprecated : Deprecation.t option; } let parse f = @@ -92,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 @@ -102,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 = @@ -504,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 @@ -523,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 @@ -1265,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 @@ -2379,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; @@ -2559,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)) diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 6a52177dd5..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,11 +52,6 @@ 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) @@ -130,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 78b7f21b0d..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,11 +68,6 @@ 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 = |