diff options
87 files changed, 1918 insertions, 1211 deletions
diff --git a/.gitattributes b/.gitattributes index a5edcdb5bf..742ef27f49 100644 --- a/.gitattributes +++ b/.gitattributes @@ -53,3 +53,6 @@ tools/CoqMakefile.in whitespace=blank-at-eol # CR is desired for these Windows files. *.bat whitespace=cr-at-eol,blank-at-eol,tab-in-indent + +* eol=lf +*.bat eol=crlf diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 98fe2546b5..0f2dd89975 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -37,6 +37,9 @@ *.nix @coq/nix-maintainers +azure-pipelines.yml @coq/ci-maintainers +/dev/ci/azure* @coq/ci-maintainers + ########## Documentation ########## /README.md @Zimmi48 diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index de0de4cf83..108ecb5a04 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,7 +9,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2018-12-05-V1" + CACHEKEY: "bionic_coq-V2018-12-14-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -367,6 +367,57 @@ test-suite:egde:dune:dev: paths: - _build/default/test-suite/logs +test-suite:edge+trunk+make: + stage: test + dependencies: [] + script: + - opam switch create 4.08.0 --empty + - eval $(opam env) + - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam update + - opam install ocaml-variants=4.08.0 num + - eval $(opam env) + # We avoid problems with warnings: + - ./configure -profile devel -warn-error no + - make -j "$NJOBS" world + - make -j "$NJOBS" test-suite UNIT_TESTS= + variables: + OPAM_SWITCH: edge + artifacts: + name: "$CI_JOB_NAME.logs" + when: always + paths: + - test-suite/logs + expire_in: 1 week + allow_failure: true + +test-suite:edge+trunk+dune: + stage: test + dependencies: [] + script: + - opam switch create 4.08.0 --empty + - eval $(opam env) + - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam update + - opam install ocaml-variants=4.08.0 num + - opam pin add dune --dev # ounit lablgtk conf-gtksourceview + - opam install dune + - eval $(opam env) + # We use the release profile to avoid problems with warnings + - make -f Makefile.dune trunk + - export COQ_UNIT_TEST=noop + - dune runtest --profile=ocaml408 + variables: + OPAM_SWITCH: edge + artifacts: + name: "$CI_JOB_NAME.logs" + when: always + paths: + - _build/log + - _build/default/test-suite/logs + expire_in: 1 week + allow_failure: true + validate:base: <<: *validate-template dependencies: diff --git a/CHANGES.md b/CHANGES.md index 4fafb9a18a..d64b5accd7 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -90,6 +90,9 @@ Vernacular commands - `Arguments` now accepts names for arguments provided with `extra_scopes`. +- The naming scheme for anonymous binders in a `Theorem` has changed to + avoid conflicts with explicitly named binders. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -136,6 +139,15 @@ Misc - Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. +SSReflect + +- New intro patterns: + - temporary introduction: => + + - block introduction: => [^ prefix ] [^~ suffix ] + - fast introduction: => >H + - tactics as views: => /ltac:mytac + See the reference manual for the actual documentation. + Changes from 8.8.2 to 8.9+beta1 =============================== diff --git a/Makefile.ci b/Makefile.ci index 956e3ee58f..2df6a792b6 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -60,6 +60,7 @@ ci-math-classes: ci-bignums ci-corn: ci-math-classes +ci-simple-io: ci-ext-lib ci-quickchick: ci-ext-lib ci-simple-io ci-formal-topology: ci-corn diff --git a/Makefile.dune b/Makefile.dune index 4baf3402f1..22e3271260 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -4,7 +4,7 @@ .PHONY: help voboot states world watch check # Main developer targets .PHONY: quickbyte quickopt # Partial / quick developer targets .PHONY: test-suite refman-html apidoc release # Accesory targets -.PHONY: ocheck ireport clean # Maintenance targets +.PHONY: ocheck trunk ireport clean # Maintenance targets # use DUNEOPT=--display=short for a more verbose build # DUNEOPT=--display=short @@ -28,6 +28,7 @@ help: @echo " - release: build Coq in release mode" @echo "" @echo " - ocheck: build for all supported OCaml versions [requires OPAM]" + @echo " - trunk: build with a configuration compatible with OCaml trunk" @echo " - ireport: build with optimized flambda settings and emit an inline report" @echo " - clean: remove build directory and autogenerated files" @echo " - help: show this message" @@ -75,6 +76,11 @@ release: voboot ocheck: voboot dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all +trunk: + dune build $(DUNEOPT) --profile=ocaml408 @vodeps + dune exec coq_dune $(BUILD_CONTEXT)/.vfiles.d + dune build $(DUNEOPT) --profile=ocaml408 coq.install coqide-server.install + ireport: dune clean dune build $(DUNEOPT) @vodeps --profile=ireport diff --git a/azure-pipelines.yml b/azure-pipelines.yml new file mode 100644 index 0000000000..e217601ae2 --- /dev/null +++ b/azure-pipelines.yml @@ -0,0 +1,31 @@ + +pool: + vmImage: 'vs2017-win2016' + +steps: +- checkout: self + fetchDepth: 10 + +# cygwin package list not checked for minimality +- script: | + powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" + SET CYGROOT=C:\cygwin64 + SET CYGCACHE=%CYGROOT%\var\cache\setup + setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python + + SET TARGET_ARCH=x86_64-w64-mingw32 + SET CD_MFMT=%cd:\=/% + SET RESULT_INSTALLDIR_CFMT=%CD_MFMT:C:/=/cygdrive/c/% + C:\cygwin64\bin\bash -l %cd%\dev\build\windows\configure_profile.sh + displayName: 'Install cygwin' + env: + CYGMIRROR: "http://mirror.easyname.at/cygwin" + +- script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-opam.sh + displayName: 'Install opam' + +- script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-build.sh + displayName: 'Build Coq' + +- script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-test.sh + displayName: 'Test Coq' diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 8489bcfc3a..fdbb0eca2b 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -1,488 +1,488 @@ -@ECHO OFF
-
-REM ========== COPYRIGHT/COPYLEFT ==========
-
-REM (C) 2016 Intel Deutschland GmbH
-REM Author: Michael Soegtrop
-
-REM Released to the public by Intel under the
-REM GNU Lesser General Public License Version 2.1 or later
-REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html
-
-REM ========== NOTES ==========
-
-REM For Cygwin setup command line options
-REM see https://cygwin.com/faq/faq.html#faq.setup.cli
-
-REM ========== DEFAULT VALUES FOR PARAMETERS ==========
-
-REM For a description of all parameters, see ReadMe.txt
-
-SET BATCHFILE=%~0
-SET BATCHDIR=%~dp0
-
-REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32)
-SET ARCH=x86_64
-
-REM see -mode in ReadMe.txt
-SET INSTALLMODE=absolute
-
-REM see -installer in ReadMe.txt
-SET MAKEINSTALLER=N
-
-REM see -ocaml in ReadMe.txt
-SET INSTALLOCAML=N
-
-REM see -make in ReadMe.txt
-SET INSTALLMAKE=N
-
-REM see -destcyg in ReadMe.txt
-SET DESTCYG=C:\bin\cygwin_coq
-
-REM see -destcoq in ReadMe.txt
-SET DESTCOQ=C:\bin\coq
-
-REM see -setup in ReadMe.txt
-SET SETUP=setup-x86_64.exe
-
-REM see -proxy in ReadMe.txt
-IF DEFINED HTTP_PROXY (
- SET PROXY=%HTTP_PROXY:http://=%
-) else (
- REM One can't set a variable to empty in DOS, but you can set it to a space this way.
- REM The quotes are just there to make the space visible and to protect from "remove trailing spaces".
- SET "PROXY= "
-)
-
-REM see -cygrepo in ReadMe.txt
-SET CYGWIN_REPOSITORY=http://mirror.easyname.at/cygwin
-
-REM see -cygcache in ReadMe.txt
-SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
-
-REM see -cyglocal in ReadMe.txt
-SET CYGWIN_FROM_CACHE=N
-
-REM see -cygquiet in ReadMe.txt
-SET CYGWIN_QUIET=Y
-
-REM see -srccache in ReadMe.txt
-SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache
-
-REM see -coqver in ReadMe.txt
-SET COQ_VERSION=8.5pl3
-
-REM see -gtksrc in ReadMe.txt
-SET GTK_FROM_SOURCES=N
-
-REM see -threads in ReadMe.txt
-SET MAKE_THREADS=8
-
-REM see -addon in ReadMe.txt
-SET "COQ_ADDONS= "
-
-REM ========== PARSE COMMAND LINE PARAMETERS ==========
-
-SHIFT
-
-:Parse
-
-IF "%~0" == "-arch" (
- IF "%~1" == "32" (
- SET ARCH=i686
- SET SETUP=setup-x86.exe
- ) ELSE (
- IF "%~1" == "64" (
- SET ARCH=x86_64
- SET SETUP=setup-x86_64.exe
- ) ELSE (
- ECHO "Invalid -arch, valid are 32 and 64"
- GOTO :EOF
- )
- )
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-mode" (
- IF "%~1" == "mingwincygwin" (
- SET INSTALLMODE=%~1
- ) ELSE (
- IF "%~1" == "absolute" (
- SET INSTALLMODE=%~1
- ) ELSE (
- IF "%~1" == "relocatable" (
- SET INSTALLMODE=%~1
- ) ELSE (
- ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable"
- GOTO :EOF
- )
- )
- )
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-installer" (
- SET MAKEINSTALLER=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-ocaml" (
- SET INSTALLOCAML=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-make" (
- SET INSTALLMAKE=%~1
- CALL :CheckYN -installer %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-destcyg" (
- SET DESTCYG=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-destcoq" (
- SET DESTCOQ=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-setup" (
- SET SETUP=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-proxy" (
- SET PROXY=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygrepo" (
- SET CYGWIN_REPOSITORY=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygcache" (
- SET CYGWIN_LOCAL_CACHE_WFMT=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cyglocal" (
- SET CYGWIN_FROM_CACHE=%~1
- CALL :CheckYN -cyglocal %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-cygquiet" (
- SET CYGWIN_QUIET=%~1
- CALL :CheckYN -cygquiet %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-srccache" (
- SET SOURCE_LOCAL_CACHE_WFMT=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-coqver" (
- SET COQ_VERSION=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-gtksrc" (
- SET GTK_FROM_SOURCES=%~1
- CALL :CheckYN -gtksrc %~1 || GOTO ErrorExit
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-threads" (
- SET MAKE_THREADS=%~1
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-IF "%~0" == "-addon" (
- SET "COQ_ADDONS=%COQ_ADDONS% %~1"
- SHIFT
- SHIFT
- GOTO Parse
-)
-
-
-IF NOT "%~0" == "" (
- ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW
- ECHO !!! Illegal parameter %~0
- ECHO Usage:
- ECHO MakeCoq_MinGW
- CALL :PrintPars
- GOTO :EOF
-)
-
-IF NOT EXIST %SETUP% (
- ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html.
- ECHO If the setup is in a different folder, set the full path to %SETUP% using the -setup option.
- GOTO :EOF
-)
-
-REM ========== ADJUST PARAMETERS ==========
-
-IF "%INSTALLMODE%" == "mingwincygwin" (
- SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw
-)
-
-IF "%MAKEINSTALLER%" == "Y" (
- SET INSTALLMODE=relocatable
-)
-
-REM ========== CONFIRM PARAMETERS ==========
-
-CALL :PrintPars
-REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block
-IF "%COQREGTESTING%"=="Y" (GOTO DontAsk)
- SET /p ANSWER="Is this correct? y/n "
- IF NOT "%ANSWER%"=="y" (GOTO :EOF)
-:DontAsk
-
-REM ========== DERIVED VARIABLES ==========
-
-SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG%
-SET RESULT_INSTALLDIR_WFMT=%DESTCOQ%
-SET TARGET_ARCH=%ARCH%-w64-mingw32
-SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash
-
-REM Convert pathes to various formats
-REM WFMT = windows format (C:\..) Used in this batch file.
-REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH varible, which is : separated, so C: doesn't work.
-REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /.
-
-SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/%
-SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/%
-SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/%
-
-SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
-SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/%
-SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/%
-
-ECHO CYGWIN INSTALL DIR (WIN) = %CYGWIN_INSTALLDIR_WFMT%
-ECHO CYGWIN INSTALL DIR (MINGW) = %CYGWIN_INSTALLDIR_MFMT%
-ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT%
-ECHO RESULT INSTALL DIR (WIN) = %RESULT_INSTALLDIR_WFMT%
-ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT%
-ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT%
-
-REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset
-SET MAKE_OPT=-j %MAKE_THREADS%
-
-REM ========== DERIVED CYGWIN SETUP OPTIONS ==========
-
-REM One can't set a variable to empty in DOS, but you can set it to a space this way.
-REM The quotes are just there to make the space visible and to protect from "remove trailing spaces".
-SET "CYGWIN_OPT= "
-
-IF "%CYGWIN_FROM_CACHE%" == "Y" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -L
-)
-
-IF "%CYGWIN_QUIET%" == "Y" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin
-)
-
-IF "%GTK_FROM_SOURCES%"=="N" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0
-)
-
-REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
-REM Otherwise chmod won't work and e.g. the ocaml build will fail.
-REM Cygwin setup does not touch the ACLs of existing folders.
-
-REM Run Cygwin Setup
-
-SET RUNSETUP=Y
-IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" (
- SET RUNSETUP=N
-)
-IF NOT "%CYGWIN_QUIET%" == "Y" (
- SET RUNSETUP=Y
-)
-
-IF "%COQREGTESTING%" == "Y" (
- ECHO "========== REMOVE EXISTING CYGWIN =========="
- DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL
- SET RUNSETUP=Y
-)
-
-SET "EXTRAPACKAGES= "
-
-IF NOT "%APPVEYOR%" == "True" (
- SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5
-)
-
-ECHO "========== INSTALL CYGWIN =========="
-
-IF "%RUNSETUP%"=="Y" (
- %SETUP% ^
- --proxy "%PROXY%" ^
- --site "%CYGWIN_REPOSITORY%" ^
- --root "%CYGWIN_INSTALLDIR_WFMT%" ^
- --local-package-dir "%CYGWIN_LOCAL_CACHE_WFMT%" ^
- --no-shortcuts ^
- %CYGWIN_OPT% ^
- -P make,unzip ^
- -P gdb,liblzma5 ^
- -P patch,automake1.14 ^
- -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^
- -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^
- -P libiconv-devel,libunistring-devel,libncurses-devel ^
- -P gettext-devel,libgettextpo-devel ^
- -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^
- -P libfontconfig1 ^
- -P gtk-update-icon-cache ^
- -P libtool,automake ^
- -P intltool ^
- %EXTRAPACKAGES% ^
- || GOTO ErrorExit
-
- MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
- MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs"
-)
-
-IF NOT "%CYGWIN_QUIET%" == "Y" (
- REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it.
- REM This is not required with the -cygquiet=Y and the resulting --no-admin option.
- :waitsetup
- tasklist /fi "imagename eq %SETUP%" | find ":" > NUL
- IF ERRORLEVEL 1 GOTO waitsetup
-)
-
-ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ==========
-
-REM In case this batch file is called from a cygwin bash (e.g. a git repo) we need to clear
-REM HOME (otherwise we get to the home directory of the other installation)
-REM PROFILEREAD (this is set to true if the /etc/profile has been read, which creates user)
-SET "HOME="
-SET "PROFILEREAD="
-
-copy "%BATCHDIR%\configure_profile.sh" "%CYGWIN_INSTALLDIR_WFMT%\var\tmp" || GOTO ErrorExit
-%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh" "%PROXY%" || GOTO ErrorExit
-
-ECHO ========== BUILD COQ ==========
-
-MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
-MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
-
-COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" || GOTO ErrorExit
-COPY "%BATCHDIR%\patches_coq\*.*" "%CYGWIN_INSTALLDIR_WFMT%\build\patches" || GOTO ErrorExit
-
-%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh" || GOTO ErrorExit
-
-ECHO ========== FINISHED ==========
-
-GOTO :EOF
-
-ECHO ========== BATCH FUNCTIONS ==========
-
-:PrintPars
- REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789
- ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit
- ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^>
- ECHO ^<absoloute = install coq in -destcoq absulute path^>
- ECHO ^<relocatable = install relocatable coq in -destcoq path^>
- ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis)
- ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N)
- ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N)
- ECHO -destcyg ^<path to cygwin destination folder^>
- ECHO -destcoq ^<path to coq destination folder (mode=absoloute/relocatable)^>
- ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch)
- ECHO -proxy ^<internet proxy^>
- ECHO -cygrepo ^<cygwin download repository^>
- ECHO -cygcache ^<local cygwin repository/cache^>
- ECHO -cyglocal ^<Y or N^> install cygwin from cache
- ECHO -cygquiet ^<Y or N^> install cygwin without user interaction
- ECHO -srccache ^<local source code repository/cache^>
- ECHO -coqver ^<Coq version to install^>
- ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version
- ECHO -threads ^<1..N^> Number of make threads
- ECHO -addon ^<name^> Enable building selected addon (can be repeated)
- ECHO(
- ECHO See ReadMe.txt for a detailed description of all parameters
- ECHO(
- ECHO Parameter values (default or currently set):
- ECHO -arch = %ARCH%
- ECHO -mode = %INSTALLMODE%
- ECHO -ocaml = %INSTALLOCAML%
- ECHO -installer= %MAKEINSTALLER%
- ECHO -make = %INSTALLMAKE%
- ECHO -destcyg = %DESTCYG%
- ECHO -destcoq = %DESTCOQ%
- ECHO -setup = %SETUP%
- ECHO -proxy = %PROXY%
- ECHO -cygrepo = %CYGWIN_REPOSITORY%
- ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT%
- ECHO -cyglocal = %CYGWIN_FROM_CACHE%
- ECHO -cygquiet = %CYGWIN_QUIET%
- ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT%
- ECHO -coqver = %COQ_VERSION%
- ECHO -gtksrc = %GTK_FROM_SOURCES%
- ECHO -threads = %MAKE_THREADS%
- ECHO -addon = %COQ_ADDONS%
- GOTO :EOF
-
-:CheckYN
- REM Reset errorlevel to 0
- CMD /c "EXIT /b 0"
- IF "%2" == "Y" (
- REM OK Y
- ) ELSE IF "%2" == "N" (
- REM OK N
- ) ELSE (
- ECHO ERROR Parameter %1 must be Y or N, but is %2
- GOTO ErrorExit
- )
- GOTO :EOF
-
-:ErrorExit
- ECHO ERROR MakeCoq_MinGW.bat failed
- EXIT /b 1
+@ECHO OFF + +REM ========== COPYRIGHT/COPYLEFT ========== + +REM (C) 2016 Intel Deutschland GmbH +REM Author: Michael Soegtrop + +REM Released to the public by Intel under the +REM GNU Lesser General Public License Version 2.1 or later +REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html + +REM ========== NOTES ========== + +REM For Cygwin setup command line options +REM see https://cygwin.com/faq/faq.html#faq.setup.cli + +REM ========== DEFAULT VALUES FOR PARAMETERS ========== + +REM For a description of all parameters, see ReadMe.txt + +SET BATCHFILE=%~0 +SET BATCHDIR=%~dp0 + +REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32) +SET ARCH=x86_64 + +REM see -mode in ReadMe.txt +SET INSTALLMODE=absolute + +REM see -installer in ReadMe.txt +SET MAKEINSTALLER=N + +REM see -ocaml in ReadMe.txt +SET INSTALLOCAML=N + +REM see -make in ReadMe.txt +SET INSTALLMAKE=N + +REM see -destcyg in ReadMe.txt +SET DESTCYG=C:\bin\cygwin_coq + +REM see -destcoq in ReadMe.txt +SET DESTCOQ=C:\bin\coq + +REM see -setup in ReadMe.txt +SET SETUP=setup-x86_64.exe + +REM see -proxy in ReadMe.txt +IF DEFINED HTTP_PROXY ( + SET PROXY=%HTTP_PROXY:http://=% +) else ( + REM One can't set a variable to empty in DOS, but you can set it to a space this way. + REM The quotes are just there to make the space visible and to protect from "remove trailing spaces". + SET "PROXY= " +) + +REM see -cygrepo in ReadMe.txt +SET CYGWIN_REPOSITORY=http://mirror.easyname.at/cygwin + +REM see -cygcache in ReadMe.txt +SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache + +REM see -cyglocal in ReadMe.txt +SET CYGWIN_FROM_CACHE=N + +REM see -cygquiet in ReadMe.txt +SET CYGWIN_QUIET=Y + +REM see -srccache in ReadMe.txt +SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache + +REM see -coqver in ReadMe.txt +SET COQ_VERSION=8.5pl3 + +REM see -gtksrc in ReadMe.txt +SET GTK_FROM_SOURCES=N + +REM see -threads in ReadMe.txt +SET MAKE_THREADS=8 + +REM see -addon in ReadMe.txt +SET "COQ_ADDONS= " + +REM ========== PARSE COMMAND LINE PARAMETERS ========== + +SHIFT + +:Parse + +IF "%~0" == "-arch" ( + IF "%~1" == "32" ( + SET ARCH=i686 + SET SETUP=setup-x86.exe + ) ELSE ( + IF "%~1" == "64" ( + SET ARCH=x86_64 + SET SETUP=setup-x86_64.exe + ) ELSE ( + ECHO "Invalid -arch, valid are 32 and 64" + GOTO :EOF + ) + ) + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-mode" ( + IF "%~1" == "mingwincygwin" ( + SET INSTALLMODE=%~1 + ) ELSE ( + IF "%~1" == "absolute" ( + SET INSTALLMODE=%~1 + ) ELSE ( + IF "%~1" == "relocatable" ( + SET INSTALLMODE=%~1 + ) ELSE ( + ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable" + GOTO :EOF + ) + ) + ) + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-installer" ( + SET MAKEINSTALLER=%~1 + CALL :CheckYN -installer %~1 || GOTO ErrorExit + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-ocaml" ( + SET INSTALLOCAML=%~1 + CALL :CheckYN -installer %~1 || GOTO ErrorExit + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-make" ( + SET INSTALLMAKE=%~1 + CALL :CheckYN -installer %~1 || GOTO ErrorExit + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-destcyg" ( + SET DESTCYG=%~1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-destcoq" ( + SET DESTCOQ=%~1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-setup" ( + SET SETUP=%~1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-proxy" ( + SET PROXY=%~1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-cygrepo" ( + SET CYGWIN_REPOSITORY=%~1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-cygcache" ( + SET CYGWIN_LOCAL_CACHE_WFMT=%~1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-cyglocal" ( + SET CYGWIN_FROM_CACHE=%~1 + CALL :CheckYN -cyglocal %~1 || GOTO ErrorExit + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-cygquiet" ( + SET CYGWIN_QUIET=%~1 + CALL :CheckYN -cygquiet %~1 || GOTO ErrorExit + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-srccache" ( + SET SOURCE_LOCAL_CACHE_WFMT=%~1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-coqver" ( + SET COQ_VERSION=%~1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-gtksrc" ( + SET GTK_FROM_SOURCES=%~1 + CALL :CheckYN -gtksrc %~1 || GOTO ErrorExit + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-threads" ( + SET MAKE_THREADS=%~1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%~0" == "-addon" ( + SET "COQ_ADDONS=%COQ_ADDONS% %~1" + SHIFT + SHIFT + GOTO Parse +) + + +IF NOT "%~0" == "" ( + ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW + ECHO !!! Illegal parameter %~0 + ECHO Usage: + ECHO MakeCoq_MinGW + CALL :PrintPars + GOTO :EOF +) + +IF NOT EXIST %SETUP% ( + ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html. + ECHO If the setup is in a different folder, set the full path to %SETUP% using the -setup option. + GOTO :EOF +) + +REM ========== ADJUST PARAMETERS ========== + +IF "%INSTALLMODE%" == "mingwincygwin" ( + SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw +) + +IF "%MAKEINSTALLER%" == "Y" ( + SET INSTALLMODE=relocatable +) + +REM ========== CONFIRM PARAMETERS ========== + +CALL :PrintPars +REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block +IF "%COQREGTESTING%"=="Y" (GOTO DontAsk) + SET /p ANSWER="Is this correct? y/n " + IF NOT "%ANSWER%"=="y" (GOTO :EOF) +:DontAsk + +REM ========== DERIVED VARIABLES ========== + +SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG% +SET RESULT_INSTALLDIR_WFMT=%DESTCOQ% +SET TARGET_ARCH=%ARCH%-w64-mingw32 +SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash + +REM Convert pathes to various formats +REM WFMT = windows format (C:\..) Used in this batch file. +REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH varible, which is : separated, so C: doesn't work. +REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /. + +SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/% +SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/% +SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/% + +SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/% +SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/% +SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/% + +SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/% +SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/% +SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/% + +SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/% +SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/% +SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/% + +ECHO CYGWIN INSTALL DIR (WIN) = %CYGWIN_INSTALLDIR_WFMT% +ECHO CYGWIN INSTALL DIR (MINGW) = %CYGWIN_INSTALLDIR_MFMT% +ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT% +ECHO RESULT INSTALL DIR (WIN) = %RESULT_INSTALLDIR_WFMT% +ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT% +ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT% + +REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset +SET MAKE_OPT=-j %MAKE_THREADS% + +REM ========== DERIVED CYGWIN SETUP OPTIONS ========== + +REM One can't set a variable to empty in DOS, but you can set it to a space this way. +REM The quotes are just there to make the space visible and to protect from "remove trailing spaces". +SET "CYGWIN_OPT= " + +IF "%CYGWIN_FROM_CACHE%" == "Y" ( + SET CYGWIN_OPT= %CYGWIN_OPT% -L +) + +IF "%CYGWIN_QUIET%" == "Y" ( + SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin +) + +IF "%GTK_FROM_SOURCES%"=="N" ( + SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0 +) + +REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES. +REM Otherwise chmod won't work and e.g. the ocaml build will fail. +REM Cygwin setup does not touch the ACLs of existing folders. + +REM Run Cygwin Setup + +SET RUNSETUP=Y +IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" ( + SET RUNSETUP=N +) +IF NOT "%CYGWIN_QUIET%" == "Y" ( + SET RUNSETUP=Y +) + +IF "%COQREGTESTING%" == "Y" ( + ECHO "========== REMOVE EXISTING CYGWIN ==========" + DEL /S /F /Q "%CYGWIN_INSTALLDIR_WFMT%" > NUL + SET RUNSETUP=Y +) + +SET "EXTRAPACKAGES= " + +IF NOT "%APPVEYOR%" == "True" ( + SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5 +) + +ECHO "========== INSTALL CYGWIN ==========" + +IF "%RUNSETUP%"=="Y" ( + %SETUP% ^ + --proxy "%PROXY%" ^ + --site "%CYGWIN_REPOSITORY%" ^ + --root "%CYGWIN_INSTALLDIR_WFMT%" ^ + --local-package-dir "%CYGWIN_LOCAL_CACHE_WFMT%" ^ + --no-shortcuts ^ + %CYGWIN_OPT% ^ + -P make,unzip ^ + -P gdb,liblzma5 ^ + -P patch,automake1.14 ^ + -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^ + -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^ + -P libiconv-devel,libunistring-devel,libncurses-devel ^ + -P gettext-devel,libgettextpo-devel ^ + -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^ + -P libfontconfig1 ^ + -P gtk-update-icon-cache ^ + -P libtool,automake ^ + -P intltool ^ + %EXTRAPACKAGES% ^ + || GOTO ErrorExit + + MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build" + MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs" +) + +IF NOT "%CYGWIN_QUIET%" == "Y" ( + REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it. + REM This is not required with the -cygquiet=Y and the resulting --no-admin option. + :waitsetup + tasklist /fi "imagename eq %SETUP%" | find ":" > NUL + IF ERRORLEVEL 1 GOTO waitsetup +) + +ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ========== + +REM In case this batch file is called from a cygwin bash (e.g. a git repo) we need to clear +REM HOME (otherwise we get to the home directory of the other installation) +REM PROFILEREAD (this is set to true if the /etc/profile has been read, which creates user) +SET "HOME=" +SET "PROFILEREAD=" + +copy "%BATCHDIR%\configure_profile.sh" "%CYGWIN_INSTALLDIR_WFMT%\var\tmp" || GOTO ErrorExit +%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh" "%PROXY%" || GOTO ErrorExit + +ECHO ========== BUILD COQ ========== + +MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build" +MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches" + +COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" || GOTO ErrorExit +COPY "%BATCHDIR%\patches_coq\*.*" "%CYGWIN_INSTALLDIR_WFMT%\build\patches" || GOTO ErrorExit + +%BASH% --login "%CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh" || GOTO ErrorExit + +ECHO ========== FINISHED ========== + +GOTO :EOF + +ECHO ========== BATCH FUNCTIONS ========== + +:PrintPars + REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789 + ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit + ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^> + ECHO ^<absoloute = install coq in -destcoq absulute path^> + ECHO ^<relocatable = install relocatable coq in -destcoq path^> + ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis) + ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N) + ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N) + ECHO -destcyg ^<path to cygwin destination folder^> + ECHO -destcoq ^<path to coq destination folder (mode=absoloute/relocatable)^> + ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch) + ECHO -proxy ^<internet proxy^> + ECHO -cygrepo ^<cygwin download repository^> + ECHO -cygcache ^<local cygwin repository/cache^> + ECHO -cyglocal ^<Y or N^> install cygwin from cache + ECHO -cygquiet ^<Y or N^> install cygwin without user interaction + ECHO -srccache ^<local source code repository/cache^> + ECHO -coqver ^<Coq version to install^> + ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version + ECHO -threads ^<1..N^> Number of make threads + ECHO -addon ^<name^> Enable building selected addon (can be repeated) + ECHO( + ECHO See ReadMe.txt for a detailed description of all parameters + ECHO( + ECHO Parameter values (default or currently set): + ECHO -arch = %ARCH% + ECHO -mode = %INSTALLMODE% + ECHO -ocaml = %INSTALLOCAML% + ECHO -installer= %MAKEINSTALLER% + ECHO -make = %INSTALLMAKE% + ECHO -destcyg = %DESTCYG% + ECHO -destcoq = %DESTCOQ% + ECHO -setup = %SETUP% + ECHO -proxy = %PROXY% + ECHO -cygrepo = %CYGWIN_REPOSITORY% + ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT% + ECHO -cyglocal = %CYGWIN_FROM_CACHE% + ECHO -cygquiet = %CYGWIN_QUIET% + ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT% + ECHO -coqver = %COQ_VERSION% + ECHO -gtksrc = %GTK_FROM_SOURCES% + ECHO -threads = %MAKE_THREADS% + ECHO -addon = %COQ_ADDONS% + GOTO :EOF + +:CheckYN + REM Reset errorlevel to 0 + CMD /c "EXIT /b 0" + IF "%2" == "Y" ( + REM OK Y + ) ELSE IF "%2" == "N" ( + REM OK N + ) ELSE ( + ECHO ERROR Parameter %1 must be Y or N, but is %2 + GOTO ErrorExit + ) + GOTO :EOF + +:ErrorExit + ECHO ERROR MakeCoq_MinGW.bat failed + EXIT /b 1 diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 6ca3aa2981..fa8962a06f 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -20,6 +20,9 @@ We are currently running tests on the following platforms: - AppVeyor is used to test the compilation of Coq and run the test-suite on Windows. +- Azure Pipelines is used to test the compilation of Coq and run the + test-suite on Windows. It is expected to replace appveyor eventually. + You can anticipate the results of most of these tests prior to submitting your PR by running GitLab CI on your private branches. To do so follow these steps: diff --git a/dev/ci/azure-build.sh b/dev/ci/azure-build.sh new file mode 100755 index 0000000000..c0030c566f --- /dev/null +++ b/dev/ci/azure-build.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +set -e -x + +cd $(dirname $0)/../.. + +./configure -local +make -j 2 byte +make -j 2 world diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh new file mode 100755 index 0000000000..8a1e36659c --- /dev/null +++ b/dev/ci/azure-opam.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +set -e -x + +OPAM_VARIANT=ocaml-variants.4.07.1+mingw64c + +wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz +tar -xf opam64.tar.xz +bash opam64/install.sh + +opam init default -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $OPAM_VARIANT --disable-sandboxing +eval "$(opam env)" +opam install -y num ocamlfind ounit diff --git a/dev/ci/azure-test.sh b/dev/ci/azure-test.sh new file mode 100755 index 0000000000..8813245e5a --- /dev/null +++ b/dev/ci/azure-test.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +set -e -x + +#NB: if we make test-suite from the main makefile we get environment +#too large for exec error +cd $(dirname $0)/../../test-suite +make -j 2 clean +make -j 2 PRINT_LOGS=1 diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index f1020e5f8e..baf470e021 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2018-12-05-V1" +# CACHEKEY: "bionic_coq-V2018-12-14-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -37,7 +37,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.1 ounit.2.0.8 odoc.1.3.0" \ +ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.3.0" \ CI_OPAM="menhir.20180530 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. diff --git a/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh b/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh deleted file mode 100644 index b05d02c5be..0000000000 --- a/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh +++ /dev/null @@ -1,14 +0,0 @@ -_OVERLAY_BRANCH=clean-transp-state - -if [ "$CI_PULL_REQUEST" = "7925" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then - - unicoq_CI_REF="$_OVERLAY_BRANCH" - unicoq_CI_GITURL=https://github.com/ppedrot/unicoq - - equations_CI_REF="$_OVERLAY_BRANCH" - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - mtac2_CI_REF="$_OVERLAY_BRANCH" - mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 - -fi diff --git a/dev/ci/user-overlays/08705-ejgallego-vernac+remove_empty_hooks.sh b/dev/ci/user-overlays/08705-ejgallego-vernac+remove_empty_hooks.sh deleted file mode 100644 index 3600f1cd3e..0000000000 --- a/dev/ci/user-overlays/08705-ejgallego-vernac+remove_empty_hooks.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8705" ] || [ "$CI_BRANCH" = "vernac+remove_empty_hooks" ]; then - - elpi_CI_REF=vernac+remove_empty_hooks - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - equations_CI_REF=vernac+remove_empty_hooks - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - paramcoq_CI_REF=vernac+remove_empty_hooks - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - - plugin_tutorial_CI_REF=vernac+remove_empty_hooks - plugin_tutorial_CI_GITURL=https://github.com/ejgallego/plugin_tutorials - - mtac2_CI_REF=vernac+remove_empty_hooks - mtac2_CI_GITURL=https://github.com/ejgallego/mtac2 - -fi diff --git a/dev/ci/user-overlays/08850-poly-local-univs.sh b/dev/ci/user-overlays/08850-poly-local-univs.sh deleted file mode 100644 index 482792d7cd..0000000000 --- a/dev/ci/user-overlays/08850-poly-local-univs.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8850" ] || [ "$CI_BRANCH" = "poly-local-univs" ]; then - formal_topology_CI_REF=poly-local-univs - formal_topology_CI_GITURL=https://github.com/SkySkimmer/topology - - paramcoq_CI_REF=poly-local-univs - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq -fi diff --git a/dev/ci/user-overlays/08889-mattam-program-obl-subst.sh b/dev/ci/user-overlays/08889-mattam-program-obl-subst.sh deleted file mode 100644 index 17eb5fffae..0000000000 --- a/dev/ci/user-overlays/08889-mattam-program-obl-subst.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8889" ] || [ "$CI_BRANCH" = "program-hook-obligation-subst" ]; then - - Equations_CI_REF=program-hook-obligation-subst - Equations_CI_GITURL=https://github.com/mattam82/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh b/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh deleted file mode 100644 index 08112d3054..0000000000 --- a/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8902" ] || [ "$CI_BRANCH" = "ltac+use_atts_in_ast" ]; then - - aactactics_CI_REF=ltac+use_atts_in_ast - aactactics_CI_GITURL=https://github.com/ejgallego/aac-tactics - - coqhammer_CI_REF=ltac+use_atts_in_ast - coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer - - Equations_CI_REF=ltac+use_atts_in_ast - Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - mtac2_CI_REF=ltac+use_atts_in_ast - mtac2_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh b/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh deleted file mode 100644 index 1c5157ba12..0000000000 --- a/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8914" ] || [ "$CI_BRANCH" = "lib+better_boot_coqproject" ]; then - - quickchick_CI_REF=lib+better_boot_coqproject - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh b/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh deleted file mode 100644 index e74e53fa40..0000000000 --- a/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8933" ] || [ "$CI_BRANCH" = "solve-remaining-evars-initial-arg" ]; then - plugin_tutorial_CI_REF=solve-remaining-evars-initial-arg - plugin_tutorial_CI_GITURL=https://github.com/SkySkimmer/plugin_tutorials -fi diff --git a/dev/ci/user-overlays/08985-ejgallego-build+pack_gramlib.sh b/dev/ci/user-overlays/08985-ejgallego-build+pack_gramlib.sh deleted file mode 100644 index d7130cc67a..0000000000 --- a/dev/ci/user-overlays/08985-ejgallego-build+pack_gramlib.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8985" ] || [ "$CI_BRANCH" = "build+pack_gramlib" ]; then - - elpi_CI_REF=use_coq_gramlib - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -fi diff --git a/dev/ci/user-overlays/08998-ejgallego-legacy_proof_eng_clean.sh b/dev/ci/user-overlays/08998-ejgallego-legacy_proof_eng_clean.sh deleted file mode 100644 index c8bea0c868..0000000000 --- a/dev/ci/user-overlays/08998-ejgallego-legacy_proof_eng_clean.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8998" ] || [ "$CI_BRANCH" = "legacy_proof_eng_clean" ]; then - - equations_CI_REF=legacy_proof_eng_clean - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh b/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh deleted file mode 100644 index 61ffa4a197..0000000000 --- a/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9003" ] || [ "$CI_BRANCH" = "vernac+move_extend_ast" ]; then - - ltac2_CI_REF=vernac+move_extend_ast - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - -fi diff --git a/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh b/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh deleted file mode 100644 index 14e7c0d7f0..0000000000 --- a/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9051" ] || [ "$CI_BRANCH" = "camlp5-safe-api-strikes-back" ]; then - - equations_CI_REF=camlp5-safe-api-strikes-back - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - ltac2_CI_REF=camlp5-safe-api-strikes-back - ltac2_CI_GITURL=https://github.com/ppedrot/ltac2 - -fi diff --git a/dev/ci/user-overlays/09065-ejgallego-gramlib+no_ploc.sh b/dev/ci/user-overlays/09065-ejgallego-gramlib+no_ploc.sh deleted file mode 100644 index e9daa7a44e..0000000000 --- a/dev/ci/user-overlays/09065-ejgallego-gramlib+no_ploc.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9065" ] || [ "$CI_BRANCH" = "gramlib+no_ploc" ]; then - - elpi_CI_REF=gramlib+no_ploc - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -fi diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index b664eb4ec5..bffbe3e284 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1550,20 +1550,26 @@ whose general syntax is :undocumented: .. prodn:: - i_item ::= @i_pattern %| @s_item %| @clear_switch %| {? %{%} } /@term + i_item ::= @i_pattern %| @s_item %| @clear_switch %| @i_view %| @i_block .. prodn:: s_item ::= /= %| // %| //= .. prodn:: - i_pattern ::= @ident %| _ %| ? %| * %| {? @occ_switch } -> %| {? @occ_switch }<- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] + i_view ::= {? %{%} } /@term %| /ltac:( @tactic ) -The ``=>`` tactical first executes tactic, then the :token:`i_item` s, +.. prodn:: + i_pattern ::= @ident %| > @ident %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch }<- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] + +.. prodn:: + i_block ::= [^ @ident ] %| [^~ @ident ] %| [^~ @num ] + +The ``=>`` tactical first executes :token:`tactic`, then the :token:`i_item`\s, left to right. An :token:`s_item` specifies a simplification operation; a :token:`clear_switch` -h specifies context pruning as in :ref:`discharge_ssr`. -The :token:`i_pattern` s can be seen as a variant of *intro patterns* -:ref:`tactics`: each performs an introduction operation, i.e., pops some +specifies context pruning as in :ref:`discharge_ssr`. +The :token:`i_pattern`\s can be seen as a variant of *intro patterns* +(see :tacn:`intros`:) each performs an introduction operation, i.e., pops some variables or assumptions from the goal. An :token:`s_item` can simplify the set of subgoals or the subgoals themselves: @@ -1572,7 +1578,7 @@ An :token:`s_item` can simplify the set of subgoals or the subgoals themselves: |SSR| tactic :tacn:`done` described in :ref:`terminators_ssr`, i.e., it executes ``try done``. + ``/=`` simplifies the goal by performing partial evaluation, as per the - tactic ``simpl`` [#5]_. + tactic :tacn:`simpl` [#5]_. + ``//=`` combines both kinds of simplification; it is equivalent to ``/= //``, i.e., ``simpl; try done``. @@ -1583,21 +1589,42 @@ When an :token:`s_item` bears a :token:`clear_switch`, then the possibly using the fact ``IHn``, and will erase ``IHn`` from the context of the remaining subgoals. -The last entry in the :token:`i_item` grammar rule, ``/``:token:`term`, +The first entry in the :token:`i_view` grammar rule, :n:`/@term`, represents a view (see section :ref:`views_and_reflection_ssr`). +It interprets the top of the stack with the view :token:`term`. +It is equivalent to ``move/term``. The optional flag ``{}`` can +be used to signal that the :token:`term`, when it is a context entry, +has to be cleared. If the next :token:`i_item` is a view, then the view is applied to the assumption in top position once all the previous :token:`i_item` have been performed. -The view is applied to the top assumption. +The second entry in the :token:`i_view` grammar rule, +``/ltac:(`` :token:`tactic` ``)``, executes :token:`tactic`. +Notations can be used to name tactics, for example:: + + Notation myop := (ltac:(some ltac code)) : ssripat_scope. -|SSR| supports the following :token:`i_pattern` s: +lets one write just ``/myop`` in the intro pattern. Note the scope +annotation: views are interpreted opening the ``ssripat`` scope. + +|SSR| supports the following :token:`i_pattern`\s: :token:`ident` pops the top variable, assumption, or local definition into a new constant, fact, or defined constant :token:`ident`, respectively. Note that defined constants cannot be introduced when δ-expansion is required to expose the top variable or assumption. +``>``:token:`ident` + pops the first assumption. Type class instances are not considered + as assumptions. + The tactic ``move=> >H`` is equivalent to + ``move=> ? ? H`` with enough ``?`` to name ``H`` the first assumption. + On a goal:: + + forall x y, x < y -> G + + it names ``H`` the assumption ``x < y``. ``?`` pops the top variable into an anonymous constant or fact, whose name is picked by the tactic interpreter. |SSR| only generates names that cannot @@ -1620,7 +1647,17 @@ The view is applied to the top assumption. a first ``move=> *`` adds only ``_a_ : bool`` and ``_b_ : bool`` to the context; it takes a second ``move=> *`` to add ``_Hyp_ : _a_ = _b_``. -:token:`occ_switch` ``->`` +``+`` + temporarily introduces the top variable. It is discharged at the end + of the intro pattern. For example ``move=> + y`` on a goal:: + + forall x y, P + + is equivalent to ``move=> _x_ y; move: _x_`` that results in the goal:: + + forall x, P + +:n:`{? occ_switch } ->` (resp. :token:`occ_switch` ``<-``) pops the top assumption (which should be a rewritable proposition) into an anonymous fact, rewrites (resp. rewrites right to left) the goal with this @@ -1645,18 +1682,13 @@ The view is applied to the top assumption. variable, using the |SSR| ``case`` tactic described in :ref:`the_defective_tactics_ssr`. It then behaves as the corresponding branching :token:`i_pattern`, executing the - sequence:token:`i_item`:math:`_i` in the i-th subgoal generated by the + sequence :n:`@i_item__i` in the i-th subgoal generated by the case analysis; unless we have the trivial destructing :token:`i_pattern` ``[]``, the latter should generate exactly m subgoals, i.e., the top variable should have an inductive type with exactly m constructors [#7]_. While it is good style to use the :token:`i_item` i * to pop the variables and assumptions corresponding to each constructor, this is not enforced by |SSR|. -``/`` :token:`term` - Interprets the top of the stack with the view :token:`term`. - It is equivalent to ``move/term``. The optional flag ``{}`` can - be used to signal that the :token:`term`, when it is a context entry, - has to be cleared. ``-`` does nothing, but counts as an intro pattern. It can also be used to force the interpretation of ``[`` :token:`i_item` * ``| … |`` @@ -1721,6 +1753,40 @@ interpretation, e.g.: are all equivalent. +|SSR| supports the following :token:`i_block`\s: + +:n:`[^ @ident ]` + *block destructing* :token:`i_pattern`. It performs a case analysis + on the top variable and introduces, in one go, all the variables coming + from the case analysis. The names of these variables are obtained by + taking the names used in the inductive type declaration and prefixing them + with :token:`ident`. If the intro pattern immediately follows a call + to ``elim`` with a custom eliminator (see :ref:`custom_elim_ssr`) then + the names are taken from the ones used in the type of the eliminator. + + .. example:: + + .. coqtop:: reset + + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + + .. coqtop:: all + + Record r := { a : nat; b := (a, 3); _ : bool; }. + + Lemma test : r -> True. + Proof. move => [^ x ]. + +:n:`[^~ @ident ]` + *block destructing* using :token:`ident` as a suffix. +:n:`[^~ @num ]` + *block destructing* using :token:`num` as a suffix. + + Only a :token:`s_item` is allowed between the elimination tactic and + the block destructing. .. _generation_of_equations_ssr: @@ -4160,6 +4226,7 @@ interpretation operations with the proof stack operations. This *view mechanism* relies on the combination of the ``/`` view switch with bookkeeping tactics and tacticals. +.. _custom_elim_ssr: Interpreting eliminations ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -5238,11 +5305,21 @@ discharge item see :ref:`discharge_ssr` generalization item see :ref:`structure_ssr` -.. prodn:: i_pattern ::= @ident %| _ %| ? %| * %| {? @occ_switch } -> %| {? @occ_switch } <- %| [ {*| {* @i_item } } %| - %| [: {+ @ident } ] +.. prodn:: i_pattern ::= @ident %| > @ident %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch } <- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] intro pattern :ref:`introduction_ssr` -.. prodn:: i_item ::= @clear_switch %| @s_item %| @i_pattern %| {? %{%} } / @term +.. prodn:: i_item ::= @clear_switch %| @s_item %| @i_pattern %| @i_view %| @i_block + +view :ref:`introduction_ssr` + +.. prodn:: + i_view ::= {? %{%} } /@term %| /ltac:( @tactic ) + +intro block :ref:`introduction_ssr` + +.. prodn:: + i_block ::= [^ @ident ] %| [^~ @ident ] %| [^~ @num ] intro item see :ref:`introduction_ssr` @@ -4,7 +4,9 @@ (release (flags :standard -rectypes) (ocamlopt_flags -O3 -unbox-closures)) (ireport (flags :standard -rectypes -w -9-27-40+60) - (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report))) + (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report)) + (ocaml408 + (flags :standard -strict-sequence -strict-formats -short-paths -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) ; The _ profile could help factoring the above, however it doesn't ; seem to work like we'd expect/like: diff --git a/ide/preferences.ml b/ide/preferences.ml index 045d650c1c..4aa8c92f73 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -815,33 +815,20 @@ let configure ?(apply=(fun () -> ())) parent = custom ~label box callback true in -(* - let show_toolbar = - bool - ~f:(fun s -> - current.show_toolbar <- s; - !show_toolbar s) - "Show toolbar" current.show_toolbar - in let window_height = string - ~f:(fun s -> current.window_height <- (try int_of_string s with _ -> 600); - !resize_window (); - ) - "Window height" - (string_of_int current.window_height) + ~f:(fun s -> try window_height#set (int_of_string s) with _ -> ()) + "Default window height at starting time" + (string_of_int window_height#get) in + let window_width = string - ~f:(fun s -> current.window_width <- - (try int_of_string s with _ -> 800)) - "Window width" - (string_of_int current.window_width) + ~f:(fun s -> try window_width#set (int_of_string s) with _ -> ()) + "Default window width at starting time" + (string_of_int window_width#get) in -*) -(* - let config_appearance = [show_toolbar; window_width; window_height] in -*) + let global_auto_revert = pbool "Enable global auto revert" global_auto_revert in let global_auto_revert_delay = string @@ -1049,10 +1036,7 @@ let configure ?(apply=(fun () -> ())) parent = Section("Project", Some (`STOCK "gtk-page-setup"), [project_file_name;read_project; ]); -(* - Section("Appearance", - config_appearance); -*) + Section("Appearance", Some `PREFERENCES, [window_width; window_height]); Section("Externals", None, [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;cmd_editor;cmd_browse;doc_url;library_url]); diff --git a/interp/interp.mllib b/interp/interp.mllib index aa20bda705..147eaf20dc 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,6 +1,4 @@ Constrexpr -Genredexpr -Redops Tactypes Stdarg Notation_term diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 7b01b6dc1c..bf3a8fe215 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -11,8 +11,6 @@ open Genarg open Geninterp -type 'a and_short_name = 'a * Names.lident option - let make0 ?dyn name = let wit = Genarg.make0 name in let () = register_val0 wit dyn in @@ -53,8 +51,6 @@ let wit_uconstr = make0 "uconstr" let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" -let wit_red_expr = make0 "redexpr" - let wit_clause_dft_concl = make0 "clause_dft_concl" @@ -65,4 +61,3 @@ let wit_preident = wit_pre_ident let wit_reference = wit_ref let wit_global = wit_ref let wit_clause = wit_clause_dft_concl -let wit_redexpr = wit_red_expr diff --git a/interp/stdarg.mli b/interp/stdarg.mli index 5e5e43ed38..c974a4403c 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -14,15 +14,11 @@ open Loc open Names open EConstr open Libnames -open Genredexpr -open Pattern open Constrexpr open Genarg open Genintern open Locus -type 'a and_short_name = 'a * lident option - val wit_unit : unit uniform_genarg_type val wit_bool : bool uniform_genarg_type @@ -52,11 +48,6 @@ val wit_uconstr : (constr_expr , glob_constr_and_expr, Ltac_pretype.closed_glob_ val wit_open_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type -val wit_red_expr : - ((constr_expr,qualid or_by_notation,constr_expr) red_expr_gen, - (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, - (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type - val wit_clause_dft_concl : (lident Locus.clause_expr, lident Locus.clause_expr, Names.Id.t Locus.clause_expr) genarg_type (** Aliases for compatibility *) @@ -66,7 +57,3 @@ val wit_preident : string uniform_genarg_type val wit_reference : (qualid, GlobRef.t located or_var, GlobRef.t) genarg_type val wit_global : (qualid, GlobRef.t located or_var, GlobRef.t) genarg_type val wit_clause : (lident Locus.clause_expr, lident Locus.clause_expr, Names.Id.t Locus.clause_expr) genarg_type -val wit_redexpr : - ((constr_expr,qualid or_by_notation,constr_expr) red_expr_gen, - (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, - (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type diff --git a/kernel/dune b/kernel/dune index 4f2e0e4e28..01abdb8f67 100644 --- a/kernel/dune +++ b/kernel/dune @@ -18,3 +18,4 @@ ; warnings. (env (dev (flags :standard -w +a-4-44-50))) + ; (ocaml408 (flags :standard -w +a-3-4-44-50))) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 07f50f6cd5..4d817625f5 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -164,11 +164,12 @@ module Btauto = struct let reify env t = lapp eval [|convert_env env; convert t|] - let print_counterexample p env gl = + let print_counterexample p penv gl = let var = lapp witness [|p|] in let var = EConstr.of_constr var in (* Compute an assignment that dissatisfies the goal *) - let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in + let redfun, _ = Redexpr.reduction_of_red_expr (Refiner.pf_env gl) Genredexpr.(CbvVm None) in + let _, var = redfun Refiner.(pf_env gl) Refiner.(project gl) var in let var = EConstr.Unsafe.to_constr var in let rec to_list l = match decomp_term (Tacmach.project gl) l with | App (c, _) @@ -192,7 +193,7 @@ module Btauto = struct let msg = try let var = to_list var in - let assign = List.combine env var in + let assign = List.combine penv var in let map_msg (key, v) = let b = if v then str "true" else str "false" in let sigma, env = Pfedit.get_current_context () in diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 37fc81ee38..ea86a4b514 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -132,7 +132,7 @@ let normalize_evaluables= open Ppconstr open Printer let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_qualid -let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (pr_or_var (fun x -> pr_global (snd x))) +let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (Pputils.pr_or_var (fun x -> pr_global (snd x))) let pr_firstorder_using_typed _ _ _ = Pptactic.pr_auto_using pr_global let warn_deprecated_syntax = diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index 156ee94a66..5d5d45c58f 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -314,7 +314,7 @@ END let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c -let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl +let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Pputils.pr_lident cl let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl let in_clause' = Pltac.in_clause diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 2267d43d93..5e3f4df192 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -22,8 +22,8 @@ open Tactypes open Locus open Decl_kinds open Genredexpr -open Pputils open Ppconstr +open Pputils open Printer open Genintern @@ -159,8 +159,8 @@ let string_of_genarg_arg (ArgumentType arg) = end | _ -> default - let pr_with_occurrences pr c = pr_with_occurrences pr keyword c - let pr_red_expr pr c = pr_red_expr pr keyword c + let pr_with_occurrences pr c = Ppred.pr_with_occurrences pr keyword c + let pr_red_expr pr c = Ppred.pr_red_expr pr keyword c let pr_may_eval test prc prlc pr2 pr3 = function | ConstrEval (r,c) -> @@ -186,12 +186,6 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_and_short_name pr (c,_) = pr c - let pr_or_by_notation f = CAst.with_val (function - | AN v -> f v - | ByNotation (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc) - - let pr_located pr (_,x) = pr x - let pr_evaluable_reference = function | EvalVarRef id -> pr_id id | EvalConstRef sp -> pr_global (Globnames.ConstRef sp) @@ -694,7 +688,7 @@ let pr_goal_selector ~toplevel s = (* match t with | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal | _ ->*) - let s = prlist_with_sep spc Ppconstr.pr_lname nal ++ str ":" ++ pr.pr_lconstr t in + let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in spc() ++ hov 1 (str"(" ++ s ++ str")") in let pr_fix_tac (id,n,c) = diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 0ab9e501bc..bc47036d92 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -98,8 +98,7 @@ val pr_may_eval : ('a -> Pp.t) -> ('a -> Pp.t) -> ('b -> Pp.t) -> ('c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t -val pr_and_short_name : ('a -> Pp.t) -> 'a Stdarg.and_short_name -> Pp.t -val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t +val pr_and_short_name : ('a -> Pp.t) -> 'a Genredexpr.and_short_name -> Pp.t val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 83f563e2ab..30e316b36d 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -270,7 +270,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Stdarg.and_short_name or_var +type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -296,9 +296,6 @@ type glob_tactic_arg = (** Raw tactics *) -type r_trm = constr_expr -type r_pat = constr_pattern_expr -type r_cst = qualid or_by_notation type r_ref = qualid type r_nam = lident type r_lev = rlevel diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index da0ecfc449..8b6b14322b 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -269,7 +269,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Stdarg.and_short_name or_var +type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -295,9 +295,6 @@ type glob_tactic_arg = (** Raw tactics *) -type r_trm = constr_expr -type r_pat = constr_pattern_expr -type r_cst = qualid or_by_notation type r_ref = qualid type r_nam = lident type r_lev = rlevel diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index 11e282e4f5..fac524da6b 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -64,38 +64,37 @@ type ast_closure_term = { type ssrview = ast_closure_term list -(* TODO -type id_mod = Hat | HatTilde | Sharp - *) +type id_mod = Dependent + +type id_block = Prefix of Id.t | SuffixId of Id.t | SuffixNum of int (* Only [One] forces an introduction, possibly reducing the goal. *) type anon_iter = - | One + | One of string option (* name hint *) | Drop | All -(* TODO - | Dependent (* fast mode *) - | UntilMark - | Temporary (* "+" *) - *) + | Temporary type ssripat = | IPatNoop - | IPatId of (*TODO id_mod option * *) Id.t + | IPatId of id_mod option * Id.t | IPatAnon of anon_iter (* inaccessible name *) (* TODO | IPatClearMark *) - | IPatDispatch of bool (* ssr exception: accept a dispatch on the empty list even when there are subgoals *) * ssripatss (* (..|..) *) - | IPatCase of (* ipats_mod option * *) ssripatss (* this is not equivalent to /case /[..|..] if there are already multiple goals *) + | IPatDispatch of bool (* ssr exception: accept a dispatch on the empty list even when there are subgoals *) * ssripatss_or_block (* (..|..) *) + | IPatCase of (* ipats_mod option * *) ssripatss_or_block (* this is not equivalent to /case /[..|..] if there are already multiple goals *) | IPatInj of ssripatss | IPatRewrite of (*occurrence option * rewrite_pattern **) ssrocc * ssrdir | IPatView of bool * ssrview (* {}/view (true if the clear is present) *) | IPatClear of ssrclear (* {H1 H2} *) | IPatSimpl of ssrsimpl | IPatAbstractVars of Id.t list - | IPatTac of unit Proofview.tactic + | IPatEqGen of unit Proofview.tactic (* internal use: generation of eqn *) and ssripats = ssripat list and ssripatss = ssripats list +and ssripatss_or_block = + | Block of id_block + | Regular of ssripats list type ssrhpats = ((ssrclear * ssripats) * ssripats) * ssripats type ssrhpats_wtransp = bool * ssrhpats diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index cd9af84ed9..311d912efd 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -401,6 +401,7 @@ let max_suffix m (t, j0 as tj0) id = dt < ds && skip_digits s i = n in loop m +(** creates a fresh (w.r.t. `gl_ids` and internal names) inaccessible name of the form _tXX_ *) let mk_anon_id t gl_ids = let m, si0, id0 = let s = ref (Printf.sprintf "_%s_" t) in @@ -409,7 +410,7 @@ let mk_anon_id t gl_ids = let rec loop i j = let d = !s.[i] in if not (is_digit d) then i + 1, j else loop (i - 1) (if d = '0' then j else i) in - let m, j = loop (n - 1) n in m, (!s, j), Id.of_string !s in + let m, j = loop (n - 1) n in m, (!s, j), Id.of_string_soft !s in if not (List.mem id0 gl_ids) then id0 else let s, i = List.fold_left (max_suffix m) si0 gl_ids in let open Bytes in @@ -419,7 +420,7 @@ let mk_anon_id t gl_ids = if get s i = '9' then (set s i '0'; loop (i - 1)) else if i < m then (set s n '0'; set s m '1'; cat s (of_string "_")) else (set s i (Char.chr (Char.code (get s i) + 1)); s) in - Id.of_bytes (loop (n - 1)) + Id.of_string_soft (Bytes.to_string (loop (n - 1))) let convert_concl_no_check t = Tactics.convert_concl_no_check t DEFAULTcast let convert_concl t = Tactics.convert_concl t DEFAULTcast @@ -808,18 +809,6 @@ let clear_wilds_and_tmp_and_delayed_ids gl = (clear_with_wilds ctx.wild_ids ctx.delayed_clears) (clear_wilds (List.map fst ctx.tmp_ids @ ctx.wild_ids))) gl -let rec is_name_in_ipats name = function - | IPatClear clr :: tl -> - List.exists (function SsrHyp(_,id) -> id = name) clr - || is_name_in_ipats name tl - | IPatId id :: tl -> id = name || is_name_in_ipats name tl - | IPatAbstractVars ids :: tl -> - CList.mem_f Id.equal name ids || is_name_in_ipats name tl - | (IPatCase l | IPatDispatch (_,l) | IPatInj l) :: tl -> - List.exists (is_name_in_ipats name) l || is_name_in_ipats name tl - | (IPatView _ | IPatAnon _ | IPatSimpl _ | IPatRewrite _ | IPatTac _ | IPatNoop) :: tl -> is_name_in_ipats name tl - | [] -> false - let view_error s gv = errorstrm (str ("Cannot " ^ s ^ " view ") ++ pr_term gv) @@ -1187,9 +1176,23 @@ let gen_tmp_ids ctx.tmp_ids) gl) ;; -let pf_interp_gen gl to_ind gen = +let pf_interp_gen to_ind gen gl = let _, _, a, b, c, ucst,gl = pf_interp_gen_aux gl to_ind gen in - a, b ,c, pf_merge_uc ucst gl + (a, b ,c), pf_merge_uc ucst gl + +let pfLIFT f = + let open Proofview.Notations in + let hack = ref None in + Proofview.V82.tactic (fun gl -> + let g = sig_it gl in + let x, gl = f gl in + hack := Some (x,project gl); + re_sig [g] (project gl)) + >>= fun () -> + let x, sigma = option_assert_get !hack (Pp.str"pfLIFT") in + Proofview.Unsafe.tclEVARS sigma <*> + Proofview.tclUNIT x +;; (* TASSI: This version of unprotects inlines the unfold tactic definition, * since we don't want to wipe out let-ins, and it seems there is no flag @@ -1273,7 +1276,7 @@ let unfold cl = open Proofview open Notations -let tacSIGMA = Goal.enter_one begin fun g -> +let tacSIGMA = Goal.enter_one ~__LOC__ begin fun g -> let k = Goal.goal g in let sigma = Goal.sigma g in tclUNIT (Tacmach.re_sig k sigma) @@ -1347,6 +1350,11 @@ let tclFULL_BETAIOTA = Goal.enter begin fun gl -> Tactics.e_reduct_in_concl ~check:false (r,Constr.DEFAULTcast) end +type intro_id = + | Anon + | Id of Id.t + | Seed of string + (** [intro id k] introduces the first premise (product or let-in) of the goal under the name [id], reducing the head of the goal (using beta, iota, delta but not zeta) if necessary. If [id] is None, a name is generated, that will @@ -1360,11 +1368,12 @@ let tclINTRO ~id ~conclusion:k = Goal.enter begin fun gl -> let original_name = Rel.Declaration.get_name decl in let already_used = Tacmach.New.pf_ids_of_hyps gl in let id = match id, original_name with - | Some id, _ -> id - | _, Name id -> + | Id id, _ -> id + | Seed id, _ -> mk_anon_id id already_used + | Anon, Name id -> if is_discharged_id id then id else mk_anon_id (Id.to_string id) already_used - | _, _ -> + | Anon, Anonymous -> let ids = Tacmach.New.pf_ids_of_hyps gl in mk_anon_id ssr_anon_hyp ids in @@ -1377,8 +1386,11 @@ end let return ~orig_name:_ ~new_name:_ = tclUNIT () -let tclINTRO_ID id = tclINTRO ~id:(Some id) ~conclusion:return -let tclINTRO_ANON = tclINTRO ~id:None ~conclusion:return +let tclINTRO_ID id = tclINTRO ~id:(Id id) ~conclusion:return +let tclINTRO_ANON ?seed () = + match seed with + | None -> tclINTRO ~id:Anon ~conclusion:return + | Some seed -> tclINTRO ~id:(Seed seed) ~conclusion:return let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> let convert_concl_no_check t = @@ -1391,8 +1403,8 @@ let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> | _ -> CErrors.anomaly (Pp.str "rename_hd_prod: no head product") end -let tcl0G tac = - numgoals >>= fun ng -> if ng = 0 then tclUNIT () else tac +let tcl0G ~default tac = + numgoals >>= fun ng -> if ng = 0 then tclUNIT default else tac let rec tclFIRSTa = function | [] -> Tacticals.New.tclZEROMSG Pp.(str"No applicable tactic.") @@ -1491,6 +1503,12 @@ let tclGET k = Goal.enter begin fun gl -> k (Option.default S.init (get (Goal.state gl) state_field)) end +let tclGET1 k = Goal.enter_one begin fun gl -> + let open Proofview_monad.StateStore in + k (Option.default S.init (get (Goal.state gl) state_field)) +end + + let tclSET new_s = let open Proofview_monad.StateStore in Unsafe.tclGETGOALS >>= fun gls -> diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 824827e90c..51116ccd75 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -359,24 +359,17 @@ val genstac : Tacmach.tactic val pf_interp_gen : - Goal.goal Evd.sigma -> bool -> (Ssrast.ssrhyp list option * Ssrmatching.occ) * Ssrmatching.cpattern -> - EConstr.t * EConstr.t * Ssrast.ssrhyp list * - Goal.goal Evd.sigma - -val pf_interp_gen_aux : Goal.goal Evd.sigma -> - bool -> - (Ssrast.ssrhyp list option * Ssrmatching.occ) * - Ssrmatching.cpattern -> - bool * Ssrmatching.pattern * EConstr.t * - EConstr.t * Ssrast.ssrhyp list * UState.t * - Goal.goal Evd.sigma + (EConstr.t * EConstr.t * Ssrast.ssrhyp list) * + Goal.goal Evd.sigma -val is_name_in_ipats : - Id.t -> ssripats -> bool +(* HACK: use to put old pf_code in the tactic monad *) +val pfLIFT + : (Goal.goal Evd.sigma -> 'a * Goal.goal Evd.sigma) + -> 'a Proofview.tactic (** Basic tactics *) @@ -431,18 +424,23 @@ val tacREDUCE_TO_QUANTIFIED_IND : val tacTYPEOF : EConstr.t -> EConstr.types Proofview.tactic val tclINTRO_ID : Id.t -> unit Proofview.tactic -val tclINTRO_ANON : unit Proofview.tactic +val tclINTRO_ANON : ?seed:string -> unit -> unit Proofview.tactic (* Lower level API, calls conclusion with the name taken from the prod *) +type intro_id = + | Anon + | Id of Id.t + | Seed of string + val tclINTRO : - id:Id.t option -> + id:intro_id -> conclusion:(orig_name:Name.t -> new_name:Id.t -> unit Proofview.tactic) -> unit Proofview.tactic val tclRENAME_HD_PROD : Name.t -> unit Proofview.tactic (* calls the tactic only if there are more than 0 goals *) -val tcl0G : unit Proofview.tactic -> unit Proofview.tactic +val tcl0G : default:'a -> 'a Proofview.tactic -> 'a Proofview.tactic (* like tclFIRST but with 'a tactic *) val tclFIRSTa : 'a Proofview.tactic list -> 'a Proofview.tactic @@ -474,6 +472,7 @@ end module MakeState(S : StateType) : sig val tclGET : (S.state -> unit Proofview.tactic) -> unit Proofview.tactic + val tclGET1 : (S.state -> 'a Proofview.tactic) -> 'a Proofview.tactic val tclSET : S.state -> unit Proofview.tactic val tacUPDATE : (S.state -> S.state Proofview.tactic) -> unit Proofview.tactic diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 01af67912a..7596f6638a 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -86,10 +86,16 @@ Export SsrMatchingSyntax. Export SsrSyntax. (** + To define notations for tactic in intro patterns. + When "=> /t" is parsed, "t:%ssripat" is actually interpreted. **) +Declare Scope ssripat_scope. +Delimit Scope ssripat_scope with ssripat. + +(** Make the general "if" into a notation, so that we can override it below. The notations are "only parsing" because the Coq decompiler will not recognize the expansion of the boolean if; using the default printer - avoids a spurrious trailing %%GEN_IF. **) + avoids a spurrious trailing %%GEN_IF. **) Declare Scope general_if_scope. Delimit Scope general_if_scope with GEN_IF. diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 2c9ec3a7cf..a0b1d784f1 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -102,20 +102,28 @@ let get_eq_type gl = let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in gl, EConstr.of_constr eq -let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac gl = +let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = + let open Proofview.Notations in + Proofview.tclEVARMAP >>= begin fun sigma -> (* some sanity checks *) - let oc, orig_clr, occ, c_gen, gl = match what with - | `EConstr(_,_,t) when EConstr.isEvar (project gl) t -> - anomaly "elim called on a constr evar" + match what with + | `EConstr(_,_,t) when EConstr.isEvar sigma t -> + anomaly "elim called on a constr evar" | `EGen (_, g) when elim = None && is_wildcard g -> errorstrm Pp.(str"Indeterminate pattern and no eliminator") | `EGen ((Some clr,occ), g) when is_wildcard g -> - None, clr, occ, None, gl - | `EGen ((None, occ), g) when is_wildcard g -> None,[],occ,None,gl + Proofview.tclUNIT (None, clr, occ, None) + | `EGen ((None, occ), g) when is_wildcard g -> + Proofview.tclUNIT (None,[],occ,None) | `EGen ((_, occ), p as gen) -> - let _, c, clr,gl = pf_interp_gen gl true gen in - Some c, clr, occ, Some p,gl - | `EConstr (clr, occ, c) -> Some c, clr, occ, None,gl in + pfLIFT (pf_interp_gen true gen) >>= fun (_,c,clr) -> + Proofview.tclUNIT (Some c, clr, occ, Some p) + | `EConstr (clr, occ, c) -> + Proofview.tclUNIT (Some c, clr, occ, None) + end >>= + + fun (oc, orig_clr, occ, c_gen) -> pfLIFT begin fun gl -> + let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); let fire_subst gl t = Reductionops.nf_evar (project gl) t in @@ -145,13 +153,26 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac (* finds the eliminator applies it to evars and c saturated as needed *) (* obtaining "elim ??? (c ???)". pred is the higher order evar *) (* cty is None when the user writes _ (hence we can't make a pattern *) - let cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = + (* `seed` represents the array of types from which we derive the name seeds + for the block intro patterns *) + let seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = match elim with | Some elim -> let gl, elimty = pf_e_type_of gl elim in + let elimty = + let rename_elimty r = + EConstr.of_constr + (Arguments_renaming.rename_type + (EConstr.to_constr ~abort_on_undefined_evars:false (project gl) + elimty) r) in + match EConstr.kind (project gl) elim with + | Constr.Var kn -> rename_elimty (GlobRef.VarRef kn) + | Constr.Const (kn,_) -> rename_elimty (GlobRef.ConstRef kn) + | _ -> elimty + in let pred_id, n_elim_args, is_rec, elim_is_dep, n_pred_args,ctx_concl = analyze_eliminator elimty env (project gl) in - ind := Some (0, subgoals_tys (project gl) ctx_concl); + let seed = subgoals_tys (project gl) ctx_concl in let elim, elimty, elim_args, gl = pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in let pred = List.assoc pred_id elim_args in @@ -164,7 +185,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac | Some p -> interp_cpattern orig_gl p None | _ -> mkTpat gl c in Some(c, c_ty, pc), gl in - cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl | None -> let c = Option.get oc in let gl, c_ty = pfe_type_of gl c in let ((kn, i),_ as indu), unfolded_c_ty = @@ -183,11 +204,26 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let gl, elimty = pfe_type_of gl elim in let pred_id,n_elim_args,is_rec,elim_is_dep,n_pred_args,ctx_concl = analyze_eliminator elimty env (project gl) in - if is_case then - let mind,indb = Inductive.lookup_mind_specif env (kn,i) in - ind := Some(mind.Declarations.mind_nparams,Array.map EConstr.of_constr indb.Declarations.mind_nf_lc); - else - ind := Some (0, subgoals_tys (project gl) ctx_concl); + let seed = + if is_case then + let mind,indb = Inductive.lookup_mind_specif env (kn,i) in + let tys = indb.Declarations.mind_nf_lc in + let renamed_tys = + Array.mapi (fun j t -> + ppdebug(lazy Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); + let t = Arguments_renaming.rename_type t + (GlobRef.ConstructRef((kn,i),j+1)) in + ppdebug(lazy Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); + t) + tys + in + let drop_params x = + snd @@ EConstr.decompose_prod_n_assum (project gl) + mind.Declarations.mind_nparams (EConstr.of_constr x) in + Array.map drop_params renamed_tys + else + subgoals_tys (project gl) ctx_concl + in let rctx = fst (EConstr.decompose_prod_assum (project gl) unfolded_c_ty) in let n_c_args = Context.Rel.length rctx in let c, c_ty, t_args, gl = pf_saturate gl c ~ty:c_ty n_c_args in @@ -199,7 +235,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac | _ -> mkTpat gl c in let cty = Some (c, c_ty, pc) in let elimty = Reductionops.whd_all env (project gl) elimty in - cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl in ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat (EConstr.Unsafe.to_constr elim))); ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat (EConstr.Unsafe.to_constr elimty))); @@ -377,16 +413,29 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac in (* the elim tactic, with the eliminator and the predicated we computed *) let elim = project gl, elim in - let elim_tac gl = - Tacticals.tclTHENLIST [refine_with ~with_evars:false elim; old_cleartac clr] gl in - Tacticals.tclTHENLIST [gen_eq_tac; elim_intro_tac what eqid elim_tac is_rec clr] orig_gl + let seed = + Array.map (fun ty -> + let ctx,_ = EConstr.decompose_prod_assum (project gl) ty in + CList.rev_map Context.Rel.Declaration.get_name ctx) seed in + (elim,seed,clr,is_rec,gen_eq_tac), orig_gl -let no_intro ?ist what eqid elim_tac is_rec clr = elim_tac + end >>= fun (elim, seed,clr,is_rec,gen_eq_tac) -> + + let elim_tac = + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (refine_with ~with_evars:false elim); + cleartac clr] in + let gen_eq_tac = Proofview.V82.tactic gen_eq_tac in + Tacticals.New.tclTHENLIST [gen_eq_tac; elim_intro_tac ?seed:(Some seed) what eqid elim_tac is_rec clr] +;; let elimtac x = - Proofview.V82.tactic ~nf_evars:false - (ssrelim ~is_case:false [] (`EConstr ([],None,x)) None no_intro) -let casetac x = ssrelim ~is_case:true [] (`EConstr ([],None,x)) None no_intro + let k ?seed:_ _what _eqid elim_tac _is_rec _clr = elim_tac in + ssrelim ~is_case:false [] (`EConstr ([],None,x)) None k + +let casetac x k = + let k ?seed _what _eqid elim_tac _is_rec _clr = k ?seed elim_tac in + ssrelim ~is_case:true [] (`EConstr ([],None,x)) None k let pf_nb_prod gl = nb_prod (project gl) (pf_concl gl) @@ -444,7 +493,4 @@ let perform_injection c gl = let ssrscase_or_inj_tac c = Proofview.V82.tactic ~nf_evars:false (fun gl -> if is_injection_case c gl then perform_injection c gl - else casetac c gl) - -let ssrscasetac c = - Proofview.V82.tactic ~nf_evars:false (fun gl -> casetac c gl) + else Proofview.V82.of_tactic (casetac c (fun ?seed:_ k -> k)) gl) diff --git a/plugins/ssr/ssrelim.mli b/plugins/ssr/ssrelim.mli index c7ffba917e..a1e2f63b8f 100644 --- a/plugins/ssr/ssrelim.mli +++ b/plugins/ssr/ssrelim.mli @@ -13,7 +13,6 @@ open Ssrmatching_plugin val ssrelim : - ?ind:(int * EConstr.types array) option ref -> ?is_case:bool -> ((Ssrast.ssrhyps option * Ssrast.ssrocc) * Ssrmatching.cpattern) @@ -29,27 +28,24 @@ val ssrelim : as 'a) -> ?elim:EConstr.constr -> Ssrast.ssripat option -> - ( 'a -> + (?seed:Names.Name.t list array -> 'a -> Ssrast.ssripat option -> - (Goal.goal Evd.sigma -> Goal.goal list Evd.sigma) -> - bool -> Ssrast.ssrhyp list -> Tacmach.tactic) -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic -> + bool -> Ssrast.ssrhyp list -> unit Proofview.tactic) -> + unit Proofview.tactic val elimtac : EConstr.constr -> unit Proofview.tactic val casetac : EConstr.constr -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + (?seed:Names.Name.t list array -> unit Proofview.tactic -> unit Proofview.tactic) -> + unit Proofview.tactic val is_injection_case : EConstr.t -> Goal.goal Evd.sigma -> bool val perform_injection : EConstr.constr -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma -val ssrscasetac : - EConstr.constr -> - unit Proofview.tactic - val ssrscase_or_inj_tac : EConstr.constr -> unit Proofview.tactic diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 490e8fbdbc..64e023c68a 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -181,13 +181,18 @@ let norwocc = noclr, None let simplintac occ rdx sim gl = let simptac m gl = - if m <> ~-1 then - CErrors.user_err (Pp.str "Localized custom simpl tactic not supported"); - let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in - let simp env c _ _ = EConstr.Unsafe.to_constr (red_safe Tacred.simpl env sigma0 (EConstr.of_constr c)) in - Proofview.V82.of_tactic - (convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.Unsafe.to_constr concl0) rdx occ simp))) - gl in + if m <> ~-1 then begin + if rdx <> None then + CErrors.user_err (Pp.str "Custom simpl tactic does not support patterns"); + if occ <> None then + CErrors.user_err (Pp.str "Custom simpl tactic does not support occurrence numbers"); + simpltac (Simpl m) gl + end else + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let simp env c _ _ = EConstr.Unsafe.to_constr (red_safe Tacred.simpl env sigma0 (EConstr.of_constr c)) in + Proofview.V82.of_tactic + (convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.Unsafe.to_constr concl0) rdx occ simp))) + gl in match sim with | Simpl m -> simptac m gl | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) gl @@ -644,6 +649,6 @@ let unlocktac ist args gl = let key, gl = pf_mkSsrConst "master_key" gl in let ktacs = [ (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); - Ssrelim.casetac key ] in + Proofview.V82.of_tactic (Ssrelim.casetac key (fun ?seed:_ k -> k)) ] in tclTHENLIST (List.map utac args @ ktacs) gl diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 8cebe62e16..37c583ab53 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -104,7 +104,7 @@ let havetac ist let itac_c = introstac (IPatClear clr :: pats) in let itac, id, clr = introstac pats, Tacticals.tclIDTAC, old_cleartac clr in let binderstac n = - let rec aux = function 0 -> [] | n -> IPatAnon One :: aux (n-1) in + let rec aux = function 0 -> [] | n -> IPatAnon (One None) :: aux (n-1) in Tacticals.tclTHEN (if binders <> [] then introstac (aux n) else Tacticals.tclIDTAC) (introstac binders) in let simpltac = introstac simpl in @@ -206,7 +206,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let mkabs gen = abs_wgen false (fun x -> x) gen in let mkclr gen clrs = clr_of_wgen gen clrs in let mkpats = function - | _, Some ((x, _), _) -> fun pats -> IPatId (hoi_id x) :: pats + | _, Some ((x, _), _) -> fun pats -> IPatId (None,hoi_id x) :: pats | _ -> fun x -> x in let ct = match Ssrcommon.ssrterm_of_ast_closure_term ct with | (a, (b, Some ct)) -> @@ -265,7 +265,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = if gens = [] then errorstrm(str"gen have requires some generalizations"); let clear0 = old_cleartac clr0 in let id, name_general_hyp, cleanup, pats = match id, pats with - | None, (IPatId id as ip)::pats -> Some id, tacipat [ip], clear0, pats + | None, (IPatId(_, id) as ip)::pats -> Some id, tacipat [ip], clear0, pats | None, _ -> None, Tacticals.tclIDTAC, clear0, pats | Some (Some id),_ -> Some id, introid id, clear0, pats | Some _,_ -> diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 18b4aeab1e..e71e1bae0d 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -27,15 +27,31 @@ module IpatMachine : sig val main : ?eqtac:unit tactic -> first_case_is_dispatch:bool -> ssripats -> unit tactic + + val tclSEED_SUBGOALS : Names.Name.t list array -> unit tactic -> unit tactic + end = struct (* {{{ *) module State : sig + type delayed_gen = { + tmp_id : Id.t; (* Temporary name *) + orig_name : Name.t (* Old name *) + } + (* to_clear API *) val isCLR_PUSH : Id.t -> unit tactic val isCLR_PUSHL : Id.t list -> unit tactic val isCLR_CONSUME : unit tactic + (* to_generalize API *) + val isGEN_PUSH : delayed_gen -> unit tactic + val isGEN_CONSUME : unit tactic + + (* name_seed API *) + val isNSEED_SET : Names.Name.t list -> unit tactic + val isNSEED_CONSUME : (Names.Name.t list option -> unit tactic) -> unit tactic + (* Some data may expire *) val isTICK : ssripat -> unit tactic @@ -48,10 +64,23 @@ type istate = { (* Delayed clear *) to_clear : Id.t list; + (* Temporary intros, to be generalized back *) + to_generalize : delayed_gen list; + + (* The type of the inductive constructor corresponding to the current proof + * branch: name seeds are taken from that in an intro block *) + name_seed : Names.Name.t list option; + +} +and delayed_gen = { + tmp_id : Id.t; (* Temporary name *) + orig_name : Name.t (* Old name *) } let empty_state = { to_clear = []; + to_generalize = []; + name_seed = None; } include Ssrcommon.MakeState(struct @@ -59,28 +88,69 @@ include Ssrcommon.MakeState(struct let init = empty_state end) +let print_name_seed env sigma = function + | None -> Pp.str "-" + | Some nl -> Pp.prlist Names.Name.print nl + +let print_delayed_gen { tmp_id; orig_name } = + Pp.(Id.print tmp_id ++ str"->" ++ Name.print orig_name) + let isPRINT g = + let env, sigma = Goal.env g, Goal.sigma g in let state = get g in Pp.(str"{{ to_clear: " ++ prlist_with_sep spc Id.print state.to_clear ++ spc () ++ - str" }}") + str"to_generalize: " ++ + prlist_with_sep spc print_delayed_gen state.to_generalize ++ spc () ++ + str"name_seed: " ++ print_name_seed env sigma state.name_seed ++ str" }}") let isCLR_PUSH id = - tclGET (fun { to_clear = ids } -> - tclSET { to_clear = id :: ids }) + tclGET (fun ({ to_clear = ids } as s) -> + tclSET { s with to_clear = id :: ids }) let isCLR_PUSHL more_ids = - tclGET (fun { to_clear = ids } -> - tclSET { to_clear = more_ids @ ids }) + tclGET (fun ({ to_clear = ids } as s) -> + tclSET { s with to_clear = more_ids @ ids }) let isCLR_CONSUME = - tclGET (fun { to_clear = ids } -> - tclSET { to_clear = [] } <*> + tclGET (fun ({ to_clear = ids } as s) -> + tclSET { s with to_clear = [] } <*> Tactics.clear ids) -let isTICK _ = tclUNIT () +let isGEN_PUSH dg = + tclGET (fun s -> + tclSET { s with to_generalize = dg :: s.to_generalize }) + +(* generalize `id` as `new_name` *) +let gen_astac id new_name = + let gen = ((None,Some(false,[])),Ssrmatching.cpattern_of_id id) in + V82.tactic (Ssrcommon.gentac gen) + <*> Ssrcommon.tclRENAME_HD_PROD new_name + +(* performs and resets all delayed generalizations *) +let isGEN_CONSUME = + tclGET (fun ({ to_generalize = dgs } as s) -> + tclSET { s with to_generalize = [] } <*> + Tacticals.New.tclTHENLIST + (List.map (fun { tmp_id; orig_name } -> + gen_astac tmp_id orig_name) dgs) <*> + Tactics.clear (List.map (fun gen -> gen.tmp_id) dgs)) + + +let isNSEED_SET ty = + tclGET (fun s -> + tclSET { s with name_seed = Some ty }) + +let isNSEED_CONSUME k = + tclGET (fun ({ name_seed = x } as s) -> + tclSET { s with name_seed = None } <*> + k x) + +let isTICK = function + | IPatSimpl _ | IPatClear _ -> tclUNIT () + | _ -> tclGET (fun s -> tclSET { s with name_seed = None }) end (* }}} *************************************************************** *) @@ -105,18 +175,49 @@ let intro_anon_all = Goal.enter begin fun gl -> let sigma = Goal.sigma gl in let g = Goal.concl gl in let n = nb_assums env sigma g in - Tacticals.New.tclDO n Ssrcommon.tclINTRO_ANON + Tacticals.New.tclDO n (Ssrcommon.tclINTRO_ANON ()) +end + +(*** [=> >*] **************************************************************) +(** [nb_deps_assums] returns the number of dependent premises *) +let rec nb_deps_assums cur env sigma t = + let t' = Reductionops.whd_allnolet env sigma t in + match EConstr.kind sigma t' with + | Constr.Prod(name,ty,body) -> + if EConstr.Vars.noccurn sigma 1 body && + not (Typeclasses.is_class_type sigma ty) then cur + else nb_deps_assums (cur+1) env sigma body + | Constr.LetIn(name,ty,t1,t2) -> + nb_deps_assums (cur+1) env sigma t2 + | Constr.Cast(t,_,_) -> + nb_deps_assums cur env sigma t + | _ -> cur +let nb_deps_assums = nb_deps_assums 0 + +let intro_anon_deps = Goal.enter begin fun gl -> + let env = Goal.env gl in + let sigma = Goal.sigma gl in + let g = Goal.concl gl in + let n = nb_deps_assums env sigma g in + Tacticals.New.tclDO n (Ssrcommon.tclINTRO_ANON ()) end (** [intro_drop] behaves like [intro_anon] but registers the id of the introduced assumption for a delayed clear. *) let intro_drop = - Ssrcommon.tclINTRO ~id:None + Ssrcommon.tclINTRO ~id:Ssrcommon.Anon ~conclusion:(fun ~orig_name:_ ~new_name -> isCLR_PUSH new_name) +(** [intro_temp] behaves like [intro_anon] but registers the id of the + introduced assumption for a regeneralization. *) +let intro_anon_temp = + Ssrcommon.tclINTRO ~id:Ssrcommon.Anon + ~conclusion:(fun ~orig_name ~new_name -> + isGEN_PUSH { tmp_id = new_name; orig_name }) + (** [intro_end] performs the actions that have been delayed. *) let intro_end = - Ssrcommon.tcl0G (isCLR_CONSUME) + Ssrcommon.tcl0G ~default:() (isCLR_CONSUME <*> isGEN_CONSUME) (** [=> _] *****************************************************************) let intro_clear ids = @@ -138,6 +239,27 @@ let tacCHECK_HYPS_EXIST hyps = Goal.enter begin fun gl -> end (** [=> []] *****************************************************************) + +(* calls t1 then t2 on each subgoal passing to t2 the index of the current + * subgoal (starting from 0) as well as the number of subgoals *) +let tclTHENin t1 t2 = + tclUNIT () >>= begin fun () -> let i = ref (-1) in + t1 <*> numgoals >>= fun n -> + Goal.enter begin fun g -> incr i; t2 !i n end +end + +(* Attaches one element of `seeds` to each of the last k goals generated by +`tac`, where k is the size of `seeds` *) +let tclSEED_SUBGOALS seeds tac = + tclTHENin tac (fun i n -> + Ssrprinters.ppdebug (lazy Pp.(str"seeding")); + (* eg [case: (H _ : nat)] generates 3 goals: + - 1 for _ + - 2 for the nat constructors *) + let extra_goals = n - Array.length seeds in + if i < extra_goals then tclUNIT () + else isNSEED_SET seeds.(i - extra_goals)) + let tac_case t = Goal.enter begin fun _ -> Ssrcommon.tacTYPEOF t >>= fun ty -> @@ -145,10 +267,36 @@ let tac_case t = if is_inj then V82.tactic ~nf_evars:false (Ssrelim.perform_injection t) else - Ssrelim.ssrscasetac t + Goal.enter begin fun g -> + (Ssrelim.casetac t (fun ?seed k -> + match seed with + | None -> k + | Some seed -> tclSEED_SUBGOALS seed k)) + end end -(***[=> [: id]] ************************************************************) +(** [=> [^ seed ]] *********************************************************) +let tac_intro_seed interp_ipats fix = Goal.enter begin fun gl -> + isNSEED_CONSUME begin fun seeds -> + let seeds = + Ssrcommon.option_assert_get seeds Pp.(str"tac_intro_seed: no seed") in + let ipats = List.map (function + | Anonymous -> + let s = match fix with + | Prefix id -> Id.to_string id ^ "?" + | SuffixNum n -> "?" ^ string_of_int n + | SuffixId id -> "?" ^ Id.to_string id in + IPatAnon (One (Some s)) + | Name id -> + let s = match fix with + | Prefix fix -> Id.to_string fix ^ Id.to_string id + | SuffixNum n -> Id.to_string id ^ string_of_int n + | SuffixId fix -> Id.to_string id ^ Id.to_string fix in + IPatId (None, Id.of_string s)) seeds in + interp_ipats ipats +end end + +(*** [=> [: id]] ************************************************************) [@@@ocaml.warning "-3"] let mk_abstract_id = let open Coqlib in @@ -205,95 +353,112 @@ let tclLOG p t = end <*> t p - <*> + >>= fun ret -> Goal.enter begin fun g -> Ssrprinters.ppdebug (lazy Pp.(str "done: " ++ isPRINT g)); tclUNIT () end + >>= fun () -> tclUNIT ret -let rec ipat_tac1 ipat : unit tactic = +let notTAC = tclUNIT false + +(* returns true if it was a tactic (eg /ltac:tactic) *) +let rec ipat_tac1 ipat : bool tactic = match ipat with | IPatView (clear_if_id,l) -> - Ssrview.tclIPAT_VIEWS ~views:l ~clear_if_id + Ssrview.tclIPAT_VIEWS + ~views:l ~clear_if_id ~conclusion:(fun ~to_clear:clr -> intro_clear clr) - | IPatDispatch(true,[[]]) -> - tclUNIT () - | IPatDispatch(_,ipatss) -> - tclDISPATCH (List.map ipat_tac ipatss) + | IPatDispatch(true, Regular [[]]) -> + notTAC + | IPatDispatch(_, Regular ipatss) -> + tclDISPATCH (List.map ipat_tac ipatss) <*> notTAC + | IPatDispatch(_,Block id_block) -> + tac_intro_seed ipat_tac id_block <*> notTAC + + | IPatId (None, id) -> Ssrcommon.tclINTRO_ID id <*> notTAC + | IPatId (Some Dependent, id) -> + intro_anon_deps <*> Ssrcommon.tclINTRO_ID id <*> notTAC - | IPatId id -> Ssrcommon.tclINTRO_ID id + | IPatCase (Block id_block) -> + Ssrcommon.tclWITHTOP tac_case <*> tac_intro_seed ipat_tac id_block <*> notTAC - | IPatCase ipatss -> - tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss + | IPatCase (Regular ipatss) -> + tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss <*> notTAC | IPatInj ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) ipatss + <*> notTAC - | IPatAnon Drop -> intro_drop - | IPatAnon One -> Ssrcommon.tclINTRO_ANON - | IPatAnon All -> intro_anon_all + | IPatAnon Drop -> intro_drop <*> notTAC + | IPatAnon (One seed) -> Ssrcommon.tclINTRO_ANON ?seed () <*> notTAC + | IPatAnon All -> intro_anon_all <*> notTAC + | IPatAnon Temporary -> intro_anon_temp <*> notTAC - | IPatNoop -> tclUNIT () - | IPatSimpl Nop -> tclUNIT () + | IPatNoop -> notTAC + | IPatSimpl Nop -> notTAC | IPatClear ids -> tacCHECK_HYPS_EXIST ids <*> - intro_clear (List.map Ssrcommon.hyp_id ids) + intro_clear (List.map Ssrcommon.hyp_id ids) <*> + notTAC - | IPatSimpl (Simpl n) -> - V82.tactic ~nf_evars:false (Ssrequality.simpltac (Simpl n)) - | IPatSimpl (Cut n) -> - V82.tactic ~nf_evars:false (Ssrequality.simpltac (Cut n)) - | IPatSimpl (SimplCut (n,m)) -> - V82.tactic ~nf_evars:false (Ssrequality.simpltac (SimplCut (n,m))) + | IPatSimpl x -> + V82.tactic ~nf_evars:false (Ssrequality.simpltac x) <*> notTAC | IPatRewrite (occ,dir) -> Ssrcommon.tclWITHTOP - (fun x -> V82.tactic ~nf_evars:false (Ssrequality.ipat_rewrite occ dir x)) + (fun x -> V82.tactic ~nf_evars:false (Ssrequality.ipat_rewrite occ dir x)) <*> notTAC - | IPatAbstractVars ids -> tclMK_ABSTRACT_VARS ids + | IPatAbstractVars ids -> tclMK_ABSTRACT_VARS ids <*> notTAC - | IPatTac t -> t + | IPatEqGen t -> t <*> notTAC and ipat_tac pl : unit tactic = match pl with | [] -> tclUNIT () | pat :: pl -> - Ssrcommon.tcl0G (tclLOG pat ipat_tac1) <*> - isTICK pat <*> - ipat_tac pl + Ssrcommon.tcl0G ~default:false (tclLOG pat ipat_tac1) >>= fun was_tac -> + isTICK pat (* drops expired seeds *) >>= fun () -> + if was_tac then (* exception *) + let ip_before, case, ip_after = split_at_first_case pl in + let case = ssr_exception true case in + let case = option_to_list case in + ipat_tac (ip_before @ case @ ip_after) + else ipat_tac pl and tclIORPAT tac = function | [[]] -> tac | p -> Tacticals.New.tclTHENS tac (List.map ipat_tac p) -let split_at_first_case ipats = +and ssr_exception is_on = function + | Some (IPatCase l) when is_on -> Some (IPatDispatch(true, l)) + | x -> x + +and option_to_list = function None -> [] | Some x -> [x] + +and split_at_first_case ipats = let rec loop acc = function | (IPatSimpl _ | IPatClear _) as x :: rest -> loop (x :: acc) rest - | IPatCase _ as x :: xs -> CList.rev acc, Some x, xs + | (IPatCase _ | IPatDispatch _) as x :: xs -> CList.rev acc, Some x, xs | pats -> CList.rev acc, None, pats in loop [] ipats - -let ssr_exception is_on = function - | Some (IPatCase l) when is_on -> Some (IPatDispatch(true, l)) - | x -> x - -let option_to_list = function None -> [] | Some x -> [x] +;; (* Simple pass doing {x}/v -> /v{x} *) let elaborate_ipats l = let rec elab = function | [] -> [] | (IPatClear _ as p1) :: (IPatView _ as p2) :: rest -> p2 :: p1 :: elab rest - | IPatDispatch(s,p) :: rest -> IPatDispatch (s,List.map elab p) :: elab rest - | IPatCase p :: rest -> IPatCase (List.map elab p) :: elab rest + | IPatDispatch(s, Regular p) :: rest -> IPatDispatch (s, Regular (List.map elab p)) :: elab rest + | IPatCase (Regular p) :: rest -> IPatCase (Regular (List.map elab p)) :: elab rest | IPatInj p :: rest -> IPatInj (List.map elab p) :: elab rest - | (IPatTac _ | IPatId _ | IPatSimpl _ | IPatClear _ | + | (IPatEqGen _ | IPatId _ | IPatSimpl _ | IPatClear _ | IPatAnon _ | IPatView _ | IPatNoop | IPatRewrite _ | - IPatAbstractVars _) as x :: rest -> x :: elab rest + IPatAbstractVars _ | IPatDispatch(_, Block _) | IPatCase(Block _)) as x :: rest -> x :: elab rest in elab l @@ -302,8 +467,8 @@ let main ?eqtac ~first_case_is_dispatch ipats = let ip_before, case, ip_after = split_at_first_case ipats in let case = ssr_exception first_case_is_dispatch case in let case = option_to_list case in - let eqtac = option_to_list (Option.map (fun x -> IPatTac x) eqtac) in - Ssrcommon.tcl0G (ipat_tac (ip_before @ case @ eqtac @ ip_after) <*> intro_end) + let eqtac = option_to_list (Option.map (fun x -> IPatEqGen x) eqtac) in + Ssrcommon.tcl0G ~default:() (ipat_tac (ip_before @ case @ eqtac @ ip_after) <*> intro_end) end (* }}} *) @@ -344,10 +509,11 @@ let mkCoqRefl t c env sigma = (** Intro patterns processing for elim tactic, in particular when used in conjunction with equation generation as in [elim E: x] *) -let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = +let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = let intro_eq = match eqid with - | Some (IPatId ipat) when not is_rec -> + | Some (IPatId (Some _, _)) -> assert false (* parser *) + | Some (IPatId (None,ipat)) when not is_rec -> let rec intro_eq () = Goal.enter begin fun g -> let sigma, env, concl = Goal.(sigma g, env g, concl g) in match EConstr.kind_of_type sigma concl with @@ -356,12 +522,12 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = | Term.AtomicType (hd, _) when Ssrcommon.is_protect hd env sigma -> V82.tactic ~nf_evars:false Ssrcommon.unprotecttac <*> Ssrcommon.tclINTRO_ID ipat - | _ -> Ssrcommon.tclINTRO_ANON <*> intro_eq () + | _ -> Ssrcommon.tclINTRO_ANON () <*> intro_eq () end |_ -> Ssrcommon.errorstrm (Pp.str "Too many names in intro pattern") end in intro_eq () - | Some (IPatId ipat) -> + | Some (IPatId (None,ipat)) -> let intro_lhs = Goal.enter begin fun g -> let sigma = Goal.sigma g in let elim_name = match clr, what with @@ -369,12 +535,9 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = | _, `EConstr(_,_,t) when EConstr.isVar sigma t -> EConstr.destVar sigma t | _ -> Ssrcommon.mk_anon_id "K" (Tacmach.New.pf_ids_of_hyps g) in - let elim_name = - if Ssrcommon.is_name_in_ipats elim_name ipats then - Ssrcommon.mk_anon_id "K" (Tacmach.New.pf_ids_of_hyps g) - else elim_name - in - Ssrcommon.tclINTRO_ID elim_name + Tacticals.New.tclFIRST + [ Ssrcommon.tclINTRO_ID elim_name + ; Ssrcommon.tclINTRO_ANON ~seed:"K" ()] end in let rec gen_eq_tac () = Goal.enter begin fun g -> let sigma, env, concl = Goal.(sigma g, env g, concl g) in @@ -389,7 +552,7 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = | _ -> assert false in let case = args.(Array.length args-1) in if not(EConstr.Vars.closed0 sigma case) - then Ssrcommon.tclINTRO_ANON <*> gen_eq_tac () + then Ssrcommon.tclINTRO_ANON () <*> gen_eq_tac () else Ssrcommon.tacTYPEOF case >>= fun case_ty -> let open EConstr in @@ -407,13 +570,14 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = intro_lhs <*> Ssrcommon.tclINTRO_ID ipat | _ -> tclUNIT () in - let unprot = + let unprotect = if eqid <> None && is_rec then V82.tactic ~nf_evars:false Ssrcommon.unprotecttac else tclUNIT () in - V82.of_tactic begin - V82.tactic ~nf_evars:false ssrelim <*> - tclIPAT_EQ (intro_eq <*> unprot) ipats - end + begin match seed with + | None -> ssrelim + | Some s -> IpatMachine.tclSEED_SUBGOALS s ssrelim end <*> + tclIPAT_EQ (intro_eq <*> unprotect) ipats +;; let mkEq dir cl c t n env sigma = let open EConstr in @@ -506,13 +670,11 @@ let ssrelimtac (view, (eqid, (dgens, ipats))) = | [v] -> Ssrcommon.tclINTERP_AST_CLOSURE_TERM_AS_CONSTR v >>= fun cs -> tclDISPATCH (List.map (fun elim -> - V82.tactic ~nf_evars:false (Ssrelim.ssrelim deps (`EGen gen) ~elim eqid (elim_intro_tac ipats))) cs) | [] -> tclINDEPENDENT - (V82.tactic ~nf_evars:false - (Ssrelim.ssrelim deps (`EGen gen) eqid (elim_intro_tac ipats))) + (Ssrelim.ssrelim deps (`EGen gen) eqid (elim_intro_tac ipats)) | _ -> Ssrcommon.errorstrm Pp.(str "elim: only one elimination lemma can be provided") @@ -535,9 +697,8 @@ let ssrcasetac (view, (eqid, (dgens, ipats))) = if view <> [] && eqid <> None && deps = [] then [gen], [], None else deps, clear, occ in - V82.tactic ~nf_evars:false - (Ssrelim.ssrelim ~is_case:true deps (`EConstr (clear, occ, vc)) - eqid (elim_intro_tac ipats)) + Ssrelim.ssrelim ~is_case:true deps (`EConstr (clear, occ, vc)) + eqid (elim_intro_tac ipats) in if view = [] then conclusion false c clear c else tacVIEW_THEN_GRAB ~simple_types:false view ~conclusion info) @@ -556,18 +717,16 @@ let pushmoveeqtac cl c = Goal.enter begin fun g -> Tactics.apply_type ~typecheck:true (EConstr.mkProd (x, t, cl2)) [c; eqc] end -let eqmovetac _ gen = Goal.enter begin fun g -> - Ssrcommon.tacSIGMA >>= fun gl -> - let cl, c, _, gl = Ssrcommon.pf_interp_gen gl false gen in - Unsafe.tclEVARS (Tacmach.project gl) <*> - pushmoveeqtac cl c -end +let eqmovetac _ gen = + Ssrcommon.pfLIFT (Ssrcommon.pf_interp_gen false gen) >>= + fun (cl, c, _) -> pushmoveeqtac cl c +;; let rec eqmoveipats eqpat = function | (IPatSimpl _ | IPatClear _ as ipat) :: ipats -> ipat :: eqmoveipats eqpat ipats | (IPatAnon All :: _ | []) as ipats -> - IPatAnon One :: eqpat :: ipats + IPatAnon (One None) :: eqpat :: ipats | ipat :: ipats -> ipat :: eqpat :: ipats @@ -700,8 +859,8 @@ let ssrabstract dgens = let open Ssrmatching in let ipats = List.map (fun (_,cp) -> match id_of_pattern (interp_cpattern gl0 cp None) with - | None -> IPatAnon One - | Some id -> IPatId id) + | None -> IPatAnon (One None) + | Some id -> IPatId (None,id)) (List.tl gens) in conclusion ipats end in diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index c9221ef758..6938bbc9f6 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -605,18 +605,18 @@ let remove_loc x = x.CAst.v let ipat_of_intro_pattern p = Tactypes.( let rec ipat_of_intro_pattern = function - | IntroNaming (IntroIdentifier id) -> IPatId id + | IntroNaming (IntroIdentifier id) -> IPatId (None,id) | IntroAction IntroWildcard -> IPatAnon Drop | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> - IPatCase - (List.map (List.map ipat_of_intro_pattern) - (List.map (List.map remove_loc) iorpat)) + IPatCase (Regular( + List.map (List.map ipat_of_intro_pattern) + (List.map (List.map remove_loc) iorpat))) | IntroAction (IntroOrAndPattern (IntroAndPattern iandpat)) -> IPatCase - [List.map ipat_of_intro_pattern (List.map remove_loc iandpat)] - | IntroNaming IntroAnonymous -> IPatAnon One + (Regular [List.map ipat_of_intro_pattern (List.map remove_loc iandpat)]) + | IntroNaming IntroAnonymous -> IPatAnon (One None) | IntroAction (IntroRewrite b) -> IPatRewrite (allocc, if b then L2R else R2L) - | IntroNaming (IntroFresh id) -> IPatAnon One + | IntroNaming (IntroFresh id) -> IPatAnon (One None) | IntroAction (IntroApplyOn _) -> (* to do *) CErrors.user_err (Pp.str "TO DO") | IntroAction (IntroInjection ips) -> IPatInj [List.map ipat_of_intro_pattern (List.map remove_loc ips)] @@ -630,14 +630,20 @@ let ipat_of_intro_pattern p = Tactypes.( let rec map_ipat map_id map_ssrhyp map_ast_closure_term = function | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x - | IPatId id -> IPatId (map_id id) + | IPatId (m,id) -> IPatId (m,map_id id) | IPatAbstractVars l -> IPatAbstractVars (List.map map_id l) | IPatClear clr -> IPatClear (List.map map_ssrhyp clr) - | IPatCase iorpat -> IPatCase (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) - | IPatDispatch (s,iorpat) -> IPatDispatch (s,List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) + | IPatCase (Regular iorpat) -> IPatCase (Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) + | IPatCase (Block(hat)) -> IPatCase (Block(map_block map_id hat)) + | IPatDispatch (s, Regular iorpat) -> IPatDispatch (s, Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) + | IPatDispatch (s, Block (hat)) -> IPatDispatch (s, Block(map_block map_id hat)) | IPatInj iorpat -> IPatInj (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) | IPatView (clr,v) -> IPatView (clr,List.map map_ast_closure_term v) - | IPatTac _ -> assert false (*internal usage only *) + | IPatEqGen _ -> assert false (*internal usage only *) +and map_block map_id = function + | Prefix id -> Prefix (map_id id) + | SuffixId id -> SuffixId (map_id id) + | SuffixNum _ as x -> x type ssripatrep = ssripat let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat @@ -688,8 +694,20 @@ let rec add_intro_pattern_hyps ipat hyps = * we have no clue what a name could be bound to (maybe another ipat) *) let interp_ipat ist gl = let ltacvar id = Id.Map.mem id ist.Tacinterp.lfun in + let interp_block = function + | Prefix id when ltacvar id -> + begin match interp_introid ist gl id with + | IntroNaming (IntroIdentifier id) -> Prefix id + | _ -> Ssrcommon.errorstrm Pp.(str"Variable " ++ Id.print id ++ str" in block intro pattern should be bound to an identifier.") + end + | SuffixId id when ltacvar id -> + begin match interp_introid ist gl id with + | IntroNaming (IntroIdentifier id) -> SuffixId id + | _ -> Ssrcommon.errorstrm Pp.(str"Variable " ++ Id.print id ++ str" in block intro pattern should be bound to an identifier.") + end + | x -> x in let rec interp = function - | IPatId id when ltacvar id -> + | IPatId(_, id) when ltacvar id -> ipat_of_intro_pattern (interp_introid ist gl id) | IPatId _ as x -> x | IPatClear clr -> @@ -698,17 +716,21 @@ let interp_ipat ist gl = add_intro_pattern_hyps CAst.(make ?loc (interp_introid ist gl id)) hyps in let clr' = List.fold_right add_hyps clr [] in check_hyps_uniq [] clr'; IPatClear clr' - | IPatCase(iorpat) -> - IPatCase(List.map (List.map interp) iorpat) - | IPatDispatch(s,iorpat) -> - IPatDispatch(s,List.map (List.map interp) iorpat) + | IPatCase(Regular iorpat) -> + IPatCase(Regular(List.map (List.map interp) iorpat)) + | IPatCase(Block(hat)) -> IPatCase(Block(interp_block hat)) + + | IPatDispatch(s,Regular iorpat) -> + IPatDispatch(s,Regular (List.map (List.map interp) iorpat)) + | IPatDispatch(s,Block(hat)) -> IPatDispatch(s,Block(interp_block hat)) + | IPatInj iorpat -> IPatInj (List.map (List.map interp) iorpat) | IPatAbstractVars l -> IPatAbstractVars (List.map get_intro_id (List.map (interp_introid ist gl) l)) | IPatView (clr,l) -> IPatView (clr,List.map (fun x -> snd(interp_ast_closure_term ist gl x)) l) | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x - | IPatTac _ -> assert false (*internal usage only *) + | IPatEqGen _ -> assert false (*internal usage only *) in interp @@ -729,19 +751,11 @@ ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } GLOBALIZED BY { intern_ipats } | [ "_" ] -> { [IPatAnon Drop] } | [ "*" ] -> { [IPatAnon All] } - (* - | [ "^" "*" ] -> { [IPatFastMode] } - | [ "^" "_" ] -> { [IPatSeed `Wild] } - | [ "^_" ] -> { [IPatSeed `Wild] } - | [ "^" "?" ] -> { [IPatSeed `Anon] } - | [ "^?" ] -> { [IPatSeed `Anon] } - | [ "^" ident(id) ] -> { [IPatSeed (`Id(id,`Pre))] } - | [ "^" "~" ident(id) ] -> { [IPatSeed (`Id(id,`Post))] } - | [ "^~" ident(id) ] -> { [IPatSeed (`Id(id,`Post))] } - *) - | [ ident(id) ] -> { [IPatId id] } - | [ "?" ] -> { [IPatAnon One] } -(* TODO | [ "+" ] -> [ [IPatAnon Temporary] ] *) + | [ ">" ident(id) ] -> { [IPatId(Some Dependent,id)] } + | [ ident(id) ] -> { [IPatId (None,id)] } + | [ "?" ] -> { [IPatAnon (One None)] } + | [ "+" ] -> { [IPatAnon Temporary] } + | [ "++" ] -> { [IPatAnon Temporary; IPatAnon Temporary] } | [ ssrsimpl_ne(sim) ] -> { [IPatSimpl sim] } | [ ssrdocc(occ) "->" ] -> { match occ with | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") @@ -805,28 +819,42 @@ let reject_ssrhid strm = let test_nohidden = Pcoq.Entry.of_parser "test_ssrhid" reject_ssrhid +let rec reject_binder crossed_paren k s = + match + try Some (Util.stream_nth k s) + with Stream.Failure -> None + with + | Some (Tok.KEYWORD "(") when not crossed_paren -> reject_binder true (k+1) s + | Some (Tok.IDENT _) when crossed_paren -> reject_binder true (k+1) s + | Some (Tok.KEYWORD ":" | Tok.KEYWORD ":=") when crossed_paren -> + raise Stream.Failure + | Some (Tok.KEYWORD ")") when crossed_paren -> raise Stream.Failure + | _ -> if crossed_paren then () else raise Stream.Failure + +let _test_nobinder = Pcoq.Entry.of_parser "test_nobinder" (reject_binder false 0) + } ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY { pr_ssripat } - | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> { IPatCase(x) } + | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> { IPatCase(Regular x) } END (* Pcoq *) GRAMMAR EXTEND Gram GLOBAL: ssrcpat; + hat: [ + [ "^"; id = ident -> { Prefix id } + | "^"; "~"; id = ident -> { SuffixId id } + | "^"; "~"; n = natural -> { SuffixNum n } + | "^~"; id = ident -> { SuffixId id } + | "^~"; n = natural -> { SuffixNum n } + ]]; ssrcpat: [ - [ test_nohidden; "["; iorpat = ssriorpat; "]" -> { -(* check_no_inner_seed !@loc false iorpat; - IPatCase (understand_case_type iorpat) *) - IPatCase iorpat } -(* - | test_nohidden; "("; iorpat = ssriorpat; ")" -> -(* check_no_inner_seed !@loc false iorpat; - IPatCase (understand_case_type iorpat) *) - IPatDispatch iorpat -*) + [ test_nohidden; "["; hat_id = hat; "]" -> { + IPatCase (Block(hat_id)) } + | test_nohidden; "["; iorpat = ssriorpat; "]" -> { + IPatCase (Regular iorpat) } | test_nohidden; "[="; iorpat = ssriorpat; "]" -> { -(* check_no_inner_seed !@loc false iorpat; *) IPatInj iorpat } ]]; END @@ -1464,7 +1492,7 @@ END { let intro_id_to_binder = List.map (function - | IPatId id -> + | IPatId (None,id) -> let { CAst.loc=xloc } as x = bvar_lname (mkCVar id) in (FwdPose, [BFvar]), CAst.make @@ CLambdaN ([CLocalAssum([x], Default Explicit, mkCHole xloc)], @@ -1474,9 +1502,9 @@ let intro_id_to_binder = List.map (function let binder_to_intro_id = CAst.(List.map (function | (FwdPose, [BFvar]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } | (FwdPose, [BFdecl _]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } -> - List.map (function {v=Name id} -> IPatId id | _ -> IPatAnon One) ids - | (FwdPose, [BFdef]), { v = CLetIn ({v=Name id},_,_,_) } -> [IPatId id] - | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon One] + List.map (function {v=Name id} -> IPatId (None,id) | _ -> IPatAnon (One None)) ids + | (FwdPose, [BFdef]), { v = CLetIn ({v=Name id},_,_,_) } -> [IPatId (None,id)] + | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon (One None)] | _ -> anomaly "ssrbinder is not a binder")) let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = @@ -1966,9 +1994,10 @@ let test_ssreqid = Pcoq.Entry.of_parser "test_ssreqid" accept_ssreqid GRAMMAR EXTEND Gram GLOBAL: ssreqid; ssreqpat: [ - [ id = Prim.ident -> { IPatId id } + [ id = Prim.ident -> { IPatId (None,id) } | "_" -> { IPatAnon Drop } - | "?" -> { IPatAnon One } + | "?" -> { IPatAnon (One None) } + | "+" -> { IPatAnon Temporary } | occ = ssrdocc; "->" -> { match occ with | None, occ -> IPatRewrite (occ, L2R) | _ -> CErrors.user_err ~loc (str"Only occurrences are allowed here") } diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 8bf4816e99..6ccefa1cab 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -97,24 +97,30 @@ let pr_view2 = pr_list mt (fun c -> str "/" ++ pr_ast_closure_term c) let rec pr_ipat p = match p with - | IPatId id -> Id.print id + | IPatId (None,id) -> Id.print id + | IPatId (Some Dependent,id) -> str">" ++ Id.print id | IPatSimpl sim -> pr_simpl sim | IPatClear clr -> pr_clear mt clr - | IPatCase iorpat -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") - | IPatDispatch(_,iorpat) -> hov 1 (str "/[" ++ pr_iorpat iorpat ++ str "]") + | IPatCase (Regular iorpat) -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") + | IPatCase (Block m) -> hov 1 (str"[" ++ pr_block m ++ str"]") + | IPatDispatch(_,Regular iorpat) -> hov 1 (str "(" ++ pr_iorpat iorpat ++ str ")") + | IPatDispatch (_,Block m) -> hov 1 (str"(" ++ pr_block m ++ str")") | IPatInj iorpat -> hov 1 (str "[=" ++ pr_iorpat iorpat ++ str "]") | IPatRewrite (occ, dir) -> pr_occ occ ++ pr_dir dir | IPatAnon All -> str "*" | IPatAnon Drop -> str "_" - | IPatAnon One -> str "?" + | IPatAnon (One _) -> str "?" | IPatView (false,v) -> pr_view2 v | IPatView (true,v) -> str"{}" ++ pr_view2 v + | IPatAnon Temporary -> str "+" | IPatNoop -> str "-" | IPatAbstractVars l -> str "[:" ++ pr_list spc Id.print l ++ str "]" - | IPatTac _ -> str "<tac>" -(* TODO | IPatAnon Temporary -> str "+" *) + | IPatEqGen _ -> str "<tac>" and pr_ipats ipats = pr_list spc pr_ipat ipats and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat +and pr_block = function (Prefix id) -> str"^" ++ Id.print id + | (SuffixId id) -> str"^~" ++ Id.print id + | (SuffixNum n) -> str"^~" ++ int n (* 0 cost pp function. Active only if Debug Ssreflect is Set *) let ppdebug_ref = ref (fun _ -> ()) diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 1aa64d7141..4816027296 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -59,18 +59,23 @@ end (* Forward View application code *****************************************) +let reduce_or l = tclUNIT (List.fold_left (||) false l) + module State : sig (* View storage API *) - val vsINIT : EConstr.t * Id.t list -> unit tactic + val vsINIT : view:EConstr.t -> subject_name:Id.t list -> to_clear:Id.t list -> unit tactic val vsPUSH : (EConstr.t -> (EConstr.t * Id.t list) tactic) -> unit tactic - val vsCONSUME : (name:Id.t option -> EConstr.t -> to_clear:Id.t list -> unit tactic) -> unit tactic + val vsCONSUME : (names:Id.t list -> EConstr.t -> to_clear:Id.t list -> unit tactic) -> unit tactic + + (* The bool is the || of the bool returned by the continuations *) + val vsCONSUME_IF_PRESENT : (names:Id.t list -> EConstr.t option -> to_clear:Id.t list -> bool tactic) -> bool tactic val vsASSERT_EMPTY : unit tactic end = struct (* {{{ *) type vstate = { - subject_name : Id.t option; (* top *) + subject_name : Id.t list; (* top *) (* None if views are being applied to a term *) view : EConstr.t; (* v2 (v1 top) *) to_clear : Id.t list; @@ -81,34 +86,43 @@ include Ssrcommon.MakeState(struct let init = None end) -let vsINIT (view, to_clear) = - tclSET (Some { subject_name = None; view; to_clear }) +let vsINIT ~view ~subject_name ~to_clear = + tclSET (Some { subject_name; view; to_clear }) + +(** Initializes the state in which view data is accumulated when views are +applied to the first assumption in the goal *) +let vsBOOTSTRAP = Goal.enter_one ~__LOC__ begin fun gl -> + let concl = Goal.concl gl in + let id = (* We keep the orig name for checks in "in" tcl *) + match EConstr.kind_of_type (Goal.sigma gl) concl with + | Term.ProdType(Name.Name id, _, _) + when Ssrcommon.is_discharged_id id -> id + | _ -> mk_anon_id "view_subject" (Tacmach.New.pf_ids_of_hyps gl) in + let view = EConstr.mkVar id in + Ssrcommon.tclINTRO_ID id <*> + tclSET (Some { subject_name = [id]; view; to_clear = [] }) +end -let vsPUSH k = - tacUPDATE (fun s -> match s with +let rec vsPUSH k = + tclINDEPENDENT (tclGET (function | Some { subject_name; view; to_clear } -> k view >>= fun (view, clr) -> - tclUNIT (Some { subject_name; view; to_clear = to_clear @ clr }) - | None -> - Goal.enter_one ~__LOC__ begin fun gl -> - let concl = Goal.concl gl in - let id = (* We keep the orig name for checks in "in" tcl *) - match EConstr.kind_of_type (Goal.sigma gl) concl with - | Term.ProdType(Name.Name id, _, _) - when Ssrcommon.is_discharged_id id -> id - | _ -> mk_anon_id "view_subject" (Tacmach.New.pf_ids_of_hyps gl) in - let view = EConstr.mkVar id in - Ssrcommon.tclINTRO_ID id <*> - k view >>= fun (view, to_clear) -> - tclUNIT (Some { subject_name = Some id; view; to_clear }) - end) - -let vsCONSUME k = - tclGET (fun s -> match s with + tclSET (Some { subject_name; view; to_clear = to_clear @ clr }) + | None -> vsBOOTSTRAP <*> vsPUSH k)) + +let rec vsCONSUME k = + tclINDEPENDENT (tclGET (function | Some { subject_name; view; to_clear } -> tclSET None <*> - k ~name:subject_name view ~to_clear - | None -> anomaly "vsCONSUME: empty storage") + k ~names:subject_name view ~to_clear + | None -> vsBOOTSTRAP <*> vsCONSUME k)) + +let vsCONSUME_IF_PRESENT k = + tclINDEPENDENTL (tclGET1 (function + | Some { subject_name; view; to_clear } -> + tclSET None <*> + k ~names:subject_name (Some view) ~to_clear + | None -> k ~names:[] None ~to_clear:[])) >>= reduce_or let vsASSERT_EMPTY = tclGET (function @@ -128,13 +142,19 @@ let intern_constr_expr { Genintern.genv; ltacvars = vars } sigma ce = To allow for t being a notation, like "Notation foo x := ltac:(foo x)", we need to internalize t. *) -let is_tac_in_term { body; glob_env; interp_env } = +let is_tac_in_term ?extra_scope { body; glob_env; interp_env } = Goal.(enter_one ~__LOC__ begin fun goal -> let genv = env goal in let sigma = sigma goal in let ist = Ssrcommon.option_assert_get glob_env (Pp.str"not a term") in (* We use the env of the goal, not the global one *) let ist = { ist with Genintern.genv } in + (* We open extra_scope *) + let body = + match extra_scope with + | None -> body + | Some s -> CAst.make (Constrexpr.CDelimiters(s,body)) + in (* We unravel notations *) let g = intern_constr_expr ist sigma body in match DAst.get g with @@ -300,51 +320,83 @@ end let pose_proof subject_name p = Tactics.generalize [p] <*> - Option.cata - (fun id -> Ssrcommon.tclRENAME_HD_PROD (Name.Name id)) (tclUNIT()) - subject_name + begin match subject_name with + | id :: _ -> Ssrcommon.tclRENAME_HD_PROD (Name.Name id) + | _ -> tclUNIT() end <*> Tactics.New.reduce_after_refine -let rec apply_all_views ~clear_if_id ending vs s0 = +(* returns true if the last item was a tactic *) +let rec apply_all_views_aux ~clear_if_id vs finalization conclusion s0 = match vs with - | [] -> ending s0 + | [] -> finalization s0 (fun name p -> + (match p with + | None -> conclusion ~to_clear:[] + | Some p -> + pose_proof name p <*> conclusion ~to_clear:name) <*> + tclUNIT false) | v :: vs -> Ssrprinters.ppdebug (lazy Pp.(str"piling...")); - is_tac_in_term v >>= function - | `Tac tac -> - Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); - ending s0 <*> Tacinterp.eval_tactic tac <*> - Ssrcommon.tacSIGMA >>= apply_all_views ~clear_if_id ending vs + is_tac_in_term ~extra_scope:"ssripat" v >>= function | `Term v -> Ssrprinters.ppdebug (lazy Pp.(str"..a term")); pile_up_view ~clear_if_id v <*> - apply_all_views ~clear_if_id ending vs s0 + apply_all_views_aux ~clear_if_id vs finalization conclusion s0 + | `Tac tac -> + Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); + finalization s0 (fun name p -> + (match p with + | None -> tclUNIT () + | Some p -> pose_proof name p) <*> + Tacinterp.eval_tactic tac <*> + if vs = [] then begin + Ssrprinters.ppdebug (lazy Pp.(str"..was the last view")); + conclusion ~to_clear:name <*> tclUNIT true + end else + Tactics.clear name <*> + tclINDEPENDENTL begin + Ssrprinters.ppdebug (lazy Pp.(str"..was NOT the last view")); + Ssrcommon.tacSIGMA >>= + apply_all_views_aux ~clear_if_id vs finalization conclusion + end >>= reduce_or) + +let apply_all_views vs ~conclusion ~clear_if_id = + let finalization s0 k = + State.vsCONSUME_IF_PRESENT (fun ~names t ~to_clear -> + match t with + | None -> k [] None + | Some t -> + finalize_view s0 t >>= fun p -> k (names @ to_clear) (Some p)) in + Ssrcommon.tacSIGMA >>= + apply_all_views_aux ~clear_if_id vs finalization conclusion + +(* We apply a view to a term given by the user, e.g. `case/V: x`. `x` is + `subject` *) +let apply_all_views_to subject ~simple_types vs ~conclusion = begin + let rec process_all_vs = function + | [] -> tclUNIT () + | v :: vs -> is_tac_in_term v >>= function + | `Tac _ -> Ssrcommon.errorstrm Pp.(str"tactic view not supported") + | `Term v -> pile_up_view ~clear_if_id:false v <*> process_all_vs vs in + State.vsASSERT_EMPTY <*> + State.vsINIT ~subject_name:[] ~to_clear:[] ~view:subject <*> + Ssrcommon.tacSIGMA >>= fun s0 -> + process_all_vs vs <*> + State.vsCONSUME (fun ~names:_ t ~to_clear:_ -> + finalize_view s0 ~simple_types t >>= conclusion) +end (* Entry points *********************************************************) -let tclIPAT_VIEWS ~views:vs ?(clear_if_id=false) ~conclusion:tac = - let end_view_application s0 = - State.vsCONSUME (fun ~name t ~to_clear -> - let to_clear = Option.cata (fun x -> [x]) [] name @ to_clear in - finalize_view s0 t >>= pose_proof name <*> tac ~to_clear) in - tclINDEPENDENT begin +let tclIPAT_VIEWS ~views:vs ?(clear_if_id=false) ~conclusion = + tclINDEPENDENTL begin State.vsASSERT_EMPTY <*> - Ssrcommon.tacSIGMA >>= - apply_all_views ~clear_if_id end_view_application vs <*> - State.vsASSERT_EMPTY - end - -let tclWITH_FWD_VIEWS ~simple_types ~subject ~views:vs ~conclusion:tac = - let ending_tac s0 = - State.vsCONSUME (fun ~name:_ t ~to_clear:_ -> - finalize_view s0 ~simple_types t >>= tac) in - tclINDEPENDENT begin + apply_all_views vs ~conclusion ~clear_if_id >>= fun was_tac -> State.vsASSERT_EMPTY <*> - State.vsINIT (subject,[]) <*> - Ssrcommon.tacSIGMA >>= - apply_all_views ~clear_if_id:false ending_tac vs <*> - State.vsASSERT_EMPTY - end + tclUNIT was_tac + end >>= reduce_or + +let tclWITH_FWD_VIEWS ~simple_types ~subject ~views:vs ~conclusion = + tclINDEPENDENT (apply_all_views_to subject ~simple_types vs ~conclusion) (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrview.mli b/plugins/ssr/ssrview.mli index b128a95da7..fb9203263a 100644 --- a/plugins/ssr/ssrview.mli +++ b/plugins/ssr/ssrview.mli @@ -22,11 +22,12 @@ end (* Apply views to the top of the stack (intro pattern). If clear_if_id is * true (default false) then views that happen to be a variable are considered - * as to be cleared (see the to_clear argument to the continuation) *) -val tclIPAT_VIEWS : - views:ast_closure_term list -> ?clear_if_id:bool -> + * as to be cleared (see the to_clear argument to the continuation) + * + * returns true if the last view was a tactic *) +val tclIPAT_VIEWS : views:ast_closure_term list -> ?clear_if_id:bool -> conclusion:(to_clear:Names.Id.t list -> unit Proofview.tactic) -> - unit Proofview.tactic + bool Proofview.tactic (* Apply views to a given subject (as if was the top of the stack), then call conclusion on the obtained term (something like [v2 (v1 subject)]). diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 3da1ab7439..0ace11839e 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -69,19 +69,23 @@ let rename_arguments local r names = let arguments_names r = GlobRef.Map.find r !name_table -let rec rename_prod c = function - | [] -> c - | (Name _ as n) :: tl -> - (match kind_of_type c with - | ProdType (_, s, t) -> mkProd (n, s, rename_prod t tl) - | _ -> c) - | _ :: tl -> - match kind_of_type c with - | ProdType (n, s, t) -> mkProd (n, s, rename_prod t tl) - | _ -> c - let rename_type ty ref = - try rename_prod ty (arguments_names ref) + let name_override old_name override = + match override with + | Name _ as x -> x + | Anonymous -> old_name in + let rec rename_type_aux c = function + | [] -> c + | rename :: rest as renamings -> + match kind_of_type c with + | ProdType (old, s, t) -> + mkProd (name_override old rename, s, rename_type_aux t rest) + | LetInType(old, s, b, t) -> + mkLetIn (old ,s, b, rename_type_aux t renamings) + | CastType (t,_) -> rename_type_aux t renamings + | SortType _ -> c + | AtomicType _ -> c in + try rename_type_aux ty (arguments_names ref) with Not_found -> ty let rename_type_of_constant env c = diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 6d53349fa1..26202ef4ca 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -14,7 +14,6 @@ open Util open Pp open CAst open Names -open Nameops open Libnames open Pputils open Ppextend @@ -230,20 +229,6 @@ let tag_var = tag Tag.variable | { CAst.v = CHole (_,IntroAnonymous,_) } -> mt () | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t - let pr_lident {loc; v=id} = - match loc with - | None -> pr_id id - | Some loc -> let (b,_) = Loc.unloc loc in - pr_located pr_id (Some (Loc.make_loc (b,b + String.length (Id.to_string id))), id) - - let pr_lname = function - | {CAst.loc; v=Name id} -> pr_lident CAst.(make ?loc id) - | x -> pr_ast Name.print x - - let pr_or_var pr = function - | Locus.ArgArg x -> pr x - | Locus.ArgVar id -> pr_lident id - let pr_prim_token = function | Numeral (n,s) -> str (if s then n else "-"^n) | String s -> qs s diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index e7f71849a5..1cb3aa6d7a 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -21,11 +21,6 @@ val prec_less : precedence -> tolerability -> bool val pr_tight_coma : unit -> Pp.t -val pr_or_var : ('a -> Pp.t) -> 'a Locus.or_var -> Pp.t - -val pr_lident : lident -> Pp.t -val pr_lname : lname -> Pp.t - val pr_with_comments : ?loc:Loc.t -> Pp.t -> Pp.t val pr_com_at : int -> Pp.t val pr_sep_com : diff --git a/printing/pputils.ml b/printing/pputils.ml index 59e5f68f22..e6daf9544c 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -12,7 +12,6 @@ open Util open Pp open Genarg open Locus -open Genredexpr let beautify_comments = ref [] @@ -39,91 +38,25 @@ let pr_located pr (loc, x) = let pr_ast pr { CAst.loc; v } = pr_located pr (loc, v) -let pr_or_var pr = function - | ArgArg x -> pr x - | ArgVar {CAst.v=s} -> Names.Id.print s - -let pr_with_occurrences pr keyword (occs,c) = - match occs with - | AllOccurrences -> - pr c - | NoOccurrences -> - failwith "pr_with_occurrences: no occurrences" - | OnlyOccurrences nl -> - hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++ - hov 0 (prlist_with_sep spc (pr_or_var int) nl)) - | AllOccurrencesBut nl -> - hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++ - hov 0 (prlist_with_sep spc (pr_or_var int) nl)) - -exception ComplexRedFlag - -let pr_short_red_flag pr r = - if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then - raise ComplexRedFlag - else if List.is_empty r.rConst then - if r.rDelta then mt () else raise ComplexRedFlag - else (if r.rDelta then str "-" else mt ()) ++ - hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]") - -let pr_red_flag pr r = - try pr_short_red_flag pr r - with ComplexRedFlag -> - (if r.rBeta then pr_arg str "beta" else mt ()) ++ - (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else - (if r.rMatch then pr_arg str "match" else mt ()) ++ - (if r.rFix then pr_arg str "fix" else mt ()) ++ - (if r.rCofix then pr_arg str "cofix" else mt ())) ++ - (if r.rZeta then pr_arg str "zeta" else mt ()) ++ - (if List.is_empty r.rConst then - if r.rDelta then pr_arg str "delta" - else mt () - else - pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ - hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) - -let pr_union pr1 pr2 = function - | Inl a -> pr1 a - | Inr b -> pr2 b - -let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function - | Red false -> keyword "red" - | Hnf -> keyword "hnf" - | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f) - ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o - | Cbv f -> - if f.rBeta && f.rMatch && f.rFix && f.rCofix && - f.rZeta && f.rDelta && List.is_empty f.rConst then - keyword "compute" - else - hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f) - | Lazy f -> - hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f) - | Cbn f -> - hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f) - | Unfold l -> - hov 1 (keyword "unfold" ++ spc() ++ - prlist_with_sep pr_comma (pr_with_occurrences pr_ref keyword) l) - | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l) - | Pattern l -> - hov 1 (keyword "pattern" ++ - pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr keyword)) l) +let pr_lident { CAst.loc; v=id } = + let open Names.Id in + match loc with + | None -> print id + | Some loc -> let (b,_) = Loc.unloc loc in + pr_located print + (Some (Loc.make_loc (b,b + String.length (to_string id))), id) - | Red true -> - CErrors.user_err Pp.(str "Shouldn't be accessible from user.") - | ExtraRedExpr s -> - str s - | CbvVm o -> - keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o - | CbvNative o -> - keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o +let pr_lname = let open Names in function + | {CAst.loc; v=Name id} -> pr_lident CAst.(make ?loc id) + | x -> pr_ast Name.print x -let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) = - pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma) +let pr_or_var pr = function + | ArgArg x -> pr x + | ArgVar id -> pr_lident id -let pr_or_by_notation f = let open Constrexpr in function - | {CAst.loc; v=AN v} -> f v - | {CAst.loc; v=ByNotation (s,sc)} -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc +let pr_or_by_notation f = let open Constrexpr in CAst.with_val (function + | AN v -> f v + | ByNotation (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc) let hov_if_not_empty n p = if Pp.ismt p then p else hov n p diff --git a/printing/pputils.mli b/printing/pputils.mli index 5b1969e232..ea554355bc 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -8,33 +8,17 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open Genarg -open Locus -open Genredexpr val pr_located : ('a -> Pp.t) -> 'a Loc.located -> Pp.t val pr_ast : ('a -> Pp.t) -> 'a CAst.t -> Pp.t (** Prints an object surrounded by its commented location *) -val pr_or_var : ('a -> Pp.t) -> 'a or_var -> Pp.t +val pr_lident : lident -> Pp.t +val pr_lname : lname -> Pp.t +val pr_or_var : ('a -> Pp.t) -> 'a Locus.or_var -> Pp.t val pr_or_by_notation : ('a -> Pp.t) -> 'a Constrexpr.or_by_notation -> Pp.t -val pr_with_occurrences : - ('a -> Pp.t) -> (string -> Pp.t) -> 'a with_occurrences -> Pp.t - -val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t -val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t - -val pr_red_expr : - ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> - (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t - -val pr_red_expr_env : Environ.env -> Evd.evar_map -> - (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * - (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * - ('b -> Pp.t) * - (Environ.env -> Evd.evar_map -> 'c -> Pp.t) -> - (string -> Pp.t) -> - ('a,'b,'c) red_expr_gen -> Pp.t val pr_raw_generic : Environ.env -> rlevel generic_argument -> Pp.t val pr_glb_generic : Environ.env -> glevel generic_argument -> Pp.t diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index bea5580074..f8adc58921 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -53,11 +53,12 @@ let default_proof_mode = ref (find_proof_mode "No") let get_default_proof_mode_name () = (CEphemeron.default !default_proof_mode standard).name +let proof_mode_opt_name = ["Default";"Proof";"Mode"] let () = Goptions.(declare_string_option { optdepr = false; optname = "default proof mode" ; - optkey = ["Default";"Proof";"Mode"] ; + optkey = proof_mode_opt_name ; optread = begin fun () -> (CEphemeron.default !default_proof_mode standard).name end; diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 9e904c57aa..e762f3b7dc 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -168,6 +168,8 @@ val register_proof_mode : proof_mode -> unit (* Can't make this deprecated due to limitations of camlp5 *) (* [@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] *) +val proof_mode_opt_name : string list + val get_default_proof_mode_name : unit -> proof_mode_name [@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] @@ -181,4 +183,3 @@ val activate_proof_mode : proof_mode_name -> unit val disactivate_current_proof_mode : unit -> unit [@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] - diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index dbd5be23ab..0ce726db25 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -7,7 +7,6 @@ Logic Goal_select Proof_bullet Proof_global -Redexpr Refiner Tacmach Pfedit diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a5f691babb..df90354717 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -15,7 +15,6 @@ open Environ open Reductionops open Evd open Typing -open Redexpr open Tacred open Logic open Context.Named.Declaration @@ -71,11 +70,6 @@ let pf_global gls id = let sigma = project gls in Evd.fresh_global env sigma (Constrintern.construct_reference (pf_hyps gls) id) -let pf_reduction_of_red_expr gls re c = - let (redfun, _) = reduction_of_red_expr (pf_env gls) re in - let sigma = project gls in - redfun (pf_env gls) sigma c - let pf_apply f gls = f (pf_env gls) (project gls) let pf_eapply f gls x = on_sig gls (fun evm -> f (pf_env gls) evm x) diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index ef6a1544e4..213ed7bfda 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -12,7 +12,6 @@ open Names open Constr open Environ open EConstr -open Redexpr open Locus (** Operations for handling terms under a local typing context. *) @@ -44,9 +43,6 @@ val pf_get_hyp_typ : Goal.goal sigma -> Id.t -> types val pf_get_new_id : Id.t -> Goal.goal sigma -> Id.t -val pf_reduction_of_red_expr : Goal.goal sigma -> red_expr -> constr -> evar_map * constr - - val pf_apply : (env -> evar_map -> 'a) -> Goal.goal sigma -> 'a val pf_eapply : (env -> evar_map -> 'a -> evar_map * 'b) -> Goal.goal sigma -> 'a -> Goal.goal sigma * 'b diff --git a/stm/stm.ml b/stm/stm.ml index c84721bcb5..32c6c7d959 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -76,18 +76,6 @@ let async_proofs_is_master opt = opt.async_proofs_mode = APon && !Flags.async_proofs_worker_id = "master" -(* Protect against state changes *) -let stm_purify f x = - let st = Vernacstate.freeze_interp_state ~marshallable:false in - try - let res = f x in - Vernacstate.unfreeze_interp_state st; - res - with e -> - let e = CErrors.push e in - Vernacstate.unfreeze_interp_state st; - Exninfo.iraise e - let execution_error ?loc state_id msg = feedback ~id:state_id (Message (Error, loc, msg)) @@ -775,6 +763,11 @@ let state_of_id ~doc id = (****** A cache: fills in the nodes of the VCS document with their value ******) module State : sig + type t + + val freeze : unit -> t + val unfreeze : t -> unit + (** The function is from unit, so it uses the current state to define a new one. I.e. one may been to install the right state before defining a new one. @@ -815,13 +808,22 @@ module State : sig be removed in the state handling refactoring. *) val cur_id : Stateid.t ref + val purify : ('a -> 'b) -> 'a -> 'b + end = struct (* {{{ *) + type t = { id : Stateid.t; vernac_state : Vernacstate.t } + (* cur_id holds Stateid.dummy in case the last attempt to define a state * failed, so the global state may contain garbage *) let cur_id = ref Stateid.dummy let fix_exn_ref = ref (fun x -> x) + let freeze () = { id = !cur_id; vernac_state = Vernacstate.freeze_interp_state ~marshallable:false } + let unfreeze st = + Vernacstate.unfreeze_interp_state st.vernac_state; + cur_id := st.id + type proof_part = Proof_global.t * int * (* Evarutil.meta_counter_summary_tag *) @@ -839,7 +841,7 @@ end = struct (* {{{ *) Summary.project_from_summary st Util.(pi2 summary_pstate), Summary.project_from_summary st Util.(pi3 summary_pstate) - let freeze ~marshallable id = + let cache_state ~marshallable id = VCS.set_state id (Valid (Vernacstate.freeze_interp_state ~marshallable)) let freeze_invalid id iexn = VCS.set_state id (Error iexn) @@ -847,7 +849,7 @@ end = struct (* {{{ *) let is_cached ?(cache=false) id only_valid = if Stateid.equal id !cur_id then try match VCS.get_info id with - | { state = Empty } when cache -> freeze ~marshallable:false id; true + | { state = Empty } when cache -> cache_state ~marshallable:false id; true | _ -> true with VCS.Expired -> false else @@ -930,6 +932,8 @@ end = struct (* {{{ *) let e2 = Summary.project_from_summary s2 Global.global_env_summary_tag in e1 == e2 + (* [define] puts the system in state [id] calling [f ()] *) + (* [safe_id] is the last known valid state before execution *) let define ~doc ?safe_id ?(redefine=false) ?(cache=false) ?(feedback_processed=true) f id = @@ -944,7 +948,7 @@ end = struct (* {{{ *) fix_exn_ref := exn_on id ~valid:good_id; f (); fix_exn_ref := (fun x -> x); - if cache then freeze ~marshallable:false id; + if cache then cache_state ~marshallable:false id; stm_prerr_endline (fun () -> "setting cur id to "^str_id); cur_id := id; if feedback_processed then @@ -974,7 +978,21 @@ end = struct (* {{{ *) let restore_root_state () = cur_id := Stateid.dummy; - Vernacstate.unfreeze_interp_state (Option.get !init_state); + Vernacstate.unfreeze_interp_state (Option.get !init_state) + + (* Protect against state changes *) + let purify f x = + let st = freeze () in + try + let res = f x in + Vernacstate.invalidate_cache (); + unfreeze st; + res + with e -> + let e = CErrors.push e in + Vernacstate.invalidate_cache (); + unfreeze st; + Exninfo.iraise e end (* }}} *) @@ -1535,14 +1553,14 @@ end = struct (* {{{ *) * a bad fixpoint *) let fix_exn = Future.fix_exn_of future_proof in (* STATE: We use the current installed imperative state *) - let st = Vernacstate.freeze_interp_state ~marshallable:false in + let st = State.freeze () in if not drop then begin let checked_proof = Future.chain future_proof (fun p -> let opaque = Proof_global.Opaque in (* Unfortunately close_future_proof and friends are not pure so we need to set the state manually here *) - Vernacstate.unfreeze_interp_state st; + State.unfreeze st; let pobject, _ = Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) @@ -1556,7 +1574,7 @@ end = struct (* {{{ *) ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) - Vernacstate.unfreeze_interp_state st; + State.unfreeze st; RespBuiltProof(proof,time) with | e when CErrors.noncritical e || e = Stack_overflow -> @@ -1938,7 +1956,7 @@ end = struct (* {{{ *) Option.iter VCS.restore vcs; try Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:false id; - stm_purify (fun () -> + State.purify (fun () -> let Proof.{sigma=sigma0} = Proof.data (Proof_global.give_me_the_proof ()) in let g = Evd.find sigma0 r_goal in let is_ground c = Evarutil.is_ground_term sigma0 c in @@ -2371,7 +2389,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; update_global_env () in let rec pure_cherry_pick_non_pstate safe_id id = - stm_purify (fun id -> + State.purify (fun id -> stm_prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); reach ~safe_id id; cherry_pick_non_pstate ()) @@ -2765,7 +2783,7 @@ let check_task name (tasks,rcbackup) i = RemoteCounter.restore rcbackup; let vcs = VCS.backup () in try - let rc = stm_purify (Slaves.check_task name tasks) i in + let rc = State.purify (Slaves.check_task name tasks) i in VCS.restore vcs; rc with e when CErrors.noncritical e -> VCS.restore vcs; false @@ -2775,7 +2793,7 @@ let finish_tasks name u d p (t,rcbackup as tasks) = RemoteCounter.restore rcbackup; let finish_task u (_,_,i) = let vcs = VCS.backup () in - let u = stm_purify (Slaves.finish_task name u d p t) i in + let u = State.purify (Slaves.finish_task name u d p t) i in VCS.restore vcs; u in try @@ -3134,7 +3152,7 @@ type focus = { } let query ~doc ~at ~route s = - stm_purify (fun s -> + State.purify (fun s -> if Stateid.equal at Stateid.dummy then ignore(finish ~doc:dummy_doc) else Reach.known_state ~doc ~cache:true at; try diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 44d07279fc..f40b3e901b 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -56,7 +56,9 @@ let stm_allow_nested_proofs_option_name = ["Nested";"Proofs";"Allowed"] let options_affecting_stm_scheduling = [ Attributes.universe_polymorphism_option_name; - stm_allow_nested_proofs_option_name ] + stm_allow_nested_proofs_option_name; + Proof_global.proof_mode_opt_name; + ] let classify_vernac e = let static_classifier ~poly e = match e with diff --git a/interp/genredexpr.ml b/tactics/genredexpr.ml index 607f2258fd..8209684c37 100644 --- a/interp/genredexpr.ml +++ b/tactics/genredexpr.ml @@ -63,3 +63,17 @@ type r_pat = constr_pattern_expr type r_cst = qualid or_by_notation type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen + +let make0 ?dyn name = + let wit = Genarg.make0 name in + let () = Geninterp.register_val0 wit dyn in + wit + +type 'a and_short_name = 'a * Names.lident option + +let wit_red_expr : + ((constr_expr,qualid or_by_notation,constr_expr) red_expr_gen, + (Genintern.glob_constr_and_expr,Names.evaluable_global_reference and_short_name Locus.or_var,Genintern.glob_constr_pattern_and_expr) red_expr_gen, + (EConstr.t,Names.evaluable_global_reference,Pattern.constr_pattern) red_expr_gen) + Genarg.genarg_type = + make0 "redexpr" diff --git a/tactics/ppred.ml b/tactics/ppred.ml new file mode 100644 index 0000000000..dd1bcd4699 --- /dev/null +++ b/tactics/ppred.ml @@ -0,0 +1,83 @@ +open Util +open Pp +open Locus +open Genredexpr +open Pputils + +let pr_with_occurrences pr keyword (occs,c) = + match occs with + | AllOccurrences -> + pr c + | NoOccurrences -> + failwith "pr_with_occurrences: no occurrences" + | OnlyOccurrences nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + | AllOccurrencesBut nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + +exception ComplexRedFlag + +let pr_short_red_flag pr r = + if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then + raise ComplexRedFlag + else if List.is_empty r.rConst then + if r.rDelta then mt () else raise ComplexRedFlag + else (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]") + +let pr_red_flag pr r = + try pr_short_red_flag pr r + with ComplexRedFlag -> + (if r.rBeta then pr_arg str "beta" else mt ()) ++ + (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else + (if r.rMatch then pr_arg str "match" else mt ()) ++ + (if r.rFix then pr_arg str "fix" else mt ()) ++ + (if r.rCofix then pr_arg str "cofix" else mt ())) ++ + (if r.rZeta then pr_arg str "zeta" else mt ()) ++ + (if List.is_empty r.rConst then + if r.rDelta then pr_arg str "delta" + else mt () + else + pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) + +let pr_union pr1 pr2 = function + | Inl a -> pr1 a + | Inr b -> pr2 b + +let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function + | Red false -> keyword "red" + | Hnf -> keyword "hnf" + | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f) + ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | Cbv f -> + if f.rBeta && f.rMatch && f.rFix && f.rCofix && + f.rZeta && f.rDelta && List.is_empty f.rConst then + keyword "compute" + else + hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f) + | Lazy f -> + hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f) + | Cbn f -> + hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f) + | Unfold l -> + hov 1 (keyword "unfold" ++ spc() ++ + prlist_with_sep pr_comma (pr_with_occurrences pr_ref keyword) l) + | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l) + | Pattern l -> + hov 1 (keyword "pattern" ++ + pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr keyword)) l) + + | Red true -> + CErrors.user_err Pp.(str "Shouldn't be accessible from user.") + | ExtraRedExpr s -> + str s + | CbvVm o -> + keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | CbvNative o -> + keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + +let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) = + pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma) diff --git a/tactics/ppred.mli b/tactics/ppred.mli new file mode 100644 index 0000000000..b3a306a36f --- /dev/null +++ b/tactics/ppred.mli @@ -0,0 +1,19 @@ +open Genredexpr + +val pr_with_occurrences : + ('a -> Pp.t) -> (string -> Pp.t) -> 'a Locus.with_occurrences -> Pp.t + +val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t +val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t + +val pr_red_expr : + ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> + (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t + +val pr_red_expr_env : Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + ('b -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'c -> Pp.t) -> + (string -> Pp.t) -> + ('a,'b,'c) red_expr_gen -> Pp.t diff --git a/proofs/redexpr.ml b/tactics/redexpr.ml index 6658c37f41..aabfae444e 100644 --- a/proofs/redexpr.ml +++ b/tactics/redexpr.ml @@ -74,13 +74,13 @@ let set_strategy_one ref l = Csymtable.set_opaque_const sp | ConstKey sp, _ -> let cb = Global.lookup_constant sp in - (match cb.const_body with - | OpaqueDef _ -> + (match cb.const_body with + | OpaqueDef _ -> user_err ~hdr:"set_transparent_const" (str "Cannot make" ++ spc () ++ Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef sp) ++ - spc () ++ str "transparent because it was declared opaque."); - | _ -> Csymtable.set_transparent_const sp) + spc () ++ str "transparent because it was declared opaque."); + | _ -> Csymtable.set_transparent_const sp) | _ -> () let cache_strategy (_,str) = @@ -126,10 +126,10 @@ type strategy_obj = let inStrategy : strategy_obj -> obj = declare_object {(default_object "STRATEGY") with cache_function = (fun (_,obj) -> cache_strategy obj); - load_function = (fun _ (_,obj) -> cache_strategy obj); - subst_function = subst_strategy; + load_function = (fun _ (_,obj) -> cache_strategy obj); + subst_function = subst_strategy; discharge_function = discharge_strategy; - classify_function = classify_strategy } + classify_function = classify_strategy } let set_strategy local str = @@ -154,16 +154,16 @@ let make_flag env f = let red = if f.rDelta then (* All but rConst *) let red = red_add red fDELTA in - let red = red_add_transparent red + let red = red_add_transparent red (Conv_oracle.get_transp_state (Environ.oracle env)) in - List.fold_right - (fun v red -> red_sub red (make_flag_constant v)) - f.rConst red + List.fold_right + (fun v red -> red_sub red (make_flag_constant v)) + f.rConst red else (* Only rConst *) let red = red_add_transparent (red_add red fDELTA) TransparentState.empty in - List.fold_right - (fun v red -> red_add red (make_flag_constant v)) - f.rConst red + List.fold_right + (fun v red -> red_add red (make_flag_constant v)) + f.rConst red in red (* table of custom reductino fonctions, not synchronized, @@ -234,7 +234,7 @@ let reduction_of_red_expr env = let am = if !simplIsCbn then strong_cbn (make_flag f) else simpl in let () = if not (!simplIsCbn || List.is_empty f.rConst) then - warn_simpl_unfolding_modifiers () in + warn_simpl_unfolding_modifiers () in (contextualize (if head_style then whd_am else am) am o,DEFAULTcast) | Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast) | Cbn f -> @@ -246,9 +246,9 @@ let reduction_of_red_expr env = | ExtraRedExpr s -> (try (e_red (String.Map.find s !reduction_tab),DEFAULTcast) with Not_found -> - (try reduction_of_red_expr (String.Map.find s !red_expr_tab) - with Not_found -> - user_err ~hdr:"Redexpr.reduction_of_red_expr" + (try reduction_of_red_expr (String.Map.find s !red_expr_tab) + with Not_found -> + user_err ~hdr:"Redexpr.reduction_of_red_expr" (str "unknown user-defined reduction \"" ++ str s ++ str "\""))) | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) @@ -270,9 +270,9 @@ let inReduction : bool * string * red_expr -> obj = cache_function = (fun (_,(_,s,e)) -> decl_red_expr s e); load_function = (fun _ (_,(_,s,e)) -> decl_red_expr s e); subst_function = - (fun (subs,(b,s,e)) -> b,s,subst_red_expr subs e); + (fun (subs,(b,s,e)) -> b,s,subst_red_expr subs e); classify_function = - (fun ((b,_,_) as obj) -> if b then Dispose else Substitute obj) } + (fun ((b,_,_) as obj) -> if b then Dispose else Substitute obj) } let declare_red_expr locality s expr = Lib.add_anonymous_leaf (inReduction (locality,s,expr)) diff --git a/proofs/redexpr.mli b/tactics/redexpr.mli index 1e59f436c3..1f65862701 100644 --- a/proofs/redexpr.mli +++ b/tactics/redexpr.mli @@ -20,7 +20,7 @@ open Locus type red_expr = (constr, evaluable_global_reference, constr_pattern) red_expr_gen - + val out_with_occurrences : 'a with_occurrences -> occurrences * 'a val reduction_of_red_expr : diff --git a/interp/redops.ml b/tactics/redops.ml index b9a74136e4..6f83ea9a34 100644 --- a/interp/redops.ml +++ b/tactics/redops.ml @@ -21,14 +21,14 @@ let make_red_flag l = | FCofix :: lf -> add_flag { red with rCofix = true } lf | FZeta :: lf -> add_flag { red with rZeta = true } lf | FConst l :: lf -> - if red.rDelta then - CErrors.user_err Pp.(str - "Cannot set both constants to unfold and constants not to unfold"); + if red.rDelta then + CErrors.user_err Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); add_flag { red with rConst = union_consts red.rConst l } lf | FDeltaBut l :: lf -> - if red.rConst <> [] && not red.rDelta then - CErrors.user_err Pp.(str - "Cannot set both constants to unfold and constants not to unfold"); + if red.rConst <> [] && not red.rDelta then + CErrors.user_err Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); add_flag { red with rConst = union_consts red.rConst l; rDelta = true } lf diff --git a/interp/redops.mli b/tactics/redops.mli index 7254f29b25..7254f29b25 100644 --- a/interp/redops.mli +++ b/tactics/redops.mli diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 9e9d52b72c..b1f2ceee57 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -889,7 +889,7 @@ let reduce redexp cl = let trace env sigma = let open Printer in let pr = (pr_econstr_env, pr_leconstr_env, pr_evaluable_reference, pr_constr_pattern_env) in - Pp.(hov 2 (Pputils.pr_red_expr_env env sigma pr str redexp)) + Pp.(hov 2 (Ppred.pr_red_expr_env env sigma pr str redexp)) in let trace () = let sigma, env = Pfedit.get_current_context () in @@ -1063,9 +1063,16 @@ let intros_replacing ids = (* The standard for implementing Automatic Introduction *) let auto_intros_tac ids = - Tacticals.New.tclMAP (function - | Name id -> intro_mustbe_force id - | Anonymous -> intro) (List.rev ids) + let fold used = function + | Name id -> Id.Set.add id used + | Anonymous -> used + in + let avoid = NamingAvoid (List.fold_left fold Id.Set.empty ids) in + let naming = function + | Name id -> NamingMustBe CAst.(make id) + | Anonymous -> avoid + in + Tacticals.New.tclMAP (fun name -> intro_gen (naming name) MoveLast true false) (List.rev ids) (* User-level introduction tactics *) diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 5afec74fae..1861c5b99b 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -6,6 +6,10 @@ Hipattern Ind_tables Eqschemes Elimschemes +Genredexpr +Redops +Redexpr +Ppred Tactics Abstract Elim diff --git a/test-suite/Makefile b/test-suite/Makefile index 530671e1a1..34a1900bbc 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -90,19 +90,17 @@ FAIL = >&2 echo 'FAILED $@' # Testing subsystems ####################################################################### -# Apart so that it can be easily skipped with overriding +# These targets can be skipped by doing `make TARGET= test-suite` COMPLEXITY := $(if $(bogomips),complexity) - BUGS := bugs/opened bugs/closed - INTERACTIVE := interactive - +UNIT_TESTS := unit-tests VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ output-modulo-time $(INTERACTIVE) micromega $(COMPLEXITY) modules stm \ coqdoc ssr # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools unit-tests +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools $(UNIT_TESTS) PREREQUISITELOG = prerequisite/admit.v.log \ prerequisite/make_local.v.log prerequisite/make_notation.v.log \ @@ -119,6 +117,10 @@ PREREQUISITELOG = prerequisite/admit.v.log \ all: run $(MAKE) report +# do nothing +.PHONY: noop +noop: ; + run: $(SUBSYSTEMS) bugs: $(BUGS) diff --git a/test-suite/bugs/closed/bug_8819.v b/test-suite/bugs/closed/bug_8819.v new file mode 100644 index 0000000000..a4cb9dcd14 --- /dev/null +++ b/test-suite/bugs/closed/bug_8819.v @@ -0,0 +1,2 @@ +Theorem foo (_ : nat) (H : bool) : bool. +Proof. exact H. Qed. diff --git a/test-suite/dune b/test-suite/dune index c5fa0bb14a..eae072553a 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -70,4 +70,4 @@ (progn ; XXX: we will allow to set the NJOBS variable in a future Dune ; version, either by using an env var or by letting Dune set `-j` - (run make -j 2 BIN= PRINT_LOGS=1)))) + (run make -j 2 BIN= PRINT_LOGS=1 UNIT_TESTS=%{env:COQ_UNIT_TEST=unit-tests})))) diff --git a/test-suite/ssr/elim.v b/test-suite/ssr/elim.v index 908249a369..720f4f6607 100644 --- a/test-suite/ssr/elim.v +++ b/test-suite/ssr/elim.v @@ -33,7 +33,7 @@ Qed. (* The same but without names for variables involved in the generated eq *) Lemma testL3 : forall A (s : seq A), s = s. Proof. -move=> A s; elim branch: s; move: (s) => _. +move=> A s; elim branch: s. match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end. move=> _; match goal with _ : _ = _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end. Qed. diff --git a/test-suite/ssr/ipat_clear_if_id.v b/test-suite/ssr/ipat_clear_if_id.v index 7a44db2ea0..cc087a62ad 100644 --- a/test-suite/ssr/ipat_clear_if_id.v +++ b/test-suite/ssr/ipat_clear_if_id.v @@ -8,6 +8,7 @@ Variable v2 : nat -> bool. Lemma test (v3 : nat -> bool) (v4 : bool -> bool) (v5 : bool -> bool) : nat -> nat -> nat -> nat -> True. Proof. +Set Debug Ssreflect. move=> {}/v1 b1 {}/v2 b2 {}/v3 b3 {}/v2/v4/v5 b4. Check b1 : bool. Check b2 : bool. @@ -20,4 +21,12 @@ Check v2 : nat -> bool. by []. Qed. +Lemma test2 (v : True <-> False) : True -> False. +Proof. +move=> {}/v. +Fail Check v. +by []. +Qed. + + End Foo. diff --git a/test-suite/ssr/ipat_fastid.v b/test-suite/ssr/ipat_fastid.v new file mode 100644 index 0000000000..8dc0c6cf0b --- /dev/null +++ b/test-suite/ssr/ipat_fastid.v @@ -0,0 +1,31 @@ +Require Import ssreflect. + +Axiom odd : nat -> Prop. + +Lemma simple : + forall x, 3 <= x -> forall y, odd (y+x) -> x = y -> True. +Proof. +move=> >x_ge_3 >xy_odd. +lazymatch goal with +| |- ?x = ?y -> True => done +end. +Qed. + + +Definition stuff x := 3 <= x -> forall y, odd (y+x) -> x = y -> True. + +Lemma harder : forall x, stuff x. +Proof. +move=> >x_ge_3 >xy_odd. +lazymatch goal with +| |- ?x = ?y -> True => done +end. +Qed. + +Lemma homotop : forall x : nat, forall e : x = x, e = e -> True. +Proof. +move=> >eq_ee. +lazymatch goal with +| |- True => done +end. +Qed. diff --git a/test-suite/ssr/ipat_seed.v b/test-suite/ssr/ipat_seed.v new file mode 100644 index 0000000000..e418d66917 --- /dev/null +++ b/test-suite/ssr/ipat_seed.v @@ -0,0 +1,60 @@ +Require Import ssreflect. + +Section foo. + +Variable A : Type. + +Record bar (X : Type) := mk_bar { + a : X * A; + b : A; + c := (a,7); + _ : X; + _ : X +}. + +Inductive baz (X : Type) (Y : Type) : nat -> Type := +| K1 x (e : 0=1) (f := 3) of x=x:>X : baz X Y O +| K2 n of n=n & baz X nat 0 : baz X Y (n+1). + +Axiom Q : nat -> Prop. +Axiom Qx : forall x, Q x. +Axiom my_ind : + forall P : nat -> Prop, P O -> (forall n m (w : P n /\ P m), P (n+m)) -> + forall w, P w. + +Lemma test x : bar nat -> baz nat nat x -> forall n : nat, Q n. +Proof. + +(* record *) +move => [^~ _ccc ]. +Check (refl_equal _ : c_ccc = (a_ccc, 7)). + +(* inductive *) +move=> [^ xxx_ ]. +Check (refl_equal _ : xxx_f = 3). + by []. +Check (refl_equal _ : xxx_n = xxx_n). + +(* eliminator *) +elim/my_ind => [^ wow_ ]. + exact: Qx 0. +Check (wow_w : Q wow_n /\ Q wow_m). +exact: Qx (wow_n + wow_m). + +Qed. + +Arguments mk_bar A x y z w : rename. +Arguments K1 A B a b c : rename. + + +Lemma test2 x : bar nat -> baz nat nat x -> forall n : nat, Q n. +Proof. +move=> [^~ _ccc ]. +Check (refl_equal _ : c_ccc = (x_ccc, 7)). +move=> [^ xxx_ ]. +Check (refl_equal _ : xxx_f = 3). + by []. +Check (refl_equal _ : xxx_n = xxx_n). +Abort. + +End foo. diff --git a/test-suite/ssr/ipat_tac.v b/test-suite/ssr/ipat_tac.v new file mode 100644 index 0000000000..cfef2e37be --- /dev/null +++ b/test-suite/ssr/ipat_tac.v @@ -0,0 +1,38 @@ +Require Import ssreflect. + +Ltac fancy := case; last first. + +Notation fancy := (ltac:( fancy )). + +Ltac replicate n := + let what := fresh "_replicate_" in + move=> what; do n! [ have := what ]; clear what. + +Notation replicate n := (ltac:( replicate n )). + +Lemma foo x (w : nat) (J : bool -> nat -> nat) : exists y, x=0+y. +Proof. +move: (w) => /ltac:(idtac) _. +move: w => /(replicate 6) w1 w2 w3 w4 w5 w6. +move: w1 => /J/fancy [w'||];last exact: false. + move: w' => /J/fancy[w''||]; last exact: false. + by exists x. + by exists x. +by exists x. +Qed. + +Ltac unfld what := rewrite /what. + +Notation "% n" := (ltac:( unfld n )) (at level 0) : ssripat_scope. +Notation "% n" := n : nat_scope. + +Open Scope nat_scope. + + +Definition def := 4. + +Lemma test : True -> def = 4. +Proof. +move=> _ /(% def). +match goal with |- 4 = 4 => reflexivity end. +Qed. diff --git a/test-suite/ssr/ipat_tmp.v b/test-suite/ssr/ipat_tmp.v new file mode 100644 index 0000000000..5f5421ac74 --- /dev/null +++ b/test-suite/ssr/ipat_tmp.v @@ -0,0 +1,22 @@ +Require Import ssreflect ssrbool. + + Axiom eqn : nat -> nat -> bool. + Infix "==" := eqn (at level 40). + Axiom eqP : forall x y : nat, reflect (x = y) (x == y). + + Lemma test1 : + forall x y : nat, x = y -> forall z : nat, y == z -> x = z. + Proof. + by move=> x y + z /eqP <-; apply. + Qed. + + Lemma test2 : forall (x y : nat) (e : x = y), e = e -> x = y. + Proof. + move=> + y + _ => x def_x; exact: (def_x : x = y). + Qed. + + Lemma test3 : + forall x y : nat, x = y -> forall z : nat, y == z -> x = z. + Proof. + move=> ++++ /eqP <- => x y e z; exact: e. + Qed. diff --git a/test-suite/ssr/misc_extended.v b/test-suite/ssr/misc_extended.v new file mode 100644 index 0000000000..81c86f1af4 --- /dev/null +++ b/test-suite/ssr/misc_extended.v @@ -0,0 +1,83 @@ +Require Import ssreflect. + +Require Import List. + +Lemma test_elim_pattern_1 : forall A (l:list A), l ++ nil = l. +Proof. +intros A. +elim/list_ind => [^~ 1 ]. + by []. +match goal with |- (a1 :: l1) ++ nil = a1 :: l1 => idtac end. +Abort. + +Lemma test_elim_pattern_2 : forall A (l:list A), l ++ nil = l. +Proof. +intros. elim: l => [^~ 1 ]. + by []. +match goal with |- (a1 :: l1) ++ nil = a1 :: l1 => idtac end. +Abort. + +Lemma test_elim_pattern_3 : forall A (l:list A), l ++ nil = l. +Proof. +intros. elim: l => [ | x l' IH ]. + by []. +match goal with |- (x :: l') ++ nil = x :: l' => idtac end. +Abort. + + +Generalizable Variables A. + +Class Inhab (A:Type) : Type := + { arbitrary : A }. + +Lemma test_intro_typeclass_1 : forall A `{Inhab A} (l1 l2:list A), l2 = nil -> l1 ++ l2 = l1. +Proof. +move =>> H. + match goal with |- _ = _ => idtac end. +Abort. + +Lemma test_intro_typeclass_2 : forall A `{Inhab A} (x:A), x = arbitrary -> x = arbitrary. +Proof. +move =>> H. + match goal with |- _ = _ => idtac end. +Abort. + +Lemma test_intro_temporary_1 : forall A (l1 l2:list A), l2 = nil -> l1 ++ l2 = l1. +Proof. +move => A + l2. + match goal with |- forall l1, l2 = nil -> l1 ++ l2 = l1 => idtac end. +Abort. + +Lemma test_intro_temporary_2 : forall A `{Inhab A} (l1 l2:list A), l2 = nil -> l1 ++ l2 = l1. +Proof. +move => > E. + match goal with |- _ = _ => idtac end. +Abort. + +Lemma test_dispatch : (forall x:nat, x= x )/\ (forall y:nat, y = y). +Proof. +intros. split => [ a | b ]. + match goal with |- a = a => by [] end. +match goal with |- b = b => by [] end. +Abort. + +Lemma test_tactics_as_view_1 : forall A (l1:list A), nil ++ l1 = l1. +Proof. +move => /ltac:(simpl). +Abort. + +Lemma test_tactics_as_view_2 : forall A, (forall (l1:list A), nil ++ l1 = l1) /\ (nil ++ nil = @nil A). +Proof. +move => A. +(* TODO: I want to do [split =>.] as a temporary step in setting up my script, + but this syntax does not seem to be supported. Can't we have an empty ipat? + Note that I can do [split => [ | ]]*) +split => [| /ltac:(simpl)]. +Abort. + +Notation "%%" := (ltac:(simpl)) : ssripat_scope. + +Lemma test_tactics_as_view_3 : forall A, (forall (l1:list A), nil ++ l1 = l1) /\ (nil ++ nil = @nil A). +Proof. +move => /ltac:(split) [ | /%% ]. +Abort. diff --git a/test-suite/ssr/misc_tc.v b/test-suite/ssr/misc_tc.v new file mode 100644 index 0000000000..4db45b743a --- /dev/null +++ b/test-suite/ssr/misc_tc.v @@ -0,0 +1,30 @@ +Require Import ssreflect List. + +Generalizable Variables A B. + +Class Inhab (A:Type) : Type := + { arbitrary : A }. + +Lemma test_intro_typeclass_1 : forall A `{Inhab A} (x:A), x = arbitrary -> x = arbitrary. +Proof. +move =>> H. (* introduces [H:x=arbitrary] because first non dependent hypothesis *) +Abort. + +Lemma test_intro_typeclass_2 : forall A `{Inhab A} (l1 l2:list A), l2 = nil -> l1 ++ l2 = l1. +Proof. +move =>> H. (* introduces [Inhab A] automatically because it is a typeclass instance *) +Abort. + +Lemma test_intro_typeclass_3 : forall `{Inhab A, Inhab B} (x:A) (y:B), True -> x = x. +Proof. (* Above types [A] and [B] are implicitly quantified *) +move =>> y H. (* introduces the two typeclass instances automatically *) +Abort. + +Class Foo `{Inhab A} : Type := + { foo : A }. + +Lemma test_intro_typeclass_4 : forall `{Foo A}, True -> True. +Proof. (* Above, [A] and [{Inhab A}] are implicitly quantified *) +move =>> H. (* introduces [A] and [Inhab A] because they are dependently used, + and introduce [Foo A] automatically because it is an instance. *) +Abort. diff --git a/test-suite/stm/classify_set_proof_mode_9093.v b/test-suite/stm/classify_set_proof_mode_9093.v new file mode 100644 index 0000000000..d3f73ff435 --- /dev/null +++ b/test-suite/stm/classify_set_proof_mode_9093.v @@ -0,0 +1,9 @@ +(* -*- coq-prog-args: ("-async-proofs" "on" "-noinit"); -*- *) + +Declare ML Module "ltac_plugin". + +Set Default Proof Mode "Classic". + +Goal Prop. + idtac. +Abort. diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 8535585749..e0dd3380f9 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -700,7 +700,7 @@ open Pputils | None -> mt() | Some r -> keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ + Ppred.pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ keyword " in" ++ spc() in let pr_def_body = function @@ -1134,7 +1134,7 @@ open Pputils let pr_mayeval r c = match r with | Some r0 -> hov 2 (keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ + Ppred.pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ spc() ++ keyword "in" ++ spc () ++ pr_lconstr c) | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c) in @@ -1146,7 +1146,7 @@ open Pputils | VernacDeclareReduction (s,r) -> return ( keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r + Ppred.pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r ) | VernacPrint p -> return (pr_printable p) diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index f26e0d0885..a647b2ef73 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -52,4 +52,4 @@ let set_command_entry e = Vernac_.command_entry_ref := e let get_command_entry () = !Vernac_.command_entry_ref let () = - register_grammar Stdarg.wit_red_expr (Vernac_.red_expr); + register_grammar Genredexpr.wit_red_expr (Vernac_.red_expr); |