diff options
168 files changed, 3244 insertions, 2210 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..6789bc038e 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: @@ -132,10 +135,30 @@ Universes for the "Private Polymorphic Universes" option (and Unset it to get the previous behaviour). +Inductives + +- An option and attributes to control the automatic decision to + declare an inductive type as template polymorphic were added. + Warning "auto-template" will trigger when an inductive is + automatically declared template polymorphic without the attribute. + +Funind + +- Inductive types declared by Funind will never be template polymorphic. + 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: => > + - 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..ee3e2d6cb7 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -2,9 +2,10 @@ # Dune Makefile for Coq .PHONY: help voboot states world watch check # Main developer targets +.PHONY: coq coqide coqide-server # Package 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 @@ -19,6 +20,10 @@ help: @echo " - watch: build all binaries and libraries [continuous build]" @echo " - check: build all ML files as fast as possible" @echo "" + @echo " - coq: build package Coq [toplevel compilers, tools, stdlib, no GTK]" + @echo " - coqide-server: build package coqide-server [XML protocol language server]" + @echo " - coqide: build package CoqIDE [gtk application]" + @echo "" @echo " - quickbyte: build main ML files [coqtop + plugins + ide + printers] using the bytecode compiler" @echo " - quickopt: build main ML files [coqtop + plugins + ide + printers] using the optimizing compiler" @echo "" @@ -28,6 +33,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" @@ -42,6 +48,15 @@ states: voboot world: voboot dune build $(DUNEOPT) @install +coq: voboot + dune build $(DUNEOPT) coq.install + +coqide: voboot + dune build $(DUNEOPT) coqide.install + +coqide-server: voboot + dune build $(DUNEOPT) coqide-server.install + watch: voboot dune build $(DUNEOPT) @install -w @@ -75,6 +90,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 @@ -84,11 +104,11 @@ ireport: clean: dune clean -# Other common dev targets +# Other common dev targets: # # dune build coq.install -# dune build ide/coqide.install - +# dune build coqide.install +# # Packaging / OPAM targets: # # dune -p coq @install 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/clib/cSig.mli b/clib/cSig.mli index fb36cc5b51..859018ca4b 100644 --- a/clib/cSig.mli +++ b/clib/cSig.mli @@ -83,6 +83,7 @@ sig val choose: 'a t -> (key * 'a) val split: key -> 'a t -> 'a t * 'a option * 'a t val find: key -> 'a t -> 'a + val find_opt : key -> 'a t -> 'a option val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end diff --git a/clib/hMap.ml b/clib/hMap.ml index 9c80398e4d..5d634b7af0 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -353,6 +353,12 @@ struct let m = Int.Map.find h s in Map.find k m + let find_opt k s = + let h = M.hash k in + match Int.Map.find_opt h s with + | None -> None + | Some m -> Map.find_opt k m + let get k s = try find k s with Not_found -> assert false let split k s = assert false (** Cannot be implemented efficiently *) diff --git a/clib/int.ml b/clib/int.ml index fa21379565..3924c152d6 100644 --- a/clib/int.ml +++ b/clib/int.ml @@ -41,6 +41,13 @@ struct if i < k then find i l else if i = k then v else find i r + + let rec find_opt i s = match map_prj s with + | MEmpty -> None + | MNode (l, k, v, r, h) -> + if i < k then find_opt i l + else if i = k then Some v + else find_opt i r end module List = struct 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..92bd4dbd1d 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 %| > %| _ %| ? %| * %| + %| {? @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,43 @@ 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. +``>`` + pops every variable occurring in the rest of the stack. + Type class instances are popped even if they don't occur + in the rest of the stack. + The tactic ``move=> >`` is equivalent to + ``move=> ? ?`` on a goal such as:: + + forall x y, x < y -> G + + A typical use if ``move=>> H`` to name ``H`` the first assumption, + in the example above ``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 +1648,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 +1683,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 +1754,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 +4227,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 +5306,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 %| > %| _ %| ? %| * %| + %| {? @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/engine/evd.ml b/engine/evd.ml index 7bc3be87a4..31c326df6a 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -601,19 +601,19 @@ let is_defined d e = EvMap.mem e d.defn_evars let is_undefined d e = EvMap.mem e d.undf_evars -let existential_value d (n, args) = - let info = find d n in - match evar_body info with - | Evar_defined c -> - instantiate_evar_array info c args - | Evar_empty -> - raise NotInstantiatedEvar +let existential_opt_value d (n, args) = + match EvMap.find_opt n d.defn_evars with + | None -> None + | Some info -> + match evar_body info with + | Evar_defined c -> Some (instantiate_evar_array info c args) + | Evar_empty -> None (* impossible but w/e *) -let existential_value0 = existential_value +let existential_value d ev = match existential_opt_value d ev with + | None -> raise NotInstantiatedEvar + | Some v -> v -let existential_opt_value d ev = - try Some (existential_value d ev) - with NotInstantiatedEvar -> None +let existential_value0 = existential_value let existential_opt_value0 = existential_opt_value diff --git a/engine/proofview.ml b/engine/proofview.ml index 8c15579bb0..cf4224bbdb 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -636,7 +636,7 @@ let shelve = let open Proof in Comb.get >>= fun initial -> Comb.set [] >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve")) >> Shelf.modify (fun gls -> gls @ CList.map drop_state initial) let shelve_goals l = @@ -644,7 +644,7 @@ let shelve_goals l = Comb.get >>= fun initial -> let comb = CList.filter (fun g -> not (CList.mem (drop_state g) l)) initial in Comb.set comb >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_goals")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve_goals")) >> Shelf.modify (fun gls -> gls @ l) (** [depends_on sigma src tgt] checks whether the goal [src] appears @@ -710,7 +710,7 @@ let shelve_unifiable_informative = Pv.get >>= fun initial -> let (u,n) = partition_unifiable initial.solution initial.comb in Comb.set n >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve_unifiable")) >> let u = CList.map drop_state u in Shelf.modify (fun gls -> gls @ u) >> tclUNIT u @@ -794,7 +794,7 @@ let goodmod p m = let cycle n = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.(str"cycle "++int n))) >> Comb.modify begin fun initial -> let l = CList.length initial in let n' = goodmod n l in @@ -804,7 +804,7 @@ let cycle n = let swap i j = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> Comb.modify begin fun initial -> let l = CList.length initial in let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in @@ -819,7 +819,7 @@ let swap i j = let revgoals = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"revgoals")) >> Comb.modify CList.rev let numgoals = @@ -858,7 +858,7 @@ let give_up = Comb.get >>= fun initial -> Comb.set [] >> mark_as_unsafe >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"give_up")) >> Giveup.put (CList.map drop_state initial) @@ -1188,9 +1188,9 @@ module Trace = struct let log m = InfoL.leaf (Info.Msg m) let name_tactic m t = InfoL.tag (Info.Tactic m) t - let pr_info ?(lvl=0) info = + let pr_info env sigma ?(lvl=0) info = assert (lvl >= 0); - Info.(print (collapse lvl info)) + Info.(print env sigma (collapse lvl info)) end @@ -1234,7 +1234,7 @@ module V82 = struct let (goalss,evd) = Evd.Monad.List.map tac initgoals_w_state initevd in let sgs = CList.flatten goalss in let sgs = undefined evd sgs in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"<unknown>")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"<unknown>")) >> Pv.set { ps with solution = evd; comb = sgs; } with e when catchable_exception e -> let (e, info) = CErrors.push e in diff --git a/engine/proofview.mli b/engine/proofview.mli index 28e793f0fc..286703c0dc 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -548,7 +548,7 @@ module Trace : sig val log : Proofview_monad.lazy_msg -> unit tactic val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic - val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.t + val pr_info : Environ.env -> Evd.evar_map -> ?lvl:int -> Proofview_monad.Info.tree -> Pp.t end diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 52bcabf958..69341d97df 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -64,8 +64,7 @@ end (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) -type lazy_msg = unit -> Pp.t -let pr_lazy_msg msg = msg () +type lazy_msg = Environ.env -> Evd.evar_map -> Pp.t (** Info trace. *) module Info = struct @@ -80,9 +79,7 @@ module Info = struct type state = tag Trace.incr type tree = tag Trace.forest - - - let pr_in_comments m = Pp.(str"(* "++pr_lazy_msg m++str" *)") + let pr_in_comments env sigma m = Pp.(str"(* "++ m env sigma ++str" *)") let unbranch = function | Trace.Seq (DBranch,brs) -> brs @@ -112,31 +109,31 @@ module Info = struct (** [with_sep] is [true] when [Tactic m] must be printed with a trailing semi-colon. *) - let rec pr_tree with_sep = let open Trace in function - | Seq (Msg m,[]) -> pr_in_comments m + let rec pr_tree env sigma with_sep = let open Trace in function + | Seq (Msg m,[]) -> pr_in_comments env sigma m | Seq (Tactic m,_) -> let tail = if with_sep then Pp.str";" else Pp.mt () in - Pp.(pr_lazy_msg m ++ tail) + Pp.(m env sigma ++ tail) | Seq (Dispatch,brs) -> let tail = if with_sep then Pp.str";" else Pp.mt () in - Pp.(pr_dispatch brs++tail) + Pp.(pr_dispatch env sigma brs++tail) | Seq (Msg _,_::_) | Seq (DBranch,_) -> assert false - and pr_dispatch brs = + and pr_dispatch env sigma brs = let open Pp in let brs = List.map unbranch brs in match brs with - | [br] -> pr_forest br + | [br] -> pr_forest env sigma br | _ -> let sep () = spc()++str"|"++spc() in - let branches = prlist_with_sep sep pr_forest brs in + let branches = prlist_with_sep sep (pr_forest env sigma) brs in str"[>"++spc()++branches++spc()++str"]" - and pr_forest = function + and pr_forest env sigma = function | [] -> Pp.mt () - | [tr] -> pr_tree false tr - | tr::l -> Pp.(pr_tree true tr ++ pr_forest l) + | [tr] -> pr_tree env sigma false tr + | tr::l -> Pp.(pr_tree env sigma true tr ++ pr_forest env sigma l) - let print f = - pr_forest (compress f) + let print env sigma f = + pr_forest env sigma (compress f) let rec collapse_tree n t = let open Trace in diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index 9d75242175..a08cab3bf6 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -45,7 +45,7 @@ end (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) -type lazy_msg = unit -> Pp.t +type lazy_msg = Environ.env -> Evd.evar_map -> Pp.t (** Info trace. *) module Info : sig @@ -60,7 +60,7 @@ module Info : sig type state = tag Trace.incr type tree = tag Trace.forest - val print : tree -> Pp.t + val print : Environ.env -> Evd.evar_map -> tree -> Pp.t (** [collapse n t] flattens the first [n] levels of [Tactic] in an info trace, effectively forgetting about the [n] top level of 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/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 3a5af1dd5f..7bc5d090b4 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -366,6 +366,14 @@ let free_vars_of_constr_expr c = | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c in aux [] Id.Set.empty c +let names_of_constr_expr c = + let vars = ref Id.Set.empty in + let rec aux () () = function + | { CAst.v = CRef (qid, _) } when qualid_is_ident qid -> + let id = qualid_basename qid in vars := Id.Set.add id !vars + | c -> fold_constr_expr_with_binders (fun a () -> vars := Id.Set.add a !vars) aux () () c + in aux () () c; !vars + let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) (* Used in correctness and interface *) diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 7f14eb4583..8c735edfc9 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -119,6 +119,9 @@ val ids_of_cases_indtype : cases_pattern_expr -> Id.Set.t val free_vars_of_constr_expr : constr_expr -> Id.Set.t val occur_var_constr_expr : Id.t -> constr_expr -> bool +(** Return all (non-qualified) names treating binders as names *) +val names_of_constr_expr : constr_expr -> Id.Set.t + val split_at_annot : local_binder_expr list -> lident option -> local_binder_expr list * local_binder_expr list val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> notation -> (int * int) list 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/kernel/uGraph.ml b/kernel/uGraph.ml index 5fc8d0297f..8187dea41b 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -8,749 +8,80 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Pp -open Util open Univ -(* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *) -(* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *) -(* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *) -(* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) -(* Support for universe polymorphism by MS [2014] *) +module G = AcyclicGraph.Make(struct + type t = Level.t + module Set = LSet + module Map = LMap + module Constraint = Constraint -(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu - Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) + let equal = Level.equal + let compare = Level.compare -let error_inconsistency o u v p = - raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) + type explanation = Univ.explanation + let error_inconsistency d u v p = + raise (UniverseInconsistency (d,Universe.make u, Universe.make v, p)) -(* Universes are stratified by a partial ordering $\le$. - Let $\~{}$ be the associated equivalence. We also have a strict ordering - $<$ between equivalence classes, and we maintain that $<$ is acyclic, - and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$. + let pr = Level.pr + end) [@@inlined] (* without inline, +1% ish on HoTT, compcert. See jenkins 594 vs 596 *) +(* Do not include G to make it easier to control universe specific + code (eg add_universe with a constraint vs G.add with no + constraint) *) - At every moment, we have a finite number of universes, and we - maintain the ordering in the presence of assertions $U<V$ and $U\le V$. - - The equivalence $\~{}$ is represented by a tree structure, as in the - union-find algorithm. The assertions $<$ and $\le$ are represented by - adjacency lists. - - We use the algorithm described in the paper: - - Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A - new approach to incremental cycle detection and related - problems. arXiv preprint arXiv:1112.0784. - - *) - -open Universe - -module UMap = LMap - -type status = NoMark | Visited | WeakVisited | ToMerge - -(* Comparison on this type is pointer equality *) -type canonical_node = - { univ: Level.t; - ltle: bool UMap.t; (* true: strict (lt) constraint. - false: weak (le) constraint. *) - gtge: LSet.t; - rank : int; - klvl: int; - ilvl: int; - mutable status: status - } - -let big_rank = 1000000 - -(* A Level.t is either an alias for another one, or a canonical one, - for which we know the universes that are above *) - -type univ_entry = - Canonical of canonical_node - | Equiv of Level.t - -type universes = - { entries : univ_entry UMap.t; - index : int; - n_nodes : int; n_edges : int } - -type t = universes - -(** Used to cleanup universes if a traversal function is interrupted before it - has the opportunity to do it itself. *) -let unsafe_cleanup_universes g = - let iter _ n = match n with - | Equiv _ -> () - | Canonical n -> n.status <- NoMark - in - UMap.iter iter g.entries - -let rec cleanup_universes g = - try unsafe_cleanup_universes g - with e -> - (** The only way unsafe_cleanup_universes may raise an exception is when - a serious error (stack overflow, out of memory) occurs, or a signal is - sent. In this unlikely event, we relaunch the cleanup until we finally - succeed. *) - cleanup_universes g; raise e - -(* Every Level.t has a unique canonical arc representative *) - -(* Low-level function : makes u an alias for v. - Does not removes edges from n_edges, but decrements n_nodes. - u should be entered as canonical before. *) -let enter_equiv g u v = - { entries = - UMap.modify u (fun _ a -> - match a with - | Canonical n -> - n.status <- NoMark; - Equiv v - | _ -> assert false) g.entries; - index = g.index; - n_nodes = g.n_nodes - 1; - n_edges = g.n_edges } - -(* Low-level function : changes data associated with a canonical node. - Resets the mutable fields in the old record, in order to avoid breaking - invariants for other users of this record. - n.univ should already been inserted as a canonical node. *) -let change_node g n = - { g with entries = - UMap.modify n.univ - (fun _ a -> - match a with - | Canonical n' -> - n'.status <- NoMark; - Canonical n - | _ -> assert false) - g.entries } - -(* repr : universes -> Level.t -> canonical_node *) -(* canonical representative : we follow the Equiv links *) -let rec repr g u = - let a = - try UMap.find u g.entries - with Not_found -> CErrors.anomaly ~label:"Univ.repr" - (str"Universe " ++ Level.pr u ++ str" undefined.") - in - match a with - | Equiv v -> repr g v - | Canonical arc -> arc - -let get_set_arc g = repr g Level.set -let is_set_arc u = Level.is_set u.univ -let is_prop_arc u = Level.is_prop u.univ - -exception AlreadyDeclared - -(* Reindexes the given universe, using the next available index. *) -let use_index g u = - let u = repr g u in - let g = change_node g { u with ilvl = g.index } in - assert (g.index > min_int); - { g with index = g.index - 1 } - -(* [safe_repr] is like [repr] but if the graph doesn't contain the - searched universe, we add it. *) -let safe_repr g u = - let rec safe_repr_rec entries u = - match UMap.find u entries with - | Equiv v -> safe_repr_rec entries v - | Canonical arc -> arc - in - try g, safe_repr_rec g.entries u - with Not_found -> - let can = - { univ = u; - ltle = UMap.empty; gtge = LSet.empty; - rank = if Level.is_small u then big_rank else 0; - klvl = 0; ilvl = 0; - status = NoMark } - in - let g = { g with - entries = UMap.add u (Canonical can) g.entries; - n_nodes = g.n_nodes + 1 } - in - let g = use_index g u in - g, repr g u - -(* Returns 1 if u is higher than v in topological order. - -1 lower - 0 if u = v *) -let topo_compare u v = - if u.klvl > v.klvl then 1 - else if u.klvl < v.klvl then -1 - else if u.ilvl > v.ilvl then 1 - else if u.ilvl < v.ilvl then -1 - else (assert (u==v); 0) - -(* Checks most of the invariants of the graph. For debugging purposes. *) -let check_universes_invariants g = - let n_edges = ref 0 in - let n_nodes = ref 0 in - UMap.iter (fun l u -> - match u with - | Canonical u -> - UMap.iter (fun v _strict -> - incr n_edges; - let v = repr g v in - assert (topo_compare u v = -1); - if u.klvl = v.klvl then - assert (LSet.mem u.univ v.gtge || - LSet.exists (fun l -> u == repr g l) v.gtge)) - u.ltle; - LSet.iter (fun v -> - let v = repr g v in - assert (v.klvl = u.klvl && - (UMap.mem u.univ v.ltle || - UMap.exists (fun l _ -> u == repr g l) v.ltle)) - ) u.gtge; - assert (u.status = NoMark); - assert (Level.equal l u.univ); - assert (u.ilvl > g.index); - assert (not (UMap.mem u.univ u.ltle)); - incr n_nodes - | Equiv _ -> assert (not (Level.is_small l))) - g.entries; - assert (!n_edges = g.n_edges); - assert (!n_nodes = g.n_nodes) - -let clean_ltle g ltle = - UMap.fold (fun u strict acc -> - let uu = (repr g u).univ in - if Level.equal uu u then acc - else ( - let acc = UMap.remove u (fst acc) in - if not strict && UMap.mem uu acc then (acc, true) - else (UMap.add uu strict acc, true))) - ltle (ltle, false) - -let clean_gtge g gtge = - LSet.fold (fun u acc -> - let uu = (repr g u).univ in - if Level.equal uu u then acc - else LSet.add uu (LSet.remove u (fst acc)), true) - gtge (gtge, false) - -(* [get_ltle] and [get_gtge] return ltle and gtge arcs. - Moreover, if one of these lists is dirty (e.g. points to a - non-canonical node), these functions clean this node in the - graph by removing some duplicate edges *) -let get_ltle g u = - let ltle, chgt_ltle = clean_ltle g u.ltle in - if not chgt_ltle then u.ltle, u, g - else - let sz = UMap.cardinal u.ltle in - let sz2 = UMap.cardinal ltle in - let u = { u with ltle } in - let g = change_node g u in - let g = { g with n_edges = g.n_edges + sz2 - sz } in - u.ltle, u, g - -let get_gtge g u = - let gtge, chgt_gtge = clean_gtge g u.gtge in - if not chgt_gtge then u.gtge, u, g - else - let u = { u with gtge } in - let g = change_node g u in - u.gtge, u, g - -(* [revert_graph] rollbacks the changes made to mutable fields in - nodes in the graph. - [to_revert] contains the touched nodes. *) -let revert_graph to_revert g = - List.iter (fun t -> - match UMap.find t g.entries with - | Equiv _ -> () - | Canonical t -> - t.status <- NoMark) to_revert - -exception AbortBackward of universes -exception CycleDetected - -(* Implementation of the algorithm described in § 5.1 of the following paper: - - Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A - new approach to incremental cycle detection and related - problems. arXiv preprint arXiv:1112.0784. - - The "STEP X" comments contained in this file refers to the - corresponding step numbers of the algorithm described in Section - 5.1 of this paper. *) - -(* [delta] is the timeout for backward search. It might be - useful to tune a multiplicative constant. *) -let get_delta g = - int_of_float - (min (float_of_int g.n_edges ** 0.5) - (float_of_int g.n_nodes ** (2./.3.))) - -let rec backward_traverse to_revert b_traversed count g x = - let x = repr g x in - let count = count - 1 in - if count < 0 then begin - revert_graph to_revert g; - raise (AbortBackward g) - end; - if x.status = NoMark then begin - x.status <- Visited; - let to_revert = x.univ::to_revert in - let gtge, x, g = get_gtge g x in - let to_revert, b_traversed, count, g = - LSet.fold (fun y (to_revert, b_traversed, count, g) -> - backward_traverse to_revert b_traversed count g y) - gtge (to_revert, b_traversed, count, g) - in - to_revert, x.univ::b_traversed, count, g - end - else to_revert, b_traversed, count, g - -let rec forward_traverse f_traversed g v_klvl x y = - let y = repr g y in - if y.klvl < v_klvl then begin - let y = { y with klvl = v_klvl; - gtge = if x == y then LSet.empty - else LSet.singleton x.univ } - in - let g = change_node g y in - let ltle, y, g = get_ltle g y in - let f_traversed, g = - UMap.fold (fun z _ (f_traversed, g) -> - forward_traverse f_traversed g v_klvl y z) - ltle (f_traversed, g) - in - y.univ::f_traversed, g - end else if y.klvl = v_klvl && x != y then - let g = change_node g - { y with gtge = LSet.add x.univ y.gtge } in - f_traversed, g - else f_traversed, g - -let rec find_to_merge to_revert g x v = - let x = repr g x in - match x.status with - | Visited -> false, to_revert | ToMerge -> true, to_revert - | NoMark -> - let to_revert = x::to_revert in - if Level.equal x.univ v then - begin x.status <- ToMerge; true, to_revert end - else - begin - let merge, to_revert = LSet.fold - (fun y (merge, to_revert) -> - let merge', to_revert = find_to_merge to_revert g y v in - merge' || merge, to_revert) x.gtge (false, to_revert) - in - x.status <- if merge then ToMerge else Visited; - merge, to_revert - end - | _ -> assert false - -let get_new_edges g to_merge = - (* Computing edge sets. *) - let to_merge_lvl = - List.fold_left (fun acc u -> UMap.add u.univ u acc) - UMap.empty to_merge - in - let ltle = - let fold _ n acc = - let fold u strict acc = - if strict then UMap.add u strict acc - else if UMap.mem u acc then acc - else UMap.add u false acc - in - UMap.fold fold n.ltle acc - in - UMap.fold fold to_merge_lvl UMap.empty - in - let ltle, _ = clean_ltle g ltle in - let ltle = - UMap.merge (fun _ a strict -> - match a, strict with - | Some _, Some true -> - (* There is a lt edge inside the new component. This is a - "bad cycle". *) - raise CycleDetected - | Some _, Some false -> None - | _, _ -> strict - ) to_merge_lvl ltle - in - let gtge = - UMap.fold (fun _ n acc -> LSet.union acc n.gtge) - to_merge_lvl LSet.empty - in - let gtge, _ = clean_gtge g gtge in - let gtge = LSet.diff gtge (UMap.domain to_merge_lvl) in - (ltle, gtge) - - -let reorder g u v = - (* STEP 2: backward search in the k-level of u. *) - let delta = get_delta g in - - (* [v_klvl] is the chosen future level for u, v and all - traversed nodes. *) - let b_traversed, v_klvl, g = - try - let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in - revert_graph to_revert g; - let v_klvl = (repr g u).klvl in - b_traversed, v_klvl, g - with AbortBackward g -> - (* Backward search was too long, use the next k-level. *) - let v_klvl = (repr g u).klvl + 1 in - [], v_klvl, g - in - let f_traversed, g = - (* STEP 3: forward search. Contrary to what is described in - the paper, we do not test whether v_klvl = u.klvl nor we assign - v_klvl to v.klvl. Indeed, the first call to forward_traverse - will do all that. *) - forward_traverse [] g v_klvl (repr g v) v - in - - (* STEP 4: merge nodes if needed. *) - let to_merge, b_reindex, f_reindex = - if (repr g u).klvl = v_klvl then - begin - let merge, to_revert = find_to_merge [] g u v in - let r = - if merge then - List.filter (fun u -> u.status = ToMerge) to_revert, - List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, - List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed - else [], b_traversed, f_traversed - in - List.iter (fun u -> u.status <- NoMark) to_revert; - r - end - else [], b_traversed, f_traversed - in - let to_reindex, g = - match to_merge with - | [] -> List.rev_append f_reindex b_reindex, g - | n0::q0 -> - (* Computing new root. *) - let root, rank_rest = - List.fold_left (fun ((best, _rank_rest) as acc) n -> - if n.rank >= best.rank then n, best.rank else acc) - (n0, min_int) q0 - in - let ltle, gtge = get_new_edges g to_merge in - (* Inserting the new root. *) - let g = change_node g - { root with ltle; gtge; - rank = max root.rank (rank_rest + 1); } - in - - (* Inserting shortcuts for old nodes. *) - let g = List.fold_left (fun g n -> - if Level.equal n.univ root.univ then g else enter_equiv g n.univ root.univ) - g to_merge - in - - (* Updating g.n_edges *) - let oldsz = - List.fold_left (fun sz u -> sz+UMap.cardinal u.ltle) - 0 to_merge - in - let sz = UMap.cardinal ltle in - let g = { g with n_edges = g.n_edges + sz - oldsz } in - - (* Not clear in the paper: we have to put the newly - created component just between B and F. *) - List.rev_append f_reindex (root.univ::b_reindex), g - - in - - (* STEP 5: reindex traversed nodes. *) - List.fold_left use_index g to_reindex - -(* Assumes [u] and [v] are already in the graph. *) -(* Does NOT assume that ucan != vcan. *) -let insert_edge strict ucan vcan g = - try - let u = ucan.univ and v = vcan.univ in - (* STEP 1: do we need to reorder nodes ? *) - let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in - - (* STEP 6: insert the new edge in the graph. *) - let u = repr g u in - let v = repr g v in - if u == v then - if strict then raise CycleDetected else g - else - let g = - try let oldstrict = UMap.find v.univ u.ltle in - if strict && not oldstrict then - change_node g { u with ltle = UMap.add v.univ true u.ltle } - else g - with Not_found -> - { (change_node g { u with ltle = UMap.add v.univ strict u.ltle }) - with n_edges = g.n_edges + 1 } - in - if u.klvl <> v.klvl || LSet.mem u.univ v.gtge then g - else - let v = { v with gtge = LSet.add u.univ v.gtge } in - change_node g v - with - | CycleDetected as e -> raise e - | e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -let add_universe_gen vlev g = - try - let _arcv = UMap.find vlev g.entries in - raise AlreadyDeclared - with Not_found -> - assert (g.index > min_int); - let v = { - univ = vlev; - ltle = LMap.empty; - gtge = LSet.empty; - rank = 0; - klvl = 0; - ilvl = g.index; - status = NoMark; - } - in - let entries = UMap.add vlev (Canonical v) g.entries in - { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges }, v - -let add_universe vlev strict g = - let g, v = add_universe_gen vlev g in - insert_edge strict (get_set_arc g) v g - -let add_universe_unconstrained vlev g = - fst (add_universe_gen vlev g) - -exception UndeclaredLevel of Univ.Level.t -let check_declared_universes g us = - let check l = if not (UMap.mem l g.entries) then raise (UndeclaredLevel l) in - Univ.LSet.iter check us - -exception Found_explanation of explanation - -let get_explanation strict u v g = - let v = repr g v in - let visited_strict = ref UMap.empty in - let rec traverse strict u = - if u == v then - if strict then None else Some [] - else if topo_compare u v = 1 then None - else - let visited = - try not (UMap.find u.univ !visited_strict) || strict - with Not_found -> false - in - if visited then None - else begin - visited_strict := UMap.add u.univ strict !visited_strict; - try - UMap.iter (fun u' strictu' -> - match traverse (strict && not strictu') (repr g u') with - | None -> () - | Some exp -> - let typ = if strictu' then Lt else Le in - raise (Found_explanation ((typ, make u') :: exp))) - u.ltle; - None - with Found_explanation exp -> Some exp - end - in - let u = repr g u in - if u == v then [(Eq, make v.univ)] - else match traverse strict u with Some exp -> exp | None -> assert false - -let get_explanation strict u v g = - Some (lazy (get_explanation strict u v g)) - -(* To compare two nodes, we simply do a forward search. - We implement two improvements: - - we ignore nodes that are higher than the destination; - - we do a BFS rather than a DFS because we expect to have a short - path (typically, the shortest path has length 1) -*) -exception Found of canonical_node list -let search_path strict u v g = - let rec loop to_revert todo next_todo = - match todo, next_todo with - | [], [] -> to_revert (* No path found *) - | [], _ -> loop to_revert next_todo [] - | (u, strict)::todo, _ -> - if u.status = Visited || (u.status = WeakVisited && strict) - then loop to_revert todo next_todo - else - let to_revert = - if u.status = NoMark then u::to_revert else to_revert - in - u.status <- if strict then WeakVisited else Visited; - if try UMap.find v.univ u.ltle || not strict - with Not_found -> false - then raise (Found to_revert) - else - begin - let next_todo = - UMap.fold (fun u strictu next_todo -> - let strict = not strictu && strict in - let u = repr g u in - if u == v && not strict then raise (Found to_revert) - else if topo_compare u v = 1 then next_todo - else (u, strict)::next_todo) - u.ltle next_todo - in - loop to_revert todo next_todo - end - in - if u == v then not strict - else - try - let res, to_revert = - try false, loop [] [u, strict] [] - with Found to_revert -> true, to_revert - in - List.iter (fun u -> u.status <- NoMark) to_revert; - res - with e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -(** Uncomment to debug the cycle detection algorithm. *) -(*let insert_edge strict ucan vcan g = - check_universes_invariants g; - let g = insert_edge strict ucan vcan g in - check_universes_invariants g; - let ucan = repr g ucan.univ in - let vcan = repr g vcan.univ in - assert (search_path strict ucan vcan g); - g*) - -(** First, checks on universe levels *) - -let check_equal g u v = - let arcu = repr g u and arcv = repr g v in - arcu == arcv - -let check_eq_level g u v = u == v || check_equal g u v - -let check_smaller g strict u v = - let arcu = repr g u and arcv = repr g v in - if strict then - search_path true arcu arcv g - else - is_prop_arc arcu - || (is_set_arc arcu && not (is_prop_arc arcv)) - || search_path false arcu arcv g - -(** Then, checks on universes *) - -type 'a check_function = universes -> 'a -> 'a -> bool +type t = G.t +type 'a check_function = 'a G.check_function let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with - | 0 -> check_smaller g false u v - | 1 -> check_smaller g true u v - | x when x < 0 -> check_smaller g false u v + | 0 -> G.check_leq g u v + | 1 -> G.check_lt g u v + | x when x < 0 -> G.check_leq g u v | _ -> false let exists_bigger g ul l = - Universe.exists (fun ul' -> + Universe.exists (fun ul' -> check_smaller_expr g ul ul') l let real_check_leq g u v = Universe.for_all (fun ul -> exists_bigger g ul v) u - + let check_leq g u v = Universe.equal u v || is_type0m_univ u || real_check_leq g u v -let check_eq_univs g l1 l2 = - real_check_leq g l1 l2 && real_check_leq g l2 l1 - let check_eq g u v = - Universe.equal u v || check_eq_univs g u v - -(* enforce_univ_eq g u v will force u=v if possible, will fail otherwise *) - -let rec enforce_univ_eq u v g = - let ucan = repr g u in - let vcan = repr g v in - if topo_compare ucan vcan = 1 then enforce_univ_eq v u g - else - let g = insert_edge false ucan vcan g in (* Cannot fail *) - try insert_edge false vcan ucan g - with CycleDetected -> - error_inconsistency Eq v u (get_explanation true u v g) - -(* enforce_univ_leq g u v will force u<=v if possible, will fail otherwise *) -let enforce_univ_leq u v g = - let ucan = repr g u in - let vcan = repr g v in - try insert_edge false ucan vcan g - with CycleDetected -> - error_inconsistency Le u v (get_explanation true v u g) - -(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *) -let enforce_univ_lt u v g = - let ucan = repr g u in - let vcan = repr g v in - try insert_edge true ucan vcan g - with CycleDetected -> - error_inconsistency Lt u v (get_explanation false v u g) - -let empty_universes = - { entries = UMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + Universe.equal u v || + (real_check_leq g u v && real_check_leq g v u) + +let check_eq_level = G.check_eq + +let empty_universes = G.empty let initial_universes = - let set_arc = Canonical { - univ = Level.set; - ltle = LMap.empty; - gtge = LSet.empty; - rank = big_rank; - klvl = 0; - ilvl = (-1); - status = NoMark; - } in - let prop_arc = Canonical { - univ = Level.prop; - ltle = LMap.empty; - gtge = LSet.empty; - rank = big_rank; - klvl = 0; - ilvl = 0; - status = NoMark; - } in - let entries = UMap.add Level.set set_arc (UMap.singleton Level.prop prop_arc) in - let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in - enforce_univ_lt Level.prop Level.set empty - -let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries - -let enforce_constraint cst g = - match cst with - | (u,Lt,v) -> enforce_univ_lt u v g - | (u,Le,v) -> enforce_univ_leq u v g - | (u,Eq,v) -> enforce_univ_eq u v g - -let merge_constraints c g = - Constraint.fold enforce_constraint c g - -let check_constraint g (l,d,r) = + let big_rank = 1000000 in + let g = G.empty in + let g = G.add ~rank:big_rank Level.prop g in + let g = G.add ~rank:big_rank Level.set g in + G.enforce_lt Level.prop Level.set g + +let enforce_constraint (u,d,v) g = + match d with + | Le -> G.enforce_leq u v g + | Lt -> G.enforce_lt u v g + | Eq -> G.enforce_eq u v g + +let merge_constraints csts g = Constraint.fold enforce_constraint csts g + +let check_constraint g (u,d,v) = match d with - | Eq -> check_equal g l r - | Le -> check_smaller g false l r - | Lt -> check_smaller g true l r + | Le -> G.check_leq g u v + | Lt -> G.check_lt g u v + | Eq -> G.check_eq g u v -let check_constraints c g = - Constraint.for_all (check_constraint g) c +let check_constraints csts g = Constraint.for_all (check_constraint g) csts let leq_expr (u,m) (v,n) = let d = match m - n with @@ -760,6 +91,7 @@ let leq_expr (u,m) (v,n) = (u,d,v) let enforce_leq_alg u v g = + let open Util in let enforce_one (u,v) = function | Inr _ as orig -> orig | Inl (cstrs,g) as orig -> @@ -791,148 +123,19 @@ let enforce_leq_alg u v g = assert (check_leq g u v); cg -(* Normalization *) - -(** [normalize_universes g] returns a graph where all edges point - directly to the canonical representent of their target. The output - graph should be equivalent to the input graph from a logical point - of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges. *) -let normalize_universes g = - let g = - { g with - entries = UMap.map (fun entry -> - match entry with - | Equiv u -> Equiv ((repr g u).univ) - | Canonical ucan -> Canonical { ucan with rank = 1 }) - g.entries } - in - UMap.fold (fun _ u g -> - match u with - | Equiv _u -> g - | Canonical u -> - let _, u, g = get_ltle g u in - let _, _, g = get_gtge g u in - g) - g.entries g - -let constraints_of_universes g = - let module UF = Unionfind.Make (LSet) (LMap) in - let uf = UF.create () in - let constraints_of u v acc = - match v with - | Canonical {univ=u; ltle; _} -> - UMap.fold (fun v strict acc-> - let typ = if strict then Lt else Le in - Constraint.add (u,typ,v) acc) ltle acc - | Equiv v -> UF.union u v uf; acc - in - let csts = UMap.fold constraints_of g.entries Constraint.empty in - csts, UF.partition uf - -(* domain g.entries = kept + removed *) -let constraints_for ~kept g = - (* rmap: partial map from canonical universes to kept universes *) - let rmap, csts = LSet.fold (fun u (rmap,csts) -> - let arcu = repr g u in - if LSet.mem arcu.univ kept then - LMap.add arcu.univ arcu.univ rmap, enforce_eq_level u arcu.univ csts - else - match LMap.find arcu.univ rmap with - | v -> rmap, enforce_eq_level u v csts - | exception Not_found -> LMap.add arcu.univ u rmap, csts) - kept (LMap.empty,Constraint.empty) - in - let rec add_from u csts todo = match todo with - | [] -> csts - | (v,strict)::todo -> - let v = repr g v in - (match LMap.find v.univ rmap with - | v -> - let d = if strict then Lt else Le in - let csts = Constraint.add (u,d,v) csts in - add_from u csts todo - | exception Not_found -> - (* v is not equal to any kept universe *) - let todo = LMap.fold (fun v' strict' todo -> - (v',strict || strict') :: todo) - v.ltle todo - in - add_from u csts todo) - in - LSet.fold (fun u csts -> - let arc = repr g u in - LMap.fold (fun v strict csts -> add_from u csts [v,strict]) - arc.ltle csts) - kept csts - -let domain g = LMap.domain g.entries - -let choose p g u = - let exception Found of Level.t in - let ru = (repr g u).univ in - if p ru then Some ru - else - try LMap.iter (fun v -> function - | Canonical _ -> () (* we already tried [p ru] *) - | Equiv v' -> - let rv = (repr g v').univ in - if rv == ru && p v then raise (Found v) - (* NB: we could also try [p v'] but it will come up in the - rest of the iteration regardless. *) - ) g.entries; None - with Found v -> Some v - -(** [sort_universes g] builds a totally ordered universe graph. The - output graph should imply the input graph (and the implication - will be strict most of the time), but is not necessarily minimal. - Moreover, it adds levels [Type.n] to identify universes at level - n. An artificial constraint Set < Type.2 is added to ensure that - Type.n and small universes are not merged. Note: the result is - unspecified if the input graph already contains [Type.n] nodes - (calling a module Type is probably a bad idea anyway). *) -let sort_universes g = - let cans = - UMap.fold (fun _ u l -> - match u with - | Equiv _ -> l - | Canonical can -> can :: l - ) g.entries [] - in - let cans = List.sort topo_compare cans in - let lowest_levels = - UMap.mapi (fun u _ -> if Level.is_small u then 0 else 2) - (UMap.filter - (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) - g.entries) - in - let lowest_levels = - List.fold_left (fun lowest_levels can -> - let lvl = UMap.find can.univ lowest_levels in - UMap.fold (fun u' strict lowest_levels -> - let cost = if strict then 1 else 0 in - let u' = (repr g u').univ in - UMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest_levels) - can.ltle lowest_levels) - lowest_levels cans - in - let max_lvl = UMap.fold (fun _ a b -> max a b) lowest_levels 0 in - let mp = Names.DirPath.make [Names.Id.of_string "Type"] in - let types = Array.init (max_lvl + 1) (function - | 0 -> Level.prop - | 1 -> Level.set - | n -> Level.make (Level.UGlobal.make mp (n-2))) - in - let g = Array.fold_left (fun g u -> - let g, u = safe_repr g u in - change_node g { u with rank = big_rank }) g types - in - let g = if max_lvl >= 2 then enforce_univ_lt Level.set types.(2) g else g in - let g = - UMap.fold (fun u lvl g -> enforce_univ_eq u (types.(lvl)) g) - lowest_levels g - in - normalize_universes g +exception AlreadyDeclared = G.AlreadyDeclared +let add_universe u strict g = + let g = G.add u g in + let d = if strict then Lt else Le in + enforce_constraint (Level.set,d,u) g + +let add_universe_unconstrained u g = G.add u g + +exception UndeclaredLevel = G.Undeclared +let check_declared_universes = G.check_declared + +let constraints_of_universes = G.constraints_of +let constraints_for = G.constraints_for (** Subtyping of polymorphic contexts *) @@ -957,45 +160,23 @@ let check_eq_instances g t1 t2 = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) -(** Pretty-printing *) - -let pr_umap sep pr map = - let cmp (u,_) (v,_) = Level.compare u v in - Pp.prlist_with_sep sep pr (List.sort cmp (UMap.bindings map)) - -let pr_arc prl = function - | _, Canonical {univ=u; ltle; _} -> - if UMap.is_empty ltle then mt () - else - prl u ++ str " " ++ - v 0 - (pr_umap Pp.spc (fun (v, strict) -> - (if strict then str "< " else str "<= ") ++ prl v) - ltle) ++ - fnl () - | u, Equiv v -> - prl u ++ str " = " ++ prl v ++ fnl () - -let pr_universes prl g = - pr_umap mt (pr_arc prl) g.entries - -(* Dumping constraints to a file *) - -let dump_universes output g = - let dump_arc u = function - | Canonical {univ=u; ltle; _} -> - UMap.iter (fun v strict -> - let typ = if strict then Lt else Le in - output typ u v) ltle; - | Equiv v -> - output Eq u v - in - UMap.iter dump_arc g.entries +let domain = G.domain +let choose = G.choose + +let dump_universes = G.dump + +let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g + +let pr_universes = G.pr + +let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] +let make_dummy i = Level.(make (UGlobal.make dummy_mp i)) +let sort_universes g = G.sort make_dummy [Level.prop;Level.set] g (** Profiling *) -let merge_constraints = - if Flags.profile then +let merge_constraints = + if Flags.profile then let key = CProfile.declare_profile "merge_constraints" in CProfile.profile2 key merge_constraints else merge_constraints @@ -1005,15 +186,14 @@ let check_constraints = CProfile.profile2 key check_constraints else check_constraints -let check_eq = +let check_eq = if Flags.profile then let check_eq_key = CProfile.declare_profile "check_eq" in CProfile.profile3 check_eq_key check_eq else check_eq -let check_leq = - if Flags.profile then +let check_leq = + if Flags.profile then let check_leq_key = CProfile.declare_profile "check_leq" in CProfile.profile3 check_leq_key check_leq else check_leq - diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 4dbfac5c73..e1a5d50425 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -22,9 +22,6 @@ val check_eq_level : Level.t check_function (** The initial graph of universes: Prop < Set *) val initial_universes : t -(** Check if we are in the initial case *) -val is_initial_universes : t -> bool - (** Check equality of instances w.r.t. a universe graph *) val check_eq_instances : Instance.t check_function diff --git a/kernel/univ.ml b/kernel/univ.ml index d7c0cf13ec..8940c0337e 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -533,9 +533,9 @@ open Universe let universe_level = Universe.level -type constraint_type = Lt | Le | Eq +type constraint_type = AcyclicGraph.constraint_type = Lt | Le | Eq -type explanation = (constraint_type * universe) list +type explanation = (constraint_type * Level.t) list let constraint_type_ord c1 c2 = match c1, c2 with | Lt, Lt -> 0 @@ -1269,7 +1269,7 @@ let hcons_universe_context_set (v, c) = let hcons_univ x = Universe.hcons x -let explain_universe_inconsistency prl (o,u,v,p) = +let explain_universe_inconsistency prl (o,u,v,p : univ_inconsistency) = let pr_uni = Universe.pr_with prl in let pr_rel = function | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" @@ -1281,9 +1281,9 @@ let explain_universe_inconsistency prl (o,u,v,p) = if p = [] then mt () else str " because" ++ spc() ++ pr_uni v ++ - prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) + prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ prl v) p ++ - (if Universe.equal (snd (List.last p)) u then mt() else + (if Universe.equal (Universe.make (snd (List.last p))) u then mt() else (spc() ++ str "= " ++ pr_uni u)) in str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ diff --git a/kernel/univ.mli b/kernel/univ.mli index d7097be570..b83251e983 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -166,7 +166,7 @@ val univ_level_rem : Level.t -> Universe.t -> Universe.t -> Universe.t (** {6 Constraints. } *) -type constraint_type = Lt | Le | Eq +type constraint_type = AcyclicGraph.constraint_type = Lt | Le | Eq type univ_constraint = Level.t * constraint_type * Level.t module Constraint : sig @@ -203,7 +203,7 @@ val enforce_leq_level : Level.t constraint_function system stores the graph and may result from combination of several Constraint.t... *) -type explanation = (constraint_type * Universe.t) list +type explanation = (constraint_type * Level.t) list type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation Lazy.t option exception UniverseInconsistency of univ_inconsistency diff --git a/lib/acyclicGraph.ml b/lib/acyclicGraph.ml new file mode 100644 index 0000000000..7d04c8f5a1 --- /dev/null +++ b/lib/acyclicGraph.ml @@ -0,0 +1,852 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type constraint_type = Lt | Le | Eq + +module type Point = sig + type t + + module Set : CSig.SetS with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + + module Constraint : CSet.S with type elt = (t * constraint_type * t) + + val equal : t -> t -> bool + val compare : t -> t -> int + + type explanation = (constraint_type * t) list + val error_inconsistency : constraint_type -> t -> t -> explanation lazy_t option -> 'a + + val pr : t -> Pp.t +end + +module Make (Point:Point) = struct + + (* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *) + (* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *) + (* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *) + (* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) + (* Support for universe polymorphism by MS [2014] *) + + (* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu + Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) + + (* Points are stratified by a partial ordering $\le$. + Let $\~{}$ be the associated equivalence. We also have a strict ordering + $<$ between equivalence classes, and we maintain that $<$ is acyclic, + and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$. + + At every moment, we have a finite number of points, and we + maintain the ordering in the presence of assertions $U<V$ and $U\le V$. + + The equivalence $\~{}$ is represented by a tree structure, as in the + union-find algorithm. The assertions $<$ and $\le$ are represented by + adjacency lists. + + We use the algorithm described in the paper: + + Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A + new approach to incremental cycle detection and related + problems. arXiv preprint arXiv:1112.0784. + + *) + + module PMap = Point.Map + module PSet = Point.Set + module Constraint = Point.Constraint + + type status = NoMark | Visited | WeakVisited | ToMerge + + (* Comparison on this type is pointer equality *) + type canonical_node = + { canon: Point.t; + ltle: bool PMap.t; (* true: strict (lt) constraint. + false: weak (le) constraint. *) + gtge: PSet.t; + rank : int; + klvl: int; + ilvl: int; + mutable status: status + } + + let big_rank = 1000000 + + (* A Point.t is either an alias for another one, or a canonical one, + for which we know the points that are above *) + + type entry = + | Canonical of canonical_node + | Equiv of Point.t + + type t = + { entries : entry PMap.t; + index : int; + n_nodes : int; n_edges : int } + + (** Used to cleanup mutable marks if a traversal function is + interrupted before it has the opportunity to do it itself. *) + let unsafe_cleanup_marks g = + let iter _ n = match n with + | Equiv _ -> () + | Canonical n -> n.status <- NoMark + in + PMap.iter iter g.entries + + let rec cleanup_marks g = + try unsafe_cleanup_marks g + with e -> + (* The only way unsafe_cleanup_marks may raise an exception is when + a serious error (stack overflow, out of memory) occurs, or a signal is + sent. In this unlikely event, we relaunch the cleanup until we finally + succeed. *) + cleanup_marks g; raise e + + (* Every Point.t has a unique canonical arc representative *) + + (* Low-level function : makes u an alias for v. + Does not removes edges from n_edges, but decrements n_nodes. + u should be entered as canonical before. *) + let enter_equiv g u v = + { entries = + PMap.modify u (fun _ a -> + match a with + | Canonical n -> + n.status <- NoMark; + Equiv v + | _ -> assert false) g.entries; + index = g.index; + n_nodes = g.n_nodes - 1; + n_edges = g.n_edges } + + (* Low-level function : changes data associated with a canonical node. + Resets the mutable fields in the old record, in order to avoid breaking + invariants for other users of this record. + n.canon should already been inserted as a canonical node. *) + let change_node g n = + { g with entries = + PMap.modify n.canon + (fun _ a -> + match a with + | Canonical n' -> + n'.status <- NoMark; + Canonical n + | _ -> assert false) + g.entries } + + (* canonical representative : we follow the Equiv links *) + let rec repr g u = + match PMap.find u g.entries with + | Equiv v -> repr g v + | Canonical arc -> arc + | exception Not_found -> + CErrors.anomaly ~label:"Univ.repr" + Pp.(str"Universe " ++ Point.pr u ++ str" undefined.") + + exception AlreadyDeclared + + (* Reindexes the given point, using the next available index. *) + let use_index g u = + let u = repr g u in + let g = change_node g { u with ilvl = g.index } in + assert (g.index > min_int); + { g with index = g.index - 1 } + + (* [safe_repr] is like [repr] but if the graph doesn't contain the + searched point, we add it. *) + let safe_repr g u = + let rec safe_repr_rec entries u = + match PMap.find u entries with + | Equiv v -> safe_repr_rec entries v + | Canonical arc -> arc + in + try g, safe_repr_rec g.entries u + with Not_found -> + let can = + { canon = u; + ltle = PMap.empty; gtge = PSet.empty; + rank = 0; + klvl = 0; ilvl = 0; + status = NoMark } + in + let g = { g with + entries = PMap.add u (Canonical can) g.entries; + n_nodes = g.n_nodes + 1 } + in + let g = use_index g u in + g, repr g u + + (* Returns 1 if u is higher than v in topological order. + -1 lower + 0 if u = v *) + let topo_compare u v = + if u.klvl > v.klvl then 1 + else if u.klvl < v.klvl then -1 + else if u.ilvl > v.ilvl then 1 + else if u.ilvl < v.ilvl then -1 + else (assert (u==v); 0) + + (* Checks most of the invariants of the graph. For debugging purposes. *) + let check_invariants ~required_canonical g = + let n_edges = ref 0 in + let n_nodes = ref 0 in + PMap.iter (fun l u -> + match u with + | Canonical u -> + PMap.iter (fun v _strict -> + incr n_edges; + let v = repr g v in + assert (topo_compare u v = -1); + if u.klvl = v.klvl then + assert (PSet.mem u.canon v.gtge || + PSet.exists (fun l -> u == repr g l) v.gtge)) + u.ltle; + PSet.iter (fun v -> + let v = repr g v in + assert (v.klvl = u.klvl && + (PMap.mem u.canon v.ltle || + PMap.exists (fun l _ -> u == repr g l) v.ltle)) + ) u.gtge; + assert (u.status = NoMark); + assert (Point.equal l u.canon); + assert (u.ilvl > g.index); + assert (not (PMap.mem u.canon u.ltle)); + incr n_nodes + | Equiv _ -> assert (not (required_canonical l))) + g.entries; + assert (!n_edges = g.n_edges); + assert (!n_nodes = g.n_nodes) + + let clean_ltle g ltle = + PMap.fold (fun u strict acc -> + let uu = (repr g u).canon in + if Point.equal uu u then acc + else ( + let acc = PMap.remove u (fst acc) in + if not strict && PMap.mem uu acc then (acc, true) + else (PMap.add uu strict acc, true))) + ltle (ltle, false) + + let clean_gtge g gtge = + PSet.fold (fun u acc -> + let uu = (repr g u).canon in + if Point.equal uu u then acc + else PSet.add uu (PSet.remove u (fst acc)), true) + gtge (gtge, false) + + (* [get_ltle] and [get_gtge] return ltle and gtge arcs. + Moreover, if one of these lists is dirty (e.g. points to a + non-canonical node), these functions clean this node in the + graph by removing some duplicate edges *) + let get_ltle g u = + let ltle, chgt_ltle = clean_ltle g u.ltle in + if not chgt_ltle then u.ltle, u, g + else + let sz = PMap.cardinal u.ltle in + let sz2 = PMap.cardinal ltle in + let u = { u with ltle } in + let g = change_node g u in + let g = { g with n_edges = g.n_edges + sz2 - sz } in + u.ltle, u, g + + let get_gtge g u = + let gtge, chgt_gtge = clean_gtge g u.gtge in + if not chgt_gtge then u.gtge, u, g + else + let u = { u with gtge } in + let g = change_node g u in + u.gtge, u, g + + (* [revert_graph] rollbacks the changes made to mutable fields in + nodes in the graph. + [to_revert] contains the touched nodes. *) + let revert_graph to_revert g = + List.iter (fun t -> + match PMap.find t g.entries with + | Equiv _ -> () + | Canonical t -> + t.status <- NoMark) to_revert + + exception AbortBackward of t + exception CycleDetected + + (* Implementation of the algorithm described in § 5.1 of the following paper: + + Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A + new approach to incremental cycle detection and related + problems. arXiv preprint arXiv:1112.0784. + + The "STEP X" comments contained in this file refers to the + corresponding step numbers of the algorithm described in Section + 5.1 of this paper. *) + + (* [delta] is the timeout for backward search. It might be + useful to tune a multiplicative constant. *) + let get_delta g = + int_of_float + (min (float_of_int g.n_edges ** 0.5) + (float_of_int g.n_nodes ** (2./.3.))) + + let rec backward_traverse to_revert b_traversed count g x = + let x = repr g x in + let count = count - 1 in + if count < 0 then begin + revert_graph to_revert g; + raise (AbortBackward g) + end; + if x.status = NoMark then begin + x.status <- Visited; + let to_revert = x.canon::to_revert in + let gtge, x, g = get_gtge g x in + let to_revert, b_traversed, count, g = + PSet.fold (fun y (to_revert, b_traversed, count, g) -> + backward_traverse to_revert b_traversed count g y) + gtge (to_revert, b_traversed, count, g) + in + to_revert, x.canon::b_traversed, count, g + end + else to_revert, b_traversed, count, g + + let rec forward_traverse f_traversed g v_klvl x y = + let y = repr g y in + if y.klvl < v_klvl then begin + let y = { y with klvl = v_klvl; + gtge = if x == y then PSet.empty + else PSet.singleton x.canon } + in + let g = change_node g y in + let ltle, y, g = get_ltle g y in + let f_traversed, g = + PMap.fold (fun z _ (f_traversed, g) -> + forward_traverse f_traversed g v_klvl y z) + ltle (f_traversed, g) + in + y.canon::f_traversed, g + end else if y.klvl = v_klvl && x != y then + let g = change_node g + { y with gtge = PSet.add x.canon y.gtge } in + f_traversed, g + else f_traversed, g + + let rec find_to_merge to_revert g x v = + let x = repr g x in + match x.status with + | Visited -> false, to_revert | ToMerge -> true, to_revert + | NoMark -> + let to_revert = x::to_revert in + if Point.equal x.canon v then + begin x.status <- ToMerge; true, to_revert end + else + begin + let merge, to_revert = PSet.fold + (fun y (merge, to_revert) -> + let merge', to_revert = find_to_merge to_revert g y v in + merge' || merge, to_revert) x.gtge (false, to_revert) + in + x.status <- if merge then ToMerge else Visited; + merge, to_revert + end + | _ -> assert false + + let get_new_edges g to_merge = + (* Computing edge sets. *) + let to_merge_lvl = + List.fold_left (fun acc u -> PMap.add u.canon u acc) + PMap.empty to_merge + in + let ltle = + let fold _ n acc = + let fold u strict acc = + if strict then PMap.add u strict acc + else if PMap.mem u acc then acc + else PMap.add u false acc + in + PMap.fold fold n.ltle acc + in + PMap.fold fold to_merge_lvl PMap.empty + in + let ltle, _ = clean_ltle g ltle in + let ltle = + PMap.merge (fun _ a strict -> + match a, strict with + | Some _, Some true -> + (* There is a lt edge inside the new component. This is a + "bad cycle". *) + raise CycleDetected + | Some _, Some false -> None + | _, _ -> strict + ) to_merge_lvl ltle + in + let gtge = + PMap.fold (fun _ n acc -> PSet.union acc n.gtge) + to_merge_lvl PSet.empty + in + let gtge, _ = clean_gtge g gtge in + let gtge = PSet.diff gtge (PMap.domain to_merge_lvl) in + (ltle, gtge) + + + let reorder g u v = + (* STEP 2: backward search in the k-level of u. *) + let delta = get_delta g in + + (* [v_klvl] is the chosen future level for u, v and all + traversed nodes. *) + let b_traversed, v_klvl, g = + try + let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in + revert_graph to_revert g; + let v_klvl = (repr g u).klvl in + b_traversed, v_klvl, g + with AbortBackward g -> + (* Backward search was too long, use the next k-level. *) + let v_klvl = (repr g u).klvl + 1 in + [], v_klvl, g + in + let f_traversed, g = + (* STEP 3: forward search. Contrary to what is described in + the paper, we do not test whether v_klvl = u.klvl nor we assign + v_klvl to v.klvl. Indeed, the first call to forward_traverse + will do all that. *) + forward_traverse [] g v_klvl (repr g v) v + in + + (* STEP 4: merge nodes if needed. *) + let to_merge, b_reindex, f_reindex = + if (repr g u).klvl = v_klvl then + begin + let merge, to_revert = find_to_merge [] g u v in + let r = + if merge then + List.filter (fun u -> u.status = ToMerge) to_revert, + List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, + List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed + else [], b_traversed, f_traversed + in + List.iter (fun u -> u.status <- NoMark) to_revert; + r + end + else [], b_traversed, f_traversed + in + let to_reindex, g = + match to_merge with + | [] -> List.rev_append f_reindex b_reindex, g + | n0::q0 -> + (* Computing new root. *) + let root, rank_rest = + List.fold_left (fun ((best, _rank_rest) as acc) n -> + if n.rank >= best.rank then n, best.rank else acc) + (n0, min_int) q0 + in + let ltle, gtge = get_new_edges g to_merge in + (* Inserting the new root. *) + let g = change_node g + { root with ltle; gtge; + rank = max root.rank (rank_rest + 1); } + in + + (* Inserting shortcuts for old nodes. *) + let g = List.fold_left (fun g n -> + if Point.equal n.canon root.canon then g else enter_equiv g n.canon root.canon) + g to_merge + in + + (* Updating g.n_edges *) + let oldsz = + List.fold_left (fun sz u -> sz+PMap.cardinal u.ltle) + 0 to_merge + in + let sz = PMap.cardinal ltle in + let g = { g with n_edges = g.n_edges + sz - oldsz } in + + (* Not clear in the paper: we have to put the newly + created component just between B and F. *) + List.rev_append f_reindex (root.canon::b_reindex), g + + in + + (* STEP 5: reindex traversed nodes. *) + List.fold_left use_index g to_reindex + + (* Assumes [u] and [v] are already in the graph. *) + (* Does NOT assume that ucan != vcan. *) + let insert_edge strict ucan vcan g = + try + let u = ucan.canon and v = vcan.canon in + (* STEP 1: do we need to reorder nodes ? *) + let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in + + (* STEP 6: insert the new edge in the graph. *) + let u = repr g u in + let v = repr g v in + if u == v then + if strict then raise CycleDetected else g + else + let g = + try let oldstrict = PMap.find v.canon u.ltle in + if strict && not oldstrict then + change_node g { u with ltle = PMap.add v.canon true u.ltle } + else g + with Not_found -> + { (change_node g { u with ltle = PMap.add v.canon strict u.ltle }) + with n_edges = g.n_edges + 1 } + in + if u.klvl <> v.klvl || PSet.mem u.canon v.gtge then g + else + let v = { v with gtge = PSet.add u.canon v.gtge } in + change_node g v + with + | CycleDetected as e -> raise e + | e -> + (* Unlikely event: fatal error or signal *) + let () = cleanup_marks g in + raise e + + let add ?(rank=0) v g = + try + let _arcv = PMap.find v g.entries in + raise AlreadyDeclared + with Not_found -> + assert (g.index > min_int); + let node = { + canon = v; + ltle = PMap.empty; + gtge = PSet.empty; + rank; + klvl = 0; + ilvl = g.index; + status = NoMark; + } + in + let entries = PMap.add v (Canonical node) g.entries in + { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } + + exception Undeclared of Point.t + let check_declared g us = + let check l = if not (PMap.mem l g.entries) then raise (Undeclared l) in + PSet.iter check us + + exception Found_explanation of (constraint_type * Point.t) list + + let get_explanation strict u v g = + let v = repr g v in + let visited_strict = ref PMap.empty in + let rec traverse strict u = + if u == v then + if strict then None else Some [] + else if topo_compare u v = 1 then None + else + let visited = + try not (PMap.find u.canon !visited_strict) || strict + with Not_found -> false + in + if visited then None + else begin + visited_strict := PMap.add u.canon strict !visited_strict; + try + PMap.iter (fun u' strictu' -> + match traverse (strict && not strictu') (repr g u') with + | None -> () + | Some exp -> + let typ = if strictu' then Lt else Le in + raise (Found_explanation ((typ, u') :: exp))) + u.ltle; + None + with Found_explanation exp -> Some exp + end + in + let u = repr g u in + if u == v then [(Eq, v.canon)] + else match traverse strict u with Some exp -> exp | None -> assert false + + let get_explanation strict u v g = + Some (lazy (get_explanation strict u v g)) + + (* To compare two nodes, we simply do a forward search. + We implement two improvements: + - we ignore nodes that are higher than the destination; + - we do a BFS rather than a DFS because we expect to have a short + path (typically, the shortest path has length 1) + *) + exception Found of canonical_node list + let search_path strict u v g = + let rec loop to_revert todo next_todo = + match todo, next_todo with + | [], [] -> to_revert (* No path found *) + | [], _ -> loop to_revert next_todo [] + | (u, strict)::todo, _ -> + if u.status = Visited || (u.status = WeakVisited && strict) + then loop to_revert todo next_todo + else + let to_revert = + if u.status = NoMark then u::to_revert else to_revert + in + u.status <- if strict then WeakVisited else Visited; + if try PMap.find v.canon u.ltle || not strict + with Not_found -> false + then raise (Found to_revert) + else + begin + let next_todo = + PMap.fold (fun u strictu next_todo -> + let strict = not strictu && strict in + let u = repr g u in + if u == v && not strict then raise (Found to_revert) + else if topo_compare u v = 1 then next_todo + else (u, strict)::next_todo) + u.ltle next_todo + in + loop to_revert todo next_todo + end + in + if u == v then not strict + else + try + let res, to_revert = + try false, loop [] [u, strict] [] + with Found to_revert -> true, to_revert + in + List.iter (fun u -> u.status <- NoMark) to_revert; + res + with e -> + (* Unlikely event: fatal error or signal *) + let () = cleanup_marks g in + raise e + + (** Uncomment to debug the cycle detection algorithm. *) + (*let insert_edge strict ucan vcan g = + let check_invariants = check_invariants ~required_canonical:(fun _ -> false) in + check_invariants g; + let g = insert_edge strict ucan vcan g in + check_invariants g; + let ucan = repr g ucan.canon in + let vcan = repr g vcan.canon in + assert (search_path strict ucan vcan g); + g*) + + (** User interface *) + + type 'a check_function = t -> 'a -> 'a -> bool + + let check_eq g u v = + u == v || + let arcu = repr g u and arcv = repr g v in + arcu == arcv + + let check_smaller g strict u v = + search_path strict (repr g u) (repr g v) g + + let check_leq g u v = check_smaller g false u v + let check_lt g u v = check_smaller g true u v + + (* enforce_eq g u v will force u=v if possible, will fail otherwise *) + + let rec enforce_eq u v g = + let ucan = repr g u in + let vcan = repr g v in + if topo_compare ucan vcan = 1 then enforce_eq v u g + else + let g = insert_edge false ucan vcan g in (* Cannot fail *) + try insert_edge false vcan ucan g + with CycleDetected -> + Point.error_inconsistency Eq v u (get_explanation true u v g) + + (* enforce_leq g u v will force u<=v if possible, will fail otherwise *) + let enforce_leq u v g = + let ucan = repr g u in + let vcan = repr g v in + try insert_edge false ucan vcan g + with CycleDetected -> + Point.error_inconsistency Le u v (get_explanation true v u g) + + (* enforce_lt u v will force u<v if possible, will fail otherwise *) + let enforce_lt u v g = + let ucan = repr g u in + let vcan = repr g v in + try insert_edge true ucan vcan g + with CycleDetected -> + Point.error_inconsistency Lt u v (get_explanation false v u g) + + let empty = + { entries = PMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + + (* Normalization *) + + (** [normalize g] returns a graph where all edges point + directly to the canonical representent of their target. The output + graph should be equivalent to the input graph from a logical point + of view, but optimized. We maintain the invariant that the key of + a [Canonical] element is its own name, by keeping [Equiv] edges. *) + let normalize g = + let g = + { g with + entries = PMap.map (fun entry -> + match entry with + | Equiv u -> Equiv ((repr g u).canon) + | Canonical ucan -> Canonical { ucan with rank = 1 }) + g.entries } + in + PMap.fold (fun _ u g -> + match u with + | Equiv _u -> g + | Canonical u -> + let _, u, g = get_ltle g u in + let _, _, g = get_gtge g u in + g) + g.entries g + + let constraints_of g = + let module UF = Unionfind.Make (PSet) (PMap) in + let uf = UF.create () in + let constraints_of u v acc = + match v with + | Canonical {canon=u; ltle; _} -> + PMap.fold (fun v strict acc-> + let typ = if strict then Lt else Le in + Constraint.add (u,typ,v) acc) ltle acc + | Equiv v -> UF.union u v uf; acc + in + let csts = PMap.fold constraints_of g.entries Constraint.empty in + csts, UF.partition uf + + (* domain g.entries = kept + removed *) + let constraints_for ~kept g = + (* rmap: partial map from canonical points to kept points *) + let rmap, csts = PSet.fold (fun u (rmap,csts) -> + let arcu = repr g u in + if PSet.mem arcu.canon kept then + PMap.add arcu.canon arcu.canon rmap, Constraint.add (u,Eq,arcu.canon) csts + else + match PMap.find arcu.canon rmap with + | v -> rmap, Constraint.add (u,Eq,v) csts + | exception Not_found -> PMap.add arcu.canon u rmap, csts) + kept (PMap.empty,Constraint.empty) + in + let rec add_from u csts todo = match todo with + | [] -> csts + | (v,strict)::todo -> + let v = repr g v in + (match PMap.find v.canon rmap with + | v -> + let d = if strict then Lt else Le in + let csts = Constraint.add (u,d,v) csts in + add_from u csts todo + | exception Not_found -> + (* v is not equal to any kept point *) + let todo = PMap.fold (fun v' strict' todo -> + (v',strict || strict') :: todo) + v.ltle todo + in + add_from u csts todo) + in + PSet.fold (fun u csts -> + let arc = repr g u in + PMap.fold (fun v strict csts -> add_from u csts [v,strict]) + arc.ltle csts) + kept csts + + let domain g = PMap.domain g.entries + + let choose p g u = + let exception Found of Point.t in + let ru = (repr g u).canon in + if p ru then Some ru + else + try PMap.iter (fun v -> function + | Canonical _ -> () (* we already tried [p ru] *) + | Equiv v' -> + let rv = (repr g v').canon in + if rv == ru && p v then raise (Found v) + (* NB: we could also try [p v'] but it will come up in the + rest of the iteration regardless. *) + ) g.entries; None + with Found v -> Some v + + let sort make_dummy first g = + let cans = + PMap.fold (fun _ u l -> + match u with + | Equiv _ -> l + | Canonical can -> can :: l + ) g.entries [] + in + let cans = List.sort topo_compare cans in + let lowest = + PMap.mapi (fun u _ -> if CList.mem_f Point.equal u first then 0 else 2) + (PMap.filter + (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) + g.entries) + in + let lowest = + List.fold_left (fun lowest can -> + let lvl = PMap.find can.canon lowest in + PMap.fold (fun u' strict lowest -> + let cost = if strict then 1 else 0 in + let u' = (repr g u').canon in + PMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest) + can.ltle lowest) + lowest cans + in + let max_lvl = PMap.fold (fun _ a b -> max a b) lowest 0 in + let types = Array.init (max_lvl + 1) (fun i -> + match List.nth_opt first i with + | Some u -> u + | None -> make_dummy (i-2)) + in + let g = Array.fold_left (fun g u -> + let g, u = safe_repr g u in + change_node g { u with rank = big_rank }) g types + in + let g = if max_lvl > List.length first && not (CList.is_empty first) then + enforce_lt (CList.last first) types.(List.length first) g + else g + in + let g = + PMap.fold (fun u lvl g -> enforce_eq u (types.(lvl)) g) + lowest g + in + normalize g + + (** Pretty-printing *) + + let pr_pmap sep pr map = + let cmp (u,_) (v,_) = Point.compare u v in + Pp.prlist_with_sep sep pr (List.sort cmp (PMap.bindings map)) + + let pr_arc prl = let open Pp in + function + | _, Canonical {canon=u; ltle; _} -> + if PMap.is_empty ltle then mt () + else + prl u ++ str " " ++ + v 0 + (pr_pmap spc (fun (v, strict) -> + (if strict then str "< " else str "<= ") ++ prl v) + ltle) ++ + fnl () + | u, Equiv v -> + prl u ++ str " = " ++ prl v ++ fnl () + + let pr prl g = + pr_pmap Pp.mt (pr_arc prl) g.entries + + (* Dumping constraints to a file *) + + let dump output g = + let dump_arc u = function + | Canonical {canon=u; ltle; _} -> + PMap.iter (fun v strict -> + let typ = if strict then Lt else Le in + output typ u v) ltle; + | Equiv v -> + output Eq u v + in + PMap.iter dump_arc g.entries + +end diff --git a/lib/acyclicGraph.mli b/lib/acyclicGraph.mli new file mode 100644 index 0000000000..b53a4c018f --- /dev/null +++ b/lib/acyclicGraph.mli @@ -0,0 +1,82 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Graphs representing strict orders *) + +type constraint_type = Lt | Le | Eq + +module type Point = sig + type t + + module Set : CSig.SetS with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + + module Constraint : CSet.S with type elt = (t * constraint_type * t) + + val equal : t -> t -> bool + val compare : t -> t -> int + + type explanation = (constraint_type * t) list + val error_inconsistency : constraint_type -> t -> t -> explanation lazy_t option -> 'a + + val pr : t -> Pp.t +end + +module Make (Point:Point) : sig + + type t + + val empty : t + + val check_invariants : required_canonical:(Point.t -> bool) -> t -> unit + + exception AlreadyDeclared + val add : ?rank:int -> Point.t -> t -> t + (** All points must be pre-declared through this function before + they can be mentioned in the others. NB: use a large [rank] to + keep the node canonical *) + + exception Undeclared of Point.t + val check_declared : t -> Point.Set.t -> unit + (** @raise Undeclared if one of the points is not present in the graph. *) + + type 'a check_function = t -> 'a -> 'a -> bool + + val check_eq : Point.t check_function + val check_leq : Point.t check_function + val check_lt : Point.t check_function + + val enforce_eq : Point.t -> Point.t -> t -> t + val enforce_leq : Point.t -> Point.t -> t -> t + val enforce_lt : Point.t -> Point.t -> t -> t + + val constraints_of : t -> Point.Constraint.t * Point.Set.t list + + val constraints_for : kept:Point.Set.t -> t -> Point.Constraint.t + + val domain : t -> Point.Set.t + + val choose : (Point.t -> bool) -> t -> Point.t -> Point.t option + + val sort : (int -> Point.t) -> Point.t list -> t -> t + (** [sort mk first g] builds a totally ordered graph. The output + graph should imply the input graph (and the implication will be + strict most of the time), but is not necessarily minimal. The + lowest points in the result are identified with [first]. + Moreover, it adds levels [Type.n] to identify the points (not in + [first]) at level n. An artificial constraint (last first < mk + (length first)) is added to ensure that they are not merged. + Note: the result is unspecified if the input graph already + contains [mk n] nodes. *) + + val pr : (Point.t -> Pp.t) -> t -> Pp.t + + val dump : (constraint_type -> Point.t -> Point.t -> unit) -> t -> unit +end diff --git a/lib/lib.mllib b/lib/lib.mllib index 206b2504db..2db59712b9 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -11,6 +11,7 @@ Feedback CErrors CWarnings +AcyclicGraph Rtree System Explore 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/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 98aaa081c3..4b6caea70d 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1494,7 +1494,7 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive ~template:None None rel_inds false false false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds false false false ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with | UserError(s,msg) as e -> 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/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 816741b894..ae4cd06022 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -104,7 +104,7 @@ let pr_appl h vs = let rec name_with_list appl t = match appl with | [] -> t - | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) + | (h,vs)::l -> Proofview.Trace.name_tactic (fun _ _ -> pr_appl h vs) (name_with_list l t) let name_if_glob appl t = match appl with | UnnamedAppl -> t @@ -1050,7 +1050,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with return (hov 0 msg , hov 0 msg) in let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in - let log (msg,_) = Proofview.Trace.log (fun () -> msg) in + let log (msg,_) = Proofview.Trace.log (fun _ _ -> msg) in let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in Ftactic.run msgnl begin fun msgnl -> print msgnl <*> log msgnl <*> break @@ -1132,7 +1132,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> - let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in + let name _ _ = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, @@ -1153,7 +1153,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let tac = Tacenv.interp_ml_tactic opn in let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = - let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in + let name _ _ = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) in Ftactic.run args tac @@ -1539,7 +1539,7 @@ and name_atomic ?env tacexpr tac : unit Proofview.tactic = | None -> Proofview.tclENV end >>= fun env -> Proofview.tclEVARMAP >>= fun sigma -> - let name () = Pptactic.pr_atomic_tactic env sigma tacexpr in + let name _ _ = Pptactic.pr_atomic_tactic env sigma tacexpr in Proofview.Trace.name_tactic name tac (* Interprets a primitive tactic *) @@ -1560,7 +1560,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<apply>") begin Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in @@ -1601,7 +1601,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<mutual fix>") begin Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = @@ -1616,7 +1616,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<mutual cofix>") begin Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = @@ -1731,7 +1731,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacChange (None,c,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> let is_onhyps = match cl.onhyps with | None | Some [] -> true @@ -1756,7 +1756,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacChange (Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 4042959b50..eb84b1203d 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -118,6 +118,7 @@ Section MakeRingPol. - (Pinj i (Pc c)) is (Pc c) *) + #[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol @@ -939,6 +940,7 @@ Qed. (** Definition of polynomial expressions *) + #[universes(template)] Inductive PExpr : Type := | PEc : C -> PExpr | PEX : positive -> PExpr diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index f066ea462f..782fab5e68 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -289,6 +289,7 @@ destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). now apply (Rplus_nonneg_nonneg sor). Qed. +#[universes(template)] Inductive Psatz : Type := | PsatzIn : nat -> Psatz | PsatzSquare : PolC -> Psatz @@ -685,6 +686,7 @@ end. Definition eval_pexpr : PolEnv -> PExpr C -> R := PEeval rplus rtimes rminus ropp phi pow_phi rpow. +#[universes(template)] Record Formula (T:Type) : Type := { Flhs : PExpr T; Fop : Op2; diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 458844e1b9..587f2f1fa4 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -21,6 +21,7 @@ Require Import Bool. Set Implicit Arguments. + #[universes(template)] Inductive BFormula (A:Type) : Type := | TT : BFormula A | FF : BFormula A diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 2d2c0bc77a..c888f9af45 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -30,6 +30,7 @@ Section MakeVarMap. Variable A : Type. Variable default : A. + #[universes(template)] Inductive t : Type := | Empty : t | Leaf : A -> t diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 99c02995fb..751f0d8334 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -81,10 +81,12 @@ Section Store. Variable A:Type. +#[universes(template)] Inductive Poption : Type:= PSome : A -> Poption | PNone : Poption. +#[universes(template)] Inductive Tree : Type := Tempty : Tree | Branch0 : Tree -> Tree -> Tree @@ -177,6 +179,7 @@ generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. Qed. +#[universes(template)] Record Store : Type := mkStore {index:positive;contents:Tree}. @@ -191,6 +194,7 @@ Lemma get_empty : forall i, get i empty = PNone. intro i; case i; unfold empty,get; simpl;reflexivity. Qed. +#[universes(template)] Inductive Full : Store -> Type:= F_empty : Full empty | F_push : forall a S, Full S -> Full (push a S). diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index ce115f564f..dba72337b2 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -730,6 +730,7 @@ Qed. (* The input: syntax of a field expression *) +#[universes(template)] Inductive FExpr : Type := | FEO : FExpr | FEI : FExpr @@ -762,6 +763,7 @@ Strategy expand [FEeval]. (* The result of the normalisation *) +#[universes(template)] Record linear : Type := mk_linear { num : PExpr C; denum : PExpr C; @@ -944,6 +946,7 @@ induction e2; intros p1 p2; now rewrite <- PEpow_mul_r. Qed. +#[universes(template)] Record rsplit : Type := mk_rsplit { rsplit_left : PExpr C; rsplit_common : PExpr C; diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index f5db275465..15d490a6ab 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -740,6 +740,7 @@ Ltac abstract_ring_morphism set ext rspec := | _ => fail 1 "bad ring structure" end. +#[universes(template)] Record hypo : Type := mkhypo { hypo_type : Type; hypo_proof : hypo_type diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v index 12208ff6b9..31182f51e2 100644 --- a/plugins/setoid_ring/Ncring_polynom.v +++ b/plugins/setoid_ring/Ncring_polynom.v @@ -32,6 +32,7 @@ Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. with coefficients in C : *) +#[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | PX : Pol -> positive -> positive -> Pol -> Pol. @@ -43,6 +44,7 @@ Definition cI:C . exact ring1. Defined. Definition P1 := Pc 1. Variable Ceqb:C->C->bool. +#[universes(template)] Class Equalityb (A : Type):= {equalityb : A -> A -> bool}. Notation "x =? y" := (equalityb x y) (at level 70, no associativity). Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y). diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index ccd82eabcd..9ef24144d2 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -121,6 +121,7 @@ Section MakeRingPol. - (Pinj i (Pc c)) is (Pc c) *) + #[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol @@ -908,6 +909,7 @@ Section MakeRingPol. (** Definition of polynomial expressions *) + #[universes(template)] Inductive PExpr : Type := | PEO : PExpr | PEI : PExpr diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index d67a8d8dce..6c782269ab 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -540,6 +540,7 @@ Section AddRing. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. *) +#[universes(template)] Inductive ring_kind : Type := | Abstract | Computational diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index 11e282e4f5..dd2c2d0ba4 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -64,38 +64,36 @@ type ast_closure_term = { type ssrview = ast_closure_term list -(* TODO -type id_mod = Hat | HatTilde | Sharp - *) +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.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 + | IPatFastNondep + | 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/ssrbool.v b/plugins/ssr/ssrbool.v index 3a7cf41d43..ed4ff2aa66 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -609,6 +609,7 @@ Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. (** Allow the direct application of a reflection lemma to a boolean assertion. **) Coercion elimT : reflect >-> Funclass. +#[universes(template)] Variant implies P Q := Implies of P -> Q. Lemma impliesP P Q : implies P Q -> P -> Q. Proof. by case. Qed. Lemma impliesPn (P Q : Prop) : implies P Q -> ~ Q -> ~ P. @@ -1130,10 +1131,12 @@ Proof. by move=> *; apply/orP; left. Qed. Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). Proof. by move=> *; apply/orP; right. Qed. +#[universes(template)] Variant mem_pred := Mem of pred T. Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). +#[universes(template)] Structure predType := PredType { pred_sort :> Type; topred : pred_sort -> pred T; @@ -1275,6 +1278,7 @@ Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). implementation of unification, notably improper expansion of telescope projections and overwriting of a variable assignment by a later unification (probably due to conversion cache cross-talk). **) +#[universes(template)] Structure manifest_applicative_pred p := ManifestApplicativePred { manifest_applicative_pred_value :> pred T; _ : manifest_applicative_pred_value = p @@ -1283,18 +1287,21 @@ Definition ApplicativePred p := ManifestApplicativePred (erefl p). Canonical applicative_pred_applicative sp := ApplicativePred (applicative_pred_of_simpl sp). +#[universes(template)] Structure manifest_simpl_pred p := ManifestSimplPred { manifest_simpl_pred_value :> simpl_pred T; _ : manifest_simpl_pred_value = SimplPred p }. Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). +#[universes(template)] Structure manifest_mem_pred p := ManifestMemPred { manifest_mem_pred_value :> mem_pred T; _ : manifest_mem_pred_value= Mem [eta p] }. Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). +#[universes(template)] Structure applicative_mem_pred p := ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. Canonical check_applicative_mem_pred p (ap : manifest_applicative_pred p) mp := @@ -1345,6 +1352,7 @@ End simpl_mem. (** Qualifiers and keyed predicates. **) +#[universes(template)] Variant qualifier (q : nat) T := Qualifier of predPredType T. Coercion has_quality n T (q : qualifier n T) : pred_class := @@ -1392,9 +1400,11 @@ Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) Section KeyPred. Variable T : Type. +#[universes(template)] Variant pred_key (p : predPredType T) := DefaultPredKey. Variable p : predPredType T. +#[universes(template)] Structure keyed_pred (k : pred_key p) := PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. @@ -1426,6 +1436,7 @@ Section KeyedQualifier. Variables (T : Type) (n : nat) (q : qualifier n T). +#[universes(template)] Structure keyed_qualifier (k : pred_key q) := PackKeyedQualifier {unkey_qualifier; _ : unkey_qualifier = q}. Definition KeyedQualifier k := PackKeyedQualifier k (erefl q). 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..4721e19a8b 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. @@ -172,6 +178,7 @@ Register abstract_key as plugins.ssreflect.abstract_key. Register abstract as plugins.ssreflect.abstract. (** Constants for tactic-views **) +#[universes(template)] Inductive external_view : Type := tactic_view of Type. (** @@ -200,6 +207,7 @@ Inductive external_view : Type := tactic_view of Type. Module TheCanonical. +#[universes(template)] Variant put vT sT (v1 v2 : vT) (s : sT) := Put. Definition get vT sT v s (p : @put vT sT v v s) := let: Put _ _ _ := p in s. @@ -295,9 +303,11 @@ Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) We also define a simpler version ("phant" / "Phant") of phantom for the common case where p_type is Type. **) +#[universes(template)] Variant phantom T (p : T) := Phantom. Arguments phantom : clear implicits. Arguments Phantom : clear implicits. +#[universes(template)] Variant phant (p : Type) := Phant. (** Internal tagging used by the implementation of the ssreflect elim. **) @@ -383,6 +393,7 @@ Ltac ssrdone0 := | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. (** To unlock opaque constants. **) +#[universes(template)] Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. 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/ssrfun.v b/plugins/ssr/ssrfun.v index 6535cad8b7..b51ffada0c 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -285,6 +285,7 @@ Lemma unitE : all_equal_to tt. Proof. by case. Qed. (** A generic wrapper type **) +#[universes(template)] Structure wrapped T := Wrap {unwrap : T}. Canonical wrap T x := @Wrap T x. @@ -334,6 +335,7 @@ Section SimplFun. Variables aT rT : Type. +#[universes(template)] Variant simpl_fun := SimplFun of aT -> rT. Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 8cebe62e16..257ecd2a85 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 diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 18b4aeab1e..ce81d83661 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 (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,111 @@ 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 id -> Ssrcommon.tclINTRO_ID id <*> notTAC + | IPatFastNondep -> intro_anon_deps <*> 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 _ | IPatFastNondep | 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 +466,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,7 +508,7 @@ 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 -> @@ -356,7 +520,7 @@ 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 @@ -369,12 +533,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 +550,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 +568,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 +668,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 +695,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 +715,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,7 +857,7 @@ 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 + | None -> IPatAnon (One None) | Some id -> IPatId id) (List.tl gens) in conclusion ipats diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index c9221ef758..76726009ac 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -608,15 +608,15 @@ let ipat_of_intro_pattern p = Tactypes.( | IntroNaming (IntroIdentifier id) -> IPatId 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)] @@ -629,15 +629,21 @@ 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 + | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop | IPatFastNondep) as x -> x | IPatId id -> IPatId (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,6 +694,18 @@ 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 -> ipat_of_intro_pattern (interp_introid ist gl id) @@ -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 *) + | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop | IPatFastNondep) as x -> x + | 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))] } - *) + | [ ">" ] -> { [IPatFastNondep] } | [ ident(id) ] -> { [IPatId id] } - | [ "?" ] -> { [IPatAnon One] } -(* TODO | [ "+" ] -> [ [IPatAnon Temporary] ] *) + | [ "?" ] -> { [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 @@ -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 + List.map (function {v=Name id} -> IPatId id | _ -> IPatAnon (One None)) ids | (FwdPose, [BFdef]), { v = CLetIn ({v=Name id},_,_,_) } -> [IPatId id] - | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon One] + | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon (One None)] | _ -> anomaly "ssrbinder is not a binder")) let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = @@ -1968,7 +1996,8 @@ GRAMMAR EXTEND Gram ssreqpat: [ [ id = Prim.ident -> { IPatId 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..898e03b00e 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -100,21 +100,27 @@ let rec pr_ipat p = | IPatId id -> 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 "+" *) + | IPatFastNondep -> 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/pfedit.ml b/proofs/pfedit.ml index e2b7df19de..7f1ae6d12b 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -107,11 +107,14 @@ let solve ?with_end_tac gi info_lvl tac pr = Proofview.tclTHEN tac Refine.solve_constraints else tac in - let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in + let env = Global.env () in + let (p,(status,info)) = Proof.run_tactic env tac pr in + let env = Global.env () in + let sigma = Evd.from_env env in let () = match info_lvl with | None -> () - | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) + | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) in (p,status) with diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 8077da8807..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; @@ -339,6 +340,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now Proof.in_proof proof (fun m -> Evd.existential_opt_value0 m k) in let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst universes) in + let make_body = if poly || now then let make_body t (c, eff) = @@ -386,14 +388,21 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now fun t p -> (* Already checked the univ_decl for the type universes when starting the proof. *) let univctx = Entries.Monomorphic_const_entry (UState.context_set universes) in - Future.from_val (univctx, nf t), + let t = nf t in + Future.from_val (univctx, t), Future.chain p (fun (pt,eff) -> (* Deferred proof, we already checked the universe declaration with the initial universes, ensure that the final universes respect the declaration as well. If the declaration is non-extensible, this will prevent the body from adding universes and constraints. *) - let bodyunivs = constrain_variables (Future.force univs) in - let univs = UState.check_mono_univ_decl bodyunivs universe_decl in + let univs = Future.force univs in + let univs = constrain_variables univs in + let used_univs = Univ.LSet.union + (Vars.universes_of_constr t) + (Vars.universes_of_constr pt) + in + let univs = UState.restrict univs used_univs in + let univs = UState.check_mono_univ_decl univs universe_decl in (pt,univs),eff) in let entry_fn p (_, t) = 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/refine.ml b/proofs/refine.ml index d812a8cad7..1d796fece5 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -107,8 +107,8 @@ let generic_refine ~typecheck f gl = (* Mark goals *) let sigma = Proofview.Unsafe.mark_as_goals sigma comb in let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in - let trace () = Pp.(hov 2 (str"simple refine"++spc()++ - Termops.Internal.print_constr_env env sigma c)) in + let trace env sigma = Pp.(hov 2 (str"simple refine"++spc()++ + Termops.Internal.print_constr_env env sigma c)) in Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v -> Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*> Proofview.Unsafe.tclEVARS sigma <*> 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/tactics/auto.ml b/tactics/auto.ml index f5c3619e64..2619620eb8 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -215,11 +215,15 @@ let tclLOG (dbg,_,depth,trace) pp tac = let s = String.make (depth+1) '*' in Proofview.(tclIFCATCH ( tac >>= fun v -> - Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); + tclENV >>= fun env -> + tclEVARMAP >>= fun sigma -> + Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*success*)"); tclUNIT v - ) Proofview.tclUNIT + ) tclUNIT (fun (exn, info) -> - Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); + tclENV >>= fun env -> + tclEVARMAP >>= fun sigma -> + Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*fail*)"); tclZERO ~info exn)) | Info -> (* For "info (trivial/auto)", we store a log trace *) @@ -248,12 +252,12 @@ and erase_subtree depth = function | [] -> [] | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l -let pr_info_atom (d,pp) = - str (String.make d ' ') ++ pp () ++ str "." +let pr_info_atom env sigma (d,pp) = + str (String.make d ' ') ++ pp env sigma ++ str "." -let pr_info_trace = function +let pr_info_trace env sigma = function | (Info,_,_,{contents=(d,Some pp)::l}) -> - Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) + Feedback.msg_info (prlist_with_sep fnl (pr_info_atom env sigma) (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function @@ -269,8 +273,12 @@ let pr_dbg_header = function let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in - let tac = delay (fun () -> pr_dbg_header d; tac) >>= - fun () -> pr_info_trace d; Proofview.tclUNIT () in + let tac = + delay (fun () -> pr_dbg_header d; tac) >>= fun () -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + pr_info_trace env sigma d; + Proofview.tclUNIT () in let after = delay (fun () -> pr_info_nop d; Proofview.tclUNIT ()) in Tacticals.New.tclORELSE0 tac after @@ -300,8 +308,8 @@ let exists_evaluable_reference env = function | EvalConstRef _ -> true | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false -let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro -let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption +let dbg_intro dbg = tclLOG dbg (fun _ _ -> str "intro") intro +let dbg_assumption dbg = tclLOG dbg (fun _ _ -> str "assumption") assumption let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = @@ -385,12 +393,11 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= | Extern tacast -> conclPattern concl p tacast in - let pr_hint () = + let pr_hint env sigma = let origin = match dbname with | None -> mt () | Some n -> str " (in " ++ str n ++ str ")" in - let sigma, env = Pfedit.get_current_context () in pr_hint env sigma t ++ origin in tclLOG dbg pr_hint (run_hint t tactic) 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..1043c50f00 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -889,11 +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)) - in - let trace () = - let sigma, env = Pfedit.get_current_context () in - trace env sigma + Pp.(hov 2 (Ppred.pr_red_expr_env env sigma pr str redexp)) in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter begin fun gl -> @@ -1063,9 +1059,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/bugs/closed/bug_9229.v b/test-suite/bugs/closed/bug_9229.v new file mode 100644 index 0000000000..7514741af4 --- /dev/null +++ b/test-suite/bugs/closed/bug_9229.v @@ -0,0 +1,6 @@ +(* There was a problem of freshness with Infix choice of vars *) + +(* In particular, x and y were special... *) + +Infix "#" := (fun x y => x + y) (at level 50, left associativity). +Check (3 # 5). 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/output/Cases.v b/test-suite/output/Cases.v index 43718a0f07..4e949dcb04 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -43,6 +43,7 @@ Print foo. (* Accept and use notation with binded parameters *) +#[universes(template)] Inductive I (A: Type) : Type := C : A -> I A. Notation "x <: T" := (C T x) (at level 38). @@ -83,6 +84,7 @@ Print f. (* Was enhancement request #5142 (error message reported on the most general return clause heuristic) *) +#[universes(template)] Inductive gadt : Type -> Type := | gadtNat : nat -> gadt nat | gadtTy : forall T, T -> gadt T. diff --git a/test-suite/output/Coercions.v b/test-suite/output/Coercions.v index 0e84bf3966..6976f35a88 100644 --- a/test-suite/output/Coercions.v +++ b/test-suite/output/Coercions.v @@ -1,7 +1,7 @@ (* Submitted by Randy Pollack *) -Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. -Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. +#[universes(template)] Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. +#[universes(template)] Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. Section testSection. Variables (S : Set) (P : pred S) (R : rel S) (x : S). diff --git a/test-suite/output/Extraction_matchs_2413.v b/test-suite/output/Extraction_matchs_2413.v index 1ecd9771eb..f9398fdca9 100644 --- a/test-suite/output/Extraction_matchs_2413.v +++ b/test-suite/output/Extraction_matchs_2413.v @@ -101,7 +101,7 @@ Section decoder_result. Variable inst : Type. - Inductive decoder_result : Type := + #[universes(template)] Inductive decoder_result : Type := | DecUndefined : decoder_result | DecUnpredictable : decoder_result | DecInst : inst -> decoder_result diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index 61ae4edbd1..9b25c2dbd3 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -44,7 +44,7 @@ fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). omega. Qed. -CoInductive Inf := S { projS : Inf }. +#[universes(template)] CoInductive Inf := S { projS : Inf }. Definition expand_Inf (x : Inf) := S (projS x). CoFixpoint inf := S inf. Eval compute in inf. diff --git a/test-suite/output/Inductive.v b/test-suite/output/Inductive.v index 8ff91268a6..9eec9a7dad 100644 --- a/test-suite/output/Inductive.v +++ b/test-suite/output/Inductive.v @@ -3,5 +3,5 @@ Fail Inductive list' (A:Set) : Set := | cons' : A -> list' A -> list' (A*A). (* Check printing of let-ins *) -Inductive foo (A : Type) (x : A) (y := x) := Foo. +#[universes(template)] Inductive foo (A : Type) (x : A) (y := x) := Foo. Print foo. diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 15211f1233..2caffad1d9 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -123,7 +123,7 @@ Check fun n => foo4 n (fun x y z => (fun _ => y=0) z). (**********************************************************************) (* Test printing of #4932 *) -Inductive ftele : Type := +#[universes(template)] Inductive ftele : Type := | fb {T:Type} : T -> ftele | fr {T} : (T -> ftele) -> ftele. diff --git a/test-suite/output/PatternsInBinders.v b/test-suite/output/PatternsInBinders.v index d671053c07..0c1b08f5a3 100644 --- a/test-suite/output/PatternsInBinders.v +++ b/test-suite/output/PatternsInBinders.v @@ -53,7 +53,7 @@ Module Suboptimal. (** This test shows an example which exposes the [let] introduced by the pattern notation in binders. *) -Inductive Fin (n:nat) := Z : Fin n. +#[universes(template)] Inductive Fin (n:nat) := Z : Fin n. Definition F '(n,p) : Type := (Fin n * Fin p)%type. Definition both_z '(n,p) : F (n,p) := (Z _,Z _). Print both_z. diff --git a/test-suite/output/Projections.v b/test-suite/output/Projections.v index 098a518dc4..2713e6a188 100644 --- a/test-suite/output/Projections.v +++ b/test-suite/output/Projections.v @@ -5,7 +5,7 @@ Class HostFunction := host_func : Type. Section store. Context `{HostFunction}. - Record store := { store_funcs : host_func }. + #[universes(template)] Record store := { store_funcs : host_func }. End store. Check (fun (S:@store nat) => S.(store_funcs)). diff --git a/test-suite/output/Record.v b/test-suite/output/Record.v index d9a649fadc..4fe7b051f8 100644 --- a/test-suite/output/Record.v +++ b/test-suite/output/Record.v @@ -20,12 +20,12 @@ Check {| field := 5 |}. Check build_r 5. Check build_c 5. -Record N := C { T : Type; _ : True }. +#[universes(template)] Record N := C { T : Type; _ : True }. Check fun x:N => let 'C _ p := x in p. Check fun x:N => let 'C T _ := x in T. Check fun x:N => let 'C T p := x in (T,p). -Record M := D { U : Type; a := 0; q : True }. +#[universes(template)] Record M := D { U : Type; a := 0; q : True }. Check fun x:M => let 'D T _ p := x in p. Check fun x:M => let 'D T _ p := x in T. Check fun x:M => let 'D T p := x in (T,p). diff --git a/test-suite/output/ShowMatch.v b/test-suite/output/ShowMatch.v index 9cf6ad35b8..99183f2064 100644 --- a/test-suite/output/ShowMatch.v +++ b/test-suite/output/ShowMatch.v @@ -3,12 +3,12 @@ *) Module A. - Inductive foo := f. + #[universes(template)] Inductive foo := f. Show Match foo. (* no need to disambiguate *) End A. Module B. - Inductive foo := f. + #[universes(template)] Inductive foo := f. (* local foo shadows A.foo, so constructor "f" needs disambiguation *) Show Match A.foo. End B. diff --git a/test-suite/output/Warnings.v b/test-suite/output/Warnings.v index 7465442cab..0eb5db1733 100644 --- a/test-suite/output/Warnings.v +++ b/test-suite/output/Warnings.v @@ -1,5 +1,5 @@ (* Term in warning was not printed in the right environment at some time *) -Record A := { B:Type; b:B->B }. +#[universes(template)] Record A := { B:Type; b:B->B }. Definition a B := {| B:=B; b:=fun x => x |}. Canonical Structure a. diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 57a4739e9f..209fedc343 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -21,6 +21,6 @@ Print P. (* Note: exact numbers of evars are not important... *) -Inductive T (n:nat) : Type := A : T n. +#[universes(template)] Inductive T (n:nat) : Type := A : T n. Check fun n (y:=A n:T n) => _ _ : T n. Check fun n => _ _ : T n. 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_fast_any.v b/test-suite/ssr/ipat_fast_any.v new file mode 100644 index 0000000000..a50984c7c0 --- /dev/null +++ b/test-suite/ssr/ipat_fast_any.v @@ -0,0 +1,21 @@ +Require Import ssreflect. + +Goal forall y x : nat, x = y -> x = x. +Proof. +move=> + > ->. match goal with |- forall y, y = y => by [] end. +Qed. + +Goal forall y x : nat, le x y -> x = y. +Proof. +move=> > [|]. + by []. +match goal with |- forall a, _ <= a -> _ = S a => admit end. +Admitted. + +Goal forall y x : nat, le x y -> x = y. +Proof. +move=> y x. +case E: x => >. + admit. +match goal with |- S _ <= y -> S _ = y => admit end. +Admitted. diff --git a/test-suite/ssr/ipat_fastid.v b/test-suite/ssr/ipat_fastid.v new file mode 100644 index 0000000000..b0985a0d2f --- /dev/null +++ b/test-suite/ssr/ipat_fastid.v @@ -0,0 +1,48 @@ +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. + +Lemma simple2 : + forall x, 3 <= x -> forall y, odd (y+x) -> x = y -> True. +Proof. +move=> >; move=>x_ge_3; move=> >; move=>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 harder2 : forall x, stuff x. +Proof. +move=> >; move=>x_ge_3;move=> >; move=>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/test-suite/stm/delayed_restrict_univs_9093.v b/test-suite/stm/delayed_restrict_univs_9093.v new file mode 100644 index 0000000000..6ca36da4b0 --- /dev/null +++ b/test-suite/stm/delayed_restrict_univs_9093.v @@ -0,0 +1,10 @@ +(* -*- coq-prog-args: ("-async-proofs" "on"); -*- *) + +Unset Universe Polymorphism. + +Ltac exact0 := let x := constr:(Type) in exact 0. + +Lemma lemma_restrict_abstract@{} : (nat * nat)%type. +Proof. split;[exact 0|abstract exact0]. Qed. +(* Debug: 10237:proofworker:0:0 STM: sending back a fat state +Error: Universe {polymorphism.1} is unbound. *) diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 86a3a88be9..4b97d75cea 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -283,6 +283,7 @@ Local Open Scope list_scope. (** A compact representation of non-dependent arities, with the codomain singled-out. *) (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) +#[universes(template)] Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist. Local Infix "::" := Tcons. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 2673a11917..e6968bd6c2 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -27,6 +27,7 @@ Require Export Coq.Classes.Morphisms. (** A setoid wraps an equivalence. *) +#[universes(template)] Class Setoid A := { equiv : relation A ; setoid_equiv :> Equivalence equiv }. @@ -128,6 +129,7 @@ Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper ( (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) +#[universes(template)] Class PartialSetoid (A : Type) := { pequiv : relation A ; pequiv_prf :> PER pequiv }. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 8fc04d81e6..9a815d2a7e 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -53,6 +53,7 @@ Variable elt : Type. The fifth field of [Node] is the height of the tree *) +#[universes(template)] Inductive tree := | Leaf : tree | Node : tree -> key -> elt -> tree -> int -> tree. @@ -235,6 +236,7 @@ Fixpoint join l : key -> elt -> t -> t := - [o] is the result of [find x m]. *) +#[universes(template)] Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). @@ -291,6 +293,7 @@ Variable cmp : elt->elt->bool. (** ** Enumeration of the elements of a tree *) +#[universes(template)] Inductive enumeration := | End : enumeration | More : key -> elt -> t -> enumeration -> enumeration. @@ -1817,6 +1820,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Module Raw := Raw I X. Import Raw.Proofs. + #[universes(template)] Record bst (elt:Type) := Bst {this :> Raw.tree elt; is_bst : Raw.bst this}. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 950b30ee4d..7bc9edff8d 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -451,6 +451,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Import Raw. Import Raw.Proofs. + #[universes(template)] Record bbst (elt:Type) := Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 6ca158a277..4febd64842 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -1024,6 +1024,7 @@ Module E := X. Definition key := E.t. +#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. Definition t (elt:Type) : Type := slist elt. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 0fc68b1433..b47c99244b 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -73,6 +73,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Definition key := positive : Type. + #[universes(template)] Inductive tree (A : Type) := | Leaf : tree A | Node : tree A -> option A -> tree A -> tree A. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 03dce9666d..a923f4e6f9 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -869,6 +869,7 @@ Module Make (X: DecidableType) <: WS with Module E:=X. Module E := X. Definition key := E.t. +#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. Definition t (elt:Type) := slist elt. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 7f0387dd12..3603604a71 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -167,6 +167,7 @@ Register S as num.nat.S. (** [option A] is the extension of [A] with an extra element [None] *) +#[universes(template)] Inductive option (A:Type) : Type := | Some : A -> option A | None : option A. @@ -186,6 +187,7 @@ Definition option_map (A B:Type) (f:A->B) (o : option A) : option B := (** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *) +#[universes(template)] Inductive sum (A B:Type) : Type := | inl : A -> sum A B | inr : B -> sum A B. @@ -198,6 +200,7 @@ Arguments inr {A B} _ , A [B] _. (** [prod A B], written [A * B], is the product of [A] and [B]; the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *) +#[universes(template)] Inductive prod (A B:Type) : Type := pair : A -> B -> A * B @@ -256,6 +259,7 @@ Defined. (** Polymorphic lists and some operations *) +#[universes(template)] Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. @@ -384,6 +388,7 @@ Proof. intros. apply CompareSpec2Type; assumption. Defined. member is the singleton datatype [identity A a a] whose sole inhabitant is denoted [identity_refl A a] *) +#[universes(template)] Inductive identity (A:Type) (a:A) : A -> Type := identity_refl : identity a a. Hint Resolve identity_refl: core. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index e4796a8059..cfba2bae69 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -24,6 +24,7 @@ Require Import Logic. Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset of elements of the type [A] which satisfy both [P] and [Q]. *) +#[universes(template)] Inductive sig (A:Type) (P:A -> Prop) : Type := exist : forall x:A, P x -> sig P. @@ -31,12 +32,14 @@ Register sig as core.sig.type. Register exist as core.sig.intro. Register sig_rect as core.sig.rect. +#[universes(template)] Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := exist2 : forall x:A, P x -> Q x -> sig2 P Q. (** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *) +#[universes(template)] Inductive sigT (A:Type) (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P. @@ -44,6 +47,7 @@ Register sigT as core.sigT.type. Register existT as core.sigT.intro. Register sigT_rect as core.sigT.rect. +#[universes(template)] Inductive sigT2 (A:Type) (P Q:A -> Type) : Type := existT2 : forall x:A, P x -> Q x -> sigT2 P Q. @@ -700,6 +704,7 @@ Register sumbool as core.sumbool.type. (** [sumor] is an option type equipped with the justification of why it may not be a regular value *) +#[universes(template)] Inductive sumor (A:Type) (B:Prop) : Type := | inleft : A -> A + {B} | inright : B -> A + {B} diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index 57f558de50..d93816e9ff 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -78,6 +78,7 @@ Section DependentMemoFunction. Variable A: nat -> Type. Variable f: forall n, A n. +#[universes(template)] Inductive memo_val: Type := memo_mval: forall n, A n -> memo_val. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 8a01b8fb19..a03799959e 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -16,6 +16,7 @@ Section Streams. Variable A : Type. +#[universes(template)] CoInductive Stream : Type := Cons : A -> Stream -> Stream. diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v index 02c8998a8d..a70bd92329 100644 --- a/theories/Logic/ExtensionalityFacts.v +++ b/theories/Logic/ExtensionalityFacts.v @@ -40,6 +40,7 @@ Definition is_inverse A B f g := (forall a:A, g (f a) = a) /\ (forall b:B, f (g (** The diagonal over A and the one-one correspondence with A *) +#[universes(template)] Record Delta A := { pi1:A; pi2:A; eq:pi1=pi2 }. Definition delta {A} (a:A) := {|pi1 := a; pi2 := a; eq := eq_refl a |}. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index ac2a143472..13e1dad361 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -208,6 +208,7 @@ Definition concat s1 s2 := - [present] is [true] if and only if [s] contains [x]. *) +#[universes(template)] Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 888f9850c1..a3dcca7dfd 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -48,6 +48,7 @@ Module Type Ops (X:OrderedType)(Info:InfoTyp). Definition elt := X.t. Hint Transparent elt : core. +#[universes(template)] Inductive tree : Type := | Leaf : tree | Node : Info.t -> tree -> X.t -> tree -> tree. @@ -167,6 +168,7 @@ end. (** Enumeration of the elements of a tree. This corresponds to the "samefringe" notion in the litterature. *) +#[universes(template)] Inductive enumeration := | End : enumeration | More : elt -> tree -> enumeration -> enumeration. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index a4bbaef52d..0ba2799bfb 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -439,6 +439,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Definition elt := E.t. +#[universes(template)] Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. Definition t := t_. Arguments Mkt this {is_ok}. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 951a4ef2b0..9f718cba65 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -28,6 +28,7 @@ Local Open Scope Z_scope. Module ZnZ. + #[universes(template)] Class Ops (t:Type) := MkOps { (* Conversion functions with Z *) diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index fe0476e4de..b6441bb76a 100644 --- a/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -22,6 +22,7 @@ Section Carry. Variable A : Type. + #[universes(template)] Inductive carry := | C0 : A -> carry | C1 : A -> carry. @@ -44,6 +45,7 @@ Section Zn2Z. first. *) + #[universes(template)] Inductive zn2z := | W0 : zn2z | WW : znz -> znz -> zn2z. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index cf42ed18db..5ae933d433 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -257,6 +257,7 @@ Ltac blocked t := block_goal ; t ; unblock_goal. be used by the [equations] resolver. It is especially useful to register the dependent elimination principles for things in [Prop] which are not automatically generated. *) +#[universes(template)] Class DependentEliminationPackage (A : Type) := { elim_type : Type ; elim : elim_type }. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index ceac021ef2..49a485c741 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -137,6 +137,7 @@ Definition IsStepFun (f:R -> R) (a b:R) : Type := { l:Rlist & is_subdivision f a b l }. (** ** Class of step functions *) +#[universes(template)] Record StepFun (a b:R) : Type := mkStepFun {fe :> R -> R; pre : IsStepFun fe a b}. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index e3e995d201..b6b72de889 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -116,6 +116,7 @@ Qed. (*******************************) (*********) +#[universes(template)] Record Metric_Space : Type := {Base : Type; dist : Base -> Base -> R; diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index 171dba5522..f94b5cab65 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -380,6 +380,7 @@ Proof. apply Rinv_0_lt_compat; prove_sup0. Qed. +#[universes(template)] Record family : Type := mkfamily {ind : R -> Prop; f :> R -> R -> Prop; diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 61fe55770b..2ed422ffe9 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -100,9 +100,11 @@ Hint Resolve Totally_ordered_definition Upper_Bound_definition Section Specific_orders. Variable U : Type. + #[universes(template)] Record Cpo : Type := Definition_of_cpo {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}. + #[universes(template)] Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index a79ddead20..6a8a3014c3 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -22,6 +22,7 @@ Section multiset_defs. Hypothesis eqA_equiv : Equivalence eqA. Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}. + #[universes(template)] Inductive multiset : Type := Bag : (A -> nat) -> multiset. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 17fc0ed25e..5b51c7b953 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -36,6 +36,7 @@ Section Partial_orders. Definition Rel := Relation U. + #[universes(template)] Record PO : Type := Definition_of_PO { Carrier_of : Ensemble U; Rel_of : Relation U; diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 6a22501afa..f5cda792ce 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -42,6 +42,7 @@ Section defs. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. + #[universes(template)] Inductive Tree := | Tree_Leaf : Tree | Tree_Node : A -> Tree -> Tree -> Tree. @@ -128,6 +129,7 @@ Section defs. (** ** Merging two sorted lists *) + #[universes(template)] Inductive merge_lem (l1 l2:list A) : Type := merge_exist : forall l:list A, @@ -201,6 +203,7 @@ Section defs. (** ** Specification of heap insertion *) + #[universes(template)] Inductive insert_spec (a:A) (T:Tree) : Type := insert_exist : forall T1:Tree, @@ -234,6 +237,7 @@ Section defs. (** ** Building a heap from a list *) + #[universes(template)] Inductive build_heap (l:list A) : Type := heap_exist : forall T:Tree, @@ -258,6 +262,7 @@ Section defs. (** ** Building the sorted list *) + #[universes(template)] Inductive flat_spec (T:Tree) : Type := flat_exist : forall l:list A, diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 7f96aa6b87..906cf79ca9 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -28,6 +28,7 @@ Local Open Scope nat_scope. (** A vector is a list of size n whose elements belong to a set A. *) +#[universes(template)] Inductive t A : nat -> Type := |nil : t A 0 |cons : forall (h:A) (n:nat), t A n -> t A (S n). diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index fd363d02ca..cf46657d36 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -18,6 +18,7 @@ Section WellOrdering. Variable A : Type. Variable B : A -> Type. + #[universes(template)] Inductive WO : Type := sup : forall (a:A) (f:B a -> WO), WO. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 1e35370d29..0b0ed48d51 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -212,6 +212,7 @@ Module MoreInt (Import I:Int). | EZofI : ExprI -> ExprZ | EZraw : Z -> ExprZ. + #[universes(template)] Inductive ExprP : Type := | EPeq : ExprZ -> ExprZ -> ExprP | EPlt : ExprZ -> ExprZ -> ExprP diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 4af6415a4d..348e76da62 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -34,6 +34,13 @@ module RelDecl = Context.Rel.Declaration (* 3b| Mutual inductive definitions *) +let warn_auto_template = + CWarnings.create ~name:"auto-template" ~category:"vernacular" + (fun id -> + Pp.(strbrk "Automatically declaring " ++ Id.print id ++ + strbrk " as template polymorphic. Use attributes or " ++ + strbrk "disable Auto Template Polymorphism to avoid this warning.")) + let should_auto_template = let open Goptions in let auto = ref true in @@ -44,7 +51,10 @@ let should_auto_template = optread = (fun () -> !auto); optwrite = (fun b -> auto := b); } in - fun () -> !auto + fun id would_auto -> + let b = !auto && would_auto in + if b then warn_auto_template id; + b let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) @@ -431,8 +441,8 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); template | None -> - should_auto_template () && not poly && - Option.cata (fun s -> not (Sorts.is_small s)) false concl + should_auto_template ind.ind_name (not poly && + Option.cata (fun s -> not (Sorts.is_small s)) false concl) in { mind_entry_typename = ind.ind_name; mind_entry_arity = arity; diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 9df8f7c341..1d6f652385 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -46,7 +46,10 @@ val declare_mutual_inductive_with_eliminations : mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> MutInd.t -val should_auto_template : unit -> bool +val should_auto_template : Id.t -> bool -> bool +(** [should_auto_template x b] is [true] when [b] is [true] and we + automatically use template polymorphism. [x] is the name of the + inductive under consideration. *) (** Exported for Funind *) diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 4e79b50b79..3da12e7714 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1563,14 +1563,17 @@ let add_notation_extra_printing_rule df k v = (* Infix notations *) -let inject_var x = CAst.make @@ CRef (qualid_of_ident (Id.of_string x),None) +let inject_var x = CAst.make @@ CRef (qualid_of_ident x,None) let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = check_infix_modifiers modifiers; (* check the precedence *) - let metas = [inject_var "x"; inject_var "y"] in + let vars = names_of_constr_expr pr in + let x = Namegen.next_ident_away (Id.of_string "x") vars in + let y = Namegen.next_ident_away (Id.of_string "y") vars in + let metas = [inject_var x; inject_var y] in let c = mkAppC (pr,metas) in - let df = CAst.make ?loc @@ "x "^(quote_notation_token inf)^" y" in + let df = CAst.make ?loc @@ Id.to_string x ^" "^(quote_notation_token inf)^" "^Id.to_string y in add_notation local env c (df,modifiers) sc (**********************************************************************) 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); diff --git a/vernac/record.ml b/vernac/record.ml index ffd4f654c6..2867ad1437 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -415,9 +415,9 @@ let declare_structure finite ubinders univs paramimpls params template ?(kind=St template | None, template -> (* auto detect template *) - ComInductive.should_auto_template () && template && not poly && + ComInductive.should_auto_template id (template && not poly && let _, s = Reduction.dest_arity (Global.env()) arity in - not (Sorts.is_small s) + not (Sorts.is_small s)) in { mind_entry_typename = id; mind_entry_arity = arity; |