diff options
459 files changed, 5227 insertions, 5557 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 324889ec90..98fe2546b5 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -24,6 +24,7 @@ /.travis.yml @coq/ci-maintainers /.gitlab-ci.yml @coq/ci-maintainers /Makefile.ci @coq/ci-maintainers +/dev/ci/nix @coq/nix-maintainers /dev/ci/user-overlays/*.sh @ghost # Trick to avoid getting review requests @@ -95,16 +96,11 @@ /engine/uState.* @SkySkimmer # Secondary maintainer @mattam82 -########## Grammar macros ########## - -/grammar/ @ppedrot -# Secondary maintainer @maximedenes - ########## CoqIDE ########## /ide/ @ppedrot /test-suite/ide/ @ppedrot -# Secondary maintainer @gares +# Secondary maintainers @gares @herbelin ########## Interpretation ########## @@ -131,8 +127,9 @@ ########## Parser ########## -/parsing/ @herbelin -# Secondary maintainer @mattam82 +/coqpp/ @coq/parsing-maintainers +/gramlib/ @coq/parsing-maintainers +/parsing/ @coq/parsing-maintainers ########## Plugins ########## @@ -165,15 +162,11 @@ /plugins/setoid_ring/ @amahboubi # Secondary maintainer @bgregoir -/plugins/ssrmatching/ @gares -# Secondary maintainer @maximedenes +/plugins/ssrmatching/ @coq/ssreflect-maintainers +/plugins/ssr/ @coq/ssreflect-maintainers +/test-suite/ssr/ @coq/ssreflect-maintainers -/plugins/ssr/ @gares -/test-suite/ssr/ @gares -# Secondary maintainer @maximedenes - -/plugins/syntax/ @ppedrot -# Secondary maintainer @maximedenes +/plugins/syntax/ @coq/parsing-maintainers /plugins/rtauto/ @PierreCorbineau # Secondary maintainer @herbelin @@ -273,16 +266,6 @@ /theories/Vectors/ @herbelin -########## Dune ########## - -/.ocamlinit @ejgallego -/Makefile.dune @ejgallego -/tools/coq_dune* @ejgallego -/dune* @ejgallego -/coq.opam @ejgallego -/ide/coqide.opam @ejgallego -# Secondary maintainer @Zimmi48 - ########## Tools ########## /tools/coqdoc/ @silene @@ -319,6 +302,8 @@ /vernac/ @mattam82 # Secondary maintainer @maximedenes +/vernac/metasyntax.* @coq/parsing-maintainers + ########## Test suite ########## /test-suite/Makefile @gares @@ -357,3 +342,10 @@ /dev/tools/update-compat.py @JasonGross /test-suite/tools/update-compat/ @JasonGross # Secondary maintainer @Zimmi48 + +########## Dune ########## + +/.ocamlinit @ejgallego +*dune* @ejgallego +*.opam @ejgallego +# Secondary maintainer @Zimmi48 diff --git a/.gitignore b/.gitignore index e513837445..da675309e5 100644 --- a/.gitignore +++ b/.gitignore @@ -165,6 +165,9 @@ user-contrib plugins/ssr/ssrparser.ml plugins/ssr/ssrvernac.ml +# gramlib__pack +gramlib__pack + # ocaml dev files .merlin META.coq diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d866882dbd..45597851ef 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-10-30-V1" + CACHEKEY: "bionic_coq-V2018-11-08-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -82,7 +82,7 @@ after_script: - echo 'end:coq:build' - echo 'start:coq.install' - - make install + - make install install-byte $EXTRA_INSTALL - make install-byte - cp bin/fake_ide _install_ci/bin/ - echo 'end:coq.install' @@ -196,6 +196,7 @@ build:base: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" # coqdoc for stdlib, until we know how to build it from installed Coq EXTRA_TARGET: "stdlib" + EXTRA_INSTALL: "install-doc-stdlib-html install-doc-printable" # no coqide for 32bit: libgtk installation problems build:base+32bit: @@ -362,7 +363,7 @@ validate:edge+flambda: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" -ci-aac-tactics: +ci-aac_tactics: <<: *ci-template ci-bedrock2: @@ -378,7 +379,7 @@ ci-color: ci-compcert: <<: *ci-template-flambda -ci-coq-dpdgraph: +ci-coq_dpdgraph: <<: *ci-template ci-coquelicot: @@ -414,6 +415,9 @@ ci-formal-topology: ci-geocoq: <<: *ci-template-flambda +ci-coqhammer: + <<: *ci-template + ci-hott: <<: *ci-template @@ -429,10 +433,10 @@ ci-math-comp: ci-mtac2: <<: *ci-template -ci-pidetop: +ci-paramcoq: <<: *ci-template -ci-plugin-tutorial: +ci-plugin_tutorial: <<: *ci-template ci-quickchick: diff --git a/.merlin.in b/.merlin.in index 404a7e7935..db7259dd6f 100644 --- a/.merlin.in +++ b/.merlin.in @@ -40,6 +40,8 @@ S API B API S ide B ide +S gramlib__pack +B gramlib__pack S tools B tools @@ -51,4 +53,4 @@ B dev S plugins/** B plugins/** -PKG threads.posix camlp5 +PKG threads.posix diff --git a/.travis.yml b/.travis.yml index 6f625b1c75..02b94f4a8e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,7 +20,6 @@ env: - NJOBS=2 - COMPILER="4.07.0" - DUNE_VER=".1.2.1" - - CAMLP5_VER=".7.06" - FINDLIB_VER=".1.8.0" - LABLGTK="lablgtk.2.18.6 conf-gtksourceview.2" - NATIVE_COMP="yes" @@ -56,7 +55,7 @@ matrix: - opam switch "$COMPILER" && opam update - eval $(opam config env) - opam config list - - opam install -j "$NJOBS" -y num ocamlfind${FINDLIB_VER} dune${DUNE_VER} camlp5${CAMLP5_VER} ${EXTRA_OPAM} + - opam install -j "$NJOBS" -y num ocamlfind${FINDLIB_VER} dune${DUNE_VER} ${EXTRA_OPAM} - opam list - if: NOT (type = pull_request) @@ -81,7 +80,7 @@ matrix: - opam switch "$COMPILER" && opam update - eval $(opam config env) - opam config list - - opam install -j "$NJOBS" -y num ocamlfind${FINDLIB_VER} dune${DUNE_VER} camlp5${CAMLP5_VER} ${EXTRA_OPAM} + - opam install -j "$NJOBS" -y num ocamlfind${FINDLIB_VER} dune${DUNE_VER} ${EXTRA_OPAM} - opam list before_deploy: - dev/build/osx/make-macos-dmg.sh diff --git a/CHANGES.md b/CHANGES.md index 91763ba35c..5ff90b5123 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,11 +1,32 @@ Changes from 8.9 to 8.10 ======================== -OCaml +OCaml and dependencies - Coq 8.10 requires OCaml >= 4.05.0, bumped from 4.02.3 See the INSTALL file for more information on dependencies. +- Coq 8.10 doesn't need Camlp5 to build anymore. It now includes a + fork of the core parsing library that Coq uses, which is a small + subset of the whole Camlp5 distribution. In particular, this subset + doesn't depend on the OCaml AST, allowing easier compilation and + testing on experimental OCaml versions. + + The Coq developers would like to thank Daniel de Rauglaudre for many + years of continued support. + +Coqide + +- CoqIDE now properly sets the module name for a given file based on + its path, see -topfile change entry for more details. + +Coqtop + +- new option -topfile filename, which will set the current module name + (à la -top) based on the filename passed, taking into account the + proper -R/-Q options. For example, given -R Foo foolib using + -topfile foolib/bar.v will set the module name to Foo.Bar. + Specification language, type inference - Fixing a missing check in interpreting instances of existential @@ -47,11 +68,23 @@ Tactics (e.g. `?[n]` or `?n` in terms - not in patterns) are now interpreted the same way as other variable names occurring in Ltac functions. +- Hint declaration and removal should now specify a database (e.g. `Hint Resolve + foo : database`). When the database name is omitted, the hint is added to the + core database (as previously), but a deprecation warning is emitted. + Vernacular commands - `Combined Scheme` can now work when inductive schemes are generated in sort `Type`. It used to be limited to sort `Prop`. +- Binders for an `Instance` now act more like binders for a `Theorem`. + Names may not be repeated, and may not overlap with section variable names. + +- Removed the deprecated `Implicit Tactic` family of commands. + +- The `Automatic Introduction` option has been removed and is now the + default. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -78,6 +111,19 @@ Standard Library - Added `ByteVector` type that can convert to and from [string]. +- The prelude used to be automatically Exported and is now only + Imported. This should be relevant only when importing files which + don't use -noinit into files which do. + +Universes + +- Added `Print Universes Subgraph` variant of `Print Universes`. + Try for instance `Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1 eq_sigT2_rect.u1).` + +Misc + +- Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. + Changes from 8.8.2 to 8.9+beta1 =============================== @@ -172,8 +218,9 @@ Standard Library - Syntax notations for `string`, `ascii`, `Z`, `positive`, `N`, `R`, and `int31` are no longer available merely by `Require`ing the files - that define the inductives. You must `Import` `Coq.Strings.String`, - `Coq.Strings.Ascii`, `Coq.ZArith.BinIntDef`, `Coq.PArith.BinPosDef`, + that define the inductives. You must `Import` `Coq.Strings.String.StringSyntax` + (after `Require` `Coq.Strings.String`), `Coq.Strings.Ascii.AsciiSyntax` (after + `Require` `Coq.Strings.Ascii`), `Coq.ZArith.BinIntDef`, `Coq.PArith.BinPosDef`, `Coq.NArith.BinNatDef`, `Coq.Reals.Rdefinitions`, and `Coq.Numbers.Cyclic.Int31.Int31`, respectively, to be able to use these notations. Note that passing `-compat 8.8` or issuing @@ -152,6 +152,7 @@ of the Coq Proof assistant during the indicated time: Clément Renard (INRIA, 2001-2004) Claudio Sacerdoti Coen (INRIA, 2004-2005) Amokrane Saïbi (INRIA, 1993-1998) + Vincent Semeria (2018) Vincent Siles (INRIA, 2007) Élie Soubiran (INRIA, 2007-2010) Matthieu Sozeau (INRIA, 2005-now) @@ -39,9 +39,6 @@ WHAT DO YOU NEED ? - Findlib (version >= 1.4.1) (available at http://projects.camlcity.org/projects/findlib.html) - - Camlp5 (version >= 7.03) - (available at https://camlp5.github.io/) - - GNU Make version 3.81 or later - a C compiler @@ -49,14 +46,14 @@ WHAT DO YOU NEED ? - for CoqIDE, the lablgtk development files (version >= 2.18.5), and the GTK 2.x libraries including gtksourceview2. - Note that num, camlp5 and lablgtk should be properly registered with + Note that num and lablgtk should be properly registered with findlib/ocamlfind as Coq's makefile will use it to locate the libraries during the build. Opam (https://opam.ocaml.org/) is recommended to install OCaml and the corresponding packages. - $ opam install num ocamlfind camlp5 lablgtk conf-gtksourceview + $ opam install num ocamlfind lablgtk conf-gtksourceview should get you a reasonable OCaml environment to compile Coq. @@ -96,19 +93,14 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). bigger), you will also need the "ocamlopt" (or its native code version "ocamlopt.opt") command. -2- Check that you have Camlp5 installed on your computer and that the - command "camlp5" lies in a directory which is present in your $PATH - environment variable path. (You need Camlp5 in both bytecode and - native versions if your platform supports it). - -3- The uncompression and un-tarring of the distribution file gave birth +2- The uncompression and un-tarring of the distribution file gave birth to a directory named "coq-8.xx". You can rename this directory and put it wherever you want. Just keep in mind that you will need some spare space during the compilation (reckon on about 300 Mb of disk space for the whole system in native-code compilation). Once installed, the binaries take about 30 Mb, and the library about 200 Mb. -4- First you need to configure the system. It is done automatically with +3- First you need to configure the system. It is done automatically with the command: ./configure <options> @@ -171,7 +163,7 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). c.f. https://caml.inria.fr/mantis/view.php?id=7630 -5- Still in the root directory, do +4- Still in the root directory, do make @@ -183,7 +175,7 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). it is recommended to compile in parallel, via make -jN where N is your number of cores. -6- You can now install the Coq system. Executables, libraries, manual pages +5- You can now install the Coq system. Executables, libraries, manual pages and emacs mode are copied in some standard places of your system, defined at configuration time (step 3). Just do @@ -192,7 +184,7 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). Of course, you may need superuser rights to do that. -7- Optionally, you could build the bytecode version of Coq via: +6- Optionally, you could build the bytecode version of Coq via: make byte @@ -204,7 +196,7 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). be helpful for debugging purposes. In particular, coqtop.byte embeds an OCaml toplevel accessible via the Drop command. -8- You can now clean all the sources. (You can even erase them.) +7- You can now clean all the sources. (You can even erase them.) make clean diff --git a/META.coq.in b/META.coq.in index 16928587cb..181887bc3d 100644 --- a/META.coq.in +++ b/META.coq.in @@ -4,19 +4,7 @@ description = "The Coq Proof Assistant Plugin API" version = "8.10" directory = "" -requires = "camlp5" - -package "grammar" ( - - description = "Coq Camlp5 Grammar Extensions for Plugins" - version = "8.10" - - requires = "camlp5.gramlib" - directory = "grammar" - - archive(byte) = "grammar.cma" - archive(native) = "grammar.cmxa" -) +requires = "" package "config" ( @@ -153,12 +141,24 @@ package "proofs" ( ) +package "gramlib" ( + + description = "Coq Grammar Engine" + version = "8.10" + + requires = "" + directory = "gramlib__pack" + + archive(byte) = "gramlib.cma" + archive(native) = "gramlib.cmxa" +) + package "parsing" ( description = "Coq Parsing Engine" version = "8.10" - requires = "camlp5.gramlib, coq.proofs" + requires = "coq.gramlib, coq.proofs" directory = "parsing" archive(byte) = "parsing.cma" @@ -94,6 +94,10 @@ EXISTINGMLI := $(call find, '*.mli') ## Files that will be generated GENMLGFILES:= $(MLGFILES:.mlg=.ml) +# GRAMFILES must be in linking order +export GRAMFILES=$(addprefix gramlib__pack/gramlib__,Ploc Plexing Gramext Grammar) +export GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) +export GENGRAMFILES := $(GRAMMLFILES) gramlib__pack/gramlib.ml export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml export GENHFILES:=kernel/byterun/coq_jumptbl.h export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) @@ -121,7 +125,6 @@ help: @echo " make clean" @echo "or make archclean" @echo "For make to be verbose, add VERBOSE=1" - @echo "If you want camlp5 to generate human-readable files, add READABLE_ML4=1" @echo @echo "Bytecode compilation is now a separate target:" @echo " make byte" @@ -190,12 +193,16 @@ META.coq: META.coq.in .PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide mlgclean depclean cleanconfig distclean voclean timingclean alienclean -clean: objclean cruftclean depclean docclean camldevfilesclean +clean: objclean cruftclean depclean docclean camldevfilesclean gramlibclean cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean objclean: archclean indepclean +.PHONY: gramlibclean +gramlibclean: + rm -rf gramlib__pack/ + cruftclean: mlgclean find . \( -name '*~' -o -name '*.annot' \) -exec rm -f {} + rm -f gmon.out core @@ -284,7 +291,7 @@ KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(MLPACKFILES:.mlpack=.ml) \ $(patsubst %.mlp,%.ml,$(wildcard grammar/*.mlp)) KNOWNOBJS:=$(KNOWNML:.ml=.cmo) $(KNOWNML:.ml=.cmx) $(KNOWNML:.ml=.cmi) \ $(MLIFILES:.mli=.cmi) \ - $(MLLIBFILES:.mllib=.cma) $(MLLIBFILES:.mllib=.cmxa) grammar/grammar.cma + gramlib__pack/gramlib.cma gramlib__pack/gramlib.cmxa $(MLLIBFILES:.mllib=.cma) $(MLLIBFILES:.mllib=.cmxa) grammar/grammar.cma ALIENOBJS:=$(filter-out $(KNOWNOBJS),$(EXISTINGOBJS)) alienclean: diff --git a/Makefile.build b/Makefile.build index ee856aae8e..8e4b63c364 100644 --- a/Makefile.build +++ b/Makefile.build @@ -22,10 +22,6 @@ # set this variable to 1 (or any non-empty value): VERBOSE ?= -# If set to 1 (or non-empty) then *.ml files corresponding to *.ml4 files -# will be generated in a human-readable format rather than in a binary format. -READABLE_ML4 ?= - # When non-empty, a time command is performed at each .v compilation. # To collect compilation timings of .v and import them in a spreadsheet, # you could hence consider: make TIMED=1 2> timings.csv @@ -199,14 +195,14 @@ COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) -MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP5LIB) +MLINCLUDES=$(LOCALINCLUDES) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(FLAMBDA_FLAGS) -DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$@),, -I ide -I ide/protocol) +DEPFLAGS=$(LOCALINCLUDES) -map gramlib__pack/gramlib.ml $(if $(filter plugins/%,$@),, -I ide -I ide/protocol) # On MacOS, the binaries are signed, except our private ones ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) @@ -253,20 +249,9 @@ define ocamlbyte $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ -linkpkg $(1) $^ endef -# Camlp5 settings - -CAMLP5DEPS:=grammar/grammar.cma -CAMLP5USE=pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) - -PR_O := $(if $(READABLE_ML4),pr_o.cmo,pr_dump.cmo) -# XXX unused but should be used for mlp files - # Main packages linked by Coq. SYSMOD:=-package num,str,unix,dynlink,threads -# We do not repeat the dependencies already in SYSMOD here -P4CMA:=gramlib.cma - ########################################################################### # Infrastructure for the rest of the Makefile ########################################################################### @@ -336,70 +321,15 @@ kernel/copcodes.ml: kernel/byterun/coq_instruct.h kernel/make_opcodes.sh kernel/ $(SHOW)'CCDEP $<' $(HIDE)$(OCAMLC) -ccopt "-MM -MQ $@ -MQ $(<:.c=.o) -isystem $(CAMLHLIB)" $< $(TOTARGET) -########################################################################### -# grammar/grammar.cma -########################################################################### - -## In this part, we compile grammar/grammar.cma -## without relying on .d dependency files, for bootstraping the creation -## and inclusion of these .d files - -## Explicit dependencies for grammar stuff - -GRAMBASEDEPS := grammar/q_util.cmi -GRAMCMO := grammar/q_util.cmo \ - grammar/argextend.cmo grammar/tacextend.cmo grammar/vernacextend.cmo COQPPCMO := $(addsuffix .cmo, $(addprefix coqpp/, coqpp_parse coqpp_lex)) -grammar/argextend.cmo : $(GRAMBASEDEPS) -grammar/q_util.cmo : $(GRAMBASEDEPS) -grammar/tacextend.cmo : $(GRAMBASEDEPS) grammar/argextend.cmo -grammar/vernacextend.cmo : $(GRAMBASEDEPS) grammar/tacextend.cmo \ - grammar/argextend.cmo - coqpp/coqpp_parse.cmi: coqpp/coqpp_ast.cmi coqpp/coqpp_parse.cmo: coqpp/coqpp_ast.cmi coqpp/coqpp_parse.cmi coqpp/coqpp_lex.cmo: coqpp/coqpp_ast.cmi coqpp/coqpp_parse.cmo -## Ocaml compiler with the right options and -I for grammar - -GRAMC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) $(CAMLDEBUG) $(USERFLAGS) \ - -I $(MYCAMLP5LIB) -I grammar - -## Specific rules for grammar.cma - -grammar/grammar.cma : $(GRAMCMO) - $(SHOW)'Testing $@' - @touch grammar/test.mlp - $(HIDE)$(GRAMC) -pp '$(CAMLP5O) $^ -impl' -impl grammar/test.mlp -o grammar/test - @rm -f grammar/test.* grammar/test - $(SHOW)'OCAMLC -a $@' - $(HIDE)$(GRAMC) $^ -linkall -a -o $@ - $(COQPP): $(COQPPCMO) coqpp/coqpp_main.ml $(SHOW)'OCAMLC -a $@' - $(HIDE)$(GRAMC) -I coqpp $^ -linkall -o $@ - -## Support of Camlp5 and Camlp5 - -COMPATCMO:= -GRAMP4USE:=$(COMPATCMO) pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) -GRAMPP:=$(CAMLP5O) -I $(MYCAMLP5LIB) $(GRAMP4USE) $(CAMLP5COMPAT) -impl - -## Rules for standard .mlp and .mli files in grammar/ - -grammar/%.cmo: grammar/%.mlp | $(COMPATCMO) - $(SHOW)'OCAMLC -c -pp $<' - $(HIDE)$(GRAMC) -c -pp '$(GRAMPP)' -impl $< - -grammar/%.cmo: grammar/%.ml | $(COMPATCMO) - $(SHOW)'OCAMLC -c -pp $<' - $(HIDE)$(GRAMC) -c $< - -grammar/%.cmi: grammar/%.mli - $(SHOW)'OCAMLC -c $<' - $(HIDE)$(GRAMC) -c $< - + $(HIDE)$(OCAMLC) -I coqpp $^ -linkall -o $@ ########################################################################### # Main targets (coqtop.opt, coqtop.byte) @@ -407,7 +337,7 @@ grammar/%.cmi: grammar/%.mli .PHONY: coqbinaries coqbyte -coqbinaries: $(TOPBINOPT) $(COQTOPEXE) $(CHICKEN) $(CSDPCERT) $(FAKEIDE) $(GRAMMARCMA) +coqbinaries: $(TOPBINOPT) $(COQTOPEXE) $(CHICKEN) $(CSDPCERT) $(FAKEIDE) coqbyte: $(TOPBYTE) $(CHICKENBYTE) # Special rule for coqtop, we imitate `ocamlopt` can delete the target @@ -418,7 +348,7 @@ $(COQTOPEXE): $(TOPBINOPT:.opt=.$(BEST)) bin/%.opt$(EXE): topbin/%_bin.ml $(LINKCMX) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLOPT) -linkall -linkpkg $(MLINCLUDES) \ - $(SYSMOD) -package camlp5.gramlib \ + $(SYSMOD) \ $(LINKCMX) $(OPTFLAGS) $(LINKMETADATA) $< -o $@ $(STRIP_HIDE) $@ $(CODESIGN_HIDE) $@ @@ -427,7 +357,7 @@ bin/%.byte$(EXE): topbin/%_bin.ml $(LINKCMO) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLC) -linkall -linkpkg $(MLINCLUDES) \ -I kernel/byterun/ -cclib -lcoqrun $(VMBYTEFLAGS) \ - $(SYSMOD) -package camlp5.gramlib \ + $(SYSMOD) \ $(LINKCMO) $(BYTEFLAGS) $< -o $@ COQTOP_BYTE=topbin/coqtop_byte_bin.ml @@ -438,7 +368,7 @@ $(COQTOPBYTE): $(LINKCMO) $(LIBCOQRUN) $(COQTOP_BYTE) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLC) -linkall -linkpkg -I lib -I vernac -I toplevel \ -I kernel/byterun/ -cclib -lcoqrun $(VMBYTEFLAGS) \ - $(SYSMOD) -package camlp5.gramlib,compiler-libs.toplevel \ + $(SYSMOD) -package compiler-libs.toplevel \ $(LINKCMO) $(BYTEFLAGS) $(COQTOP_BYTE) -o $@ # For coqc @@ -612,7 +542,7 @@ VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m validate: $(CHICKEN) | $(ALLVO) $(SHOW)'COQCHK <theories & plugins>' - $(HIDE)$(CHICKEN) -boot -debug $(VALIDOPTS) $(ALLMODS) + $(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS) $(ALLSTDLIB).v: $(SHOW)'MAKE $(notdir $@)' @@ -630,15 +560,40 @@ test-suite: world byte $(ALLSTDLIB).v # Default rules for compiling ML code ########################################################################### -# Target for libraries .cma and .cmxa +gramlib__pack: + mkdir -p $@ -# The dependency over the .mllib is somewhat artificial, since -# ocamlc -a won't use this file, hence the $(filter-out ...) below. -# But this ensures that the .cm(x)a is rebuilt when needed, -# (especially when removing a module in the .mllib). -# We used to have a "order-only" dependency over .mllib.d here, -# but the -include mechanism should already ensure that we have -# up-to-date dependencies. +# gramlib.ml contents +gramlib__pack/gramlib.ml: | gramlib__pack + echo " \ +module Ploc = Gramlib__Ploc \ +module Plexing = Gramlib__Plexing \ +module Gramext = Gramlib__Gramext \ +module Grammar = Gramlib__Grammar" > $@ + +gramlib__pack/gramlib__P%: gramlib/p% | gramlib__pack + cp -a $< $@ + sed -e "1i # 1 \"$<\"" -i $@ +gramlib__pack/gramlib__G%: gramlib/g% | gramlib__pack + cp -a $< $@ + sed -e "1i # 1 \"$<\"" -i $@ + +# Specific rules for gramlib to pack it Dune / OCaml 4.08 style +GRAMOBJS=$(addsuffix .cmo, $(GRAMFILES)) + +gramlib__pack/%: COND_BYTEFLAGS+=-no-alias-deps -w -49 +gramlib__pack/%: COND_OPTFLAGS+=-no-alias-deps -w -49 + +gramlib__pack/gramlib.%: COND_OPENFLAGS= +gramlib__pack/gramlib__%: COND_OPENFLAGS=-open Gramlib + +gramlib__pack/gramlib.cma: $(GRAMOBJS) gramlib__pack/gramlib.cmo + $(SHOW)'OCAMLC -a -o $@' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $^ + +gramlib__pack/gramlib.cmxa: $(GRAMOBJS:.cmo=.cmx) gramlib__pack/gramlib.cmx + $(SHOW)'OCAMLOPT -a -o $@' + $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $^ # Specific rule for kernel.cma, with $(VMBYTEFLAGS). # This helps loading dllcoqrun.so during an ocamldebug @@ -651,6 +606,16 @@ kernel/kernel.cmxa: kernel/kernel.mllib $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -I kernel/byterun/ -cclib -lcoqrun -a -o $@ $(filter-out %.mllib, $^) +# Target for libraries .cma and .cmxa + +# The dependency over the .mllib is somewhat artificial, since +# ocamlc -a won't use this file, hence the $(filter-out ...) below. +# But this ensures that the .cm(x)a is rebuilt when needed, +# (especially when removing a module in the .mllib). +# We used to have a "order-only" dependency over .mllib.d here, +# but the -include mechanism should already ensure that we have +# up-to-date dependencies. + %.cma: %.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) @@ -672,11 +637,14 @@ kernel/kernel.cmxa: kernel/kernel.mllib COND_IDEFLAGS=$(if $(filter ide/fake_ide% tools/coq_makefile%,$<), -I ide -I ide/protocol,) COND_PRINTERFLAGS=$(if $(filter dev/%,$<), -I dev,) +# For module packing +COND_OPENFLAGS= + COND_BYTEFLAGS= \ - $(COND_IDEFLAGS) $(COND_PRINTERFLAGS) $(MLINCLUDES) $(BYTEFLAGS) + $(COND_IDEFLAGS) $(COND_PRINTERFLAGS) $(MLINCLUDES) $(BYTEFLAGS) $(COND_OPENFLAGS) COND_OPTFLAGS= \ - $(COND_IDEFLAGS) $(MLINCLUDES) $(OPTFLAGS) + $(COND_IDEFLAGS) $(MLINCLUDES) $(OPTFLAGS) $(COND_OPENFLAGS) plugins/micromega/%.cmi: plugins/micromega/%.mli $(SHOW)'OCAMLC $<' @@ -780,12 +748,13 @@ kernel/%.cmx: COND_OPTFLAGS+=-w +a-4-44-50 # Ocamldep is now used directly again (thanks to -ml-synonym in OCaml >= 3.12) OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .mlpack -MAINMLFILES := $(filter-out checker/% plugins/%, $(MLFILES) $(MLIFILES)) -MAINMLLIBFILES := $(filter-out checker/% plugins/%, $(MLLIBFILES) $(MLPACKFILES)) +MAINMLFILES := $(filter-out gramlib__pack/% checker/% plugins/%, $(MLFILES) $(MLIFILES)) +MAINMLLIBFILES := $(filter-out gramlib__pack/% checker/% plugins/%, $(MLLIBFILES) $(MLPACKFILES)) -$(MLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLFILES) $(D_DEPEND_AFTER_SRC) $(GENFILES) +$(MLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLFILES) $(D_DEPEND_AFTER_SRC) $(GENFILES) $(GENGRAMFILES) $(SHOW)'OCAMLDEP MLFILES MLIFILES' - $(HIDE)$(OCAMLDEP) $(DEPFLAGS) $(MAINMLFILES) $(TOTARGET) + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) -passrest $(MAINMLFILES) -open Gramlib $(GRAMMLFILES) $(TOTARGET) +#NB: -passrest is needed to avoid ocamlfind reordering the -open Gramlib $(MLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLLIBFILES) $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) $(SHOW)'OCAMLLIBDEP MLLIBFILES MLPACKFILES' diff --git a/Makefile.checker b/Makefile.checker index a0f0778d49..7440c767e6 100644 --- a/Makefile.checker +++ b/Makefile.checker @@ -59,8 +59,7 @@ checker/check.cmxa: checker/check.mllib $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) -CHECKMLFILES:=$(filter checker/%, $(MLFILES) $(MLIFILES)) \ - $(filter dev/checker_%, $(MLFILES) $(MLIFILES)) +CHECKMLFILES:=$(filter checker/%, $(MLFILES) $(MLIFILES)) $(CHECKMLDFILE).d: $(filter checker/%, $(MLFILES) $(MLIFILES)) $(SHOW)'OCAMLDEP checker/MLFILES checker/MLIFILES' @@ -82,14 +81,6 @@ checker/%.cmx: checker/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -c $< -dev/checker_%.cmo: dev/checker_%.ml - $(SHOW)'OCAMLC $<' - $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -I dev/ -c $< - -dev/checker_%.cmi: dev/checker_%.mli - $(SHOW)'OCAMLC $<' - $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -I dev/ -c $< - # For emacs: # Local Variables: # mode: makefile diff --git a/Makefile.ci b/Makefile.ci index 8234da0869..d0b87fc58b 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -9,12 +9,12 @@ ########################################################################## CI_TARGETS= \ - ci-aac-tactics \ + ci-aac_tactics \ ci-bedrock2 \ ci-bignums \ ci-color \ ci-compcert \ - ci-coq-dpdgraph \ + ci-coq_dpdgraph \ ci-coquelicot \ ci-corn \ ci-cpdt \ @@ -29,14 +29,15 @@ CI_TARGETS= \ ci-flocq \ ci-formal-topology \ ci-geocoq \ + ci-coqhammer \ ci-hott \ ci-iris-lambda-rust \ ci-ltac2 \ ci-math-classes \ ci-math-comp \ ci-mtac2 \ - ci-pidetop \ - ci-plugin-tutorial \ + ci-paramcoq \ + ci-plugin_tutorial \ ci-quickchick \ ci-sf \ ci-simple-io \ diff --git a/Makefile.common b/Makefile.common index f2a11ee4b4..ca2cb8fee6 100644 --- a/Makefile.common +++ b/Makefile.common @@ -91,7 +91,7 @@ MKDIR:=install -d CORESRCDIRS:=\ coqpp \ config clib lib kernel kernel/byterun library \ - engine pretyping interp proofs parsing printing \ + engine pretyping interp proofs gramlib__pack parsing printing \ tactics vernac stm toplevel PLUGINDIRS:=\ @@ -119,11 +119,10 @@ BYTERUN:=$(addprefix kernel/byterun/, \ CORECMA:=config/config.cma clib/clib.cma lib/lib.cma kernel/kernel.cma library/library.cma \ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ + gramlib__pack/gramlib.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ stm/stm.cma toplevel/toplevel.cma -GRAMMARCMA:=grammar/grammar.cma - ########################################################################### # plugins object files ########################################################################### diff --git a/Makefile.dev b/Makefile.dev index 54710b6690..9659f602d7 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -17,7 +17,7 @@ .PHONY: devel printers -DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/checker_printers.cmo +DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo devel: printers printers: $(CORECMA) $(DEBUGPRINTERS) diff --git a/Makefile.dune b/Makefile.dune index d201d1783a..2293c69c38 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -42,9 +42,9 @@ check: voboot COQTOP_FILES=ide/idetop.bc ide/coqide_main.bc checker/coqchk.bc PLUGIN_FILES=$(wildcard plugins/*/*.mlpack) -PRINTER_FILES=dev/top_printers.cma dev/checker_printers.cma +PRINTER_FILES=dev/top_printers.cma QUICKBYTE_TARGETS=$(COQTOP_FILES) $(PLUGIN_FILES:.mlpack=.cma) $(PRINTER_FILES) topbin/coqtop_byte_bin.bc -QUICKOPT_TARGETS=$(COQTOP_FILES:.bc=.exe) $(PLUGIN_FILES:.mlpack=.cmxa) $(PRINTER_FILES:.cma=.cmxa) topbin/coqtop_bin.exe +QUICKOPT_TARGETS=$(COQTOP_FILES:.bc=.exe) $(PLUGIN_FILES:.mlpack=.cmxs) $(PRINTER_FILES:.cma=.cmxa) topbin/coqtop_bin.exe quickbyte: voboot dune build $(DUNEOPT) $(QUICKBYTE_TARGETS) @@ -53,7 +53,7 @@ quickopt: voboot dune build $(DUNEOPT) $(QUICKOPT_TARGETS) test-suite: voboot - dune $(DUNEOPT) runtest + dune runtest $(DUNEOPT) release: voboot dune build $(DUNEOPT) -p coq diff --git a/Makefile.ide b/Makefile.ide index 39af1f8545..cae77ee348 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -147,7 +147,7 @@ $(IDETOPEXE): $(IDETOP:.opt=.$(BEST)) $(IDETOP): ide/idetop.ml $(LINKCMX) $(LIBCOQRUN) $(IDETOPCMX) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLOPT) -linkall -linkpkg $(MLINCLUDES) -I ide -I ide/protocol/ \ - $(SYSMOD) -package camlp5.gramlib \ + $(SYSMOD) \ $(LINKCMX) $(IDETOPCMX) $(OPTFLAGS) $(LINKMETADATA) $< -o $@ $(STRIP_HIDE) $@ $(CODESIGN_HIDE) $@ @@ -156,7 +156,7 @@ $(IDETOPBYTE): ide/idetop.ml $(LINKCMO) $(LIBCOQRUN) $(IDETOPCMA) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLC) -linkall -linkpkg $(MLINCLUDES) -I ide -I ide/protocol/ \ -I kernel/byterun/ -cclib -lcoqrun $(VMBYTEFLAGS) \ - $(SYSMOD) -package camlp5.gramlib \ + $(SYSMOD) \ $(LINKCMO) $(IDETOPCMA) $(BYTEFLAGS) $< -o $@ #################### diff --git a/Makefile.install b/Makefile.install index be6fe54933..8233807e03 100644 --- a/Makefile.install +++ b/Makefile.install @@ -93,7 +93,7 @@ install-tools: INSTALLCMI = $(sort \ $(filter-out checker/% ide/% tools/%, $(MLIFILES:.mli=.cmi)) \ $(foreach lib,$(CORECMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) \ - $(PLUGINS:.cmo=.cmi) + $(PLUGINS:.cmo=.cmi) gramlib__pack/gramlib.cmi INSTALLCMX = $(sort $(filter-out checker/% ide/% tools/% dev/% \ configure.cmx toplevel/coqtop_byte_bin.cmx plugins/extraction/big.cmx, \ diff --git a/checker/dune b/checker/dune index 35a35a1f82..ee427d26c5 100644 --- a/checker/dune +++ b/checker/dune @@ -1,26 +1,3 @@ -(copy_files# - %{project_root}/kernel/{names,esubst,declarations,environ,constr,term,univ,evar,sorts,uGraph,context}.ml{,i}) - -(copy_files# - %{project_root}/kernel/{mod_subst,vars,opaqueproof,conv_oracle,reduction,typeops,inductive,indtypes,declareops,type_errors}.ml{,i}) - -(copy_files# - %{project_root}/kernel/{modops,mod_typing,}.ml{,i}) - -(copy_files# - %{project_root}/kernel/{cClosure,cPrimitives,csymtable,vconv,vm,uint31,cemitcodes,vmvalues,cbytecodes,cinstr,retroknowledge,copcodes}.ml{,i}) - -(copy_files# - %{project_root}/kernel/{cbytegen,clambda,nativeinstr,nativevalues,nativeconv,nativecode,nativelib,nativelibrary,nativelambda}.ml{,i}) - -(copy_files# - %{project_root}/kernel/{subtyping,term_typing,safe_typing,entries,cooking}.ml{,i}) - -; VM stuff - -(copy_files# - %{project_root}/kernel/byterun/{*.c,*.h}) - ; Careful with bug https://github.com/ocaml/odoc/issues/148 ; ; If we don't pack checker we will have a problem here due to @@ -30,10 +7,8 @@ (public_name coq.checklib) (synopsis "Coq's Standalone Proof Checker") (modules :standard \ coqchk votour) - (modules_without_implementation cinstr nativeinstr) - (c_names coq_fix_code coq_memory coq_values coq_interp) (wrapped true) - (libraries coq.lib)) + (libraries coq.kernel)) (executable (name coqchk) diff --git a/checker/include b/checker/include index da0346359b..3ffc301724 100644 --- a/checker/include +++ b/checker/include @@ -13,7 +13,6 @@ #directory "kernel";; #directory "checker";; #directory "+threads";; -#directory "+camlp5";; #load "unix.cma";; #load"threads.cma";; diff --git a/checker/validate.ml b/checker/validate.ml index c214409a2c..b85944f94f 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -143,10 +143,8 @@ let validate debug v x = let o = Obj.repr x in try val_gen v mt_ec o with ValidObjError(msg,ctx,obj) -> - if debug then begin + (if debug then let ctx = List.rev_map print_frame ctx in - print_endline ("Validation failed: "^msg); print_endline ("Context: "^String.concat"/"ctx); - pr_obj obj - end; - failwith "vo structure validation failed" + pr_obj obj); + failwith ("Validation failed: "^msg^" (in "^(print_frame (List.hd ctx))^")") diff --git a/checker/values.ml b/checker/values.ml index 8f6b24ec26..0de8a3e03f 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -10,28 +10,15 @@ (** Abstract representations of values in a vo *) -(** NB: UPDATE THIS FILE EACH TIME cic.mli IS MODIFIED ! +(** NB: This needs updating when the types in declarations.ml and + their dependencies are changed. *) -To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli -with a copy we maintain here: - -MD5 b8f0139f14e3370cd0a45d4cf69882ea checker/cic.mli - -*) - -(** We reify here the types of values present in a vo (see cic.mli), +(** We reify here the types of values present in a vo. in order to validate its structure. Maybe this reification could become automatically generated someday ? - - [Any] stands for a value that we won't check, - - [Fail] means a value that shouldn't be there at all, - - [Tuple] provides a name and sub-values in this block - - [Sum] provides a name, a number of constant constructors, - and sub-values at each position of each possible constructed - variant - - [List] and [Opt] could have been defined via [Sum], but - having them here helps defining some recursive values below - - [Annot] is a no-op, just there for improving debug messages *) + See values.mli for the meaning of each constructor. +*) type value = | Any @@ -45,6 +32,7 @@ type value = | String | Annot of string * value | Dyn + | Proxy of value ref let fix (f : value -> value) : value = @@ -122,8 +110,7 @@ let v_cstrs = let v_variance = v_enum "variance" 3 let v_instance = Annot ("instance", Array v_level) -let v_context = v_tuple "universe_context" [|v_instance;v_cstrs|] -let v_abs_context = v_context (* only for clarity *) +let v_abs_context = v_tuple "abstract_universe_context" [|Array v_name; v_cstrs|] let v_abs_cum_info = v_tuple "cumulativity_info" [|v_abs_context; Array v_variance|] let v_context_set = v_tuple "universe_context_set" [|v_hset v_level;v_cstrs|] diff --git a/checker/values.mli b/checker/values.mli index 1b1437a469..616b69907f 100644 --- a/checker/values.mli +++ b/checker/values.mli @@ -10,17 +10,36 @@ type value = | Any + (** A value that we won't check, *) + | Fail of string + (** A value that shouldn't be there at all, *) + | Tuple of string * value array + (** A debug name and sub-values in this block *) + | Sum of string * int * value array array + (** A debug name, a number of constant constructors, and sub-values + at each position of each possible constructed variant *) + | Array of value | List of value | Opt of value | Int | String + (** Builtin Ocaml types. *) + | Annot of string * value + (** Adds a debug note to the inner value *) + | Dyn + (** Coq's Dyn.t *) + | Proxy of value ref + (** Same as the inner value, used to define recursive types *) + +(** NB: List and Opt have their own constructors to make it easy to + define eg [let rec foo = List foo]. *) val v_univopaques : value val v_libsum : value diff --git a/clib/cUnix.ml b/clib/cUnix.ml index 6b42e3041d..eedd878f93 100644 --- a/clib/cUnix.ml +++ b/clib/cUnix.ml @@ -74,10 +74,6 @@ let canonical_path_name p = let make_suffix name suffix = if Filename.check_suffix name suffix then name else (name ^ suffix) -let get_extension f = - let pos = try String.rindex f '.' with Not_found -> String.length f in - String.sub f pos (String.length f - pos) - let correct_path f dir = if Filename.is_relative f then Filename.concat dir f else f diff --git a/clib/cUnix.mli b/clib/cUnix.mli index 1b185345be..896ccd4ea7 100644 --- a/clib/cUnix.mli +++ b/clib/cUnix.mli @@ -38,10 +38,6 @@ val path_to_list : string -> string list [file] does not already end with [suf]. *) val make_suffix : string -> string -> string -(** Return the extension of a file, i.e. its smaller suffix starting - with "." if any, or "" otherwise. *) -val get_extension : string -> string - val file_readable_p : string -> bool (** {6 Executing commands } *) diff --git a/clib/dyn.ml b/clib/dyn.ml index 6c45767246..22c49706be 100644 --- a/clib/dyn.ml +++ b/clib/dyn.ml @@ -38,6 +38,7 @@ sig type t = Dyn : 'a tag * 'a -> t val create : string -> 'a tag + val anonymous : int -> 'a tag val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option val repr : 'a tag -> string @@ -81,15 +82,22 @@ module Self : PreS = struct let create (s : string) = let hash = Hashtbl.hash s in - let () = - if Int.Map.mem hash !dyntab then - let old = Int.Map.find hash !dyntab in - let () = Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old in - assert false - in - let () = dyntab := Int.Map.add hash s !dyntab in + if Int.Map.mem hash !dyntab then begin + let old = Int.Map.find hash !dyntab in + Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old; + assert false + end; + dyntab := Int.Map.add hash s !dyntab; hash + let anonymous n = + if Int.Map.mem n !dyntab then begin + Printf.eprintf "Dynamic tag collision: %d\n%!" n; + assert false + end; + dyntab := Int.Map.add n "<anonymous>" !dyntab; + n + let eq : 'a 'b. 'a tag -> 'b tag -> ('a, 'b) CSig.eq option = fun h1 h2 -> if Int.equal h1 h2 then Some (Obj.magic CSig.Refl) else None diff --git a/clib/dyn.mli b/clib/dyn.mli index ff9762bd6b..1bd78b2db8 100644 --- a/clib/dyn.mli +++ b/clib/dyn.mli @@ -48,6 +48,12 @@ sig Type names are hashed, so [create] may raise even if no type with the exact same name was registered due to a collision. *) + val anonymous : int -> 'a tag + (** [anonymous i] returns a tag describing an [i]-th anonymous type. + If [anonymous] is not used together with [create], [max_int] anonymous types + are available. + [anonymous] raises an exception if [i] is already registered. *) + val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option (** [eq t1 t2] returns [Some witness] if [t1] is the same as [t2], [None] otherwise. *) diff --git a/clib/store.ml b/clib/store.ml index 1469358c9d..79e26908d7 100644 --- a/clib/store.ml +++ b/clib/store.ml @@ -20,70 +20,37 @@ module type S = sig type t type 'a field + val field : unit -> 'a field val empty : t val set : t -> 'a field -> 'a -> t val get : t -> 'a field -> 'a option val remove : t -> 'a field -> t val merge : t -> t -> t - val field : unit -> 'a field end -module Make () : S = +module Make() : S = struct - - let next = - let count = ref 0 in fun () -> - let n = !count in - incr count; - n - - type t = Obj.t option array - (** Store are represented as arrays. For small values, which is typicial, - is slightly quicker than other implementations. *) - -type 'a field = int - -let allocate len : t = Array.make len None - -let empty : t = [||] - -let set (s : t) (i : 'a field) (v : 'a) : t = - let len = Array.length s in - let nlen = if i < len then len else succ i in - let () = assert (0 <= i) in - let ans = allocate nlen in - Array.blit s 0 ans 0 len; - Array.unsafe_set ans i (Some (Obj.repr v)); - ans - -let get (s : t) (i : 'a field) : 'a option = - let len = Array.length s in - if len <= i then None - else Obj.magic (Array.unsafe_get s i) - -let remove (s : t) (i : 'a field) = - let len = Array.length s in - let () = assert (0 <= i) in - let ans = allocate len in - Array.blit s 0 ans 0 len; - if i < len then Array.unsafe_set ans i None; - ans - -let merge (s1 : t) (s2 : t) : t = - let len1 = Array.length s1 in - let len2 = Array.length s2 in - let nlen = if len1 < len2 then len2 else len1 in - let ans = allocate nlen in - (** Important: No more allocation from here. *) - Array.blit s2 0 ans 0 len2; - for i = 0 to pred len1 do - let v = Array.unsafe_get s1 i in - match v with - | None -> () - | Some _ -> Array.unsafe_set ans i v - done; - ans - -let field () = next () - + module Dyn = Dyn.Make() + module Map = Dyn.Map(struct type 'a t = 'a end) + + type t = Map.t + type 'a field = 'a Dyn.tag + + let next = ref 0 + let field () = + let f = Dyn.anonymous !next in + incr next; + f + + let empty = + Map.empty + let set s f v = + Map.add f v s + let get s f = + try Some (Map.find f s) + with Not_found -> None + let remove s f = + Map.remove f s + let merge s1 s2 = + Map.fold (fun (Map.Any (f, v)) s -> Map.add f v s) s1 s2 end diff --git a/clib/store.mli b/clib/store.mli index 0c2b2e0856..7cdd1d3bed 100644 --- a/clib/store.mli +++ b/clib/store.mli @@ -19,6 +19,9 @@ sig type 'a field (** Type of field of such stores *) + val field : unit -> 'a field + (** Create a new field *) + val empty : t (** Empty store *) @@ -33,11 +36,7 @@ sig val merge : t -> t -> t (** [merge s1 s2] adds all the fields of [s1] into [s2]. *) - - val field : unit -> 'a field - (** Create a new field *) - end -module Make () : S +module Make() : S (** Create a new store type. *) diff --git a/config/coq_config.mli b/config/coq_config.mli index 22d8c49fd1..33acceb1f0 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -25,11 +25,6 @@ val docdirsuffix : string (* doc directory relative to installation prefix *) val ocamlfind : string -val camlp5o : string (* name of the camlp5o executable *) -val camlp5bin : string (* base directory for camlp5 binaries *) -val camlp5lib : string (* where is the library of camlp5 *) -val camlp5compat : string (* compatibility argument to camlp5 *) - val caml_flags : string (* arguments passed to ocamlc (ie. CAMLFLAGS) *) val arch : string (* architecture *) diff --git a/configure.ml b/configure.ml index 39c65683ff..ec765acc15 100644 --- a/configure.ml +++ b/configure.ml @@ -4,6 +4,7 @@ (**********************************) + (** This file should be run via: ocaml configure.ml <opts> You could also use our wrapper ./configure <opts> *) @@ -188,34 +189,6 @@ let which prog = let program_in_path prog = try let _ = which prog in true with Not_found -> false -(** Choose a command among a list of candidates - (command name, mandatory arguments, arguments for this test). - Chooses the first one whose execution outputs a non-empty (first) line. - Dies with message [msg] if none is found. *) - -let select_command msg candidates = - let rec search = function - | [] -> die msg - | (p, x, y) :: tl -> - if fst (tryrun p (x @ y)) <> "" - then List.fold_left (Printf.sprintf "%s %s") p x - else search tl - in search candidates - -(** As per bug #4828, ocamlfind on Windows/Cygwin barfs if you pass it - a quoted path to camlp5o via -pp. So we only quote camlp5o on not - Windows, and warn on Windows if the path contains spaces *) -let contains_suspicious_characters str = - List.fold_left (fun b ch -> String.contains str ch || b) false [' '; '\t'] - -let win_aware_quote_executable str = - if not (os_type_win32 || os_type_cygwin) then - sprintf "%S" str - else - let _ = if contains_suspicious_characters str then - warn "The string %S contains suspicious characters; ocamlfind might fail" str in - Str.global_replace (Str.regexp "\\\\") "/" str - (** * Date *) (** The short one is displayed when starting coqtop, @@ -254,7 +227,6 @@ type preferences = { coqdocdir : string option; ocamlfindcmd : string option; lablgtkdir : string option; - camlp5dir : string option; arch : string option; natdynlink : bool; coqide : ide option; @@ -292,7 +264,6 @@ let default = { coqdocdir = None; ocamlfindcmd = None; lablgtkdir = None; - camlp5dir = None; arch = None; natdynlink = true; coqide = None; @@ -399,8 +370,6 @@ let args_options = Arg.align [ "<dir> Specifies the ocamlfind command to use"; "-lablgtkdir", arg_string_option (fun p lablgtkdir -> { p with lablgtkdir }), "<dir> Specifies the path to the Lablgtk library"; - "-camlp5dir", arg_string_option (fun p camlp5dir -> { p with camlp5dir }), - "<dir> Specifies where is the Camlp5 library and tells to use it"; "-flambda-opts", arg_string_list ' ' (fun p flambda_flags -> { p with flambda_flags }), "<flags> Specifies additional flags to be passed to the flambda optimizing compiler"; "-arch", arg_string_option (fun p arch -> { p with arch }), @@ -580,8 +549,6 @@ let camlbin, caml_version, camllib, findlib_version = then reset_caml_top camlexec (camlbin / "ocaml") in camlbin, caml_version, camllib, findlib_version -let camlp5compat = "-loc loc" - (** Caml version as a list of string, e.g. ["4";"00";"1"] *) let caml_version_list = numeric_prefix_list caml_version @@ -660,76 +627,12 @@ let caml_flags = let coq_caml_flags = coq_warn_error -(** * Camlp5 configuration *) - -(* Convention: we use camldir as a prioritary location for camlp5, if given *) -(* i.e., in the case of camlp5, we search for a copy of camlp5o which *) -(* answers the right camlp5 lib dir *) - -let strip_slash dir = - let n = String.length dir in - if n>0 && dir.[n - 1] = '/' then String.sub dir 0 (n-1) else dir - -let which_camlp5o_for camlp5lib = - let camlp5o = Filename.concat camlbin "camlp5o" in - let camlp5lib = strip_slash camlp5lib in - if fst (tryrun camlp5o ["-where"]) = camlp5lib then camlp5o else - let camlp5o = which "camlp5o" in - if fst (tryrun camlp5o ["-where"]) = camlp5lib then camlp5o else - die ("Error: cannot find Camlp5 binaries corresponding to Camlp5 library " ^ camlp5lib) - -let which_camlp5 base = - let file = Filename.concat camlbin base in - if is_executable file then file else which base - -(* TODO: camlp5dir should rather be the *binary* location, just as camldir *) -(* TODO: remove the late attempts at finding gramlib.cma *) - -let check_camlp5 testcma = match !prefs.camlp5dir with - | Some dir -> - if Sys.file_exists (dir/testcma) then - let camlp5o = - try which_camlp5o_for dir - with Not_found -> die "Error: cannot find Camlp5 binaries in path.\n" in - dir, camlp5o - else - let msg = - sprintf "Cannot find camlp5 libraries in '%s' (%s not found)." - dir testcma - in die msg - | None -> - try - let camlp5o = which_camlp5 "camlp5o" in - let dir,_ = tryrun camlp5o ["-where"] in - dir, camlp5o - with Not_found -> - die "No Camlp5 installation found." - -let check_camlp5_version camlp5o = - let version_line, _ = run ~err:StdOut camlp5o ["-v"] in - let version = List.nth (string_split ' ' version_line) 2 in - match numeric_prefix_list version with - | major::minor::_ when s2i major > 6 || (s2i major, s2i minor) >= (6,6) -> - cprintf "You have Camlp5 %s. Good!" version; version - | _ -> die "Error: unsupported Camlp5 (version < 6.06 or unrecognized).\n" - -let config_camlp5 () = - let camlp5mod = "gramlib" in - let camlp5libdir, camlp5o = check_camlp5 (camlp5mod^".cma") in - let camlp5_version = check_camlp5_version camlp5o in - camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version - -let camlp5o, camlp5bindir, fullcamlp5libdir, - camlp5mod, camlp5_version = config_camlp5 () - let shorten_camllib s = if starts_with s (camllib^"/") then let l = String.length camllib + 1 in "+" ^ String.sub s l (String.length s - l) else s -let camlp5libdir = shorten_camllib fullcamlp5libdir - (** * Native compiler *) let msg_byteonly = @@ -738,9 +641,6 @@ let msg_byteonly = let msg_no_ocamlopt () = warn "Cannot find the OCaml native-code compiler.\n%s" msg_byteonly -let msg_no_camlp5_cmxa () = - warn "Cannot find the native-code library of camlp5.\n%s" msg_byteonly - let msg_no_dynlink_cmxa () = warn "Cannot find native-code dynlink library.\n%s" msg_byteonly; cprintf "For building a native-code Coq, you may try to first"; @@ -751,8 +651,6 @@ let check_native () = let () = if !prefs.byteonly then raise Not_found in let version, _ = tryrun camlexec.find ["opt";"-version"] in if version = "" then let () = msg_no_ocamlopt () in raise Not_found - else if not (Sys.file_exists (fullcamlp5libdir/camlp5mod^".cmxa")) - then let () = msg_no_camlp5_cmxa () in raise Not_found else if fst (tryrun camlexec.find ["query";"dynlink"]) = "" then let () = msg_no_dynlink_cmxa () in raise Not_found else @@ -771,7 +669,6 @@ let hasnatdynlink = !prefs.natdynlink && best_compiler = "opt" let natdynlinkflag = if hasnatdynlink then "true" else "false" - (** * OS dependent libraries *) let operating_system = @@ -1111,9 +1008,6 @@ let print_summary () = pr " OCaml binaries in : %s\n" (esc camlbin); pr " OCaml library in : %s\n" (esc camllib); pr " OCaml flambda flags : %s\n" (String.concat " " !prefs.flambda_flags); - pr " Camlp5 version : %s\n" camlp5_version; - pr " Camlp5 binaries in : %s\n" (esc camlp5bindir); - pr " Camlp5 library in : %s\n" (esc camlp5libdir); if best_compiler = "opt" then pr " Native dynamic link support : %B\n" hasnatdynlink; if coqide <> "no" then @@ -1153,7 +1047,6 @@ let write_dbg_wrapper f = pr "# DO NOT EDIT THIS FILE: automatically generated by ../configure #\n\n"; pr "export COQTOP=%S\n" coqtop; pr "OCAMLDEBUG=%S\n" (camlbin^"/ocamldebug"); - pr "CAMLP5LIB=%S\n\n" camlp5libdir; pr ". $COQTOP/dev/ocamldebug-coq.run\n"; close_out o; Unix.chmod f 0o555 @@ -1185,10 +1078,6 @@ let write_configml f = pr_p "datadirsuffix" datadirsuffix; pr_p "docdirsuffix" docdirsuffix; pr_s "ocamlfind" camlexec.find; - pr_s "camlp5o" camlp5o; - pr_s "camlp5bin" camlp5bindir; - pr_s "camlp5lib" camlp5libdir; - pr_s "camlp5compat" camlp5compat; pr_s "caml_flags" caml_flags; pr_s "version" coq_version; pr_s "caml_version" caml_version; @@ -1211,10 +1100,9 @@ let write_configml f = pr_b "bytecode_compiler" !prefs.bytecodecompiler; pr_b "native_compiler" !prefs.nativecompiler; - let core_src_dirs = [ "config"; "dev"; "lib"; "clib"; "kernel"; "library"; - "engine"; "pretyping"; "interp"; "parsing"; "proofs"; - "tactics"; "toplevel"; "printing"; - "grammar"; "ide"; "stm"; "vernac" ] in + let core_src_dirs = [ "config"; "lib"; "clib"; "kernel"; "library"; + "engine"; "pretyping"; "interp"; "gramlib__pack"; "parsing"; "proofs"; + "tactics"; "toplevel"; "printing"; "ide"; "stm"; "vernac" ] in let core_src_dirs = List.fold_left (fun acc core_src_subdir -> acc ^ " \"" ^ core_src_subdir ^ "\";\n") "" core_src_dirs in @@ -1296,11 +1184,6 @@ let write_makefile f = pr "CAMLDEBUGOPT=%s\n\n" coq_debug_flag; pr "# Compilation profile flag\n"; pr "CAMLTIMEPROF=%s\n\n" coq_profile_flag; - pr "# Camlp5 : flavor, binaries, libraries ...\n"; - pr "# NB : avoid using CAMLP5LIB (conflict under Windows)\n"; - pr "CAMLP5O=%s\n" (win_aware_quote_executable camlp5o); - pr "CAMLP5COMPAT=%s\n" camlp5compat; - pr "MYCAMLP5LIB=%S\n\n" camlp5libdir; pr "# Your architecture\n"; pr "# Can be obtain by UNIX command arch\n"; pr "ARCH=%s\n" arch; @@ -22,7 +22,6 @@ depends: [ "ocaml" { >= "4.05.0" } "dune" { build & >= "1.4.0" } "num" - "camlp5" { >= "7.03" } ] build-env: [ diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 7cecff9d75..d52bd39d72 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -139,7 +139,7 @@ let print_local fmt ext = match locals with | [] -> () | e :: locals -> - let mk_e fmt e = fprintf fmt "%s.Entry.create \"%s\"" ext.gramext_name e in + let mk_e fmt e = fprintf fmt "Pcoq.Entry.create \"%s\"" e in let () = fprintf fmt "@[<hv 2>let %s =@ @[%a@]@]@ " e mk_e e in let iter e = fprintf fmt "@[<hv 2>and %s =@ @[%a@]@]@ " e mk_e e in let () = List.iter iter locals in @@ -277,16 +277,16 @@ let print_rule fmt r = let pr_prd fmt prd = print_list fmt print_prod prd in fprintf fmt "@[(%a,@ %a,@ %a)@]" pr_lvl r.grule_label pr_asc r.grule_assoc pr_prd (List.rev r.grule_prods) -let print_entry fmt gram e = +let print_entry fmt e = let print_position_opt fmt pos = print_opt fmt print_position pos in let print_rules fmt rules = print_list fmt print_rule rules in - fprintf fmt "let () =@ @[%s.gram_extend@ %s@ @[(%a, %a)@]@]@ in@ " - gram e.gentry_name print_position_opt e.gentry_pos print_rules e.gentry_rules + fprintf fmt "let () =@ @[Pcoq.grammar_extend@ %s@ None@ @[(%a, %a)@]@]@ in@ " + e.gentry_name print_position_opt e.gentry_pos print_rules e.gentry_rules let print_ast fmt ext = let () = fprintf fmt "let _ = @[" in let () = fprintf fmt "@[<v>%a@]" print_local ext in - let () = List.iter (fun e -> print_entry fmt ext.gramext_name e) ext.gramext_entries in + let () = List.iter (fun e -> print_entry fmt e) ext.gramext_entries in let () = fprintf fmt "()@]@\n" in () @@ -357,15 +357,15 @@ let print_body fmt r = print_binders r.vernac_toks print_atts_right r.vernac_atts let rec print_sig fmt = function -| [] -> fprintf fmt "@[Vernacentries.TyNil@]" +| [] -> fprintf fmt "@[Vernacextend.TyNil@]" | ExtTerminal s :: rem -> - fprintf fmt "@[Vernacentries.TyTerminal (\"%s\", %a)@]" s print_sig rem + fprintf fmt "@[Vernacextend.TyTerminal (\"%s\", %a)@]" s print_sig rem | ExtNonTerminal (symb, _) :: rem -> - fprintf fmt "@[Vernacentries.TyNonTerminal (%a, %a)@]" + fprintf fmt "@[Vernacextend.TyNonTerminal (%a, %a)@]" print_symbol symb print_sig rem let print_rule fmt r = - fprintf fmt "Vernacentries.TyML (%b, %a, %a, %a)" + fprintf fmt "Vernacextend.TyML (%b, %a, %a, %a)" r.vernac_depr print_sig r.vernac_toks print_body r print_rule_classifier r let print_rules fmt rules = @@ -374,9 +374,9 @@ let print_rules fmt rules = let print_classifier fmt = function | ClassifDefault -> fprintf fmt "" | ClassifName "QUERY" -> - fprintf fmt "~classifier:(fun _ -> Vernac_classifier.classify_as_query)" + fprintf fmt "~classifier:(fun _ -> Vernacextend.classify_as_query)" | ClassifName "SIDEFF" -> - fprintf fmt "~classifier:(fun _ -> Vernac_classifier.classify_as_sideeff)" + fprintf fmt "~classifier:(fun _ -> Vernacextend.classify_as_sideeff)" | ClassifName s -> fatal (Printf.sprintf "Unknown classifier %s" s) | ClassifCode c -> fprintf fmt "~classifier:(%s)" c.code @@ -386,7 +386,7 @@ let print_entry fmt = function let print_ast fmt ext = let pr fmt () = - fprintf fmt "Vernacentries.vernac_extend ~command:\"%s\" %a ?entry:%a %a" + fprintf fmt "Vernacextend.vernac_extend ~command:\"%s\" %a ?entry:%a %a" ext.vernacext_name print_classifier ext.vernacext_class print_entry ext.vernacext_entry print_rules ext.vernacext_rules in @@ -481,8 +481,8 @@ let print_rules fmt (name, rules) = factorization of parsing rules. It allows to recognize rules of the form [ entry(x) ] -> [ x ] so as not to generate a proxy entry and reuse the same entry directly. *) - fprintf fmt "@[Vernacentries.Arg_alias (%s)@]" e - | _ -> fprintf fmt "@[Vernacentries.Arg_rules (%a)@]" pr rules + fprintf fmt "@[Vernacextend.Arg_alias (%s)@]" e + | _ -> fprintf fmt "@[Vernacextend.Arg_rules (%a)@]" pr rules let print_printer fmt = function | None -> fprintf fmt "@[fun _ -> Pp.str \"missing printer\"@]" @@ -491,9 +491,9 @@ let print_printer fmt = function let print_ast fmt arg = let name = arg.vernacargext_name in let pr fmt () = - fprintf fmt "Vernacentries.vernac_argument_extend ~name:%a @[{@\n\ - Vernacentries.arg_parsing = %a;@\n\ - Vernacentries.arg_printer = %a;@\n}@]" + fprintf fmt "Vernacextend.vernac_argument_extend ~name:%a @[{@\n\ + Vernacextend.arg_parsing = %a;@\n\ + Vernacextend.arg_printer = %a;@\n}@]" print_string name print_rules (name, arg.vernacargext_rules) print_printer arg.vernacargext_printer in diff --git a/default.nix b/default.nix index 7c8113c9ab..eeab388cb4 100644 --- a/default.nix +++ b/default.nix @@ -48,7 +48,7 @@ stdenv.mkDerivation rec { python2 time # coq-makefile timing tools dune ] - ++ (with ocamlPackages; [ ocaml findlib camlp5 num ]) + ++ (with ocamlPackages; [ ocaml findlib num ]) ++ optional buildIde ocamlPackages.lablgtk ++ optionals buildDoc [ # Sphinx doc dependencies @@ -67,6 +67,7 @@ stdenv.mkDerivation rec { ++ optionals shell ( [ jq curl gitFull gnupg ] # Dependencies of the merging script ++ (with ocamlPackages; [ merlin ocp-indent ocp-index utop ]) # Dev tools + ++ [ graphviz ] # Useful for STM debugging ); src = diff --git a/dev/base_include b/dev/base_include index 67a7e87d78..48feeec147 100644 --- a/dev/base_include +++ b/dev/base_include @@ -8,6 +8,7 @@ #directory "toplevel";; #directory "library";; #directory "kernel";; +#directory "gramlib";; #directory "engine";; #directory "pretyping";; #directory "lib";; @@ -18,8 +19,6 @@ #directory "stm";; #directory "vernac";; -#directory "+camlp5";; (* Gramext is found in top_printers.ml *) - #use "top_printers.ml";; #use "vm_printers.ml";; @@ -135,7 +134,6 @@ open Pfedit open Proof open Proof_using open Proof_global -open Proof_type open Redexpr open Refiner open Tacmach @@ -176,7 +174,7 @@ open Mltop open Record open Coqloop open Vernacentries -open Vernacinterp +open Vernacextend open Vernac (* Various utilities *) diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 71207bb040..d0b5f4be47 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1076,7 +1076,7 @@ function make_ocaml { function make_ocaml_tools { make_findlib - make_camlp5 + # make_camlp5 } ##### OCAML EXTRA LIBRARIES ##### @@ -1386,7 +1386,7 @@ function make_coq { make_ocaml make_num make_findlib - make_camlp5 + # make_camlp5 make_lablgtk if case $COQ_VERSION in @@ -1645,7 +1645,7 @@ function make_addon_bignums { function make_addon_equations { installer_addon_dependency equations - if build_prep_overlay Equations; then + if build_prep_overlay equations; then installer_addon_section equations "Equations" "Coq plugin for defining functions by equations" "" # Note: PATH is automatically saved/restored by build_prep / build_post PATH=$COQBIN:$PATH diff --git a/dev/checker.dbg b/dev/checker.dbg deleted file mode 100644 index b5b7f0e6d3..0000000000 --- a/dev/checker.dbg +++ /dev/null @@ -1,7 +0,0 @@ -load_printer threads.cma -load_printer str.cma -load_printer clib.cma -load_printer dynlink.cma -load_printer config.cma -load_printer lib.cma -load_printer check.cma diff --git a/dev/checker_db b/dev/checker_db deleted file mode 100644 index fcb6f679ed..0000000000 --- a/dev/checker_db +++ /dev/null @@ -1,5 +0,0 @@ -source checker.dbg - -load_printer checker_printers.cmo - -source checker_printers.dbg diff --git a/dev/checker_dune_db b/dev/checker_dune_db deleted file mode 100644 index cdb6a4b809..0000000000 --- a/dev/checker_dune_db +++ /dev/null @@ -1,5 +0,0 @@ -source checker_dune.dbg - -load_printer checker_printers.cma - -source checker_printers.dbg diff --git a/dev/checker_printers.dbg b/dev/checker_printers.dbg deleted file mode 100644 index 9ebbd74834..0000000000 --- a/dev/checker_printers.dbg +++ /dev/null @@ -1,35 +0,0 @@ -install_printer Checker_printers.pP - -install_printer Checker_printers.ppfuture - -install_printer Checker_printers.ppid -install_printer Checker_printers.pplab -install_printer Checker_printers.ppmbid -install_printer Checker_printers.ppdir -install_printer Checker_printers.ppmp -install_printer Checker_printers.ppcon -install_printer Checker_printers.ppproj -install_printer Checker_printers.ppkn -install_printer Checker_printers.ppmind -install_printer Checker_printers.ppind - -install_printer Checker_printers.ppbigint - -install_printer Checker_printers.ppintset -install_printer Checker_printers.ppidset - -install_printer Checker_printers.ppidmapgen - -install_printer Checker_printers.ppididmap - -install_printer Checker_printers.ppuni -install_printer Checker_printers.ppuni_level -install_printer Checker_printers.ppuniverse_set -install_printer Checker_printers.ppuniverse_instance -install_printer Checker_printers.ppauniverse_context -install_printer Checker_printers.ppuniverse_context -install_printer Checker_printers.ppconstraints -install_printer Checker_printers.ppuniverse_context_future -install_printer Checker_printers.ppuniverses - -install_printer Checker_printers.pploc diff --git a/dev/checker_printers.ml b/dev/checker_printers.ml deleted file mode 100644 index 4f89bbd34e..0000000000 --- a/dev/checker_printers.ml +++ /dev/null @@ -1,69 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -open Pp -open Names -open Univ - -let pp x = Pp.pp_with Format.std_formatter x - -(** Future printer *) - -let ppfuture kx = pp (Future.print (fun _ -> str "_") kx) - -(* name printers *) -let ppid id = pp (Id.print id) -let pplab l = pp (Label.print l) -let ppmbid mbid = pp (str (MBId.debug_to_string mbid)) -let ppdir dir = pp (DirPath.print dir) -let ppmp mp = pp(str (ModPath.debug_to_string mp)) -let ppcon con = pp(Constant.debug_print con) -let ppproj con = pp(Constant.debug_print (Projection.constant con)) -let ppkn kn = pp(str (KerName.to_string kn)) -let ppmind kn = pp(MutInd.debug_print kn) -let ppind (kn,i) = pp(MutInd.debug_print kn ++ str"," ++int i) - -(* term printers *) -let ppbigint n = pp (str (Bigint.to_string n));; - -let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]" -let ppintset l = pp (prset int (Int.Set.elements l)) -let ppidset l = pp (prset Id.print (Id.Set.elements l)) - -let prset' pr l = str "[" ++ hov 0 (prlist_with_sep pr_comma pr l) ++ str "]" - -let pridmap pr l = - let pr (id,b) = Id.print id ++ str "=>" ++ pr id b in - prset' pr (Id.Map.fold (fun a b l -> (a,b)::l) l []) -let ppidmap pr l = pp (pridmap pr l) - -let pridmapgen l = - let dom = Id.Set.elements (Id.Map.domain l) in - if dom = [] then str "[]" else - str "[domain= " ++ hov 0 (prlist_with_sep spc Id.print dom) ++ str "]" -let ppidmapgen l = pp (pridmapgen l) - -let prididmap = pridmap (fun _ -> Id.print) -let ppididmap = ppidmap (fun _ -> Id.print) - -let pP s = pp (hov 0 s) - -(* proof printers *) -let ppuni u = pp(Universe.pr u) -let ppuni_level u = pp (Level.pr u) - -let ppuniverse_context l = pp (pr_universe_context Level.pr l) -let ppconstraints c = pp (pr_constraints Level.pr c) -let ppuniverse_context_future c = - let ctx = Future.force c in - ppuniverse_context ctx - -let pploc x = let (l,r) = Loc.unloc x in - print_string"(";print_int l;print_string",";print_int r;print_string")" diff --git a/dev/checker_printers.mli b/dev/checker_printers.mli deleted file mode 100644 index 8be9b87257..0000000000 --- a/dev/checker_printers.mli +++ /dev/null @@ -1,50 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -(** Printers for the ocaml toplevel. *) - -val pp : Pp.t -> unit -val pP : Pp.t -> unit (* with surrounding box *) - -val ppfuture : 'a Future.computation -> unit - -val ppid : Names.Id.t -> unit -val pplab : Names.Label.t -> unit -val ppmbid : Names.MBId.t -> unit -val ppdir : Names.DirPath.t -> unit -val ppmp : Names.ModPath.t -> unit -val ppcon : Names.Constant.t -> unit -val ppproj : Names.Projection.t -> unit -val ppkn : Names.KerName.t -> unit -val ppmind : Names.MutInd.t -> unit -val ppind : Names.inductive -> unit - -val ppbigint : Bigint.bigint -> unit - -val ppintset : Int.Set.t -> unit -val ppidset : Names.Id.Set.t -> unit - -val pridmap : (Names.Id.Map.key -> 'a -> Pp.t) -> 'a Names.Id.Map.t -> Pp.t -val ppidmap : (Names.Id.Map.key -> 'a -> Pp.t) -> 'a Names.Id.Map.t -> unit - -val pridmapgen : 'a Names.Id.Map.t -> Pp.t -val ppidmapgen : 'a Names.Id.Map.t -> unit - -val prididmap : Names.Id.t Names.Id.Map.t -> Pp.t -val ppididmap : Names.Id.t Names.Id.Map.t -> unit - -(* Universes *) -val ppuni : Univ.Universe.t -> unit -val ppuni_level : Univ.Level.t -> unit (* raw *) -val ppuniverse_context : Univ.UContext.t -> unit -val ppconstraints : Univ.Constraint.t -> unit -val ppuniverse_context_future : Univ.UContext.t Future.computation -> unit - -val pploc : Loc.t -> unit diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md new file mode 100644 index 0000000000..6ca3aa2981 --- /dev/null +++ b/dev/ci/README-developers.md @@ -0,0 +1,165 @@ +Information for developers about the CI system +---------------------------------------------- + +When you submit a pull request (PR) on the Coq GitHub repository, this will +automatically launch a battery of CI tests. The PR will not be integrated +unless these tests pass. + +We are currently running tests on the following platforms: + +- GitLab CI is the main CI platform. It tests the compilation of Coq, + of the documentation, and of CoqIDE on Linux with several versions + of OCaml and with warnings as errors; it runs the test-suite and + tests the compilation of several external developments. + +- Travis CI is used to test the compilation of Coq and run the test-suite on + macOS. It also runs a linter that checks whitespace discipline. A + [pre-commit hook](../tools/pre-commit) is automatically installed by + `./configure`. It should allow complying with this discipline without pain. + +- AppVeyor is used to test the compilation of Coq and run the test-suite on + Windows. + +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: + +1. Log into GitLab CI (the easiest way is to sign in with your GitHub account). +2. Click on "New Project". +3. Choose "CI / CD for external repository" then click on "GitHub". +4. Find your fork of the Coq repository and click on "Connect". +5. If GitLab did not do so automatically, [enable the Container Registry](https://docs.gitlab.com/ee/user/project/container_registry.html#enable-the-container-registry-for-your-project). +6. You are encouraged to go to the CI / CD general settings and increase the + timeout from 1h to 2h for better reliability. + +Now everytime you push (including force-push unless you changed the default +GitLab setting) to your fork on GitHub, it will be synchronized on GitLab and +CI will be run. You will receive an e-mail with a report of the failures if +there are some. + +You can also run one CI target locally (using `make ci-somedev`). + +See also [`test-suite/README.md`](../../test-suite/README.md) for information about adding new tests to the test-suite. + +### Breaking changes + +When your PR breaks an external project we test in our CI, you must +prepare a patch (or ask someone to prepare a patch) to fix the +project. There is experimental support for an improved workflow, see +[the next section](#experimental-automatic-overlay-creation-and-building), below +are the steps to manually prepare a patch: + +1. Fork the external project, create a new branch, push a commit adapting + the project to your changes. +2. Test your pull request with your adapted version of the external project by + adding an overlay file to your pull request (cf. + [`dev/ci/user-overlays/README.md`](user-overlays/README.md)). +3. Fixes to external libraries (pure Coq projects) *must* be backward + compatible (i.e. they should also work with the development version of Coq, + and the latest stable version). This will allow you to open a PR on the + external project repository to have your changes merged *before* your PR on + Coq can be integrated. + + On the other hand, patches to plugins (projects linking to the Coq ML API) + can very rarely be made backward compatible and plugins we test will + generally have a dedicated branch per Coq version. + You can still open a pull request but the merging will be requested by the + developer who merges the PR on Coq. There are plans to improve this, cf. + [#6724](https://github.com/coq/coq/issues/6724). + +Moreover your PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) file. + +### Experimental automatic overlay creation and building + +If you break external projects that are hosted on GitHub, you can use +the `create-overlays.sh` script to automatically perform most of the +above steps. In order to do so, call the script as: +``` +./dev/tools/create-overlays.sh ejgallego 9873 aac_tactics elpi ltac +``` +replacing `ejgallego` by your GitHub nickname and `9873` by the actual PR +number. The script will: + +- checkout the contributions and prepare the branch/remote so you can + just commit the fixes and push, +- add the corresponding overlay file in `dev/ci/user-overlays`. + +For problems related to ML-plugins, if you use `dune build` to build +Coq, it will actually be aware of the broken contributions and perform +a global build. This is very convenient when using `merlin` as you +will get a coherent view of all the broken plugins, with full +incremental cross-project rebuild. + +Advanced GitLab CI information +------------------------------ + +GitLab CI is set up to use the "build artifact" feature to avoid +rebuilding Coq. In one job, Coq is built with `./configure -prefix _install_ci` +and `make install` is run, then the `_install_ci` directory +persists to and is used by the next jobs. + +### Artifacts + +Build artifacts from GitLab can be linked / downloaded in a systematic +way, see [GitLab's documentation](https://docs.gitlab.com/ce/user/project/pipelines/job_artifacts.html#downloading-the-latest-job-artifacts) +for more information. For example, to access the documentation of the +`master` branch, you can do: + +https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman + +Browsing artifacts is also possible: +https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_install_ci/?job=build:base + +Above, you can replace `master` and `job` by the desired GitLab branch and job name. + +Currently available artifacts are: + +- the Coq executables and stdlib, in four copies varying in + architecture and OCaml version used to build Coq: + https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_install_ci/?job=build:base + + Additionally, an experimental Dune build is provided: + https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_build/?job=build:edge:dune:dev + +- the Coq documentation, built in the `doc:*` jobs. When submitting + a documentation PR, this can help reviewers checking the rendered result: + + + Coq's Reference Manual [master branch] + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman + + Coq's Standard Library Documentation [master branch] + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=build:base + + Coq's ML API Documentation [master branch] + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc + +### GitLab and Windows + +If your repository has access to runners tagged `windows`, setting the +secret variable `WINDOWS` to `enabled` will add jobs building Windows +versions of Coq (32bit and 64bit). + +If the secret variable `WINDOWS` is set to `enabled_all_addons`, +an extended set of addons will be added to the Windows installer. +This leads to a considerable runtime in CI so this is not enabled +by default for pipelines for pull requests. + +The Windows jobs are enabled on Coq's repository, where pipelines for +pull requests run. + +### GitLab and Docker + +System and opam packages are installed in a Docker image. The image is +automatically built and uploaded to your GitLab registry, and is +loaded by subsequent jobs. + +**IMPORTANT**: When updating Coq's CI docker image, you must modify +the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml) +and [`Dockerfile`](docker/bionic_coq/Dockerfile) + +The Docker building job reuses the uploaded image if it is available, +but if you wish to save more time you can skip the job by setting +`SKIP_DOCKER` to `true`. + +This means you will need to change its value when the Docker image +needs to be updated. You can do so for a single pipeline by starting +it through the web interface. + +See also [`docker/README.md`](docker/README.md). diff --git a/dev/ci/README-users.md b/dev/ci/README-users.md new file mode 100644 index 0000000000..01769aeddb --- /dev/null +++ b/dev/ci/README-users.md @@ -0,0 +1,85 @@ +Information for external library / Coq plugin authors +----------------------------------------------------- + +You are encouraged to consider submitting your development for addition to +Coq's CI. This means that: + +- Any time that a proposed change is breaking your development, Coq developers + will send you patches to adapt it or, at the very least, will work with you + to see how to adapt it. + +On the condition that: + +- At the time of the submission, your development works with Coq's + `master` branch. + +- Your development is publicly available in a git repository and we can easily + send patches to you (e.g. through pull / merge requests). + +- You react in a timely manner to discuss / integrate those patches. + +- You do not push, to the branches that we test, commits that haven't been + first tested to compile with the corresponding branch(es) of Coq. + + For that, we recommend setting a CI system for you development, see + [supported CI images for Coq](#supported-ci-images-for-coq) below. + +- You maintain a reasonable build time for your development, or you provide + a "lite" target that we can use. + +In case you forget to comply with these last three conditions, we would reach +out to you and give you a 30-day grace period during which your development +would be moved into our "allow failure" category. At the end of the grace +period, in the absence of progress, the development would be removed from our +CI. + +### Timely merging of overlays + +A pitfall of the current CI setup is that when a breaking change is +merged in Coq upstream, CI for your contrib will be broken until you +merge the corresponding pull request with the fix for your contribution. + +As of today, you have to worry about synchronizing with Coq upstream +every once in a while; we hope we will improve this in the future by +using [coqbot](https://github.com/coq/bot); meanwhile, a workaround is +to give merge permissions to someone from the Coq team as to help with +these kind of merges. + +### Add your development by submitting a pull request + +Add a new `ci-mydev.sh` script to [`dev/ci`](.); set the corresponding +variables in [`ci-basic-overlay.sh`](ci-basic-overlay.sh); add the +corresponding target to [`Makefile.ci`](../../Makefile.ci) and a new job to +[`.gitlab-ci.yml`](../../.gitlab-ci.yml) so that this new target is run. +Have a look at [#7656](https://github.com/coq/coq/pull/7656/files) for an +example. **Do not hesitate to submit an incomplete pull request if you need +help to finish it.** + +You may also be interested in having your development tested in our +performance benchmark. Currently this is done by providing an OPAM package +in https://github.com/coq/opam-coq-archive and opening an issue at +https://github.com/coq/coq-bench/issues. + +### Recommended branching policy. + +It is sometimes the case that you will need to maintain a branch of +your development for particular Coq versions. This is in fact very +likely if your development includes a Coq ML plugin. + +We thus recommend a branching convention that mirrors Coq's branching +policy. Then, you would have a `master` branch that follows Coq's +`master`, a `v8.8` branch that works with Coq's `v8.8` branch and so +on. + +This convention will be supported by tools in the future to make some +developer commands work more seamlessly. + +### Supported CI images for Coq + +The Coq developers and contributors provide official Docker and Nix +images for testing against Coq master. Using these images is highly +recommended: + +- For Docker, see: https://github.com/coq-community/docker-coq +- For Nix, see the setup at + https://github.com/coq-community/manifesto/wiki/Continuous-Integration-with-Nix diff --git a/dev/ci/README.md b/dev/ci/README.md index 4709247549..afbfab3ac6 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -6,213 +6,15 @@ breakage on our Continuous Integration (CI) platforms *before* integration, so as to ensure better robustness and catch problems as early as possible. These tests include the compilation of several external libraries / plugins. -This document contains information for both external library / plugin authors, -who might be interested in having their development tested, and for Coq -developers / contributors, who must ensure that they don't break these -external developments accidentally. +This README is split into two specific documents: -*Remark:* the CI policy outlined in this document is susceptible to evolve and -specific accommodations are of course possible. +- [README-users.md](./README-users.md) which contains information for + authors of external libraries and plugins who might be interested in + having their development tested in our CI system. -Information for external library / plugin authors -------------------------------------------------- +- [README-developers.md](./README-developers.md) for Coq developers / + contributors, who must ensure that they don't break these external + developments accidentally. -You are encouraged to consider submitting your development for addition to -our CI. This means that: - -- Any time that a proposed change is breaking your development, Coq developers - will send you patches to adapt it or, at the very least, will work with you - to see how to adapt it. - -On the condition that: - -- At the time of the submission, your development works with Coq's - `master` branch. - -- Your development is publicly available in a git repository and we can easily - send patches to you (e.g. through pull / merge requests). - -- You react in a timely manner to discuss / integrate those patches. - -- You do not push, to the branches that we test, commits that haven't been - first tested to compile with the corresponding branch(es) of Coq. - -- You maintain a reasonable build time for your development, or you provide - a "lite" target that we can use. - -In case you forget to comply with these last three conditions, we would reach -out to you and give you a 30-day grace period during which your development -would be moved into our "allow failure" category. At the end of the grace -period, in the absence of progress, the development would be removed from our -CI. - -### Add your development by submitting a pull request - -Add a new `ci-mydev.sh` script to [`dev/ci`](.); set the corresponding -variables in [`ci-basic-overlay.sh`](ci-basic-overlay.sh); add the -corresponding target to [`Makefile.ci`](../../Makefile.ci) and a new job to -[`.gitlab-ci.yml`](../../.gitlab-ci.yml) so that this new target is run. -Have a look at [#7656](https://github.com/coq/coq/pull/7656/files) for an -example. **Do not hesitate to submit an incomplete pull request if you need -help to finish it.** - -You may also be interested in having your development tested in our -performance benchmark. Currently this is done by providing an OPAM package -in https://github.com/coq/opam-coq-archive and opening an issue at -https://github.com/coq/coq-bench/issues. - -### Recommended branching policy. - -It is sometimes the case that you will need to maintain a branch of -your development for particular Coq versions. This is in fact very -likely if your development includes a Coq ML plugin. - -We thus recommend a branching convention that mirrors Coq's branching -policy. Then, you would have a `master` branch that follows Coq's -`master`, a `v8.8` branch that works with Coq's `v8.8` branch and so -on. - -This convention will be supported by tools in the future to make some -developer commands work more seamlessly. - -Information for developers --------------------------- - -When you submit a pull request (PR) on Coq GitHub repository, this will -automatically launch a battery of CI tests. The PR will not be integrated -unless these tests pass. - -We are currently running tests on the following platforms: - -- GitLab CI is the main CI platform. It tests the compilation of Coq, of the - documentation, and of CoqIDE on Linux with several versions of OCaml / - camlp5, and with warnings as errors; it runs the test-suite and tests the - compilation of several external developments. - -- Travis CI is used to test the compilation of Coq and run the test-suite on - macOS. It also runs a linter that checks whitespace discipline. A - [pre-commit hook](../tools/pre-commit) is automatically installed by - `./configure`. It should allow complying with this discipline without pain. - -- AppVeyor is used to test the compilation of Coq and run the test-suite on - Windows. - -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: - -1. Log into GitLab CI (the easiest way is to sign in with your GitHub account). -2. Click on "New Project". -3. Choose "CI / CD for external repository" then click on "GitHub". -4. Find your fork of the Coq repository and click on "Connect". -5. If GitLab did not do so automatically, [enable the Container Registry](https://docs.gitlab.com/ee/user/project/container_registry.html#enable-the-container-registry-for-your-project). -6. You are encouraged to go to the CI / CD general settings and increase the - timeout from 1h to 2h for better reliability. - -Now everytime you push (including force-push unless you changed the default -GitLab setting) to your fork on GitHub, it will be synchronized on GitLab and -CI will be run. You will receive an e-mail with a report of the failures if -there are some. - -You can also run one CI target locally (using `make ci-somedev`). - -See also [`test-suite/README.md`](../../test-suite/README.md) for information about adding new tests to the test-suite. - -### Breaking changes - -When your PR breaks an external project we test in our CI, you must prepare a -patch (or ask someone to prepare a patch) to fix the project: - -1. Fork the external project, create a new branch, push a commit adapting - the project to your changes. -2. Test your pull request with your adapted version of the external project by - adding an overlay file to your pull request (cf. - [`dev/ci/user-overlays/README.md`](user-overlays/README.md)). -3. Fixes to external libraries (pure Coq projects) *must* be backward - compatible (i.e. they should also work with the development version of Coq, - and the latest stable version). This will allow you to open a PR on the - external project repository to have your changes merged *before* your PR on - Coq can be integrated. - - On the other hand, patches to plugins (projects linking to the Coq ML API) - can very rarely be made backward compatible and plugins we test will - generally have a dedicated branch per Coq version. - You can still open a pull request but the merging will be requested by the - developer who merges the PR on Coq. There are plans to improve this, cf. - [#6724](https://github.com/coq/coq/issues/6724). - -Moreover your PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) file. - -Advanced GitLab CI information ------------------------------- - -GitLab CI is set up to use the "build artifact" feature to avoid -rebuilding Coq. In one job, Coq is built with `./configure -prefix _install_ci` -and `make install` is run, then the `_install_ci` directory -persists to and is used by the next jobs. - -### Artifacts - -Build artifacts from GitLab can be linked / downloaded in a systematic -way, see [GitLab's documentation](https://docs.gitlab.com/ce/user/project/pipelines/job_artifacts.html#downloading-the-latest-job-artifacts) -for more information. For example, to access the documentation of the -`master` branch, you can do: - -https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman - -Browsing artifacts is also possible: -https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_install_ci/?job=build:base - -Above, you can replace `master` and `job` by the desired GitLab branch and job name. - -Currently available artifacts are: - -- the Coq executables and stdlib, in four copies varying in - architecture and OCaml version used to build Coq: - https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_install_ci/?job=build:base - - Additionally, an experimental Dune build is provided: - https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_build/?job=build:edge:dune:dev - -- the Coq documentation, built in the `doc:*` jobs. When submitting - a documentation PR, this can help reviewers checking the rendered result: - - + Coq's Reference Manual [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman - + Coq's Standard Library Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=doc:refman - + Coq's ML API Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc - -### GitLab and Windows - -If your repository has access to runners tagged `windows`, setting the -secret variable `WINDOWS` to `enabled` will add jobs building Windows -versions of Coq (32bit and 64bit). - -If the secret variable `WINDOWS` is set to `enabled_all_addons`, -an extended set of addons will be added to the Windows installer. -This leads to a considerable runtime in CI so this is not enabled -by default for pipelines for pull requests. - -The Windows jobs are enabled on Coq's repository, where pipelines for -pull requests run. - -### GitLab and Docker - -System and opam packages are installed in a Docker image. The image is -automatically built and uploaded to your GitLab registry, and is -loaded by subsequent jobs. - -**IMPORTANT**: When updating Coq's CI docker image, you must modify -the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml) -and [`Dockerfile`](docker/bionic_coq/Dockerfile) - -The Docker building job reuses the uploaded image if it is available, -but if you wish to save more time you can skip the job by setting -`SKIP_DOCKER` to `true`. - -This means you will need to change its value when the Docker image -needs to be updated. You can do so for a single pipeline by starting -it through the web interface. - -See also [`docker/README.md`](docker/README.md). +*Remark:* the CI policy outlined in these documents is susceptible to +evolve and specific accommodations are of course possible. diff --git a/dev/ci/appveyor.sh b/dev/ci/appveyor.sh index 84fec71f7a..abeb039c0e 100644 --- a/dev/ci/appveyor.sh +++ b/dev/ci/appveyor.sh @@ -10,6 +10,6 @@ bash opam64/install.sh opam init -a mingw https://github.com/fdopen/opam-repository-mingw.git --comp $APPVEYOR_OPAM_SWITCH --switch $APPVEYOR_OPAM_SWITCH eval "$(opam config env)" -opam install -y num ocamlfind camlp5 ounit +opam install -y num ocamlfind ounit cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make && make byte && make -C test-suite all INTERACTIVE= # && make validate diff --git a/dev/ci/ci-aac-tactics.sh b/dev/ci/ci-aac-tactics.sh deleted file mode 100755 index 896a0ddf66..0000000000 --- a/dev/ci/ci-aac-tactics.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download aactactics - -( cd "${CI_BUILD_DIR}/aactactics" && make && make install ) diff --git a/dev/ci/ci-aac_tactics.sh b/dev/ci/ci-aac_tactics.sh new file mode 100755 index 0000000000..19f1f43746 --- /dev/null +++ b/dev/ci/ci-aac_tactics.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download aac_tactics + +( cd "${CI_BUILD_DIR}/aac_tactics" && make && make install ) diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 50d4d21637..96bc5be7ff 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -70,6 +70,13 @@ : "${HoTT_CI_ARCHIVEURL:=${HoTT_CI_GITURL}/archive}" ######################################################################## +# CoqHammer +######################################################################## +: "${coqhammer_CI_REF:=master}" +: "${coqhammer_CI_GITURL:=https://github.com/lukaszcz/coqhammer}" +: "${coqhammer_CI_ARCHIVEURL:=${coqhammer_CI_GITURL}/archive}" + +######################################################################## # Ltac2 ######################################################################## : "${ltac2_CI_REF:=master}" @@ -106,16 +113,16 @@ ######################################################################## # CompCert ######################################################################## -: "${CompCert_CI_REF:=master}" -: "${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert}" -: "${CompCert_CI_ARCHIVEURL:=${CompCert_CI_GITURL}/archive}" +: "${compcert_CI_REF:=master}" +: "${compcert_CI_GITURL:=https://github.com/AbsInt/CompCert}" +: "${compcert_CI_ARCHIVEURL:=${compcert_CI_GITURL}/archive}" ######################################################################## # VST ######################################################################## -: "${VST_CI_REF:=master}" -: "${VST_CI_GITURL:=https://github.com/PrincetonUniversity/VST}" -: "${VST_CI_ARCHIVEURL:=${VST_CI_GITURL}/archive}" +: "${vst_CI_REF:=master}" +: "${vst_CI_GITURL:=https://github.com/PrincetonUniversity/VST}" +: "${vst_CI_ARCHIVEURL:=${vst_CI_GITURL}/archive}" ######################################################################## # cross-crypto @@ -146,7 +153,7 @@ : "${formal_topology_CI_ARCHIVEURL:=${formal_topology_CI_GITURL}/archive}" ######################################################################## -# coq-dpdgraph +# coq_dpdgraph ######################################################################## : "${coq_dpdgraph_CI_REF:=coq-master}" : "${coq_dpdgraph_CI_GITURL:=https://github.com/Karmaki/coq-dpdgraph}" @@ -155,9 +162,9 @@ ######################################################################## # CoLoR ######################################################################## -: "${CoLoR_CI_REF:=master}" -: "${CoLoR_CI_GITURL:=https://github.com/fblanqui/color}" -: "${CoLoR_CI_ARCHIVEURL:=${CoLoR_CI_GITURL}/archive}" +: "${color_CI_REF:=master}" +: "${color_CI_GITURL:=https://github.com/fblanqui/color}" +: "${color_CI_ARCHIVEURL:=${color_CI_GITURL}/archive}" ######################################################################## # SF @@ -189,16 +196,16 @@ ######################################################################## # Equations ######################################################################## -: "${Equations_CI_REF:=master}" -: "${Equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations}" -: "${Equations_CI_ARCHIVEURL:=${Equations_CI_GITURL}/archive}" +: "${equations_CI_REF:=master}" +: "${equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations}" +: "${equations_CI_ARCHIVEURL:=${equations_CI_GITURL}/archive}" ######################################################################## # Elpi ######################################################################## -: "${Elpi_CI_REF:=coq-master}" -: "${Elpi_CI_GITURL:=https://github.com/LPCIC/coq-elpi}" -: "${Elpi_CI_ARCHIVEURL:=${Elpi_CI_GITURL}/archive}" +: "${elpi_CI_REF:=coq-master}" +: "${elpi_CI_GITURL:=https://github.com/LPCIC/coq-elpi}" +: "${elpi_CI_ARCHIVEURL:=${elpi_CI_GITURL}/archive}" ######################################################################## # fcsl-pcm @@ -208,13 +215,6 @@ : "${fcsl_pcm_CI_ARCHIVEURL:=${fcsl_pcm_CI_GITURL}/archive}" ######################################################################## -# pidetop -######################################################################## -: "${pidetop_CI_REF:=v8.9}" -: "${pidetop_CI_GITURL:=https://bitbucket.org/coqpide/pidetop}" -: "${pidetop_CI_ARCHIVEURL:=${pidetop_CI_GITURL}/get}" - -######################################################################## # ext-lib ######################################################################## : "${ext_lib_CI_REF:=master}" @@ -250,8 +250,15 @@ : "${menhirlib_CI_ARCHIVEURL:=${menhirlib_CI_GITURL}/-/archive}" ######################################################################## -# aac-tactics +# aac_tactics +######################################################################## +: "${aac_tactics_CI_REF:=master}" +: "${aac_tactics_CI_GITURL:=https://github.com/coq-community/aac-tactics}" +: "${aac_tactics_CI_ARCHIVEURL:=${aac_tactics_CI_GITURL}/archive}" + +######################################################################## +# paramcoq ######################################################################## -: "${aactactics_CI_REF:=master}" -: "${aactactics_CI_GITURL:=https://github.com/coq-community/aac-tactics}" -: "${aactactics_CI_ARCHIVEURL:=${aactactics_CI_GITURL}/archive}" +: "${paramcoq_CI_REF:=master}" +: "${paramcoq_CI_GITURL:=https://github.com/coq-community/paramcoq}" +: "${paramcoq_CI_ARCHIVEURL:=${paramcoq_CI_GITURL}/archive}" diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index dc696f69d9..a0094b1006 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download CoLoR +git_download color -( cd "${CI_BUILD_DIR}/CoLoR" && make ) +( cd "${CI_BUILD_DIR}/color" && make ) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 7a450d0d48..a5aa54144c 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -46,8 +46,11 @@ for overlay in "${ci_dir}"/user-overlays/*.sh; do # shellcheck source=/dev/null . "${overlay}" done + +set +x # shellcheck source=ci-basic-overlay.sh . "${ci_dir}/ci-basic-overlay.sh" +set -x # [git_download project] will download [project] and unpack it # in [$CI_BUILD_DIR/project] if the folder does not exist already; diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 01c35ceb4a..59a85e4726 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -3,7 +3,7 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download CompCert +git_download compcert -( cd "${CI_BUILD_DIR}/CompCert" && \ +( cd "${CI_BUILD_DIR}/compcert" && \ ./configure -ignore-coq-version x86_32-linux && make && make check-proof ) diff --git a/dev/ci/ci-coq-dpdgraph.sh b/dev/ci/ci-coq_dpdgraph.sh index 2373ea6c62..2373ea6c62 100755 --- a/dev/ci/ci-coq-dpdgraph.sh +++ b/dev/ci/ci-coq_dpdgraph.sh diff --git a/dev/ci/ci-coqhammer.sh b/dev/ci/ci-coqhammer.sh new file mode 100755 index 0000000000..4384e6c828 --- /dev/null +++ b/dev/ci/ci-coqhammer.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download coqhammer + +( cd "${CI_BUILD_DIR}/coqhammer" && make ) diff --git a/dev/ci/ci-elpi.sh b/dev/ci/ci-elpi.sh index 9b4a06fd5b..d60bf34ba2 100755 --- a/dev/ci/ci-elpi.sh +++ b/dev/ci/ci-elpi.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download Elpi +git_download elpi -( cd "${CI_BUILD_DIR}/Elpi" && make && make install ) +( cd "${CI_BUILD_DIR}/elpi" && make && make install ) diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh index 998d50faa7..b58a794da2 100755 --- a/dev/ci/ci-equations.sh +++ b/dev/ci/ci-equations.sh @@ -3,7 +3,7 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download Equations +git_download equations -( cd "${CI_BUILD_DIR}/Equations" && coq_makefile -f _CoqProject -o Makefile && \ +( cd "${CI_BUILD_DIR}/equations" && coq_makefile -f _CoqProject -o Makefile && \ make && make test-suite && make examples && make install) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 7eeeb09372..c8e6fe690f 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download HoTT -( cd "${CI_BUILD_DIR}/HoTT" && ./autogen.sh && ./configure && make && make validate ) +( cd "${CI_BUILD_DIR}/HoTT" && ./autogen.sh -skip-submodules && ./configure && make && make validate ) diff --git a/dev/ci/ci-paramcoq.sh b/dev/ci/ci-paramcoq.sh new file mode 100755 index 0000000000..c641af2abb --- /dev/null +++ b/dev/ci/ci-paramcoq.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download paramcoq + +( cd "${CI_BUILD_DIR}/paramcoq" && make && make install ) diff --git a/dev/ci/ci-pidetop.sh b/dev/ci/ci-pidetop.sh deleted file mode 100755 index 1a9a26843c..0000000000 --- a/dev/ci/ci-pidetop.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download pidetop - -# Travis / Gitlab have different filesystem layout due to use of -# `-local`. We need to improve this divergence but if we use Dune this -# "local" oddity goes away automatically so not bothering... -if [ -d "$COQBIN/../lib/coq" ]; then - COQLIB="$COQBIN/../lib/coq/" -else - COQLIB="$COQBIN/../" -fi - -( cd "${CI_BUILD_DIR}/pidetop" && dune build -p pidetop @install ) - -echo -en '4\nexit' | "${CI_BUILD_DIR}/pidetop/_build/install/default/bin/pidetop" -coqlib "$COQLIB" -main-channel stdfds diff --git a/dev/ci/ci-plugin-tutorial.sh b/dev/ci/ci-plugin_tutorial.sh index 6c26a71a21..6c26a71a21 100755 --- a/dev/ci/ci-plugin-tutorial.sh +++ b/dev/ci/ci-plugin_tutorial.sh diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh index 0fec19205a..169d1a41db 100755 --- a/dev/ci/ci-vst.sh +++ b/dev/ci/ci-vst.sh @@ -3,6 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download VST +git_download vst -( cd "${CI_BUILD_DIR}/VST" && make IGNORECOQVERSION=true ) +( cd "${CI_BUILD_DIR}/vst" && make IGNORECOQVERSION=true ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 4ddb582414..3fc6dce4e5 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2018-10-30-V1" +# CACHEKEY: "bionic_coq-V2018-11-08-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -41,29 +41,27 @@ ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.4.0 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. -ENV CAMLP5_VER="7.03" \ - COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" +ENV COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" # base switch RUN opam init -a --disable-sandboxing --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam env) && opam update && \ - opam install $BASE_OPAM camlp5.$CAMLP5_VER $COQIDE_OPAM $CI_OPAM + opam install $BASE_OPAM $COQIDE_OPAM $CI_OPAM # base+32bit switch RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ - opam install $BASE_OPAM camlp5.$CAMLP5_VER + opam install $BASE_OPAM # EDGE switch ENV COMPILER_EDGE="4.07.1" \ - CAMLP5_VER_EDGE="7.06.10-g84ce6cc4" \ COQIDE_OPAM_EDGE="lablgtk.2.18.6 conf-gtksourceview.2" \ BASE_OPAM_EDGE="dune-release.1.1.0" RUN opam switch create $COMPILER_EDGE && eval $(opam env) && \ - opam install $BASE_OPAM $BASE_OPAM_EDGE camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE + opam install $BASE_OPAM $BASE_OPAM_EDGE $COQIDE_OPAM_EDGE # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. RUN opam switch create "${COMPILER_EDGE}+flambda" && eval $(opam env) && \ - opam install $BASE_OPAM $BASE_OPAM_EDGE camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE $CI_OPAM + opam install $BASE_OPAM $BASE_OPAM_EDGE $COQIDE_OPAM_EDGE $CI_OPAM RUN opam clean -a -c diff --git a/dev/ci/nix/CoLoR.nix b/dev/ci/nix/CoLoR.nix new file mode 100644 index 0000000000..4c5cfd83da --- /dev/null +++ b/dev/ci/nix/CoLoR.nix @@ -0,0 +1,5 @@ +{ bignums }: + +{ + buildInputs = [ bignums ]; +} diff --git a/dev/ci/nix/CompCert.nix b/dev/ci/nix/CompCert.nix new file mode 100644 index 0000000000..db1721e5f5 --- /dev/null +++ b/dev/ci/nix/CompCert.nix @@ -0,0 +1,7 @@ +{ ocamlPackages }: + +{ + buildInputs = with ocamlPackages; [ ocaml findlib menhir ]; + configure = "./configure -ignore-coq-version x86_64-linux"; + make = "make all check-proof"; +} diff --git a/dev/ci/nix/Corn.nix b/dev/ci/nix/Corn.nix new file mode 100644 index 0000000000..18c7750279 --- /dev/null +++ b/dev/ci/nix/Corn.nix @@ -0,0 +1,5 @@ +{ bignums, math-classes }: + +{ + buildInputs = [ bignums math-classes ]; +} diff --git a/dev/ci/nix/Elpi.nix b/dev/ci/nix/Elpi.nix new file mode 100644 index 0000000000..0a6ed20295 --- /dev/null +++ b/dev/ci/nix/Elpi.nix @@ -0,0 +1,4 @@ +{ ocamlPackages }: +{ + buildInputs = with ocamlPackages; [ ocaml findlib elpi ]; +} diff --git a/dev/ci/nix/GeoCoq.nix b/dev/ci/nix/GeoCoq.nix new file mode 100644 index 0000000000..a86fb2c44a --- /dev/null +++ b/dev/ci/nix/GeoCoq.nix @@ -0,0 +1,5 @@ +{ mathcomp }: +{ + buildInputs = [ mathcomp ]; + configure = "./configure.sh"; +} diff --git a/dev/ci/nix/HoTT.nix b/dev/ci/nix/HoTT.nix new file mode 100644 index 0000000000..dea0aeeb55 --- /dev/null +++ b/dev/ci/nix/HoTT.nix @@ -0,0 +1,6 @@ +{ autoconf, automake }: +{ + buildInputs = [ autoconf automake ]; + configure = "./autogen.sh && ./configure"; + make = "make all validate"; +} diff --git a/dev/ci/nix/VST.nix b/dev/ci/nix/VST.nix new file mode 100644 index 0000000000..3e2629a0b6 --- /dev/null +++ b/dev/ci/nix/VST.nix @@ -0,0 +1,6 @@ +{}: + +rec { + make = "make IGNORECOQVERSION=true"; + clean = "${make} clean"; +} diff --git a/dev/ci/nix/bedrock2.nix b/dev/ci/nix/bedrock2.nix new file mode 100644 index 0000000000..552d9297e2 --- /dev/null +++ b/dev/ci/nix/bedrock2.nix @@ -0,0 +1,5 @@ +{}: +{ + configure = "git submodule update --init --recursive"; + clean = "(cd deps/bbv && make clean); (cd deps/riscv-coq && make clean); (cd compiler && make clean); (cd bedrock2 && make clean)"; +} diff --git a/dev/ci/nix/bignums.nix b/dev/ci/nix/bignums.nix new file mode 100644 index 0000000000..1d931c858e --- /dev/null +++ b/dev/ci/nix/bignums.nix @@ -0,0 +1,5 @@ +{ ocamlPackages }: + +{ + buildInputs = with ocamlPackages; [ ocaml findlib camlp5 ]; +} diff --git a/dev/ci/nix/coq.nix b/dev/ci/nix/coq.nix new file mode 100644 index 0000000000..ecd280e58d --- /dev/null +++ b/dev/ci/nix/coq.nix @@ -0,0 +1,9 @@ +{ stdenv, callPackage, branch, wd }: + +let coq = callPackage wd { buildDoc = false; doInstallCheck = false; coq-version = "8.9"; }; in + +coq.overrideAttrs (o: { + name = "coq-local-${branch}"; + src = fetchGit "${wd}"; + enableParallelBuilding = true; +}) diff --git a/dev/ci/nix/coq_dpdgraph.nix b/dev/ci/nix/coq_dpdgraph.nix new file mode 100644 index 0000000000..611e2fcca5 --- /dev/null +++ b/dev/ci/nix/coq_dpdgraph.nix @@ -0,0 +1,7 @@ +{ autoconf, ocamlPackages }: + +{ + buildInputs = [ autoconf ] ++ (with ocamlPackages; [ ocaml findlib camlp5 ocamlgraph ]); + configure = "autoconf && ./configure"; + make = "make all test-suite"; +} diff --git a/dev/ci/nix/cross_crypto.nix b/dev/ci/nix/cross_crypto.nix new file mode 100644 index 0000000000..98f74f9474 --- /dev/null +++ b/dev/ci/nix/cross_crypto.nix @@ -0,0 +1,5 @@ +{}: +{ + configure = "git submodule update --init --recursive"; + clean = "make cleanall"; +} diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix new file mode 100644 index 0000000000..4acfae48e4 --- /dev/null +++ b/dev/ci/nix/default.nix @@ -0,0 +1,72 @@ +{ pkgs ? import <nixpkgs> {} +, branch +, wd +, project ? "xyz" +, bn ? "release" +}: + +with pkgs; + +# Coq from this directory +let coq = callPackage ./coq.nix { inherit branch wd; }; in + +# Third-party libraries, built with this Coq +let coqPackages = mkCoqPackages coq; in +let mathcomp = coqPackages.mathcomp.overrideAttrs (o: { + name = "coq-git-mathcomp-git"; + src = fetchTarball https://github.com/math-comp/math-comp/archive/master.tar.gz; + }); in +let bignums = coqPackages.bignums.overrideAttrs (o: + if bn == "release" then {} else + if bn == "master" then { src = fetchTarball https://github.com/coq/bignums/archive/master.tar.gz; } else + { src = fetchTarball bn; } + ); in +let coqprime = coqPackages.coqprime.override { inherit coq bignums; }; in +let math-classes = + (coqPackages.math-classes.override { inherit coq bignums; }) + .overrideAttrs (o: { + src = fetchTarball "https://github.com/coq-community/math-classes/archive/master.tar.gz"; + }); in + +let unicoq = callPackage ./unicoq.nix { inherit coq; }; in + +let callPackage = newScope { inherit coq mathcomp bignums coqprime math-classes unicoq; }; in + +# Environments for building CI libraries with this Coq +let projects = { + bedrock2 = callPackage ./bedrock2.nix {}; + bignums = callPackage ./bignums.nix {}; + CoLoR = callPackage ./CoLoR.nix {}; + CompCert = callPackage ./CompCert.nix {}; + coq_dpdgraph = callPackage ./coq_dpdgraph.nix {}; + Corn = callPackage ./Corn.nix {}; + cross_crypto = callPackage ./cross_crypto.nix {}; + Elpi = callPackage ./Elpi.nix {}; + fiat_crypto = callPackage ./fiat_crypto.nix {}; + fiat_crypto_legacy = callPackage ./fiat_crypto_legacy.nix {}; + flocq = callPackage ./flocq.nix {}; + GeoCoq = callPackage ./GeoCoq.nix {}; + HoTT = callPackage ./HoTT.nix {}; + math_classes = callPackage ./math_classes.nix {}; + mathcomp = {}; + mtac2 = callPackage ./mtac2.nix {}; + oddorder = callPackage ./oddorder.nix {}; + VST = callPackage ./VST.nix {}; +}; in + +if !builtins.hasAttr project projects +then throw "Unknown project “${project}”; choose from: ${pkgs.lib.concatStringsSep ", " (builtins.attrNames projects)}." +else + +let prj = projects."${project}"; in + +stdenv.mkDerivation { + name = "shell-for-${project}-in-${branch}"; + + buildInputs = [ coq ] ++ (prj.buildInputs or []); + + configure = prj.configure or "true"; + make = prj.make or "make"; + clean = prj.clean or "make clean"; + +} diff --git a/dev/ci/nix/fiat_crypto.nix b/dev/ci/nix/fiat_crypto.nix new file mode 100644 index 0000000000..7b37e6e8e4 --- /dev/null +++ b/dev/ci/nix/fiat_crypto.nix @@ -0,0 +1,6 @@ +{ coqprime }: +{ + buildInputs = [ coqprime ]; + configure = "git submodule update --init --recursive && ulimit -s 32768"; + make = "make new-pipeline c-files"; +} diff --git a/dev/ci/nix/fiat_crypto_legacy.nix b/dev/ci/nix/fiat_crypto_legacy.nix new file mode 100644 index 0000000000..3248665579 --- /dev/null +++ b/dev/ci/nix/fiat_crypto_legacy.nix @@ -0,0 +1,6 @@ +{}: + +{ + configure = "./etc/ci/remove_autogenerated.sh"; + make = "make print-old-pipeline-lite old-pipeline-lite lite-display"; +} diff --git a/dev/ci/nix/flocq.nix b/dev/ci/nix/flocq.nix new file mode 100644 index 0000000000..e153043557 --- /dev/null +++ b/dev/ci/nix/flocq.nix @@ -0,0 +1,7 @@ +{ autoconf, automake }: + +{ + buildInputs = [ autoconf automake ]; + configure = "./autogen.sh && ./configure"; + make = "./remake"; +} diff --git a/dev/ci/nix/math_classes.nix b/dev/ci/nix/math_classes.nix new file mode 100644 index 0000000000..b0fa2fe795 --- /dev/null +++ b/dev/ci/nix/math_classes.nix @@ -0,0 +1,6 @@ +{ bignums }: + +{ + buildInputs = [ bignums ]; + configure = "./configure.sh"; +} diff --git a/dev/ci/nix/mtac2.nix b/dev/ci/nix/mtac2.nix new file mode 100644 index 0000000000..9a2353c5cf --- /dev/null +++ b/dev/ci/nix/mtac2.nix @@ -0,0 +1,5 @@ +{ coq, unicoq }: +{ + buildInputs = [ unicoq ] ++ (with coq.ocamlPackages; [ ocaml findlib camlp5 ]); + configure = "./configure.sh"; +} diff --git a/dev/ci/nix/oddorder.nix b/dev/ci/nix/oddorder.nix new file mode 100644 index 0000000000..3b8fdbab51 --- /dev/null +++ b/dev/ci/nix/oddorder.nix @@ -0,0 +1,4 @@ +{ mathcomp }: +{ + buildInputs = [ mathcomp ]; +} diff --git a/dev/ci/nix/shell b/dev/ci/nix/shell new file mode 100755 index 0000000000..2e4462ed40 --- /dev/null +++ b/dev/ci/nix/shell @@ -0,0 +1,20 @@ +#!/usr/bin/env sh + +## This file should be run from the root of the Coq source tree + +BRANCH=$(git rev-parse --abbrev-ref HEAD) +echo "Branch: $BRANCH in $PWD" + +if [ "$#" -ne 1 ]; then + PROJECT="" +else + PROJECT="--argstr project $1" +fi + +if [ "$BN" ]; then + BN="--argstr bn ${BN}" +else + BN="" +fi + +nix-shell ./dev/ci/nix/ --show-trace --argstr wd $PWD --argstr branch $BRANCH $PROJECT $BN diff --git a/dev/ci/nix/unicoq.nix b/dev/ci/nix/unicoq.nix new file mode 100644 index 0000000000..f10afd5680 --- /dev/null +++ b/dev/ci/nix/unicoq.nix @@ -0,0 +1,14 @@ +{ stdenv, fetchzip, coq }: + +stdenv.mkDerivation { + name = "coq${coq.coq-version}-unicoq-0.0-git"; + src = fetchzip { + url = "https://github.com/vbgl/unicoq/archive/8b33e37700e92bfd404bf8bf9fe03f1be8928d97.tar.gz"; + sha256 = "0s4z0wjxlp56ccgzxgk04z7skw90rdnz39v730ffkgrjl38rr9il"; + }; + + buildInputs = [ coq ] ++ (with coq.ocamlPackages; [ ocaml findlib camlp5 num ]); + + configurePhase = "coq_makefile -f Make -o Makefile"; + installFlags = [ "COQLIB=$(out)/lib/coq/${coq.coq-version}/" ]; +} diff --git a/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh b/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh deleted file mode 100644 index d812df3ec0..0000000000 --- a/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "669" ] || [ "$CI_BRANCH" = "ssr-merge" ]; then - mathcomp_CI_REF=ssr-merge - mathcomp_CI_GITURL=https://github.com/maximedenes/math-comp -fi diff --git a/dev/ci/user-overlays/07085-ppedrot-pure-sharing-flag.sh b/dev/ci/user-overlays/07085-ppedrot-pure-sharing-flag.sh deleted file mode 100644 index 575df07425..0000000000 --- a/dev/ci/user-overlays/07085-ppedrot-pure-sharing-flag.sh +++ /dev/null @@ -1,8 +0,0 @@ -_OVERLAY_BRANCH=pure-sharing-flag - -if [ "$CI_PULL_REQUEST" = "7085" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then - - mtac2_CI_BRANCH="$_OVERLAY_BRANCH" - mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 - -fi diff --git a/dev/ci/user-overlays/07257-herbelin-master+fix-yet-another-unif-dep-in-alphabet.sh b/dev/ci/user-overlays/07257-herbelin-master+fix-yet-another-unif-dep-in-alphabet.sh deleted file mode 100644 index 019cb8054d..0000000000 --- a/dev/ci/user-overlays/07257-herbelin-master+fix-yet-another-unif-dep-in-alphabet.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "7257" ] || [ "$CI_BRANCH" = "master+fix-yet-another-unif-dep-in-alphabet" ]; then - cross_crypto_CI_REF=master+fix-coq7257-ascii-sensitive-unification - cross_crypto_CI_GITURL=https://github.com/herbelin/cross-crypto -fi diff --git a/dev/ci/user-overlays/07288-herbelin-master+new-module-pretyping-id-management.sh b/dev/ci/user-overlays/07288-herbelin-master+new-module-pretyping-id-management.sh deleted file mode 100644 index 3a6480a5a1..0000000000 --- a/dev/ci/user-overlays/07288-herbelin-master+new-module-pretyping-id-management.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "7288" ] || [ "$CI_BRANCH" = "master+new-module-pretyping-id-management" ]; then - - ltac2_CI_BRANCH=master+globenv-coq-pr7288 - ltac2_CI_GITURL=https://github.com/herbelin/ltac2 - -fi diff --git a/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh b/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh new file mode 100644 index 0000000000..b05d02c5be --- /dev/null +++ b/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh @@ -0,0 +1,14 @@ +_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/08456-fix-6764.sh b/dev/ci/user-overlays/08456-fix-6764.sh deleted file mode 100644 index 3b951d9c07..0000000000 --- a/dev/ci/user-overlays/08456-fix-6764.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8456" ] || [ "$CI_BRANCH" = "fix-6764" ]; then - Elpi_CI_REF=overlay/8456 -fi diff --git a/dev/ci/user-overlays/08515-command-atts.sh b/dev/ci/user-overlays/08515-command-atts.sh deleted file mode 100755 index 4605255d5e..0000000000 --- a/dev/ci/user-overlays/08515-command-atts.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8515" ] || [ "$CI_BRANCH" = "command-atts" ]; then - ltac2_CI_REF=command-atts - ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 - - Equations_CI_REF=command-atts - Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - plugin_tutorial_CI_REF=command-atts - plugin_tutorial_CI_GITURL=https://github.com/SkySkimmer/plugin_tutorials -fi diff --git a/dev/ci/user-overlays/08552-gares-elpi-11.sh b/dev/ci/user-overlays/08552-gares-elpi-11.sh deleted file mode 100644 index c08f44fc50..0000000000 --- a/dev/ci/user-overlays/08552-gares-elpi-11.sh +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8552" ] || [ "$CI_BRANCH" = "elpi-1.1" ]; then - Elpi_CI_REF=coq-master-elpi-1.1 -fi diff --git a/dev/ci/user-overlays/08554-herbelin-master+fix8553-change-under-binders.sh b/dev/ci/user-overlays/08554-herbelin-master+fix8553-change-under-binders.sh deleted file mode 100644 index 484ad8f9e6..0000000000 --- a/dev/ci/user-overlays/08554-herbelin-master+fix8553-change-under-binders.sh +++ /dev/null @@ -1,11 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8554" ] || [ "$CI_BRANCH" = "master+fix8553-change-under-binders" ]; then - - ltac2_CI_BRANCH=master+fix-pr8554-change-takes-env - ltac2_CI_REF=master+fix-pr8554-change-takes-env - ltac2_CI_GITURL=https://github.com/herbelin/ltac2 - - Equations_CI_BRANCH=master+fix-pr8554-change-takes-env - Equations_CI_REF=master+fix-pr8554-change-takes-env - Equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08555-maximedenes-rm-section-path.sh b/dev/ci/user-overlays/08555-maximedenes-rm-section-path.sh deleted file mode 100644 index 41c2ad6fef..0000000000 --- a/dev/ci/user-overlays/08555-maximedenes-rm-section-path.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8555" ] || [ "$CI_BRANCH" = "rm-section-path" ]; then - - ltac2_CI_REF=rm-section-path - ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 - - Equations_CI_REF=rm-section-path - Equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08671-mattam-plugin-tutorials.sh b/dev/ci/user-overlays/08671-mattam-plugin-tutorials.sh deleted file mode 100644 index bd3e1bf7ff..0000000000 --- a/dev/ci/user-overlays/08671-mattam-plugin-tutorials.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8741" ] || [ "$CI_BRANCH" = "typeclasses-functional-evar_map" ]; then - plugin_tutorial_CI_REF=pr8671-fix - plugin_tutorial_CI_GITURL=https://github.com/mattam82/plugin_tutorials - -fi diff --git a/dev/ci/user-overlays/08684-maximedenes-cleanup-kernel-entries.sh b/dev/ci/user-overlays/08684-maximedenes-cleanup-kernel-entries.sh deleted file mode 100644 index 98530c825a..0000000000 --- a/dev/ci/user-overlays/08684-maximedenes-cleanup-kernel-entries.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8684" ] || [ "$CI_BRANCH" = "kernel-entries-cleanup" ]; then - - Elpi_CI_REF=kernel-entries-cleanup - Elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi - - Equations_CI_REF=kernel-entries-cleanup - Equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08688-herbelin-master+generalizing-evar-map-printer-over-env.sh b/dev/ci/user-overlays/08688-herbelin-master+generalizing-evar-map-printer-over-env.sh deleted file mode 100644 index 81ed91f52b..0000000000 --- a/dev/ci/user-overlays/08688-herbelin-master+generalizing-evar-map-printer-over-env.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8688" ] || [ "$CI_BRANCH" = "master+generalizing-evar-map-printer-over-env" ]; then - - Elpi_CI_REF=master+generalized-evar-printers-pr8688 - Elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - -fi diff --git a/dev/ci/user-overlays/08704-ejgallego-vernac+monify_hook.sh b/dev/ci/user-overlays/08704-ejgallego-vernac+monify_hook.sh deleted file mode 100644 index b3a9f67e00..0000000000 --- a/dev/ci/user-overlays/08704-ejgallego-vernac+monify_hook.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8704" ] || [ "$CI_BRANCH" = "vernac+monify_hook" ]; then - - # ltac2_CI_REF=rm-section-path - # ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 - - plugin_tutorial_CI_REF=vernac+monify_hook - plugin_tutorial_CI_GITURL=https://github.com/ejgallego/plugin_tutorials - - Elpi_CI_REF=vernac+monify_hook - Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - Equations_CI_REF=vernac+monify_hook - Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08844-split-tactics.sh b/dev/ci/user-overlays/08844-split-tactics.sh deleted file mode 100644 index 8ad8cba243..0000000000 --- a/dev/ci/user-overlays/08844-split-tactics.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8844" ] || [ "$CI_BRANCH" = "split-tactics" ]; then - Equations_CI_REF=split-tactics - Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - ltac2_CI_REF=split-tactics - ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 - - fiat_parsers_CI_REF=split-tactics - fiat_parsers_CI_GITURL=https://github.com/SkySkimmer/fiat -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 new file mode 100644 index 0000000000..08112d3054 --- /dev/null +++ b/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh @@ -0,0 +1,15 @@ +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 new file mode 100644 index 0000000000..1c5157ba12 --- /dev/null +++ b/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000000..e74e53fa40 --- /dev/null +++ b/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh @@ -0,0 +1,6 @@ +#!/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 new file mode 100644 index 0000000000..d7130cc67a --- /dev/null +++ b/dev/ci/user-overlays/08985-ejgallego-build+pack_gramlib.sh @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000000..c8bea0c868 --- /dev/null +++ b/dev/ci/user-overlays/08998-ejgallego-legacy_proof_eng_clean.sh @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000000..61ffa4a197 --- /dev/null +++ b/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000000..14e7c0d7f0 --- /dev/null +++ b/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh @@ -0,0 +1,9 @@ +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/jasongross-numeral-notation-4.sh b/dev/ci/user-overlays/jasongross-numeral-notation-4.sh deleted file mode 100644 index 76aa37d380..0000000000 --- a/dev/ci/user-overlays/jasongross-numeral-notation-4.sh +++ /dev/null @@ -1,5 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8064" ] || [ "$CI_BRANCH" = "numeral-notation-4" ]; then - HoTT_CI_REF=fix-for-numeral-notations - HoTT_CI_GITURL=https://github.com/JasonGross/HoTT - HoTT_CI_ARCHIVEURL=${HoTT_CI_GITURL}/archive -fi diff --git a/dev/doc/README.md b/dev/doc/README.md index 223cf6286e..c764455aed 100644 --- a/dev/doc/README.md +++ b/dev/doc/README.md @@ -16,7 +16,6 @@ $ opam init --comp <latest-ocaml-version> ~/.bashrc and ~/.ocamlinit files. $ source ~/.bashrc -$ opam install camlp5 # needed if you want to build "coqide" target diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 0aeb30c4e8..3609171b82 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -10,7 +10,8 @@ Coq can now be built using [Dune](https://github.com/ocaml/dune). ## Quick Start -You need Dune >= 1.2.1 ; just type `dune build` to build the base Coq +Dune >= 1.5.0 is recommended, see `dune-project` for the minimum +required version; type `dune build` to build the base Coq libraries. No call to `./configure` is needed. Dune will get confused if it finds leftovers of in-tree compilation, @@ -49,14 +50,25 @@ The default dune target is `dune build` (or `dune build @install`), which will scan all sources in the Coq tree and then build the whole project, creating an "install" overlay in `_build/install/default`. -You can build some other target by doing `dune build $TARGET`. +You can build some other target by doing `dune build $TARGET`, where +`$TARGET` can be a `.cmxa`, a binary, a file that Dune considers a +target, an alias, etc... In order to build a single package, you can do `dune build $PACKAGE.install`. +A very useful target is `dune build @check`, that will compile all the +ml files in quick mode. + Dune also provides targets for documentation, testing, and release builds, please see below. +## Documentation and test targets + +Coq's test-suite can be run with `dune runtest`. + +The documentation target is not implemented in Dune yet. + ## Developer shell You can create a developer shell with `dune utop $library`, where @@ -81,7 +93,7 @@ or ``` dune exec dev/dune-dbg checker -(ocd) source checker_dune_db +(ocd) source dune_db ``` for the checker. Unfortunately, dependency handling here is not fully @@ -139,11 +151,6 @@ Note that due to https://github.com/ocaml/dune/issues/1401 , we must perform a full rebuild each time as otherwise Dune will remove the files. We hope to solve this in the future. -## Documentation and test targets - -The documentation and test suite targets for Coq are still not -implemented in Dune. - ## Planned and Advanced features Dune supports or will support extra functionality that may result very diff --git a/dev/doc/changes.md b/dev/doc/changes.md index b1fdfafd3a..acb0d80c18 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,5 +1,15 @@ ## Changes between Coq 8.9 and Coq 8.10 +### ML4 Pre Processing + +- Support for `.ml4` files, processed by camlp5 has been removed in + favor of `.mlg` files processed by `coqpp`. + + Porting is usually straightforward, and involves renaming the + `file.ml4` file to `file.mlg` and adding a few brackets. + + See "Transitioning away from Camlp5" below for update instructions. + ### ML API General deprecation @@ -19,6 +29,10 @@ Names Constant.make3 has been removed, use Constant.make2 Constant.repr3 has been removed, use Constant.repr2 +- `Names.transparent_state` has been moved to its own module `TransparentState`. + This module gathers utility functions that used to be defined in several + places. + Coqlib: - Most functions from the `Coqlib` module have been deprecated in favor of diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt index 764d482957..e5e4f740bd 100644 --- a/dev/doc/coq-src-description.txt +++ b/dev/doc/coq-src-description.txt @@ -94,7 +94,7 @@ Tacexpr.glob_tactic_expr | | Tacinterp.eval_tactic (?) V -Proof_type.tactic +Proofview.V82.tac TODO: check with Hugo @@ -3,22 +3,14 @@ (public_name coq.top_printers) (synopsis "Coq's Debug Printers") (wrapped false) - (modules :standard \ checker_printers) + (modules :standard) + (optional) (libraries coq.toplevel coq.plugins.ltac)) -(library - (name checker_printers) - (public_name coq.checker_printers) - (synopsis "Coq's Debug Printers [for the Checker]") - (wrapped false) - (flags :standard -open Checklib) - (modules checker_printers) - (libraries coq.checklib)) - (rule (targets dune-dbg) (deps dune-dbg.in - ../checker/main.bc + ../checker/coqchk.bc ../topbin/coqtop_byte_bin.bc ; This is not enough as the call to `ocamlfind` will fail :/ top_printers.cma) diff --git a/dev/dune-dbg.in b/dev/dune-dbg.in index 464e026400..80ad0500e0 100755 --- a/dev/dune-dbg.in +++ b/dev/dune-dbg.in @@ -2,10 +2,12 @@ # Run in a proper install dune env. case $1 in -checker) - ocamldebug `ocamlfind query -recursive -i-format coq.checker_printers` -I +threads -I dev _build/default/checker/main.bc - ;; -*) - ocamldebug `ocamlfind query -recursive -i-format coq.top_printers` -I +threads -I dev _build/default/topbin/coqtop_byte_bin.bc - ;; + checker) + exe=_build/default/checker/coqchk.bc + ;; + *) + exe=_build/default/topbin/coqtop_byte_bin.bc + ;; esac + +ocamldebug $(ocamlfind query -recursive -i-format coq.top_printers) -I +threads -I dev $exe diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index d330f517be..707c7f07ce 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -8,14 +8,13 @@ # here are some reasonable default values [ -z "$OCAMLDEBUG" ] && OCAMLDEBUG=ocamldebug -[ -z "$CAMLP5LIB" ] && CAMLP5LIB=+camlp5 [ -z "$COQTOP" -a -d "$PWD/kernel" ] && COQTOP=$PWD [ -z "$COQTOP" -a -d "$PWD/../kernel" ] && COQTOP=`dirname $PWD` export CAML_LD_LIBRARY_PATH=$COQTOP/kernel/byterun:$CAML_LD_LIBRARY_PATH exec $OCAMLDEBUG \ - -I $CAMLP5LIB -I +threads \ + -I +threads \ -I $COQTOP \ -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar -I $COQTOP/clib \ -I $COQTOP/lib -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ diff --git a/dev/tools/create_overlays.sh b/dev/tools/create_overlays.sh new file mode 100755 index 0000000000..41392be5d7 --- /dev/null +++ b/dev/tools/create_overlays.sh @@ -0,0 +1,78 @@ +#!/usr/bin/env bash + +# TODO: +# +# - Check if the branch already exists in the remote => checkout +# - Better error handling +# - Just checkout, don't build +# - Rebase functionality +# + +set -x +set -e +set -o pipefail + +# setup_contrib_git("_build_ci/fiat", "https://github.com/ejgallego/fiat-core.git") +setup_contrib_git() { + + local _DIR=$1 + local _GITURL=$2 + + ( cd $_DIR + git checkout -b $OVERLAY_BRANCH || true # allow the branch to exist already + git remote add $DEVELOPER_NAME $_GITURL || true # allow the remote to exist already + ) + +} + +if [ $# -lt 3 ]; then + echo "usage: $0 github_username pr_number contrib1 ... contribN" + exit 1 +fi + +set +x +. dev/ci/ci-basic-overlay.sh +set -x + +DEVELOPER_NAME=$1 +shift +PR_NUMBER=$1 +shift +OVERLAY_BRANCH=$(git rev-parse --abbrev-ref HEAD) +OVERLAY_FILE=$(mktemp overlay-XXXX) + +# Create the overlay file +printf 'if [ "$CI_PULL_REQUEST" = "%s" ] || [ "$CI_BRANCH" = "%s" ]; then \n\n' "$PR_NUMBER" "$OVERLAY_BRANCH" > "$OVERLAY_FILE" + +# We first try to build the contribs +while test $# -gt 0 +do + _CONTRIB_NAME=$1 + _CONTRIB_GITURL=${_CONTRIB_NAME}_CI_GITURL + _CONTRIB_GITURL=${!_CONTRIB_GITURL} + echo "Processing Contrib $_CONTRIB_NAME" + + # check _CONTRIB_GIT exists and it is of the from github... + + _CONTRIB_DIR=_build_ci/$_CONTRIB_NAME + + # extract the relevant part of the repository + _CONTRIB_GITSUFFIX=${_CONTRIB_GITURL#https://github.com/*/} + _CONTRIB_GITURL="https://github.com/$DEVELOPER_NAME/$_CONTRIB_GITSUFFIX" + _CONTRIB_GITPUSHURL="git@github.com:$DEVELOPER_NAME/${_CONTRIB_GITSUFFIX}.git" + + # This should work better: for example we should be able not to + # build but just to checkout. + make ci-$_CONTRIB_NAME || true + setup_contrib_git $_CONTRIB_DIR $_CONTRIB_GITPUSHURL + + echo " ${_CONTRIB_NAME}_CI_REF=$OVERLAY_BRANCH" >> $OVERLAY_FILE + echo " ${_CONTRIB_NAME}_CI_GITURL=$_CONTRIB_GITURL" >> $OVERLAY_FILE + echo "" >> $OVERLAY_FILE + shift +done + +# End the file; copy to overlays folder. +echo "fi" >> $OVERLAY_FILE +PR_NUMBER=$(printf '%05d' "$PR_NUMBER") +mv $OVERLAY_FILE dev/ci/user-overlays/$PR_NUMBER-$DEVELOPER_NAME-${OVERLAY_BRANCH///}.sh diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index 320ef6ed07..5fd8a3b7d9 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -202,9 +202,8 @@ info "merging" git merge -v -S --no-ff FETCH_HEAD -m "Merge PR #$PR: $TITLE" -e # TODO: improve this check -if ! git diff --quiet "$REMOTE/$CURRENT_LOCAL_BRANCH" -- dev/ci/user-overlays; then - warning "this PR may have overlays (sorry the check is not perfect)" - warning "if it has overlays please check the following:" +if ! git diff --quiet --diff-filter=A "$REMOTE/$CURRENT_LOCAL_BRANCH" -- dev/ci/user-overlays; then + warning "this PR has overlays, please check the following:" warning "- each overlay has a corresponding open PR on the upstream repo" warning "- after merging please notify the upstream they can merge the PR" fi diff --git a/dev/top_printers.ml b/dev/top_printers.ml index fd08f9ffe8..4287702b3a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -509,41 +509,23 @@ VERNAC COMMAND EXTEND PrintConstr END *) -open Genarg -open Stdarg -open Egramml - let _ = - try - Vernacinterp.vinterp_add false ("PrintConstr", 0) - (function - [c] when genarg_tag c = unquote (topwit wit_constr) && true -> - let c = out_gen (rawwit wit_constr) c in - (fun ~atts ~st -> in_current_context econstr_display c; st) - | _ -> failwith "Vernac extension: cannot occur") - with - e -> pp (CErrors.print e) -let _ = - extend_vernac_command_grammar ("PrintConstr", 0) None - [GramTerminal "PrintConstr"; - GramNonTerminal - (Loc.tag (rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr))] + let open Vernacextend in + let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in + let cmd_sig = TyTerminal("PrintConstr", TyNonTerminal(ty_constr, TyNil)) in + let cmd_fn c ~atts ~st = in_current_context econstr_display c; st in + let cmd_class _ = VtQuery,VtNow in + let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in + vernac_extend ~command:"PrintConstr" [cmd] let _ = - try - Vernacinterp.vinterp_add false ("PrintPureConstr", 0) - (function - [c] when genarg_tag c = unquote (topwit wit_constr) && true -> - let c = out_gen (rawwit wit_constr) c in - (fun ~atts ~st -> in_current_context print_pure_econstr c; st) - | _ -> failwith "Vernac extension: cannot occur") - with - e -> pp (CErrors.print e) -let _ = - extend_vernac_command_grammar ("PrintPureConstr", 0) None - [GramTerminal "PrintPureConstr"; - GramNonTerminal - (Loc.tag (rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr))] + let open Vernacextend in + let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in + let cmd_sig = TyTerminal("PrintPureConstr", TyNonTerminal(ty_constr, TyNil)) in + let cmd_fn c ~atts ~st = in_current_context print_pure_econstr c; st in + let cmd_class _ = VtQuery,VtNow in + let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in + vernac_extend ~command:"PrintPureConstr" [cmd] (* Setting printer of unbound global reference *) open Names diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 63d7d58053..5eac3e2b9c 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -101,7 +101,7 @@ val ppdelta : Mod_subst.delta_resolver -> unit val pp_idpred : Names.Id.Pred.t -> unit val pp_cpred : Names.Cpred.t -> unit -val pp_transparent_state : Names.transparent_state -> unit +val pp_transparent_state : TransparentState.t -> unit val pp_stack_t : Constr.t Reductionops.Stack.t -> unit val pp_cst_stack_t : Reductionops.Cst_stack.t -> unit @@ -120,9 +120,9 @@ val ppclenv : Clenv.clausenv -> unit val ppgoalgoal : Goal.goal -> unit -val ppgoal : Proof_type.goal Evd.sigma -> unit +val ppgoal : Goal.goal Evd.sigma -> unit (* also print evar map *) -val ppgoalsigma : Proof_type.goal Evd.sigma -> unit +val ppgoalsigma : Goal.goal Evd.sigma -> unit val pphintdb : Hints.Hint_db.t -> unit val ppproofview : Proofview.proofview -> unit diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index c0a57763b9..5d219ebd0d 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -35,7 +35,7 @@ rationals ``Require Import Lqa`` and reals ``Require Import Lra``. The tactics solve propositional formulas parameterized by atomic -arithmetic expressions interpreted over a domain :math:`D` ∈ {ℤ, ℚ, ℝ}. +arithmetic expressions interpreted over a domain :math:`D \in \{\mathbb{Z},\mathbb{Q},\mathbb{R}\}`. The syntax of the formulas is the following: .. productionlist:: `F` @@ -46,8 +46,8 @@ The syntax of the formulas is the following: where :math:`c` is a numeric constant, :math:`x \in D` is a numeric variable, the operators :math:`−, +, ×` are respectively subtraction, addition, and product; :math:`p ^ n` is exponentiation by a constant :math:`n`, :math:`P` is an arbitrary proposition. -For :math:`\mathbb{Q}`, equality is not Leibniz equality = but the equality of -rationals ==. +For :math:`\mathbb{Q}`, equality is not Leibniz equality ``=`` but the equality of +rationals ``==``. For :math:`\mathbb{Z}` (resp. :math:`\mathbb{Q}`), :math:`c` ranges over integer constants (resp. rational constants). For :math:`\mathbb{R}`, the tactic recognizes as real constants the @@ -58,7 +58,7 @@ following expressions: c ::= R0 | R1 | Rmul(c,c) | Rplus(c,c) | Rminus(c,c) | IZR z | IQR q | Rdiv(c,c) | Rinv c where :math:`z` is a constant in :math:`\mathbb{Z}` and :math:`q` is a constant in :math:`\mathbb{Q}`. -This includes integer constants written using the decimal notation, *i.e.*, c%R. +This includes integer constants written using the decimal notation, *i.e.*, ``c%R``. *Positivstellensatz* refutations @@ -94,7 +94,7 @@ general form :math:`(\bigwedge_{j\in S_i} p_j \Join 0) \to \mathit{False}` and For each conjunct :math:`C_i`, the tactic calls an oracle which searches for :math:`-1` within the cone. Upon success, the oracle returns a *cone -expression* that is normalized by the ring tactic (see :ref:`theringandfieldtacticfamilies`) +expression* that is normalized by the :tacn:`ring` tactic (see :ref:`theringandfieldtacticfamilies`) and checked to be :math:`-1`. `lra`: a decision procedure for linear real and rational arithmetic @@ -245,11 +245,11 @@ proof by abstracting monomials by variables. As shown, such a goal is solved by ``intro x. psatz Z 2.``. The oracle returns the cone expression :math:`2 \times (x-1) + (\mathbf{x-1}) \times (\mathbf{x−1}) + -x^2` (polynomial hypotheses are printed in bold). By construction, this expression -belongs to :math:`\mathit{Cone}({−x^2,x -1})`. Moreover, by running `ring` we +belongs to :math:`\mathit{Cone}({−x^2,x -1})`. Moreover, by running :tacn:`ring` we obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. .. [#] Support for `nat` and :math:`\mathbb{N}` is obtained by pre-processing the goal with - the `zify` tactic. + the ``zify`` tactic. .. [#] Sources and binaries can be found at https://projects.coin-or.org/Csdp .. [#] Variants deal with equalities and strict inequalities. .. [#] In practice, the oracle might fail to produce such a refutation. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 9dae7fd102..391afcb1f7 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -2155,6 +2155,12 @@ If `string` ends in ``.dot`` or ``.gv``, the constraints are printed in the DOT language, and can be processed by Graphviz tools. The format is unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. +.. cmdv:: Print Universes Subgraph(@names) + +Prints the graph restricted to the requested names (adjusting +constraints to preserve the implied transitive constraints between +kept universes). + .. _existential-variables: Existential variables @@ -2247,7 +2253,3 @@ expression as described in :ref:`ltac`. This construction is useful when one wants to define complicated terms using highly automated tactics without resorting to writing the proof-term by means of the interactive proof engine. - -This mechanism is comparable to the ``Declare Implicit Tactic`` command -defined at :ref:`tactics-implicit-automation`, except that the used -tactic is local to each hole instead of being declared globally. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 741f9fe5b0..0b059f92ee 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -758,18 +758,6 @@ Controlling the effect of proof editing commands available hypotheses. -.. flag:: Automatic Introduction - - This option controls the way binders are handled - in assertion commands such as :n:`Theorem @ident {? @binders} : @term`. When the - option is on, which is the default, binders are automatically put in - the local context of the goal to prove. - - When the option is off, binders are discharged on the statement to be - proved and a tactic such as :tacn:`intro` (see Section :ref:`managingthelocalcontext`) - has to be used to move the assumptions to the local context. - - .. flag:: Nested Proofs Allowed When turned on (it is off by default), this option enables support for nested diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 457f9b2efa..041f1bc966 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3745,32 +3745,6 @@ Setting implicit automation tactics Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` - .. cmd:: Declare Implicit Tactic @tactic - - This command declares a tactic to be used to solve implicit arguments - that Coq does not know how to solve by unification. It is used every - time the term argument of a tactic has one of its holes not fully - resolved. - - .. deprecated:: 8.9 - - This command is deprecated. Use :ref:`typeclasses <typeclasses>` or - :ref:`tactics-in-terms <tactics-in-terms>` instead. - - .. example:: - - .. coqtop:: all - - Parameter quo : nat -> forall n:nat, n<>0 -> nat. - Notation "x // y" := (quo x y _) (at level 40). - Declare Implicit Tactic assumption. - Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }. - intros. - exists (n // m). - - The tactic ``exists (n // m)`` did not fail. The hole was solved - by ``assumption`` so that it behaved as ``exists (quo n m H)``. - .. _decisionprocedures: Decision procedures diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index eacd7b4676..8f76085d88 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -167,7 +167,7 @@ Combined Scheme Combined Scheme tree_forest_mutind from tree_forest_ind,forest_tree_ind. - The type of tree_forest_mutrec will be: + The type of tree_forest_mutind will be: .. coqtop:: all diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 8b13789179..b58148ffff 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -1 +1,77 @@ - +plugins/btauto/Algebra.v +plugins/btauto/Btauto.v +plugins/btauto/Reflect.v +plugins/derive/Derive.v +plugins/extraction/ExtrHaskellBasic.v +plugins/extraction/ExtrHaskellNatInt.v +plugins/extraction/ExtrHaskellNatInteger.v +plugins/extraction/ExtrHaskellNatNum.v +plugins/extraction/ExtrHaskellString.v +plugins/extraction/ExtrHaskellZInt.v +plugins/extraction/ExtrHaskellZInteger.v +plugins/extraction/ExtrHaskellZNum.v +plugins/extraction/ExtrOcamlBasic.v +plugins/extraction/ExtrOcamlBigIntConv.v +plugins/extraction/ExtrOcamlIntConv.v +plugins/extraction/ExtrOcamlNatBigInt.v +plugins/extraction/ExtrOcamlNatInt.v +plugins/extraction/ExtrOcamlString.v +plugins/extraction/ExtrOcamlZBigInt.v +plugins/extraction/ExtrOcamlZInt.v +plugins/extraction/Extraction.v +plugins/funind/FunInd.v +plugins/funind/Recdef.v +plugins/ltac/Ltac.v +plugins/micromega/Env.v +plugins/micromega/EnvRing.v +plugins/micromega/Fourier.v +plugins/micromega/Fourier_util.v +plugins/micromega/Lia.v +plugins/micromega/Lqa.v +plugins/micromega/Lra.v +plugins/micromega/MExtraction.v +plugins/micromega/OrderedRing.v +plugins/micromega/Psatz.v +plugins/micromega/QMicromega.v +plugins/micromega/RMicromega.v +plugins/micromega/Refl.v +plugins/micromega/RingMicromega.v +plugins/micromega/Tauto.v +plugins/micromega/VarMap.v +plugins/micromega/ZCoeff.v +plugins/micromega/ZMicromega.v +plugins/nsatz/Nsatz.v +plugins/omega/Omega.v +plugins/omega/OmegaLemmas.v +plugins/omega/OmegaPlugin.v +plugins/omega/OmegaTactic.v +plugins/omega/PreOmega.v +plugins/quote/Quote.v +plugins/romega/ROmega.v +plugins/romega/ReflOmegaCore.v +plugins/rtauto/Bintree.v +plugins/rtauto/Rtauto.v +plugins/setoid_ring/Algebra_syntax.v +plugins/setoid_ring/ArithRing.v +plugins/setoid_ring/BinList.v +plugins/setoid_ring/Cring.v +plugins/setoid_ring/Field.v +plugins/setoid_ring/Field_tac.v +plugins/setoid_ring/Field_theory.v +plugins/setoid_ring/InitialRing.v +plugins/setoid_ring/Integral_domain.v +plugins/setoid_ring/NArithRing.v +plugins/setoid_ring/Ncring.v +plugins/setoid_ring/Ncring_initial.v +plugins/setoid_ring/Ncring_polynom.v +plugins/setoid_ring/Ncring_tac.v +plugins/setoid_ring/RealField.v +plugins/setoid_ring/Ring.v +plugins/setoid_ring/Ring_base.v +plugins/setoid_ring/Ring_polynom.v +plugins/setoid_ring/Ring_tac.v +plugins/setoid_ring/Ring_theory.v +plugins/setoid_ring/Rings_Q.v +plugins/setoid_ring/Rings_R.v +plugins/setoid_ring/Rings_Z.v +plugins/setoid_ring/ZArithRing.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index e8f6decfbf..4fc9bf9e19 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -571,6 +571,7 @@ through the <tt>Require Import</tt> command.</p> theories/Reals/Sqrt_reg.v theories/Reals/Rlogic.v (theories/Reals/Reals.v) + theories/Reals/Runcountable.v </dd> <dt> <b>Program</b>: @@ -588,6 +589,17 @@ through the <tt>Require Import</tt> command.</p> theories/Program/Combinators.v </dd> + <dt> <b>SSReflect</b>: + Base libraries for the SSReflect proof language and the + small scale reflection formalization technique + </dt> + <dd> + plugins/ssrmatching/ssrmatching.v + plugins/ssr/ssreflect.v + plugins/ssr/ssrbool.v + plugins/ssr/ssrfun.v + </dd> + <dt> <b>Unicode</b>: Unicode-based notations </dt> diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index index 43802efa0a..bea6f24098 100755 --- a/doc/stdlib/make-library-index +++ b/doc/stdlib/make-library-index @@ -8,35 +8,32 @@ HIDDEN=$2 cp -f $FILE.template tmp echo -n "Building file index-list.prehtml... " -#LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Vectors Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" -LIBDIRS=`find theories/* -type d ! -name .coq-native | sed -e "s:^theories/::"` +LIBDIRS=`find theories/* plugins/* -type d ! -name .coq-native` for k in $LIBDIRS; do - i=theories/$k - d=`basename $i` - ls $i | grep -q \.v'$' + d=`basename $k` + ls $k | grep -q \.v'$' if [ $? = 0 ]; then - for j in $i/*.v; do + for j in $k/*.v; do b=`basename $j .v` rm -f tmp2 - grep -q theories/$k/$b.v tmp + grep -q $k/$b.v tmp a=$? - grep -q theories/$k/$b.v $HIDDEN + grep -q $k/$b.v $HIDDEN h=$? if [ $a = 0 ]; then if [ $h = 0 ]; then - echo Error: $FILE and $HIDDEN both mention theories/$k/$b.v; exit 1 + echo Error: $FILE and $HIDDEN both mention $k/$b.v; exit 1 else - p=`echo $k | sed 's:/:.:g'` - sed -e "s:theories/$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2 + p=`echo $k | sed 's:^[^/]*/::' | sed 's:/:.:g'` + sed -e "s:$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2 mv -f tmp2 tmp fi else if [ $h = 0 ]; then - echo Error: theories/$k/$b.v is missing in the template file - exit 1 + echo Warning: $k/$b.v will be hidden from the index else - echo Error: none of $FILE and $HIDDEN mention theories/$k/$b.v + echo Error: none of $FILE and $HIDDEN mention $k/$b.v exit 1 fi diff --git a/engine/eConstr.ml b/engine/eConstr.ml index cfc4bea85f..96f1ce5e60 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -296,6 +296,8 @@ let decompose_prod_n_assum sigma n c = let existential_type = Evd.existential_type +let lift n c = of_constr (Vars.lift n (unsafe_to_constr c)) + let map_under_context f n c = let f c = unsafe_to_constr (f (of_constr c)) in of_constr (Constr.map_under_context f n (unsafe_to_constr c)) @@ -306,137 +308,21 @@ let map_return_predicate f ci p = let f c = unsafe_to_constr (f (of_constr c)) in of_constr (Constr.map_return_predicate f ci (unsafe_to_constr p)) -let map_gen userview sigma f c = match kind sigma c with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> c - | Cast (b,k,t) -> - let b' = f b in - let t' = f t in - if b'==b && t' == t then c - else mkCast (b', k, t') - | Prod (na,t,b) -> - let b' = f b in - let t' = f t in - if b'==b && t' == t then c - else mkProd (na, t', b') - | Lambda (na,t,b) -> - let b' = f b in - let t' = f t in - if b'==b && t' == t then c - else mkLambda (na, t', b') - | LetIn (na,b,t,k) -> - let b' = f b in - let t' = f t in - let k' = f k in - if b'==b && t' == t && k'==k then c - else mkLetIn (na, b', t', k') - | App (b,l) -> - let b' = f b in - let l' = Array.Smart.map f l in - if b'==b && l'==l then c - else mkApp (b', l') - | Proj (p,t) -> - let t' = f t in - if t' == t then c - else mkProj (p, t') - | Evar (e,l) -> - let l' = Array.Smart.map f l in - if l'==l then c - else mkEvar (e, l') - | Case (ci,p,b,bl) when userview -> - let b' = f b in - let p' = map_return_predicate f ci p in - let bl' = map_branches f ci bl in - if b'==b && p'==p && bl'==bl then c - else mkCase (ci, p', b', bl') - | Case (ci,p,b,bl) -> - let b' = f b in - let p' = f p in - let bl' = Array.Smart.map f bl in - if b'==b && p'==p && bl'==bl then c - else mkCase (ci, p', b', bl') - | Fix (ln,(lna,tl,bl)) -> - let tl' = Array.Smart.map f tl in - let bl' = Array.Smart.map f bl in - if tl'==tl && bl'==bl then c - else mkFix (ln,(lna,tl',bl')) - | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.Smart.map f tl in - let bl' = Array.Smart.map f bl in - if tl'==tl && bl'==bl then c - else mkCoFix (ln,(lna,tl',bl')) - -let map_user_view = map_gen true -let map = map_gen false - -let map_with_binders sigma g f l c0 = match kind sigma c0 with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> c0 - | Cast (c, k, t) -> - let c' = f l c in - let t' = f l t in - if c' == c && t' == t then c0 - else mkCast (c', k, t') - | Prod (na, t, c) -> - let t' = f l t in - let c' = f (g l) c in - if t' == t && c' == c then c0 - else mkProd (na, t', c') - | Lambda (na, t, c) -> - let t' = f l t in - let c' = f (g l) c in - if t' == t && c' == c then c0 - else mkLambda (na, t', c') - | LetIn (na, b, t, c) -> - let b' = f l b in - let t' = f l t in - let c' = f (g l) c in - if b' == b && t' == t && c' == c then c0 - else mkLetIn (na, b', t', c') - | App (c, al) -> - let c' = f l c in - let al' = Array.Fun1.Smart.map f l al in - if c' == c && al' == al then c0 - else mkApp (c', al') - | Proj (p, t) -> - let t' = f l t in - if t' == t then c0 - else mkProj (p, t') - | Evar (e, al) -> - let al' = Array.Fun1.Smart.map f l al in - if al' == al then c0 - else mkEvar (e, al') - | Case (ci, p, c, bl) -> - let p' = f l p in - let c' = f l c in - let bl' = Array.Fun1.Smart.map f l bl in - if p' == p && c' == c && bl' == bl then c0 - else mkCase (ci, p', c', bl') - | Fix (ln, (lna, tl, bl)) -> - let tl' = Array.Fun1.Smart.map f l tl in - let l' = iterate g (Array.length tl) l in - let bl' = Array.Fun1.Smart.map f l' bl in - if tl' == tl && bl' == bl then c0 - else mkFix (ln,(lna,tl',bl')) - | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.Fun1.Smart.map f l tl in - let l' = iterate g (Array.length tl) l in - let bl' = Array.Fun1.Smart.map f l' bl in - mkCoFix (ln,(lna,tl',bl')) - -let iter sigma f c = match kind sigma c with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> () - | Cast (c,_,t) -> f c; f t - | Prod (_,t,c) -> f t; f c - | Lambda (_,t,c) -> f t; f c - | LetIn (_,b,t,c) -> f b; f t; f c - | App (c,l) -> f c; Array.iter f l - | Proj (p,c) -> f c - | Evar (_,l) -> Array.iter f l - | Case (_,p,c,bl) -> f p; f c; Array.iter f bl - | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl - | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl +let map_user_view sigma f c = + let f c = unsafe_to_constr (f (of_constr c)) in + of_constr (Constr.map_user_view f (unsafe_to_constr (whd_evar sigma c))) + +let map sigma f c = + let f c = unsafe_to_constr (f (of_constr c)) in + of_constr (Constr.map f (unsafe_to_constr (whd_evar sigma c))) + +let map_with_binders sigma g f l c = + let f l c = unsafe_to_constr (f l (of_constr c)) in + of_constr (Constr.map_with_binders g f l (unsafe_to_constr (whd_evar sigma c))) + +let iter sigma f c = + let f c = f (of_constr c) in + Constr.iter f (unsafe_to_constr (whd_evar sigma c)) let iter_with_full_binders sigma g f n c = let open Context.Rel.Declaration in @@ -453,31 +339,20 @@ let iter_with_full_binders sigma g f n c = | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> Array.iter (f n) tl; - let n' = Array.fold_left2 (fun n na t -> g (LocalAssum (na,t)) n) n lna tl in + let n' = Array.fold_left2_i (fun i n na t -> g (LocalAssum (na, lift i t)) n) n lna tl in Array.iter (f n') bl | CoFix (_,(lna,tl,bl)) -> Array.iter (f n) tl; - let n' = Array.fold_left2 (fun n na t -> g (LocalAssum (na,t)) n) n lna tl in + let n' = Array.fold_left2_i (fun i n na t -> g (LocalAssum (na,lift i t)) n) n lna tl in Array.iter (f n') bl let iter_with_binders sigma g f n c = - iter_with_full_binders sigma (fun _ acc -> g acc) f n c + let f l c = f l (of_constr c) in + Constr.iter_with_binders g f n (unsafe_to_constr (whd_evar sigma c)) -let fold sigma f acc c = match kind sigma c with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> acc - | Cast (c,_,t) -> f (f acc c) t - | Prod (_,t,c) -> f (f acc t) c - | Lambda (_,t,c) -> f (f acc t) c - | LetIn (_,b,t,c) -> f (f (f acc b) t) c - | App (c,l) -> Array.fold_left f (f acc c) l - | Proj (p,c) -> f acc c - | Evar (_,l) -> Array.fold_left f acc l - | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl - | Fix (_,(lna,tl,bl)) -> - Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl - | CoFix (_,(lna,tl,bl)) -> - Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl +let fold sigma f acc c = + let f acc c = f acc (of_constr c) in + Constr.fold f acc (unsafe_to_constr (whd_evar sigma c)) let compare_gen k eq_inst eq_sort eq_constr nargs c1 c2 = (c1 == c2) || Constr.compare_head_gen_with k k eq_inst eq_sort eq_constr nargs c1 c2 @@ -712,7 +587,7 @@ let to_rel_decl = unsafe_to_rel_decl type substl = t list (** Operations that commute with evar-normalization *) -let lift n c = of_constr (Vars.lift n (to_constr c)) +let lift = lift let liftn n m c = of_constr (Vars.liftn n m (to_constr c)) let substnl subst n c = of_constr (Vars.substnl (cast_list unsafe_eq subst) n (to_constr c)) diff --git a/engine/evd.ml b/engine/evd.ml index b3848e1b5b..6345046431 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -891,6 +891,9 @@ let make_flexible_variable evd ~algebraic u = { evd with universes = UState.make_flexible_variable evd.universes ~algebraic u } +let make_nonalgebraic_variable evd u = + { evd with universes = UState.make_nonalgebraic_variable evd.universes u } + (****************************************) (* Operations on constants *) (****************************************) diff --git a/engine/evd.mli b/engine/evd.mli index be54bebcd7..0a8d1f3287 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -561,6 +561,9 @@ val universe_rigidity : evar_map -> Univ.Level.t -> rigid val make_flexible_variable : evar_map -> algebraic:bool -> Univ.Level.t -> evar_map (** See [UState.make_flexible_variable] *) +val make_nonalgebraic_variable : evar_map -> Univ.Level.t -> evar_map +(** See [UState.make_nonalgebraic_variable]. *) + val is_sort_variable : evar_map -> Sorts.t -> Univ.Level.t option (** [is_sort_variable evm s] returns [Some u] or [None] if [s] is not a local sort variable declared in [evm] *) diff --git a/engine/termops.ml b/engine/termops.ml index ada6311067..98300764df 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -721,18 +721,16 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let bl' = Array.map (f l) bl in if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else mkCase (ci, p', c', bl') - | Fix (ln,(lna,tl,bl)) -> + | Fix (ln,(lna,tl,bl as fx)) -> let tl' = Array.map (f l) tl in - let l' = - Array.fold_left2 (fun l na t -> g (RelDecl.LocalAssum (na, t)) l) l lna tl in + let l' = fold_rec_types g fx l in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr else mkFix (ln,(lna,tl',bl')) - | CoFix(ln,(lna,tl,bl)) -> + | CoFix(ln,(lna,tl,bl as fx)) -> let tl' = Array.map (f l) tl in - let l' = - Array.fold_left2 (fun l na t -> g (RelDecl.LocalAssum (na, t)) l) l lna tl in + let l' = fold_rec_types g fx l in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr @@ -759,34 +757,17 @@ let fold_constr_with_full_binders sigma g f n acc c = Constr.fold_with_full_binders g f n acc c let fold_constr_with_binders sigma g f n acc c = - fold_constr_with_full_binders sigma (fun _ x -> g x) f n acc c + let open EConstr in + let f l acc c = f l acc (of_constr c) in + let c = Unsafe.to_constr (whd_evar sigma c) in + Constr.fold_constr_with_binders g f n acc c (* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate subterms of [c]; it carries an extra data [acc] which is processed by [g] at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) -let iter_constr_with_full_binders sigma g f l c = - let open RelDecl in - match EConstr.kind sigma c with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> () - | Cast (c,_, t) -> f l c; f l t - | Prod (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c - | Lambda (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c - | LetIn (na,b,t,c) -> f l b; f l t; f (g (LocalDef (na,b,t)) l) c - | App (c,args) -> f l c; Array.iter (f l) args - | Proj (p,c) -> f l c - | Evar (_,args) -> Array.iter (f l) args - | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl - | Fix (_,(lna,tl,bl)) -> - let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in - Array.iter (f l) tl; - Array.iter (f l') bl - | CoFix (_,(lna,tl,bl)) -> - let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in - Array.iter (f l) tl; - Array.iter (f l') bl +let iter_constr_with_full_binders = EConstr.iter_with_full_binders (***************************) (* occurs check functions *) diff --git a/engine/termops.mli b/engine/termops.mli index 6c3d4fa612..eef8452e64 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -88,6 +88,7 @@ val iter_constr_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit +[@@ocaml.deprecated "Use [EConstr.iter_with_full_binders]."] (**********************************************************************) diff --git a/engine/uState.ml b/engine/uState.ml index aa7ec63a6f..5747ae2ad4 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -101,13 +101,21 @@ let context ctx = Univ.ContextSet.to_context ctx.uctx_local let const_univ_entry ~poly uctx = let open Entries in - if poly then Polymorphic_const_entry (context uctx) + if poly then + let (binders, _) = uctx.uctx_names in + let uctx = context uctx in + let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in + Polymorphic_const_entry (nas, uctx) else Monomorphic_const_entry (context_set uctx) (* does not support cumulativity since you need more info *) let ind_univ_entry ~poly uctx = let open Entries in - if poly then Polymorphic_ind_entry (context uctx) + if poly then + let (binders, _) = uctx.uctx_names in + let uctx = context uctx in + let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in + Polymorphic_ind_entry (nas, uctx) else Monomorphic_ind_entry (context_set uctx) let of_context_set ctx = { empty with uctx_local = ctx } @@ -140,7 +148,25 @@ let of_binders b = in { ctx with uctx_names = b, rmap } -let universe_binders ctx = fst ctx.uctx_names +let invent_name (named,cnt) u = + let rec aux i = + let na = Id.of_string ("u"^(string_of_int i)) in + if Id.Map.mem na named then aux (i+1) + else Id.Map.add na u named, i+1 + in + aux cnt + +let universe_binders ctx = + let open Univ in + let named, rev = ctx.uctx_names in + let named, _ = LSet.fold (fun u named -> + match LMap.find u rev with + | exception Not_found -> (* not sure if possible *) invent_name named u + | { uname = None } -> invent_name named u + | { uname = Some _ } -> named) + (ContextSet.levels ctx.uctx_local) (named, 0) + in + named let instantiate_variable l b v = try v := Univ.LMap.set l (Some b) !v @@ -394,8 +420,11 @@ let check_univ_decl ~poly uctx decl = let ctx = let names = decl.univdecl_instance in let extensible = decl.univdecl_extensible_instance in - if poly - then Entries.Polymorphic_const_entry (universe_context ~names ~extensible uctx) + if poly then + let (binders, _) = uctx.uctx_names in + let uctx = universe_context ~names ~extensible uctx in + let nas = UnivNames.compute_instance_binders (Univ.UContext.instance uctx) binders in + Entries.Polymorphic_const_entry (nas, uctx) else let () = check_universe_context_set ~names ~extensible uctx in Entries.Monomorphic_const_entry uctx.uctx_local @@ -566,6 +595,9 @@ let make_flexible_variable ctx ~algebraic u = {ctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = avars'} +let make_nonalgebraic_variable ctx u = + { ctx with uctx_univ_algebraic = Univ.LSet.remove u ctx.uctx_univ_algebraic } + let make_flexible_nonalgebraic ctx = {ctx with uctx_univ_algebraic = Univ.LSet.empty} diff --git a/engine/uState.mli b/engine/uState.mli index 8053a7bf83..ad0cd5c1bb 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -126,9 +126,15 @@ val add_global_univ : t -> Univ.Level.t -> t Turn the variable [l] flexible, and algebraic if [algebraic] is true and [l] can be. That is if there are no strict upper constraints on [l] and and it does not appear in the instance of any non-algebraic - universe. Otherwise the variable is just made flexible. *) + universe. Otherwise the variable is just made flexible. + + If [l] is already algebraic it will remain so even with [algebraic:false]. *) val make_flexible_variable : t -> algebraic:bool -> Univ.Level.t -> t +val make_nonalgebraic_variable : t -> Univ.Level.t -> t +(** Make the level non algebraic. Undefined behaviour on + already-defined algebraics. *) + (** Turn all undefined flexible algebraic variables into simply flexible ones. Can be used in case the variables might appear in universe instances (typically for polymorphic program obligations). *) diff --git a/engine/univNames.ml b/engine/univNames.ml index a71f9c5736..1019f8f0c2 100644 --- a/engine/univNames.ml +++ b/engine/univNames.ml @@ -36,69 +36,24 @@ type universe_binders = Univ.Level.t Names.Id.Map.t let empty_binders = Id.Map.empty -let universe_binders_table = Summary.ref GlobRef.Map.empty ~name:"universe binders" - -let universe_binders_of_global ref : Id.t list = - try - let l = GlobRef.Map.find ref !universe_binders_table in l - with Not_found -> [] - -let cache_ubinder (_,(ref,l)) = - universe_binders_table := GlobRef.Map.add ref l !universe_binders_table - -let subst_ubinder (subst,(ref,l as orig)) = - let ref' = fst (Globnames.subst_global subst ref) in - if ref == ref' then orig else ref', l - let name_universe lvl = (** Best-effort naming from the string representation of the level. This is completely hackish and should be solved in upper layers instead. *) Id.of_string_soft (Level.to_string lvl) -let discharge_ubinder (_,(ref,l)) = - (** Expand polymorphic binders with the section context *) - let info = Lib.section_segment_of_reference ref in - let sec_inst = Array.to_list (Instance.to_array (info.Lib.abstr_subst)) in - let map lvl = match Level.name lvl with - | None -> (* Having Prop/Set/Var as section universes makes no sense *) - assert false - | Some na -> - try - let qid = Nametab.shortest_qualid_of_universe na in - snd (Libnames.repr_qualid qid) - with Not_found -> name_universe lvl - in - let l = List.map map sec_inst @ l in - Some (ref, l) - -let ubinder_obj : GlobRef.t * Id.t list -> Libobject.obj = - let open Libobject in - declare_object { (default_object "universe binder") with - cache_function = cache_ubinder; - load_function = (fun _ x -> cache_ubinder x); - classify_function = (fun x -> Substitute x); - subst_function = subst_ubinder; - discharge_function = discharge_ubinder; - rebuild_function = (fun x -> x); } - -let register_universe_binders ref ubinders = - (** TODO: change the API to register a [Name.t list] instead. This is the last - part of the code that depends on the internal representation of names in - abstract contexts, but removing it requires quite a rework of the - callers. *) - let univs = AUContext.instance (Environ.universes_of_global (Global.env()) ref) in +let compute_instance_binders inst ubinders = let revmap = Id.Map.fold (fun id lvl accu -> LMap.add lvl id accu) ubinders LMap.empty in let map lvl = - try LMap.find lvl revmap - with Not_found -> name_universe lvl + try Name (LMap.find lvl revmap) + with Not_found -> Name (name_universe lvl) in - let ubinders = Array.map_to_list map (Instance.to_array univs) in - if not (List.is_empty ubinders) then Lib.add_anonymous_leaf (ubinder_obj (ref, ubinders)) + Array.map map (Instance.to_array inst) type univ_name_list = Names.lname list -let universe_binders_with_opt_names ref names = - let orig = universe_binders_of_global ref in +let universe_binders_with_opt_names orig names = + let orig = AUContext.names orig in + let orig = Array.to_list orig in let udecl = match names with | None -> orig | Some udecl -> @@ -106,11 +61,14 @@ let universe_binders_with_opt_names ref names = List.map2 (fun orig {CAst.v = na} -> match na with | Anonymous -> orig - | Name id -> id) orig udecl + | Name id -> Name id) orig udecl with Invalid_argument _ -> let len = List.length orig in CErrors.user_err ~hdr:"universe_binders_with_opt_names" Pp.(str "Universe instance should have length " ++ int len) in - let fold i acc na = Names.Id.Map.add na (Level.var i) acc in + let fold i acc na = match na with + | Name id -> Names.Id.Map.add id (Level.var i) acc + | Anonymous -> acc + in List.fold_left_i fold 0 empty_binders udecl diff --git a/engine/univNames.mli b/engine/univNames.mli index bd4062ade4..6e68153ac2 100644 --- a/engine/univNames.mli +++ b/engine/univNames.mli @@ -19,7 +19,7 @@ type universe_binders = Univ.Level.t Names.Id.Map.t val empty_binders : universe_binders -val register_universe_binders : Names.GlobRef.t -> universe_binders -> unit +val compute_instance_binders : Instance.t -> universe_binders -> Names.Name.t array type univ_name_list = Names.lname list @@ -29,5 +29,5 @@ type univ_name_list = Names.lname list of [ref] by [univs] (skipping Anonymous). May error if the lengths mismatch. Otherwise return the bound universe names registered for [ref]. *) -val universe_binders_with_opt_names : Names.GlobRef.t -> +val universe_binders_with_opt_names : AUContext.t -> univ_name_list option -> universe_binders diff --git a/gramlib/gramext.ml b/gramlib/gramext.ml index 72468b540e..43a70ca13b 100644 --- a/gramlib/gramext.ml +++ b/gramlib/gramext.ml @@ -149,8 +149,6 @@ let srules rl = in Stree t -external action : 'a -> g_action = "%identity" - let is_level_labelled n lev = match lev.lname with Some n1 -> n = n1 diff --git a/gramlib/gramext.mli b/gramlib/gramext.mli index e888508277..8361e21645 100644 --- a/gramlib/gramext.mli +++ b/gramlib/gramext.mli @@ -59,7 +59,6 @@ val levels_of_rules : list -> 'te g_level list val srules : ('te g_symbol list * g_action) list -> 'te g_symbol -external action : 'a -> g_action = "%identity" val eq_symbol : 'a g_symbol -> 'a g_symbol -> bool val delete_rule_in_level_list : diff --git a/gramlib/gramlib.mllib b/gramlib/gramlib.mllib new file mode 100644 index 0000000000..4c915b2b05 --- /dev/null +++ b/gramlib/gramlib.mllib @@ -0,0 +1,4 @@ +Ploc +Plexing +Gramext +Grammar diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 760410894a..dfce26a33a 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -5,6 +5,8 @@ open Gramext open Format +external gramext_action : 'a -> g_action = "%identity" + let rec flatten_tree = function DeadEnd -> [] @@ -350,7 +352,7 @@ let top_tree entry = | LocAct (_, _) | DeadEnd -> raise Stream.Failure let skip_if_empty bp p strm = - if Stream.count strm == bp then Gramext.action (fun a -> p strm) + if Stream.count strm == bp then gramext_action (fun a -> p strm) else raise Stream.Failure let continue entry bp a s son p1 (strm__ : _ Stream.t) = @@ -359,7 +361,7 @@ let continue entry bp a s son p1 (strm__ : _ Stream.t) = try p1 strm__ with Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) in - Gramext.action (fun _ -> app act a) + gramext_action (fun _ -> app act a) let do_recover parser_of_tree entry nlevn alevn bp a s son (strm__ : _ Stream.t) = @@ -861,8 +863,6 @@ module type S = val of_parser : string -> (te Stream.t -> 'a) -> 'a e val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit - external obj : 'a e -> te Gramext.g_entry = "%identity" - val parse_token : 'a e -> te Stream.t -> 'a end type ('self, 'a) ty_symbol type ('self, 'f, 'r) ty_rule @@ -892,18 +892,11 @@ module type S = val gram_reinit : te Plexing.lexer -> unit val clear_entry : 'a Entry.e -> unit end - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit val safe_extend : 'a Entry.e -> Gramext.position option -> (string option * Gramext.g_assoc option * 'a ty_production list) list -> unit - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit val safe_delete_rule : 'a Entry.e -> ('a, 'r, 'f) ty_rule -> unit end @@ -930,18 +923,6 @@ module GMake (L : GLexerType) = Obj.magic (parse_parsable e p : Obj.t) let parse_token_stream (e : 'a e) ts : 'a = Obj.magic (e.estart 0 ts : Obj.t) - let _warned_using_parse_token = ref false - let parse_token (entry : 'a e) ts : 'a = - (* commented: too often warned in Coq... - if not warned_using_parse_token.val then do { - eprintf "<W> use of Entry.parse_token "; - eprintf "deprecated since 2017-06-16\n%!"; - eprintf "use Entry.parse_token_stream instead\n%! "; - warned_using_parse_token.val := True - } - else (); - *) - parse_token_stream entry ts let name e = e.ename let of_parser n (p : te Stream.t -> 'a) : 'a e = {egram = gram; ename = n; elocal = false; diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index 244ab710dc..1e14e557bc 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -35,8 +35,6 @@ module type S = val of_parser : string -> (te Stream.t -> 'a) -> 'a e val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit - external obj : 'a e -> te Gramext.g_entry = "%identity" - val parse_token : 'a e -> te Stream.t -> 'a end type ('self, 'a) ty_symbol type ('self, 'f, 'r) ty_rule @@ -67,18 +65,11 @@ module type S = val gram_reinit : te Plexing.lexer -> unit val clear_entry : 'a Entry.e -> unit end - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit val safe_extend : 'a Entry.e -> Gramext.position option -> (string option * Gramext.g_assoc option * 'a ty_production list) list -> unit - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit val safe_delete_rule : 'a Entry.e -> ('a, 'f, 'r) ty_rule -> unit end (** Signature type of the functor [Grammar.GMake]. The types and diff --git a/grammar/argextend.mlp b/grammar/argextend.mlp deleted file mode 100644 index b882d2164f..0000000000 --- a/grammar/argextend.mlp +++ /dev/null @@ -1,221 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -open Q_util - -let loc = Ploc.dummy - -IFDEF STRICT THEN - let ploc_vala x = Ploc.VaVal x -ELSE - let ploc_vala x = x -END - -let declare_str_items loc l = - MLast.StDcl (loc, ploc_vala l) (* correspond to <:str_item< declare $list:l'$ end >> *) - -let declare_arg loc s e = - declare_str_items loc [ - <:str_item< value ($lid:"wit_"^s$, $lid:s$) = $e$ >>; - (** Prevent the unused variable warning *) - <:str_item< value _ = ($lid:"wit_"^s$, $lid:s$) >>; - ] - -let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> - -let rec make_wit loc = function - | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> - | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> - | PairArgType (t1,t2) -> - <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >> - | ExtraArgType s -> mk_extraarg loc s - -let is_self s = function -| ExtraArgType s' -> s = s' -| _ -> false - -let make_rawwit loc arg = <:expr< Genarg.rawwit $make_wit loc arg$ >> -let make_globwit loc arg = <:expr< Genarg.glbwit $make_wit loc arg$ >> -let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> - -let make_act loc act pil = - let rec make = function - | [] -> <:expr< (fun loc -> $act$) >> - | ExtNonTerminal (_, None) :: tl -> <:expr< (fun $lid:"_"$ -> $make tl$) >> - | ExtNonTerminal (_, Some p) :: tl -> <:expr< (fun $lid:p$ -> $make tl$) >> - | ExtTerminal _ :: tl -> - <:expr< (fun _ -> $make tl$) >> in - make (List.rev pil) - -let make_prod_item self = function - | ExtTerminal s -> <:expr< Extend.Atoken (CLexer.terminal $mlexpr_of_string s$) >> - | ExtNonTerminal (Uentry e, _) when e = self -> <:expr< Extend.Aself >> - | ExtNonTerminal (g, _) -> - let base s = <:expr< $lid:s$ >> in - mlexpr_of_prod_entry_key base g - -let rec make_prod self = function -| [] -> <:expr< Extend.Stop >> -| item :: prods -> <:expr< Extend.Next $make_prod self prods$ $make_prod_item self item$ >> - -let make_rule loc self (prods,act) = - <:expr< Extend.Rule $make_prod self (List.rev prods)$ $make_act loc act prods$ >> - -let is_ident x = function -| <:expr< $lid:s$ >> -> (s : string) = x -| _ -> false - -let make_extend loc self cl = match cl with -| [[ExtNonTerminal (Uentry e, Some id)], act] when is_ident id act -> - (** Special handling of identity arguments by not redeclaring an entry *) - <:expr< Vernacentries.Arg_alias $lid:e$ >> -| _ -> - <:expr< Vernacentries.Arg_rules $mlexpr_of_list (make_rule loc self) (List.rev cl)$ >> - -let warning_deprecated prefix s = function -| None -> () -| Some _ -> - Printf.eprintf "Deprecated [%sTYPED AS] clause in [ARGUMENT EXTEND %s]. \ - Use [TYPED AS] instead.\n%!" prefix s - -let get_type s = function -| None -> None -| Some typ -> - if is_self s typ then - let () = Printf.eprintf "Redundant [TYPED AS] clause in [ARGUMENT EXTEND %s].\n%!" s in - None - else Some typ - -let declare_tactic_argument loc s (typ, f, g, h) cl = - let se = mlexpr_of_string s in - let typ, pr = match typ with - | `Uniform (typ, pr) -> - let typ = get_type s typ in - typ, <:expr< ($lid:pr$, $lid:pr$, $lid:pr$) >> - | `Specialized (a, rpr, c, gpr, e, tpr) -> - let () = warning_deprecated "RAW_" s a in - let () = warning_deprecated "GLOB_" s c in - let typ = get_type s e in - typ, <:expr< ($lid:rpr$, $lid:gpr$, $lid:tpr$) >> - in - let glob = match g, typ with - | Some f, (None | Some _) -> - <:expr< Tacentries.ArgInternFun (fun ist v -> (ist, $lid:f$ ist v)) >> - | None, Some typ -> - <:expr< Tacentries.ArgInternWit $make_wit loc typ$ >> - | None, None -> - <:expr< Tacentries.ArgInternFun (fun ist v -> (ist, v)) >> - in - let interp = match f, typ with - | Some f, (None | Some _) -> - <:expr< Tacentries.ArgInterpLegacy $lid:f$ >> - | None, Some typ -> - <:expr< Tacentries.ArgInterpWit $make_wit loc typ$ >> - | None, None -> - <:expr< Tacentries.ArgInterpRet >> - in - let subst = match h, typ with - | Some f, (None | Some _) -> - <:expr< Tacentries.ArgSubstFun $lid:f$ >> - | None, Some typ -> - <:expr< Tacentries.ArgSubstWit $make_wit loc typ$ >> - | None, None -> - <:expr< Tacentries.ArgSubstFun (fun s v -> v) >> - in - let dyn = mlexpr_of_option (fun typ -> <:expr< Geninterp.val_tag $make_topwit loc typ$ >>) typ in - declare_arg loc s <:expr< Tacentries.argument_extend ~{ name = $se$ } { - Tacentries.arg_parsing = $make_extend loc s cl$; - Tacentries.arg_tag = $dyn$; - Tacentries.arg_intern = $glob$; - Tacentries.arg_subst = $subst$; - Tacentries.arg_interp = $interp$; - Tacentries.arg_printer = $pr$ - } >> - -let declare_vernac_argument loc s pr cl = - let se = mlexpr_of_string s in - let pr_rules = match pr with - | None -> <:expr< fun _ -> Pp.str $str:"[No printer for "^s^"]"$ >> - | Some pr -> <:expr< $lid:pr$ >> in - declare_arg loc s <:expr< Vernacentries.vernac_argument_extend ~{ name = $se$ } { - Vernacentries.arg_printer = $pr_rules$; - Vernacentries.arg_parsing = $make_extend loc s cl$ - } >> - -open Pcaml - -EXTEND - GLOBAL: str_item; - str_item: - [ [ "ARGUMENT"; "EXTEND"; s = entry_name; - header = argextend_header; - OPT "|"; l = LIST1 argrule SEP "|"; - "END" -> - declare_tactic_argument loc s header l - | "VERNAC"; "ARGUMENT"; "EXTEND"; s = entry_name; - pr = OPT ["PRINTED"; "BY"; pr = LIDENT -> pr]; - OPT "|"; l = LIST1 argrule SEP "|"; - "END" -> - declare_vernac_argument loc s pr l ] ] - ; - argextend_specialized: - [ [ rawtyp = OPT [ "RAW_TYPED"; "AS"; rawtyp = argtype -> rawtyp ]; - "RAW_PRINTED"; "BY"; rawpr = LIDENT; - globtyp = OPT [ "GLOB_TYPED"; "AS"; globtyp = argtype -> globtyp ]; - "GLOB_PRINTED"; "BY"; globpr = LIDENT -> - (rawtyp, rawpr, globtyp, globpr) ] ] - ; - argextend_header: - [ [ typ = OPT [ "TYPED"; "AS"; typ = argtype -> typ ]; - "PRINTED"; "BY"; pr = LIDENT; - f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; - g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; - h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; - special = OPT argextend_specialized -> - let repr = match special with - | None -> `Uniform (typ, pr) - | Some (rtyp, rpr, gtyp, gpr) -> `Specialized (rtyp, rpr, gtyp, gpr, typ, pr) - in - (repr, f, g, h) ] ] - ; - argtype: - [ "2" - [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ] - | "1" - [ e = argtype; LIDENT "list" -> ListArgType e - | e = argtype; LIDENT "option" -> OptArgType e ] - | "0" - [ e = LIDENT -> - let e = parse_user_entry e "" in - type_of_user_symbol e - | "("; e = argtype; ")" -> e ] ] - ; - argrule: - [ [ "["; l = LIST0 genarg; "]"; "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ] - ; - genarg: - [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let e = parse_user_entry e "" in - ExtNonTerminal (e, Some s) - | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let e = parse_user_entry e sep in - ExtNonTerminal (e, Some s) - | e = LIDENT -> - let e = parse_user_entry e "" in - ExtNonTerminal (e, None) - | s = STRING -> ExtTerminal s - ] ] - ; - entry_name: - [ [ s = LIDENT -> s - | UIDENT -> failwith "Argument entry names must be lowercase" - ] ] - ; - END diff --git a/grammar/dune b/grammar/dune deleted file mode 100644 index f03fe07607..0000000000 --- a/grammar/dune +++ /dev/null @@ -1,42 +0,0 @@ -(library - (name grammar) - (synopsis "Coq Camlp5 Grammar Extensions for Plugins") - (public_name coq.grammar) - (wrapped false) - (flags (:standard -w -58)) - (libraries camlp5)) - -; Custom camlp5! This is a net speedup, and a preparation for using -; Dune's preprocessor abilities. -(rule - (targets coqmlp5) - (action (run mkcamlp5.opt pa_o.cmx pa_op.cmx pr_dump.cmx pa_extend.cmx q_MLast.cmx pa_macro.cmx pr_o.cmx -o coqmlp5))) - -(rule - (targets coqp5) - (action (run mkcamlp5.opt pa_o.cmx pa_op.cmx pr_dump.cmx pa_extend.cmx q_MLast.cmx pa_macro.cmx pr_o.cmx %{dep:grammar.cmxa} -o coqp5))) - -(install - (section bin) - (package coq) - (files coqp5 coqmlp5)) - -(rule - (targets q_util.ml) - (deps (:mlp-file q_util.mlp)) - (action (run coqmlp5 -loc loc -impl %{mlp-file} -o %{targets}))) - -(rule - (targets argextend.ml) - (deps (:mlp-file argextend.mlp)) - (action (run coqmlp5 -loc loc -impl %{mlp-file} -o %{targets}))) - -(rule - (targets tacextend.ml) - (deps (:mlp-file tacextend.mlp)) - (action (run coqmlp5 -loc loc -impl %{mlp-file} -o %{targets}))) - -(rule - (targets vernacextend.ml) - (deps (:mlp-file vernacextend.mlp)) - (action (run coqmlp5 -loc loc -impl %{mlp-file} -o %{targets}))) diff --git a/grammar/q_util.mli b/grammar/q_util.mli deleted file mode 100644 index b163100fc3..0000000000 --- a/grammar/q_util.mli +++ /dev/null @@ -1,54 +0,0 @@ -(************************************************************************) -(* * 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 argument_type = -| ListArgType of argument_type -| OptArgType of argument_type -| PairArgType of argument_type * argument_type -| ExtraArgType of string - -type user_symbol = -| Ulist1 of user_symbol -| Ulist1sep of user_symbol * string -| Ulist0 of user_symbol -| Ulist0sep of user_symbol * string -| Uopt of user_symbol -| Uentry of string -| Uentryl of string * int - -type extend_token = -| ExtTerminal of string -| ExtNonTerminal of user_symbol * string option - -val mlexpr_of_list : ('a -> MLast.expr) -> 'a list -> MLast.expr - -val mlexpr_of_pair : - ('a -> MLast.expr) -> ('b -> MLast.expr) - -> 'a * 'b -> MLast.expr - -val mlexpr_of_bool : bool -> MLast.expr - -val mlexpr_of_int : int -> MLast.expr - -val mlexpr_of_string : string -> MLast.expr - -val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr - -val mlexpr_of_name : ('a -> MLast.expr) -> 'a option -> MLast.expr - -val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.expr - -val type_of_user_symbol : user_symbol -> argument_type - -val parse_user_entry : string -> string -> user_symbol - -val mlexpr_of_symbol : user_symbol -> MLast.expr - -val binders_of_tokens : MLast.expr -> extend_token list -> MLast.expr diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp deleted file mode 100644 index a2007d258c..0000000000 --- a/grammar/q_util.mlp +++ /dev/null @@ -1,150 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -(* This file defines standard combinators to build ml expressions *) - -type argument_type = -| ListArgType of argument_type -| OptArgType of argument_type -| PairArgType of argument_type * argument_type -| ExtraArgType of string - -type user_symbol = -| Ulist1 of user_symbol -| Ulist1sep of user_symbol * string -| Ulist0 of user_symbol -| Ulist0sep of user_symbol * string -| Uopt of user_symbol -| Uentry of string -| Uentryl of string * int - -type extend_token = -| ExtTerminal of string -| ExtNonTerminal of user_symbol * string option - -let mlexpr_of_list f l = - List.fold_right - (fun e1 e2 -> - let e1 = f e1 in - let loc = Ploc.encl (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in - <:expr< [$e1$ :: $e2$] >>) - l (let loc = Ploc.dummy in <:expr< [] >>) - -let mlexpr_of_pair m1 m2 (a1,a2) = - let e1 = m1 a1 and e2 = m2 a2 in - let loc = Ploc.encl (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in - <:expr< ($e1$, $e2$) >> - -(* We don't give location for tactic quotation! *) -let loc = Ploc.dummy - - -let mlexpr_of_bool = function - | true -> <:expr< True >> - | false -> <:expr< False >> - -let mlexpr_of_int n = <:expr< $int:string_of_int n$ >> - -let mlexpr_of_string s = <:expr< $str:s$ >> - -let mlexpr_of_option f = function - | None -> <:expr< None >> - | Some e -> <:expr< Some $f e$ >> - -let mlexpr_of_name f = function - | None -> <:expr< Names.Name.Anonymous >> - | Some e -> <:expr< Names.Name.Name $f e$ >> - -let symbol_of_string s = <:expr< Extend.Atoken (CLexer.terminal $str:s$) >> - -let rec mlexpr_of_prod_entry_key f = function - | Ulist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key f s$ >> - | Ulist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >> - | Ulist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >> - | Ulist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $symbol_of_string sep$ >> - | Uopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key f s$ >> - | Uentry e -> <:expr< Extend.Aentry ($f e$) >> - | Uentryl (e, l) -> - (** Keep in sync with Pcoq! *) - assert (e = "tactic"); - if l = 5 then <:expr< Extend.Aentry Pltac.binder_tactic >> - else <:expr< Extend.Aentryl (Pltac.tactic_expr) $mlexpr_of_string (string_of_int l)$ >> - -let rec type_of_user_symbol = function -| Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) -> - ListArgType (type_of_user_symbol s) -| Uopt s -> - OptArgType (type_of_user_symbol s) -| Uentry e | Uentryl (e, _) -> ExtraArgType e - -let coincide s pat off = - let len = String.length pat in - let break = ref true in - let i = ref 0 in - while !break && !i < len do - let c = Char.code s.[off + !i] in - let d = Char.code pat.[!i] in - break := c = d; - incr i - done; - !break - -let check_separator sep = - if sep <> "" then failwith "Separator is only for arguments with suffix _list_sep." - -let rec parse_user_entry s sep = - let l = String.length s in - if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let entry = parse_user_entry (String.sub s 3 (l-8)) "" in - check_separator sep; - Ulist1 entry - else if l > 12 && coincide s "ne_" 0 && - coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 3 (l-12)) "" in - Ulist1sep (entry, sep) - else if l > 5 && coincide s "_list" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-5)) "" in - check_separator sep; - Ulist0 entry - else if l > 9 && coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 0 (l-9)) "" in - Ulist0sep (entry, sep) - else if l > 4 && coincide s "_opt" (l-4) then - let entry = parse_user_entry (String.sub s 0 (l-4)) "" in - check_separator sep; - Uopt entry - else if l = 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then - let n = Char.code s.[6] - 48 in - check_separator sep; - Uentryl ("tactic", n) - else - let s = match s with "hyp" -> "var" | _ -> s in - check_separator sep; - Uentry s - -let rec mlexpr_of_symbol = function -| Ulist1 s -> <:expr< Extend.TUlist1 $mlexpr_of_symbol s$ >> -| Ulist1sep (s,sep) -> <:expr< Extend.TUlist1sep $mlexpr_of_symbol s$ $str:sep$ >> -| Ulist0 s -> <:expr< Extend.TUlist0 $mlexpr_of_symbol s$ >> -| Ulist0sep (s,sep) -> <:expr< Extend.TUlist0sep $mlexpr_of_symbol s$ $str:sep$ >> -| Uopt s -> <:expr< Extend.TUopt $mlexpr_of_symbol s$ >> -| Uentry e -> - let wit = <:expr< $lid:"wit_"^e$ >> in - <:expr< Extend.TUentry (Genarg.get_arg_tag $wit$) >> -| Uentryl (e, l) -> - assert (e = "tactic"); - let wit = <:expr< $lid:"wit_"^e$ >> in - <:expr< Extend.TUentryl (Genarg.get_arg_tag $wit$) $mlexpr_of_int l$>> - -let rec binders_of_tokens e = function -| [] -> e -| ExtNonTerminal(_,None) :: cl -> <:expr< fun _ -> $binders_of_tokens e cl$ >> -| ExtNonTerminal(_,Some id) :: cl -> <:expr< fun $lid:id$ -> $binders_of_tokens e cl$ >> -| ExtTerminal _ :: cl -> binders_of_tokens e cl diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp deleted file mode 100644 index a093f78388..0000000000 --- a/grammar/tacextend.mlp +++ /dev/null @@ -1,72 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -(** WARNING: this file is deprecated; consider modifying coqpp instead. *) - -(** Implementation of the TACTIC EXTEND macro. *) - -open Q_util -open Argextend - -let plugin_name = <:expr< __coq_plugin_name >> - -let rec mlexpr_of_clause = function -| [] -> <:expr< TyNil >> -| ExtTerminal s :: cl -> <:expr< TyIdent($str:s$, $mlexpr_of_clause cl$) >> -| ExtNonTerminal (g, _) :: cl -> - <:expr< TyArg($mlexpr_of_symbol g$, $mlexpr_of_clause cl$) >> - -open Pcaml - -EXTEND - GLOBAL: str_item; - str_item: - [ [ "TACTIC"; "EXTEND"; s = tac_name; - depr = OPT [ "DEPRECATED"; depr = LIDENT -> depr ]; - level = OPT [ "AT"; UIDENT "LEVEL"; level = INT -> level ]; - OPT "|"; l = LIST1 tacrule SEP "|"; - "END" -> - let level = match level with Some i -> int_of_string i | None -> 0 in - let level = mlexpr_of_int level in - let depr = mlexpr_of_option (fun l -> <:expr< $lid:l$ >>) depr in - let l = <:expr< Tacentries.($mlexpr_of_list (fun x -> x) l$) >> in - declare_str_items loc [ <:str_item< Tacentries.tactic_extend - $plugin_name$ $str:s$ ~{ level = $level$ } ?{ deprecation = - $depr$ } $l$ >> ] ] ] - ; - tacrule: - [ [ "["; l = LIST1 tacargs; "]"; - "->"; "["; e = Pcaml.expr; "]" -> - let e = <:expr< fun ist -> $e$ >> in - <:expr< TyML($mlexpr_of_clause l$, $binders_of_tokens e l$) >> - ] ] - ; - - tacargs: - [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let e = parse_user_entry e "" in - ExtNonTerminal (e, Some s) - | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let e = parse_user_entry e sep in - ExtNonTerminal (e, Some s) - | e = LIDENT -> - let e = parse_user_entry e "" in - ExtNonTerminal (e, None) - | s = STRING -> - let () = if s = "" then failwith "Empty terminal." in - ExtTerminal s - ] ] - ; - tac_name: - [ [ s = LIDENT -> s - | s = UIDENT -> s - ] ] - ; - END diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp deleted file mode 100644 index 3c401e827e..0000000000 --- a/grammar/vernacextend.mlp +++ /dev/null @@ -1,115 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -(** Implementation of the VERNAC EXTEND macro. *) - -open Q_util -open Argextend - -type rule = { - r_patt : extend_token list; - (** The remaining tokens of the parsing rule *) - r_class : MLast.expr option; - (** An optional classifier for the STM *) - r_branch : MLast.expr; - (** The action performed by this rule. *) - r_depr : bool; - (** Whether this entry is deprecated *) -} - -let rec mlexpr_of_clause = function -| [] -> <:expr< Vernacentries.TyNil >> -| ExtTerminal s :: cl -> <:expr< Vernacentries.TyTerminal ($str:s$, $mlexpr_of_clause cl$) >> -| ExtNonTerminal (g, id) :: cl -> - <:expr< Vernacentries.TyNonTerminal ($mlexpr_of_symbol g$, $mlexpr_of_clause cl$) >> - -let make_rule r = - let ty = mlexpr_of_clause r.r_patt in - let cmd = binders_of_tokens r.r_branch r.r_patt in - let make_classifier c = binders_of_tokens c r.r_patt in - let classif = mlexpr_of_option make_classifier r.r_class in - <:expr< Vernacentries.TyML ($mlexpr_of_bool r.r_depr$, $ty$, $cmd$, $classif$) >> - -let declare_command loc s c nt cl = - let se = mlexpr_of_string s in - let c = mlexpr_of_option (fun x -> x) c in - let rules = mlexpr_of_list make_rule cl in - declare_str_items loc - [ <:str_item< Vernacentries.vernac_extend ?{ classifier = $c$ } ~{ command = $se$ } ?{ entry = $nt$ } $rules$ >> ] - -open Pcaml - -EXTEND - GLOBAL: str_item; - str_item: - [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT; c = OPT classification; - OPT "|"; l = LIST1 rule SEP "|"; - "END" -> - declare_command loc s c <:expr<None>> l - | "VERNAC"; "COMMAND"; "FUNCTIONAL"; "EXTEND"; s = UIDENT; c = OPT classification; - OPT "|"; l = LIST1 fun_rule SEP "|"; - "END" -> - declare_command loc s c <:expr<None>> l - | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT; c = OPT classification; - OPT "|"; l = LIST1 rule SEP "|"; - "END" -> - declare_command loc s c <:expr<Some $lid:nt$>> l - | "DECLARE"; "PLUGIN"; name = STRING -> - declare_str_items loc [ - <:str_item< value __coq_plugin_name = $str:name$ >>; - <:str_item< value _ = Mltop.add_known_module __coq_plugin_name >>; - ] - ] ] - ; - classification: - [ [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> - | "CLASSIFIED"; "AS"; "SIDEFF" -> - <:expr< fun _ -> Vernac_classifier.classify_as_sideeff >> - | "CLASSIFIED"; "AS"; "QUERY" -> - <:expr< fun _ -> Vernac_classifier.classify_as_query >> - ] ] - ; - deprecation: - [ [ -> false | "DEPRECATED" -> true ] ] - ; - rule: - [ [ "["; OPT "-"; l = LIST1 args; "]"; - d = deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let b = <:expr< fun ~{atts} ~{st} -> ( let () = $e$ in st ) >> in - { r_patt = l; r_class = c; r_branch = b; r_depr = d; } - ] ] - ; - (** The [OPT "-"] argument serves no purpose nowadays, it is left here for - backward compatibility. *) - fun_rule: - [ [ "["; OPT "-"; l = LIST1 args; "]"; - d = deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - { r_patt = l; r_class = c; r_branch = e; r_depr = d; } - ] ] - ; - classifier: - [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< $c$>> ] ] - ; - args: - [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let e = parse_user_entry e "" in - ExtNonTerminal (e, Some s) - | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let e = parse_user_entry e sep in - ExtNonTerminal (e, Some s) - | e = LIDENT -> - let e = parse_user_entry e "" in - ExtNonTerminal (e, None) - | s = STRING -> - ExtTerminal s - ] ] - ; - END -;; diff --git a/ide/.merlin.in b/ide/.merlin.in index 953b5dce4c..4dc6f45550 100644 --- a/ide/.merlin.in +++ b/ide/.merlin.in @@ -2,5 +2,7 @@ PKG unix laglgtk2 lablgtk2.sourceview2 S utils B utils +S protocol +B protocol REC diff --git a/ide/configwin.ml b/ide/configwin.ml index 69e8b647ae..24be721631 100644 --- a/ide/configwin.ml +++ b/ide/configwin.ml @@ -46,6 +46,6 @@ let modifiers = Configwin_ihm.modifiers let edit ?(apply=(fun () -> ())) - title ?width ?height + title ?parent ?width ?height conf_struct_list = - Configwin_ihm.edit ~with_apply: true ~apply title ?width ?height conf_struct_list + Configwin_ihm.edit ~with_apply: true ~apply title ?parent ?width ?height conf_struct_list diff --git a/ide/configwin.mli b/ide/configwin.mli index 7616e471db..0ee77d69b5 100644 --- a/ide/configwin.mli +++ b/ide/configwin.mli @@ -158,6 +158,7 @@ val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_ val edit : ?apply: (unit -> unit) -> string -> + ?parent:GWindow.window -> ?width:int -> ?height:int -> configuration_structure list -> diff --git a/ide/configwin_ihm.ml b/ide/configwin_ihm.ml index d16efa603d..91695e944e 100644 --- a/ide/configwin_ihm.ml +++ b/ide/configwin_ihm.ml @@ -662,12 +662,13 @@ class configuration_box (tt : GData.tooltips) conf_struct = to configure the various parameters. *) let edit ?(with_apply=true) ?(apply=(fun () -> ())) - title ?width ?height + title ?parent ?width ?height conf_struct = let dialog = GWindow.dialog ~position:`CENTER ~modal: true ~title: title - ?height ?width + ~type_hint:`DIALOG + ?parent ?height ?width () in let tooltips = GData.tooltips () in @@ -807,3 +808,40 @@ let custom ?label box f expand = custom_expand = expand ; custom_framed = label ; } + +(* Copying lablgtk question_box + forbidding hiding *) + +let question_box ~title ~buttons ?(default=1) ?icon ?parent message = + let button_nb = ref 0 in + let window = GWindow.dialog ~position:`CENTER ~modal:true ?parent ~type_hint:`DIALOG ~title () in + let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in + let bbox = window#action_area in + begin match icon with + None -> () + | Some i -> hbox#pack i#coerce ~padding:4 + end; + ignore (GMisc.label ~text: message ~packing: hbox#add ()); + (* the function called to create each button by iterating *) + let rec iter_buttons n = function + [] -> + () + | button_label :: q -> + let b = GButton.button ~label: button_label + ~packing:(bbox#pack ~expand:true ~padding:4) () + in + ignore (b#connect#clicked ~callback: + (fun () -> button_nb := n; window#destroy ())); + (* If it's the first button then give it the focus *) + if n = default then b#grab_default () else (); + + iter_buttons (n+1) q + in + iter_buttons 1 buttons; + ignore (window#connect#destroy ~callback: GMain.Main.quit); + window#set_position `CENTER; + window#show (); + GMain.Main.main (); + !button_nb + +let message_box ~title ?icon ?parent ?(ok="Ok") message = + ignore (question_box ?icon ?parent ~title message ~buttons:[ ok ]) diff --git a/ide/configwin_ihm.mli b/ide/configwin_ihm.mli index c867ad9127..772a0958ff 100644 --- a/ide/configwin_ihm.mli +++ b/ide/configwin_ihm.mli @@ -60,7 +60,17 @@ val edit : ?with_apply:bool -> ?apply:(unit -> unit) -> string -> + ?parent:GWindow.window -> ?width:int -> ?height:int -> configuration_structure list -> return_button + +val question_box : title:string -> + buttons:string list -> + ?default:int -> ?icon:#GObj.widget -> + ?parent:GWindow.window -> string -> int + +val message_box : + title:string -> ?icon:#GObj.widget -> + ?parent:GWindow.window -> ?ok:string -> string -> unit diff --git a/ide/coqide.ml b/ide/coqide.ml index 4190f43680..40b8d2f484 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -89,21 +89,30 @@ let make_coqtop_args fname = | Ignore_args -> !sup_args | Append_args -> !sup_args | Subst_args -> [] in - if read_project#get = Ignore_args then "", base_args - else - match !custom_project_file, fname with - | Some (d,proj), _ -> d, coqtop_args_from_project proj @ base_args - | None, None -> "", base_args - | None, Some the_file -> - match - CoqProject_file.find_project_file - ~from:(Filename.dirname the_file) - ~projfile_name:project_file_name#get - with - | None -> "", base_args - | Some proj -> - proj, coqtop_args_from_project (read_project_file proj) @ base_args -;; + let proj, args = + if read_project#get = Ignore_args then "", base_args + else + match !custom_project_file, fname with + | Some (d,proj), _ -> d, coqtop_args_from_project proj @ base_args + | None, None -> "", base_args + | None, Some the_file -> + match + CoqProject_file.find_project_file + ~from:(Filename.dirname the_file) + ~projfile_name:project_file_name#get + with + | None -> "", base_args + | Some proj -> + let warning_fn x = Feedback.msg_warning Pp.(str x) in + proj, coqtop_args_from_project (read_project_file ~warning_fn proj) @ base_args + in + let args = match fname with + | None -> args + | Some fname -> + if List.exists (String.equal "-top") args then args + else "-topfile"::fname::args + in + proj, args (** Setting drag & drop on widgets *) @@ -181,8 +190,8 @@ let load_file ?(maycreate=false) f = let confirm_save ok = if ok then flash_info "Saved" else warning "Save Failed" -let select_and_save ~saveas ?filename sn = - let do_save = if saveas then sn.fileops#saveas else sn.fileops#save in +let select_and_save ?parent ~saveas ?filename sn = + let do_save = if saveas then sn.fileops#saveas ?parent else sn.fileops#save in let title = if saveas then "Save file as" else "Save file" in match select_file_for_save ~title ?filename () with |None -> false @@ -192,9 +201,9 @@ let select_and_save ~saveas ?filename sn = if ok then sn.tab_label#set_text (Filename.basename f); ok -let check_save ~saveas sn = +let check_save ?parent ~saveas sn = try match sn.fileops#filename with - |None -> select_and_save ~saveas sn + |None -> select_and_save ?parent ~saveas sn |Some f -> let ok = sn.fileops#save f in confirm_save ok; @@ -203,16 +212,17 @@ let check_save ~saveas sn = exception DontQuit -let check_quit saveall = +let check_quit ?parent saveall = (try save_pref () with _ -> flash_info "Cannot save preferences"); let is_modified sn = sn.buffer#modified in if List.exists is_modified notebook#pages then begin - let answ = GToolbox.question_box ~title:"Quit" + let answ = Configwin_ihm.question_box ~title:"Quit" ~buttons:["Save Named Buffers and Quit"; "Quit without Saving"; "Don't Quit"] ~default:0 ~icon:(warn_image ())#coerce + ?parent "There are unsaved buffers" in match answ with @@ -269,15 +279,15 @@ let load _ = | None -> () | Some f -> FileAux.load_file f -let save _ = on_current_term (FileAux.check_save ~saveas:false) +let save ?parent _ = on_current_term (FileAux.check_save ?parent ~saveas:false) -let saveas sn = +let saveas ?parent sn = try let filename = sn.fileops#filename in - ignore (FileAux.select_and_save ~saveas:true ?filename sn) + ignore (FileAux.select_and_save ?parent ~saveas:true ?filename sn) with _ -> warning "Save Failed" -let saveas = cb_on_current_term saveas +let saveas ?parent = cb_on_current_term (saveas ?parent) let saveall _ = List.iter @@ -288,33 +298,34 @@ let saveall _ = let () = Coq.save_all := saveall -let revert_all _ = +let revert_all ?parent _ = List.iter - (fun sn -> if sn.fileops#changed_on_disk then sn.fileops#revert) + (fun sn -> if sn.fileops#changed_on_disk then sn.fileops#revert ?parent ()) notebook#pages -let quit _ = - try FileAux.check_quit saveall; exit 0 +let quit ?parent _ = + try FileAux.check_quit ?parent saveall; exit 0 with FileAux.DontQuit -> () -let close_buffer sn = +let close_buffer ?parent sn = let do_remove () = notebook#remove_page notebook#current_page in if not sn.buffer#modified then do_remove () else - let answ = GToolbox.question_box ~title:"Close" + let answ = Configwin_ihm.question_box ~title:"Close" ~buttons:["Save Buffer and Close"; "Close without Saving"; "Don't Close"] ~default:0 ~icon:(warn_image ())#coerce + ?parent "This buffer has unsaved modifications" in match answ with - | 1 when FileAux.check_save ~saveas:true sn -> do_remove () + | 1 when FileAux.check_save ?parent ~saveas:true sn -> do_remove () | 2 -> do_remove () | _ -> () -let close_buffer = cb_on_current_term close_buffer +let close_buffer ?parent = cb_on_current_term (close_buffer ?parent) let export kind sn = match sn.fileops#filename with @@ -425,16 +436,16 @@ let coq_makefile sn = let coq_makefile = cb_on_current_term coq_makefile -let editor sn = +let editor ?parent sn = match sn.fileops#filename with |None -> warning "Call to external editor available only on named files" |Some f -> File.save (); let f = Filename.quote f in let cmd = Util.subst_command_placeholder cmd_editor#get f in - run_command ignore (fun _ -> sn.fileops#revert) cmd + run_command ignore (fun _ -> sn.fileops#revert ?parent ()) cmd -let editor = cb_on_current_term editor +let editor ?parent = cb_on_current_term (editor ?parent) let compile sn = File.save (); @@ -936,7 +947,7 @@ let build_ui () = try w#set_icon (Some (GdkPixbuf.from_file (MiscMenu.coq_icon ()))) with _ -> () in - let _ = w#event#connect#delete ~callback:(fun _ -> File.quit (); true) in + let _ = w#event#connect#delete ~callback:(fun _ -> File.quit ~parent:w (); true) in let _ = set_drag w#drag in let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in @@ -962,18 +973,18 @@ let build_ui () = item "File" ~label:"_File"; item "New" ~callback:File.newfile ~stock:`NEW; item "Open" ~callback:File.load ~stock:`OPEN; - item "Save" ~callback:File.save ~stock:`SAVE ~tooltip:"Save current buffer"; - item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:File.saveas; + item "Save" ~callback:(File.save ~parent:w) ~stock:`SAVE ~tooltip:"Save current buffer"; + item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:(File.saveas ~parent:w); item "Save all" ~label:"Sa_ve all" ~callback:File.saveall; item "Revert all buffers" ~label:"_Revert all buffers" - ~callback:File.revert_all ~stock:`REVERT_TO_SAVED; + ~callback:(File.revert_all ~parent:w) ~stock:`REVERT_TO_SAVED; item "Close buffer" ~label:"_Close buffer" ~stock:`CLOSE - ~callback:File.close_buffer ~tooltip:"Close current buffer"; + ~callback:(File.close_buffer ~parent:w) ~tooltip:"Close current buffer"; item "Print..." ~label:"_Print..." ~callback:File.print ~stock:`PRINT ~accel:"<Ctrl>p"; item "Rehighlight" ~label:"Reh_ighlight" ~accel:"<Ctrl>l" ~callback:File.highlight ~stock:`REFRESH; - item "Quit" ~stock:`QUIT ~callback:File.quit; + item "Quit" ~stock:`QUIT ~callback:(File.quit ~parent:w); ]; menu export_menu [ @@ -1004,14 +1015,12 @@ let build_ui () = item "Find Previous" ~label:"Find _Previous" ~stock:`GO_UP ~accel:"<Shift>F3" ~callback:(cb_on_current_term (fun t -> t.finder#find_backward ())); - item "Complete Word" ~label:"Complete Word" ~accel:"<Ctrl>slash" - ~callback:(fun _ -> ()); item "External editor" ~label:"External editor" ~stock:`EDIT - ~callback:External.editor; + ~callback:(External.editor ~parent:w); item "Preferences" ~accel:"<Ctrl>comma" ~stock:`PREFERENCES ~callback:(fun _ -> begin - try Preferences.configure ~apply:refresh_notebook_pos () + try Preferences.configure ~apply:refresh_notebook_pos w with _ -> flash_info "Cannot save preferences" end; reset_revert_timer ()); @@ -1300,8 +1309,8 @@ let build_ui () = (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02")); (* Showtime ! *) - w#show () - + w#show (); + w (** {2 Coqide main function } *) @@ -1316,7 +1325,7 @@ let make_scratch_buffer () = () let main files = - build_ui (); + let w = build_ui () in reset_revert_timer (); reset_autosave_timer (); (match files with @@ -1325,8 +1334,8 @@ let main files = notebook#goto_page 0; MiscMenu.initial_about (); on_current_term (fun t -> t.script#misc#grab_focus ()); - Minilib.log "End of Coqide.main" - + Minilib.log "End of Coqide.main"; + w (** {2 Argument parsing } *) @@ -1346,7 +1355,8 @@ let read_coqide_args argv = if project_files <> None then (output_string stderr "Error: multiple -f options"; exit 1); let d = CUnix.canonical_path_name (Filename.dirname file) in - let p = CoqProject_file.read_project_file file in + let warning_fn x = Format.eprintf "%s@\n%!" x in + let p = CoqProject_file.read_project_file ~warning_fn file in filter_coqtop coqtop (Some (d,p)) out args |"-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1 @@ -1382,9 +1392,9 @@ let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup; Sys.sigill; Sys.sigpipe; Sys.sigquit; Sys.sigusr1; Sys.sigusr2] -let set_signal_handlers () = +let set_signal_handlers ?parent () = try - Sys.set_signal Sys.sigint (Sys.Signal_handle File.quit); + Sys.set_signal Sys.sigint (Sys.Signal_handle (File.quit ?parent)); List.iter (fun i -> Sys.set_signal i (Sys.Signal_handle FileAux.crash_save)) signals_to_crash diff --git a/ide/coqide.mli b/ide/coqide.mli index 03e8545377..1d438ec381 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -22,7 +22,7 @@ val logfile : string option ref val read_coqide_args : string list -> string list (** Prepare the widgets, load the given files in tabs *) -val main : string list -> unit +val main : string list -> GWindow.window (** Function to save anything and kill all coqtops @return [false] if you're allowed to quit. *) @@ -37,7 +37,7 @@ val do_load : string -> unit (** Set coqide to perform a clean quit at Ctrl-C, while launching [crash_save] and exiting for others received signals *) -val set_signal_handlers : unit -> unit +val set_signal_handlers : ?parent:GWindow.window -> unit -> unit (** Emergency saving of opened files as "foo.v.crashcoqide", and exit (if the integer isn't 127). *) diff --git a/ide/coqide_main.ml b/ide/coqide_main.ml index 91e8be875a..21f513b8f4 100644 --- a/ide/coqide_main.ml +++ b/ide/coqide_main.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let _ = Coqide.set_signal_handlers () let _ = GtkMain.Main.init () (* We handle Gtk warning messages ourselves : @@ -62,7 +61,8 @@ let () = let args = List.filter (fun x -> not (List.mem x files)) argl in Coq.check_connection args; Coqide.sup_args := args; - Coqide.main files; + let w = Coqide.main files in + Coqide.set_signal_handlers ~parent:w (); Coqide_os_specific.init (); try GMain.main (); diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index 91c529932f..c994898a4f 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -60,7 +60,6 @@ let init () = \n <menuitem action='Find' />\ \n <menuitem action='Find Next' />\ \n <menuitem action='Find Previous' />\ -\n <menuitem action='Complete Word' />\ \n <separator />\ \n <menuitem action='External editor' />\ \n <separator />\ @@ -43,3 +43,14 @@ (package coqide) (modules coqide_main) (libraries coqide.gui)) + +; FIXME: we should install those in share/coqide. We better do this +; once the make-based system has been phased out. +(install + (section share_root) + (package coqide) + (files + (coq.png as coq/coq.png) + (coq_style.xml as coq/coq_style.xml) + (coq.lang as coq/coq.lang) + (coq-ssreflect.lang as coq/coq-ssreflect.lang))) diff --git a/ide/fileOps.ml b/ide/fileOps.ml index 7acd2c37a9..e4c8942cf1 100644 --- a/ide/fileOps.ml +++ b/ide/fileOps.ml @@ -18,10 +18,10 @@ object method filename : string option method update_stats : unit method changed_on_disk : bool - method revert : unit + method revert : ?parent:GWindow.window -> unit -> unit method auto_save : unit method save : string -> bool - method saveas : string -> bool + method saveas : ?parent:GWindow.window -> string -> bool end class fileops (buffer:GText.buffer) _fn (reset_handler:unit->unit) = @@ -48,7 +48,7 @@ object(self) false |_ -> false - method revert = + method revert ?parent () = let do_revert f = push_info "Reverting buffer"; try @@ -72,13 +72,14 @@ object(self) | Some f -> if not buffer#modified then do_revert f else - let answ = GToolbox.question_box + let answ = Configwin_ihm.question_box ~title:"Modified buffer changed on disk" ~buttons:["Revert from File"; "Overwrite File"; "Disable Auto Revert"] ~default:0 ~icon:(stock_to_widget `DIALOG_WARNING) + ?parent "Some unsaved buffers changed on disk" in match answ with @@ -102,13 +103,14 @@ object(self) end else false - method saveas f = + method saveas ?parent f = if not (Sys.file_exists f) then self#save f else - let answ = GToolbox.question_box ~title:"File exists on disk" + let answ = Configwin_ihm.question_box ~title:"File exists on disk" ~buttons:["Overwrite"; "Cancel";] ~default:1 ~icon:(warn_image ())#coerce + ?parent ("File "^f^" already exists") in match answ with diff --git a/ide/fileOps.mli b/ide/fileOps.mli index 9a1f0cb738..44a19f9981 100644 --- a/ide/fileOps.mli +++ b/ide/fileOps.mli @@ -16,10 +16,10 @@ object method filename : string option method update_stats : unit method changed_on_disk : bool - method revert : unit + method revert : ?parent:GWindow.window -> unit -> unit method auto_save : unit method save : string -> bool - method saveas : string -> bool + method saveas : ?parent:GWindow.window -> string -> bool end class fileops : GText.buffer -> string option -> (unit -> unit) -> ops diff --git a/ide/idetop.ml b/ide/idetop.ml index 8a221a93e9..8cb02190e6 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -212,25 +212,20 @@ let goals () = if Proof_diffs.show_diffs () then begin let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in let diff_goal_map = Proof_diffs.make_goal_map oldp newp in - let map_goal_for_diff ng = (* todo: move to proof_diffs.ml *) - try Evar.Map.find ng diff_goal_map with Not_found -> ng - in let process_goal_diffs nsigma ng = let open Evd in - let og = map_goal_for_diff ng in let og_s = match oldp with | Some oldp -> let (_,_,_,_,osigma) = Proof.proof oldp in - Some { it = og; sigma = osigma } + (try Some { it = Evar.Map.find ng diff_goal_map; sigma = osigma } + with Not_found -> raise (Pp_diff.Diff_Failure "Unable to match goals between old and new proof states (6)")) | None -> None in let (hyps_pp_list, concl_pp) = Proof_diffs.diff_goal_ide og_s ng nsigma in { Interface.goal_hyp = hyps_pp_list; Interface.goal_ccl = concl_pp; Interface.goal_id = Goal.uid ng } in - try - Some (export_pre_goals (Proof.map_structured_proof newp process_goal_diffs)) - with Pp_diff.Diff_Failure _ -> Some (export_pre_goals (Proof.map_structured_proof newp process_goal)) + Some (export_pre_goals (Proof.map_structured_proof newp process_goal_diffs)) end else Some (export_pre_goals (Proof.map_structured_proof newp process_goal)) with Proof_global.NoCurrentProof -> None;; diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index 002722ace9..f2913b1d1d 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -153,13 +153,13 @@ let emacs = insert emacs "Emacs" [] [ i#forward_sentence_end, { s with move = None })); mkE ~mods:mM _a "a" "Move to beginning of sentence" (Motion(fun s i -> i#backward_sentence_start, { s with move = None })); - mkE _n "n" "Move to next line" ~alias:[[],_Down,"DOWN"] (Motion(fun s i -> + mkE _n "n" "Move to next line" (Motion(fun s i -> let orig_off = Option.default i#line_offset s.move in let i = i#forward_line in let new_off = min (i#chars_in_line - 1) orig_off in (if new_off > 0 then i#set_line_offset new_off else i), { s with move = Some orig_off })); - mkE _p "p" "Move to previous line" ~alias:[[],_Up,"UP"] (Motion(fun s i -> + mkE _p "p" "Move to previous line" (Motion(fun s i -> let orig_off = Option.default i#line_offset s.move in let i = i#backward_line in let new_off = min (i#chars_in_line - 1) orig_off in diff --git a/ide/preferences.ml b/ide/preferences.ml index 6dc922c225..045d650c1c 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -688,7 +688,7 @@ let pmodifiers ?(all = false) name p = modifiers name (str_to_mod_list p#get) -let configure ?(apply=(fun () -> ())) () = +let configure ?(apply=(fun () -> ())) parent = let cmd_coqtop = string ~f:(fun s -> cmd_coqtop#set (if s = "AUTO" then None else Some s)) @@ -1068,7 +1068,7 @@ let configure ?(apply=(fun () -> ())) () = (* Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string current.text_font); *) - let x = edit ~apply "Customizations" cmds in + let x = edit ~apply "Customizations" ~parent cmds in (* Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string current.text_font); *) diff --git a/ide/preferences.mli b/ide/preferences.mli index dd2976efc2..7ed6a40bdb 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -107,7 +107,7 @@ val diffs : string preference val save_pref : unit -> unit val load_pref : unit -> unit -val configure : ?apply:(unit -> unit) -> unit -> unit +val configure : ?apply:(unit -> unit) -> GWindow.window -> unit val stick : 'a preference -> (#GObj.widget as 'obj) -> ('a -> unit) -> unit diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 838ef40545..70ce6cef19 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -716,20 +716,20 @@ let rec flatten_application c = match DAst.get c with (* one with no delimiter if possible) *) let extern_possible_prim_token (custom,scopes) r = - try - let (sc,n) = uninterp_prim_token r in - match availability_of_entry_coercion custom InConstrEntrySomeLevel with - | None -> raise No_match - | Some coercion -> - match availability_of_prim_token n sc scopes with - | None -> None - | Some key -> Some (insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key)) - with No_match -> - None - -let extern_optimal_prim_token scopes r r' = - let c = extern_possible_prim_token scopes r in - let c' = if r==r' then None else extern_possible_prim_token scopes r' in + let (sc,n) = uninterp_prim_token r in + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> + match availability_of_prim_token n sc scopes with + | None -> raise No_match + | Some key -> insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) + +let extern_possible extern r = + try Some (extern r) with No_match -> None + +let extern_optimal extern r r' = + let c = extern_possible extern r in + let c' = if r==r' then None else extern_possible extern r' in match c,c' with | Some n, (Some ({ CAst.v = CDelimiters _}) | None) | _, Some n -> n | _ -> raise No_match @@ -769,12 +769,14 @@ let rec extern inctx scopes vars r = let r' = remove_coercions inctx r in try if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_optimal_prim_token scopes r r' + extern_optimal (extern_possible_prim_token scopes) r r' with No_match -> try let r'' = flatten_application r' in if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation scopes vars r'' (uninterp_notations r'') + extern_optimal + (fun r -> extern_notation scopes vars r (uninterp_notations r)) + r r'' with No_match -> let loc = r'.CAst.loc in match DAst.get r' with diff --git a/interp/declare.ml b/interp/declare.ml index 7a32018c0e..1e972d3e35 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -219,7 +219,7 @@ let cache_variable ((sp,_),o) = let (body, uctx), () = Future.force de.const_entry_body in let poly, univs = match de.const_entry_universes with | Monomorphic_const_entry uctx -> false, uctx - | Polymorphic_const_entry uctx -> true, Univ.ContextSet.of_context uctx + | Polymorphic_const_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx in let univs = Univ.ContextSet.union uctx univs in (** We must declare the universe constraints before type-checking the @@ -339,7 +339,7 @@ let infer_inductive_subtyping mind_ent = match mind_ent.mind_entry_universes with | Monomorphic_ind_entry _ | Polymorphic_ind_entry _ -> mind_ent - | Cumulative_ind_entry cumi -> + | Cumulative_ind_entry (_, cumi) -> begin let env = Global.env () in (* let (env'', typed_params) = Typeops.infer_local_decls env' (mind_ent.mind_entry_params) in *) @@ -358,27 +358,26 @@ let inInductive : mutual_inductive_entry -> obj = let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = let id = Label.to_id label in - let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in - Recordops.declare_primitive_projection p; - (* ^ needs to happen before declaring the constant, otherwise - Heads gets confused. *) let univs = match univs with | Monomorphic_ind_entry _ -> (** Global constraints already defined through the inductive *) Monomorphic_const_entry Univ.ContextSet.empty - | Polymorphic_ind_entry ctx -> - Polymorphic_const_entry ctx - | Cumulative_ind_entry ctx -> - Polymorphic_const_entry (Univ.CumulativityInfo.univ_context ctx) + | Polymorphic_ind_entry (nas, ctx) -> + Polymorphic_const_entry (nas, ctx) + | Cumulative_ind_entry (nas, ctx) -> + Polymorphic_const_entry (nas, Univ.CumulativityInfo.univ_context ctx) in let term, types = match univs with | Monomorphic_const_entry _ -> term, types - | Polymorphic_const_entry ctx -> + | Polymorphic_const_entry (_, ctx) -> let u = Univ.UContext.instance ctx in Vars.subst_instance_constr u term, Vars.subst_instance_constr u types in let entry = definition_entry ~types ~univs term in - ignore(declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent)) + let cst = declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent) in + let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in + Recordops.declare_primitive_projection p cst + let declare_projections univs mind = let env = Global.env () in @@ -473,36 +472,33 @@ type universe_source = type universe_name_decl = universe_source * (Id.t * Nametab.universe_id) list let check_exists sp = - let depth = sections_depth () in - let sp = Libnames.make_path (pop_dirpath_n depth (dirpath sp)) (basename sp) in if Nametab.exists_universe sp then alreadydeclared (str "Universe " ++ Id.print (basename sp) ++ str " already exists") else () -let qualify_univ i sp src id = - let open Libnames in +let qualify_univ i dp src id = match src with | BoundUniv | UnqualifiedUniv -> - let sp = dirpath sp in - i, make_path sp id + i, Libnames.make_path dp id | QualifiedUniv l -> - let sp = dirpath sp in - let sp = DirPath.repr sp in - Nametab.map_visibility succ i, make_path (DirPath.make (l::sp)) id + let dp = DirPath.repr dp in + Nametab.map_visibility succ i, Libnames.make_path (DirPath.make (l::dp)) id -let do_univ_name ~check i sp src (id,univ) = - let i, sp = qualify_univ i sp src id in +let do_univ_name ~check i dp src (id,univ) = + let i, sp = qualify_univ i dp src id in if check then check_exists sp; Nametab.push_universe i sp univ let cache_univ_names ((sp, _), (src, univs)) = - List.iter (do_univ_name ~check:true (Nametab.Until 1) sp src) univs + let depth = sections_depth () in + let dp = pop_dirpath_n depth (dirpath sp) in + List.iter (do_univ_name ~check:true (Nametab.Until 1) dp src) univs let load_univ_names i ((sp, _), (src, univs)) = - List.iter (do_univ_name ~check:false (Nametab.Until i) sp src) univs + List.iter (do_univ_name ~check:false (Nametab.Until i) (dirpath sp) src) univs let open_univ_names i ((sp, _), (src, univs)) = - List.iter (do_univ_name ~check:false (Nametab.Exactly i) sp src) univs + List.iter (do_univ_name ~check:false (Nametab.Exactly i) (dirpath sp) src) univs let discharge_univ_names = function | _, (BoundUniv, _) -> None @@ -520,12 +516,12 @@ let input_univ_names : universe_name_decl -> Libobject.obj = let declare_univ_binders gr pl = if Global.is_polymorphic gr then - UnivNames.register_universe_binders gr pl + () else let l = match gr with | ConstRef c -> Label.to_id @@ Constant.label c | IndRef (c, _) -> Label.to_id @@ MutInd.label c - | VarRef id -> id + | VarRef id -> anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") | ConstructRef _ -> anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on an constructor reference") diff --git a/interp/discharge.ml b/interp/discharge.ml index 21b2e85e8f..eeda5a6867 100644 --- a/interp/discharge.ml +++ b/interp/discharge.ml @@ -79,13 +79,15 @@ let process_inductive info modlist mib = | Monomorphic_ind ctx -> Univ.empty_level_subst, Monomorphic_ind_entry ctx | Polymorphic_ind auctx -> let subst, auctx = Lib.discharge_abstract_universe_context info auctx in + let nas = Univ.AUContext.names auctx in let auctx = Univ.AUContext.repr auctx in - subst, Polymorphic_ind_entry auctx + subst, Polymorphic_ind_entry (nas, auctx) | Cumulative_ind cumi -> let auctx = Univ.ACumulativityInfo.univ_context cumi in let subst, auctx = Lib.discharge_abstract_universe_context info auctx in + let nas = Univ.AUContext.names auctx in let auctx = Univ.AUContext.repr auctx in - subst, Cumulative_ind_entry (Univ.CumulativityInfo.from_universe_context auctx) + subst, Cumulative_ind_entry (nas, Univ.CumulativityInfo.from_universe_context auctx) in let discharge c = Vars.subst_univs_level_constr subst (expmod_constr modlist c) in let inds = diff --git a/interp/impargs.ml b/interp/impargs.ml index d8582d856e..d024a9e808 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -19,7 +19,6 @@ open Decl_kinds open Lib open Libobject open EConstr -open Termops open Reductionops open Constrexpr open Namegen @@ -200,16 +199,16 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc acc.(i) <- update pos rig acc.(i) | App (f,_) when rig && is_flexible_reference env sigma bound depth f -> if strict then () else - iter_constr_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders sigma push_lift (frec false) ed c | Proj (p,c) when rig -> if strict then () else - iter_constr_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders sigma push_lift (frec false) ed c | Case _ when rig -> if strict then () else - iter_constr_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders sigma push_lift (frec false) ed c | Evar _ -> () | _ -> - iter_constr_with_full_binders sigma push_lift (frec rig) ed c + iter_with_full_binders sigma push_lift (frec rig) ed c in let () = if not (Vars.noccur_between sigma 1 bound m) then frec true (env,1) m in acc diff --git a/interp/modintern.ml b/interp/modintern.ml index 51e27299e3..60056dfd90 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -107,8 +107,8 @@ let transl_with_decl env base kind = function let c, ectx = interp_constr env sigma c in let poly = lookup_polymorphism env base kind fqid in begin match UState.check_univ_decl ~poly ectx udecl with - | Entries.Polymorphic_const_entry ctx -> - let inst, ctx = Univ.abstract_universes ctx in + | Entries.Polymorphic_const_entry (nas, ctx) -> + let inst, ctx = Univ.abstract_universes nas ctx in let c = EConstr.Vars.subst_univs_level_constr (Univ.make_instance_subst inst) c in let c = EConstr.to_constr sigma c in WithDef (fqid,(c, Some ctx)), Univ.ContextSet.empty diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 95546a83e1..7e73609996 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -72,11 +72,8 @@ let with_stats c = end else Lazy.force c -let all_opaque = (Id.Pred.empty, Cpred.empty) -let all_transparent = (Id.Pred.full, Cpred.full) - -let is_transparent_variable (ids, _) id = Id.Pred.mem id ids -let is_transparent_constant (_, csts) cst = Cpred.mem cst csts +let all_opaque = TransparentState.empty +let all_transparent = TransparentState.full module type RedFlagsSig = sig type reds @@ -93,8 +90,8 @@ module type RedFlagsSig = sig val no_red : reds val red_add : reds -> red_kind -> reds val red_sub : reds -> red_kind -> reds - val red_add_transparent : reds -> transparent_state -> reds - val red_transparent : reds -> transparent_state + val red_add_transparent : reds -> TransparentState.t -> reds + val red_transparent : reds -> TransparentState.t val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool val red_projection : reds -> Projection.t -> bool @@ -106,11 +103,13 @@ module RedFlags = (struct (* [r_const=(false,cl)] means only those in [cl] *) (* [r_delta=true] just mean [r_const=(true,[])] *) + open TransparentState + type reds = { r_beta : bool; r_delta : bool; r_eta : bool; - r_const : transparent_state; + r_const : TransparentState.t; r_zeta : bool; r_match : bool; r_fix : bool; @@ -143,30 +142,30 @@ module RedFlags = (struct | ETA -> { red with r_eta = true } | DELTA -> { red with r_delta = true; r_const = all_transparent } | CONST kn -> - let (l1,l2) = red.r_const in - { red with r_const = l1, Cpred.add kn l2 } + let r = red.r_const in + { red with r_const = { r with tr_cst = Cpred.add kn r.tr_cst } } | MATCH -> { red with r_match = true } | FIX -> { red with r_fix = true } | COFIX -> { red with r_cofix = true } | ZETA -> { red with r_zeta = true } | VAR id -> - let (l1,l2) = red.r_const in - { red with r_const = Id.Pred.add id l1, l2 } + let r = red.r_const in + { red with r_const = { r with tr_var = Id.Pred.add id r.tr_var } } let red_sub red = function | BETA -> { red with r_beta = false } | ETA -> { red with r_eta = false } | DELTA -> { red with r_delta = false } | CONST kn -> - let (l1,l2) = red.r_const in - { red with r_const = l1, Cpred.remove kn l2 } + let r = red.r_const in + { red with r_const = { r with tr_cst = Cpred.remove kn r.tr_cst } } | MATCH -> { red with r_match = false } | FIX -> { red with r_fix = false } | COFIX -> { red with r_cofix = false } | ZETA -> { red with r_zeta = false } | VAR id -> - let (l1,l2) = red.r_const in - { red with r_const = Id.Pred.remove id l1, l2 } + let r = red.r_const in + { red with r_const = { r with tr_var = Id.Pred.remove id r.tr_var } } let red_transparent red = red.r_const @@ -179,12 +178,10 @@ module RedFlags = (struct | BETA -> incr_cnt red.r_beta beta | ETA -> incr_cnt red.r_eta eta | CONST kn -> - let (_,l) = red.r_const in - let c = Cpred.mem kn l in + let c = is_transparent_constant red.r_const kn in incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) - let (l,_) = red.r_const in - let c = Id.Pred.mem id l in + let c = is_transparent_variable red.r_const id in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | MATCH -> incr_cnt red.r_match nb_match diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 1ee4bccc25..b6c87b3732 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -24,14 +24,6 @@ val with_stats: 'a Lazy.t -> 'a Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) - - -val all_opaque : transparent_state -val all_transparent : transparent_state - -val is_transparent_variable : transparent_state -> variable -> bool -val is_transparent_constant : transparent_state -> Constant.t -> bool - (** Sets of reduction kinds. *) module type RedFlagsSig = sig type reds @@ -60,10 +52,10 @@ module type RedFlagsSig = sig val red_sub : reds -> red_kind -> reds (** Adds a reduction kind to a set *) - val red_add_transparent : reds -> transparent_state -> reds + val red_add_transparent : reds -> TransparentState.t -> reds (** Retrieve the transparent state of the reduction flags *) - val red_transparent : reds -> transparent_state + val red_transparent : reds -> TransparentState.t (** Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds diff --git a/kernel/constr.ml b/kernel/constr.ml index 704e6de6b8..8e5d15dd2d 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -452,27 +452,6 @@ let fold f acc c = match kind c with | CoFix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl -let fold_with_full_binders g f n acc c = - let open Context.Rel.Declaration in - match kind c with - | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ -> acc - | Cast (c,_, t) -> f n (f n acc c) t - | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c - | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c - | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c - | App (c,l) -> Array.fold_left (f n) (f n acc c) l - | Proj (_,c) -> f n acc c - | Evar (_,l) -> Array.fold_left (f n) acc l - | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl - | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl in - let fd = Array.map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl in - let fd = Array.map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - (* [iter f c] iters [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) @@ -534,12 +513,12 @@ let fold_constr_with_binders g f n acc c = | Proj (_p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl - | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in + | Fix (_,(_,tl,bl)) -> + let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in + | CoFix (_,(_,tl,bl)) -> + let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd @@ -799,6 +778,49 @@ let map_with_binders g f l c0 = match kind c0 with let bl' = Array.Fun1.Smart.map f l' bl in mkCoFix (ln,(lna,tl',bl')) +(*********************) +(* Lifting *) +(*********************) + +(* The generic lifting function *) +let rec exliftn el c = + let open Esubst in + match kind c with + | Rel i -> mkRel(reloc_rel i el) + | _ -> map_with_binders el_lift exliftn el c + +(* Lifting the binding depth across k bindings *) + +let liftn n k c = + let open Esubst in + match el_liftn (pred k) (el_shft n el_id) with + | ELID -> c + | el -> exliftn el c + +let lift n = liftn n 1 + +let fold_with_full_binders g f n acc c = + let open Context.Rel.Declaration in + match kind c with + | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ -> acc + | Cast (c,_, t) -> f n (f n acc c) t + | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c + | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (_,c) -> f n acc c + | Evar (_,l) -> Array.fold_left (f n) acc l + | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl + | Fix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | CoFix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + + type 'univs instance_compare_fn = GlobRef.t -> int -> 'univs -> 'univs -> bool diff --git a/kernel/constr.mli b/kernel/constr.mli index 1be1f63ff7..f2cedcdabb 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -383,6 +383,17 @@ type rel_context = rel_declaration list type named_context = named_declaration list type compacted_context = compacted_declaration list +(** {6 Relocation and substitution } *) + +(** [exliftn el c] lifts [c] with lifting [el] *) +val exliftn : Esubst.lift -> constr -> constr + +(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *) +val liftn : int -> int -> constr -> constr + +(** [lift n c] lifts by [n] the positive indexes in [c] *) +val lift : int -> constr -> constr + (** {6 Functionals working on expressions canonically abstracted over a local context (possibly with let-ins)} *) diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index ac78064235..fe82353b70 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -81,7 +81,8 @@ let fold_strategy f { var_opacity; cst_opacity; _ } accu = let accu = Id.Map.fold fvar var_opacity accu in Cmap.fold fcst cst_opacity accu -let get_transp_state { var_trstate; cst_trstate; _ } = (var_trstate, cst_trstate) +let get_transp_state { var_trstate; cst_trstate; _ } = + { TransparentState.tr_var = var_trstate; tr_cst = cst_trstate } let dep_order l2r k1 k2 = match k1, k2 with | RelKey _, RelKey _ -> l2r diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 67add5dd35..bc06cc21b6 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -41,5 +41,5 @@ val set_strategy : oracle -> Constant.t tableKey -> level -> oracle (** Fold over the non-transparent levels of the oracle. Order unspecified. *) val fold_strategy : (Constant.t tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a -val get_transp_state : oracle -> transparent_state +val get_transp_state : oracle -> TransparentState.t diff --git a/kernel/entries.ml b/kernel/entries.ml index c5bcd74072..58bb782f15 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -30,8 +30,8 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1]; type inductive_universes = | Monomorphic_ind_entry of Univ.ContextSet.t - | Polymorphic_ind_entry of Univ.UContext.t - | Cumulative_ind_entry of Univ.CumulativityInfo.t + | Polymorphic_ind_entry of Name.t array * Univ.UContext.t + | Cumulative_ind_entry of Name.t array * Univ.CumulativityInfo.t type one_inductive_entry = { mind_entry_typename : Id.t; @@ -60,7 +60,7 @@ type 'a const_entry_body = 'a proof_output Future.computation type constant_universes_entry = | Monomorphic_const_entry of Univ.ContextSet.t - | Polymorphic_const_entry of Univ.UContext.t + | Polymorphic_const_entry of Name.t array * Univ.UContext.t type 'a in_constant_universes_entry = 'a * constant_universes_entry diff --git a/kernel/environ.ml b/kernel/environ.ml index f61dd0c101..019c0a6819 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -384,8 +384,26 @@ let set_engagement c env = (* Unsafe *) { env with env_stratification = { env.env_stratification with env_engagement = c } } +(* It's convenient to use [{flags with foo = bar}] so we're smart wrt to it. *) +let same_flags { + check_guarded; + check_universes; + conv_oracle; + share_reduction; + enable_VM; + enable_native_compiler; + } alt = + check_guarded == alt.check_guarded && + check_universes == alt.check_universes && + conv_oracle == alt.conv_oracle && + share_reduction == alt.share_reduction && + enable_VM == alt.enable_VM && + enable_native_compiler == alt.enable_native_compiler +[@warning "+9"] + let set_typing_flags c env = (* Unsafe *) - { env with env_typing_flags = c } + if same_flags env.env_typing_flags c then env + else { env with env_typing_flags = c } (* Global constants *) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 0346026aa4..20c90bc05a 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -268,8 +268,8 @@ let typecheck_inductive env mie = let env' = match mie.mind_entry_universes with | Monomorphic_ind_entry ctx -> push_context_set ctx env - | Polymorphic_ind_entry ctx -> push_context ctx env - | Cumulative_ind_entry cumi -> push_context (Univ.CumulativityInfo.univ_context cumi) env + | Polymorphic_ind_entry (_, ctx) -> push_context ctx env + | Cumulative_ind_entry (_, cumi) -> push_context (Univ.CumulativityInfo.univ_context cumi) env in let env_params = check_context env' mie.mind_entry_params in let paramsctxt = mie.mind_entry_params in @@ -407,7 +407,7 @@ let typecheck_inductive env mie = match mie.mind_entry_universes with | Monomorphic_ind_entry _ -> () | Polymorphic_ind_entry _ -> () - | Cumulative_ind_entry cumi -> check_subtyping cumi paramsctxt env_arities inds + | Cumulative_ind_entry (_, cumi) -> check_subtyping cumi paramsctxt env_arities inds in (env_arities, env_ar_par, paramsctxt, inds) (************************************************************************) @@ -851,12 +851,12 @@ let compute_projections (kn, i as ind) mib = let abstract_inductive_universes iu = match iu with | Monomorphic_ind_entry ctx -> (Univ.empty_level_subst, Monomorphic_ind ctx) - | Polymorphic_ind_entry ctx -> - let (inst, auctx) = Univ.abstract_universes ctx in + | Polymorphic_ind_entry (nas, ctx) -> + let (inst, auctx) = Univ.abstract_universes nas ctx in let inst = Univ.make_instance_subst inst in (inst, Polymorphic_ind auctx) - | Cumulative_ind_entry cumi -> - let (inst, acumi) = Univ.abstract_cumulativity_info cumi in + | Cumulative_ind_entry (nas, cumi) -> + let (inst, acumi) = Univ.abstract_cumulativity_info nas cumi in let inst = Univ.make_instance_subst inst in (inst, Cumulative_ind acumi) diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index a18c5d1e20..54c239349d 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -1,4 +1,5 @@ Names +TransparentState Uint31 Univ UGraph diff --git a/kernel/modops.ml b/kernel/modops.ml index bab2eae3df..0dde1c7e75 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -47,10 +47,9 @@ type signature_mismatch_error = | RecordFieldExpected of bool | RecordProjectionsExpected of Name.t list | NotEqualInductiveAliases - | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.AUContext.t + | IncompatibleConstraints of { got : Univ.AUContext.t; expect : Univ.AUContext.t } type module_typing_error = | SignatureMismatch of diff --git a/kernel/modops.mli b/kernel/modops.mli index 8e7e618fcd..0acd09fb12 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -106,10 +106,9 @@ type signature_mismatch_error = | RecordFieldExpected of bool | RecordProjectionsExpected of Name.t list | NotEqualInductiveAliases - | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.AUContext.t + | IncompatibleConstraints of { got : Univ.AUContext.t; expect : Univ.AUContext.t } type module_typing_error = | SignatureMismatch of diff --git a/kernel/names.ml b/kernel/names.ml index 18560d5f8d..b2d6a489a6 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -715,13 +715,6 @@ let hcons_construct = Hashcons.simple_hcons Hconstruct.generate Hconstruct.hcons (*****************) -type transparent_state = Id.Pred.t * Cpred.t - -let empty_transparent_state = (Id.Pred.empty, Cpred.empty) -let full_transparent_state = (Id.Pred.full, Cpred.full) -let var_full_transparent_state = (Id.Pred.full, Cpred.empty) -let cst_full_transparent_state = (Id.Pred.empty, Cpred.full) - type 'a tableKey = | ConstKey of 'a | VarKey of Id.t diff --git a/kernel/names.mli b/kernel/names.mli index 98995752a2..350db871d5 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -510,14 +510,6 @@ type 'a tableKey = | VarKey of Id.t | RelKey of Int.t -(** Sets of names *) -type transparent_state = Id.Pred.t * Cpred.t - -val empty_transparent_state : transparent_state -val full_transparent_state : transparent_state -val var_full_transparent_state : transparent_state -val cst_full_transparent_state : transparent_state - type inv_rel_key = int (** index in the [rel_context] part of environment starting by the end, {e inverse} of de Bruijn indice *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 5515ff9767..fbb481424f 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -177,7 +177,7 @@ type 'a kernel_conversion_function = env -> 'a -> 'a -> unit (* functions of this type can be called from outside the kernel *) type 'a extended_conversion_function = - ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?l2r:bool -> ?reds:TransparentState.t -> env -> ?evars:((existential->constr option) * UGraph.t) -> 'a -> 'a -> unit @@ -758,7 +758,7 @@ let gen_conv cv_pb l2r reds env evars univs t1 t2 = () (* Profiling *) -let gen_conv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = +let gen_conv cv_pb ?(l2r=false) ?(reds=TransparentState.full) env ?(evars=(fun _->None), universes env) = let evars, univs = evars in if Flags.profile then let fconv_universes_key = CProfile.declare_profile "trans_fconv_universes" in @@ -792,11 +792,11 @@ let infer_conv_universes = CProfile.profile8 infer_conv_universes_key infer_conv_universes else infer_conv_universes -let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) +let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) env univs t1 t2 = infer_conv_universes CONV l2r evars ts env univs t1 t2 -let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) +let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 581e8bd88a..0408dbf057 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -31,7 +31,7 @@ exception NotConvertibleVect of int type 'a kernel_conversion_function = env -> 'a -> 'a -> unit type 'a extended_conversion_function = - ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?l2r:bool -> ?reds:TransparentState.t -> env -> ?evars:((existential->constr option) * UGraph.t) -> 'a -> 'a -> unit @@ -77,15 +77,15 @@ val conv_leq : types extended_conversion_function (** These conversion functions are used by module subtyping, which needs to infer universe constraints inside the kernel *) val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> - ?ts:Names.transparent_state -> constr infer_conversion_function + ?ts:TransparentState.t -> constr infer_conversion_function val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> - ?ts:Names.transparent_state -> types infer_conversion_function + ?ts:TransparentState.t -> types infer_conversion_function (** Depending on the universe state functions, this might raise [UniverseInconsistency] in addition to [NotConvertible] (for better error messages). *) val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> - Names.transparent_state -> (constr,'a) generic_conversion_function + TransparentState.t -> (constr,'a) generic_conversion_function val default_conv : conv_pb -> ?l2r:bool -> types kernel_conversion_function val default_conv_leq : ?l2r:bool -> types kernel_conversion_function diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 8b11851bbb..83d890b628 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -192,7 +192,9 @@ let set_engagement c senv = engagement = Some c } let set_typing_flags c senv = - { senv with env = Environ.set_typing_flags c senv.env } + let env = Environ.set_typing_flags c senv.env in + if env == senv.env then senv + else { senv with env } let set_share_reduction b senv = let flags = Environ.typing_flags senv.env in @@ -496,7 +498,7 @@ type generic_name = | M (** name already known, cf the mod_mp field *) | MT (** name already known, cf the mod_mp field *) -let add_field ((l,sfb) as field) gn senv = +let add_field ?(is_include=false) ((l,sfb) as field) gn senv = let mlabs,olabs = match sfb with | SFBmind mib -> let l = labels_of_mib mib in @@ -506,8 +508,18 @@ let add_field ((l,sfb) as field) gn senv = | SFBmodule _ | SFBmodtype _ -> check_modlabel l senv; (Label.Set.singleton l, Label.Set.empty) in - let cst = constraints_of_sfb senv.env sfb in - let senv = add_constraints_list cst senv in + let senv = + if is_include then + (* Universes and constraints were added when the included module + was defined eg in [Include F X.] (one of the trickier + versions of Include) the constraints on the fields are + exactly those of the fields of F which was defined + separately. *) + senv + else + let cst = constraints_of_sfb senv.env sfb in + add_constraints_list cst senv + in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env @@ -682,7 +694,7 @@ let constant_entry_of_side_effect cb u = | Monomorphic_const uctx -> Monomorphic_const_entry uctx | Polymorphic_const auctx -> - Polymorphic_const_entry (Univ.AUContext.repr auctx) + Polymorphic_const_entry (Univ.AUContext.names auctx, Univ.AUContext.repr auctx) in let pt = match cb.const_body, u with @@ -1047,7 +1059,7 @@ let add_include me is_module inl senv = | SFBmodule _ -> M | SFBmodtype _ -> MT in - add_field field new_name senv + add_field ~is_include:true field new_name senv in resolver, List.fold_left add senv str diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index d64342dbb0..347c30dd64 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -93,10 +93,8 @@ let check_conv_error error why cst poly f env a1 a2 = | Univ.UniverseInconsistency e -> error (IncompatibleUniverses e) let check_polymorphic_instance error env auctx1 auctx2 = - if not (Univ.AUContext.size auctx1 == Univ.AUContext.size auctx2) then - error IncompatibleInstances - else if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then - error (IncompatibleConstraints auctx1) + if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then + error (IncompatibleConstraints { got = auctx1; expect = auctx2; } ) else Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index fb1b3e236c..35fa871b4e 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -68,8 +68,8 @@ let feedback_completion_typecheck = let abstract_constant_universes = function | Monomorphic_const_entry uctx -> Univ.empty_level_subst, Monomorphic_const uctx - | Polymorphic_const_entry uctx -> - let sbst, auctx = Univ.abstract_universes uctx in + | Polymorphic_const_entry (nas, uctx) -> + let sbst, auctx = Univ.abstract_universes nas uctx in let sbst = Univ.make_instance_subst sbst in sbst, Polymorphic_const auctx @@ -78,7 +78,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = | ParameterEntry (ctx,(t,uctx),nl) -> let env = match uctx with | Monomorphic_const_entry uctx -> push_context_set ~strict:true uctx env - | Polymorphic_const_entry uctx -> push_context ~strict:false uctx env + | Polymorphic_const_entry (_, uctx) -> push_context ~strict:false uctx env in let j = infer env t in let usubst, univs = abstract_constant_universes uctx in @@ -150,7 +150,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let ctx = Univ.ContextSet.union univs ctx in let env = push_context_set ~strict:true ctx env in env, Univ.empty_level_subst, Monomorphic_const ctx - | Polymorphic_const_entry uctx -> + | Polymorphic_const_entry (nas, uctx) -> (** Ensure not to generate internal constraints in polymorphic mode. The only way for this to happen would be that either the body contained deferred universes, or that it contains monomorphic @@ -160,7 +160,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = i.e. [trust] is always [Pure]. *) let () = assert (Univ.ContextSet.is_empty ctx) in let env = push_context ~strict:false uctx env in - let sbst, auctx = Univ.abstract_universes uctx in + let sbst, auctx = Univ.abstract_universes nas uctx in let sbst = Univ.make_instance_subst sbst in env, sbst, Polymorphic_const auctx in diff --git a/kernel/transparentState.ml b/kernel/transparentState.ml new file mode 100644 index 0000000000..9661dace6a --- /dev/null +++ b/kernel/transparentState.ml @@ -0,0 +1,45 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +open Names + +type t = { + tr_var : Id.Pred.t; + tr_cst : Cpred.t; +} + +let empty = { + tr_var = Id.Pred.empty; + tr_cst = Cpred.empty; +} + +let full = { + tr_var = Id.Pred.full; + tr_cst = Cpred.full; +} + +let var_full = { + tr_var = Id.Pred.full; + tr_cst = Cpred.empty; +} + +let cst_full = { + tr_var = Id.Pred.empty; + tr_cst = Cpred.full; +} + +let is_empty ts = + Id.Pred.is_empty ts.tr_var && Cpred.is_empty ts.tr_cst + +let is_transparent_variable ts id = + Id.Pred.mem id ts.tr_var + +let is_transparent_constant ts cst = + Cpred.mem cst ts.tr_cst diff --git a/proofs/proof_type.ml b/kernel/transparentState.mli index 149f30c673..f2999c6869 100644 --- a/proofs/proof_type.ml +++ b/kernel/transparentState.mli @@ -8,21 +8,27 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Legacy proof engine. Do not use in newly written code. *) +open Names -open Evd -open Constr +(** Sets of names *) +type t = { + tr_var : Id.Pred.t; + tr_cst : Cpred.t; +} -(** This module defines the structure of proof tree and the tactic type. So, it - is used by [Proof_tree] and [Refiner] *) +val empty : t +(** Everything opaque *) -type prim_rule = - | Refine of constr +val full : t +(** Everything transparent *) -(** Nowadays, the only rules we'll consider are the primitive rules *) +val var_full : t +(** All variables transparent *) -type rule = prim_rule +val cst_full : t +(** All constant transparent *) -type goal = Goal.goal +val is_empty : t -> bool -type tactic = goal sigma -> goal list sigma +val is_transparent_variable : t -> Id.t -> bool +val is_transparent_constant : t -> Constant.t -> bool diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 9ff51fca55..9083156745 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -942,34 +942,36 @@ let check_eq_instances g t1 t2 = (** 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_sequence (fun (v, strict) -> + (pr_umap Pp.spc (fun (v, strict) -> (if strict then str "< " else str "<= ") ++ prl v) - (UMap.bindings ltle)) ++ + ltle) ++ fnl () | u, Equiv v -> prl u ++ str " = " ++ prl v ++ fnl () let pr_universes prl g = - let graph = UMap.fold (fun u a l -> (u,a)::l) g.entries [] in - prlist (pr_arc prl) graph + 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; _} -> - let u_str = Level.to_string u in UMap.iter (fun v strict -> let typ = if strict then Lt else Le in - output typ u_str (Level.to_string v)) ltle; + output typ u v) ltle; | Equiv v -> - output Eq (Level.to_string u) (Level.to_string v) + output Eq u v in UMap.iter dump_arc g.entries diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 4336a22b8c..a2cc5b3116 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -86,7 +86,7 @@ val check_subtype : AUContext.t check_function (** {6 Dumping to a file } *) val dump_universes : - (constraint_type -> string -> string -> unit) -> t -> unit + (constraint_type -> Level.t -> Level.t -> unit) -> t -> unit (** {6 Debugging} *) val check_universes_invariants : t -> unit diff --git a/kernel/univ.ml b/kernel/univ.ml index d09b54e7ec..2b3b4f9486 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -570,9 +570,9 @@ struct include S let pr prl c = - fold (fun (u1,op,u2) pp_std -> - pp_std ++ prl u1 ++ pr_constraint_type op ++ - prl u2 ++ fnl () ) c (str "") + v 0 (prlist_with_sep spc (fun (u1,op,u2) -> + hov 0 (prl u1 ++ pr_constraint_type op ++ prl u2)) + (elements c)) end @@ -937,17 +937,30 @@ let hcons_universe_context = UContext.hcons module AUContext = struct - include UContext + type t = Names.Name.t array constrained let repr (inst, cst) = - (Array.mapi (fun i _l -> Level.var i) inst, cst) + (Array.init (Array.length inst) (fun i -> Level.var i), cst) - let pr f ?variance ctx = pr f ?variance (repr ctx) + let pr f ?variance ctx = UContext.pr f ?variance (repr ctx) let instantiate inst (u, cst) = assert (Array.length u = Array.length inst); subst_instance_constraints inst cst + let names (nas, _) = nas + + let hcons (univs, cst) = + (Array.map Names.Name.hcons univs, hcons_constraints cst) + + let empty = ([||], Constraint.empty) + + let is_empty (nas, cst) = Array.is_empty nas && Constraint.is_empty cst + + let union (nas, cst) (nas', cst') = (Array.append nas nas', Constraint.union cst cst') + + let size (nas, _) = Array.length nas + end let hcons_abstract_universe_context = AUContext.hcons @@ -993,7 +1006,22 @@ end let hcons_cumulativity_info = CumulativityInfo.hcons -module ACumulativityInfo = CumulativityInfo +module ACumulativityInfo = +struct + type t = AUContext.t * Variance.t array + + let pr prl (univs, variance) = + AUContext.pr prl ~variance univs + + let hcons (univs, variance) = (* should variance be hconsed? *) + (AUContext.hcons univs, variance) + + let univ_context (univs, _subtypcst) = univs + let variance (_univs, variance) = variance + + let leq_constraints (_,variance) u u' csts = Variance.leq_constraints variance u u' csts + let eq_constraints (_,variance) u u' csts = Variance.eq_constraints variance u u' csts +end let hcons_abstract_cumulativity_info = ACumulativityInfo.hcons @@ -1145,19 +1173,20 @@ let make_inverse_instance_subst i = LMap.empty arr let make_abstract_instance (ctx, _) = - Array.mapi (fun i _l -> Level.var i) ctx + Array.init (Array.length ctx) (fun i -> Level.var i) -let abstract_universes ctx = +let abstract_universes nas ctx = let instance = UContext.instance ctx in + let () = assert (Int.equal (Array.length nas) (Instance.length instance)) in let subst = make_instance_subst instance in let cstrs = subst_univs_level_constraints subst (UContext.constraints ctx) in - let ctx = UContext.make (instance, cstrs) in + let ctx = (nas, cstrs) in instance, ctx -let abstract_cumulativity_info (univs, variance) = - let subst, univs = abstract_universes univs in +let abstract_cumulativity_info nas (univs, variance) = + let subst, univs = abstract_universes nas univs in subst, (univs, variance) let rec compact_univ s vars i u = diff --git a/kernel/univ.mli b/kernel/univ.mli index 7ac8247ca4..de7b334ae4 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -336,9 +336,6 @@ sig val empty : t val is_empty : t -> bool - (** Don't use. *) - val instance : t -> Instance.t - val size : t -> int (** Keeps the order of the instances *) @@ -347,6 +344,9 @@ sig val instantiate : Instance.t -> t -> Constraint.t (** Generate the set of instantiated Constraint.t **) + val names : t -> Names.Name.t array + (** Return the names of the bound universe variables *) + end (** Universe info for cumulative inductive types: A context of @@ -466,8 +466,8 @@ val make_instance_subst : Instance.t -> universe_level_subst val make_inverse_instance_subst : Instance.t -> universe_level_subst -val abstract_universes : UContext.t -> Instance.t * AUContext.t -val abstract_cumulativity_info : CumulativityInfo.t -> Instance.t * ACumulativityInfo.t +val abstract_universes : Names.Name.t array -> UContext.t -> Instance.t * AUContext.t +val abstract_cumulativity_info : Names.Name.t array -> CumulativityInfo.t -> Instance.t * ACumulativityInfo.t (** TODO: move universe abstraction out of the kernel *) val make_abstract_instance : AUContext.t -> Instance.t diff --git a/kernel/vars.ml b/kernel/vars.ml index 7380a860dd..f9c576ca4a 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Esubst module RelDecl = Context.Rel.Declaration @@ -80,19 +79,9 @@ let noccur_with_meta n m term = (* Lifting *) (*********************) -(* The generic lifting function *) -let rec exliftn el c = match Constr.kind c with - | Constr.Rel i -> Constr.mkRel(reloc_rel i el) - | _ -> Constr.map_with_binders el_lift exliftn el c - -(* Lifting the binding depth across k bindings *) - -let liftn n k c = - match el_liftn (pred k) (el_shft n el_id) with - | ELID -> c - | el -> exliftn el c - -let lift n = liftn n 1 +let exliftn = Constr.exliftn +let liftn = Constr.liftn +let lift = Constr.lift (*********************) (* Substituting *) diff --git a/kernel/vconv.ml b/kernel/vconv.ml index c1130e62c9..246c90c09d 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -191,7 +191,7 @@ let warn_bytecode_compiler_failed = let vm_conv_gen cv_pb env univs t1 t2 = if not (typing_flags env).Declarations.enable_VM then Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) - full_transparent_state env univs t1 t2 + TransparentState.full env univs t1 t2 else try let v1 = val_of_constr env t1 in @@ -200,7 +200,7 @@ let vm_conv_gen cv_pb env univs t1 t2 = with Not_found | Invalid_argument _ -> warn_bytecode_compiler_failed (); Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) - full_transparent_state env univs t1 t2 + TransparentState.full env univs t1 t2 let vm_conv cv_pb env t1 t2 = let univs = Environ.universes env in diff --git a/lib/coqProject_file.ml b/lib/coqProject_file.ml index d0b01453a0..868042303d 100644 --- a/lib/coqProject_file.ml +++ b/lib/coqProject_file.ml @@ -12,10 +12,6 @@ ideally we would like to make this independent so it can be bootstrapped. *) -(* Note the problem with the error invokation below calling exit... *) -(* let error msg = Feedback.msg_error msg *) -let warning msg = Feedback.msg_warning Pp.(str msg) - type arg_source = CmdLine | ProjectFile type 'a sourced = { thing : 'a; source : arg_source } @@ -147,7 +143,7 @@ let exists_dir dir = try Sys.is_directory (strip_trailing_slash dir) with Sys_error _ -> false -let process_cmd_line orig_dir proj args = +let process_cmd_line ~warning_fn orig_dir proj args = let parsing_project_file = ref (proj.project_file <> None) in let sourced x = { thing = x; source = if !parsing_project_file then ProjectFile else CmdLine } in let orig_dir = (* avoids turning foo.v in ./foo.v *) @@ -170,7 +166,7 @@ let process_cmd_line orig_dir proj args = | ("-full"|"-opt") :: r -> aux { proj with use_ocamlopt = true } r | "-install" :: d :: r -> if proj.install_kind <> None then - (warning "-install set more than once.@\n%!"); + (warning_fn "-install set more than once."); let install = match d with | "user" -> UserInstall | "none" -> NoInstall @@ -197,7 +193,7 @@ let process_cmd_line orig_dir proj args = let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in let () = match proj.project_file with | None -> () - | Some _ -> warning "Multiple project files are deprecated.@\n%!" + | Some _ -> warning_fn "Multiple project files are deprecated." in parsing_project_file := true; let proj = aux { proj with project_file = Some file } (parse file) in @@ -220,7 +216,7 @@ let process_cmd_line orig_dir proj args = let f = CUnix.correct_path f orig_dir in let proj = if exists_dir f then { proj with subdirs = proj.subdirs @ [sourced f] } - else match CUnix.get_extension f with + else match Filename.extension f with | ".v" -> { proj with v_files = proj.v_files @ [sourced f] } | ".ml" -> { proj with ml_files = proj.ml_files @ [sourced f] } @@ -236,11 +232,11 @@ let process_cmd_line orig_dir proj args = (******************************* API ************************************) -let cmdline_args_to_project ~curdir args = - process_cmd_line curdir (mk_project None None None true) args +let cmdline_args_to_project ~warning_fn ~curdir args = + process_cmd_line ~warning_fn curdir (mk_project None None None true) args -let read_project_file f = - process_cmd_line (Filename.dirname f) +let read_project_file ~warning_fn f = + process_cmd_line ~warning_fn (Filename.dirname f) (mk_project (Some f) None (Some NoInstall) true) (parse f) let rec find_project_file ~from ~projfile_name = diff --git a/lib/coqProject_file.mli b/lib/coqProject_file.mli index 2a6a09a9a0..20b276ce8c 100644 --- a/lib/coqProject_file.mli +++ b/lib/coqProject_file.mli @@ -51,8 +51,8 @@ and install = | TraditionalInstall | UserInstall -val cmdline_args_to_project : curdir:string -> string list -> project -val read_project_file : string -> project +val cmdline_args_to_project : warning_fn:(string -> unit) -> curdir:string -> string list -> project +val read_project_file : warning_fn:(string -> unit) -> string -> project val coqtop_args_from_project : project -> string list val find_project_file : from:string -> projfile_name:string -> string option diff --git a/lib/envars.ml b/lib/envars.ml index 724a3dddc7..b5036e7340 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -177,10 +177,6 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = fprintf f "%sCOQLIB=%s/\n" prefix_var_name (coqlib ()); fprintf f "%sDOCDIR=%s/\n" prefix_var_name (docdir ()); fprintf f "%sOCAMLFIND=%s\n" prefix_var_name (ocamlfind ()); - fprintf f "%sCAMLP5O=%s\n" prefix_var_name Coq_config.camlp5o; - fprintf f "%sCAMLP5BIN=%s/\n" prefix_var_name Coq_config.camlp5bin; - fprintf f "%sCAMLP5LIB=%s\n" prefix_var_name Coq_config.camlp5lib; - fprintf f "%sCAMLP5OPTIONS=%s\n" prefix_var_name Coq_config.camlp5compat; fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name (if Coq_config.has_natdynlink then "true" else "false"); diff --git a/lib/flags.ml b/lib/flags.ml index 582506f3a8..3aef5a7b2c 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -99,10 +99,6 @@ let verbosely f x = without_option quiet f x let if_silent f x = if !quiet then f x let if_verbose f x = if not !quiet then f x -let auto_intros = ref true -let make_auto_intros flag = auto_intros := flag -let is_auto_intros () = !auto_intros - let polymorphic_inductive_cumulativity = ref false let make_polymorphic_inductive_cumulativity b = polymorphic_inductive_cumulativity := b let is_polymorphic_inductive_cumulativity () = !polymorphic_inductive_cumulativity diff --git a/lib/flags.mli b/lib/flags.mli index b667235678..e282d4ca8c 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -78,9 +78,6 @@ val if_silent : ('a -> unit) -> 'a -> unit val if_verbose : ('a -> unit) -> 'a -> unit (* Miscellaneus flags for vernac *) -val make_auto_intros : bool -> unit -val is_auto_intros : unit -> bool - val program_mode : bool ref val is_program_mode : unit -> bool diff --git a/lib/pp_diff.ml b/lib/pp_diff.ml index 7b4b1eab73..a485bf31c0 100644 --- a/lib/pp_diff.ml +++ b/lib/pp_diff.ml @@ -86,7 +86,7 @@ let shorten_diff_span dtype diff_list = if (get_variant !src) = dtype then begin if (lt !dst !src) then dst := !src; - while (lt !dst len) && (get_variant !dst) <> `Common do + while (lt !dst len) && (get_variant !dst) = dtype do dst := !dst + incr; done; if (lt !dst len) && (get_str !src) = (get_str !dst) then begin diff --git a/library/goptions.ml b/library/goptions.ml index dcbc46ab72..154b863fa1 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -73,7 +73,7 @@ module MakeTable = let _ = if String.List.mem_assoc nick !A.table then - user_err Pp.(str "Sorry, this table name is already used.") + user_err Pp.(str "Sorry, this table name (" ++ str nick ++ str ") is already used.") module MySet = Set.Make (struct type t = A.t let compare = A.compare end) @@ -216,11 +216,11 @@ let get_option key = OptionMap.find key !value_tab let check_key key = try let _ = get_option key in - user_err Pp.(str "Sorry, this option name is already used.") + user_err Pp.(str "Sorry, this option name ("++ str (nickname key) ++ str ") is already used.") with Not_found -> if String.List.mem_assoc (nickname key) !string_table || String.List.mem_assoc (nickname key) !ref_table - then user_err Pp.(str "Sorry, this option name is already used.") + then user_err Pp.(str "Sorry, this option name (" ++ str (nickname key) ++ str ") is already used.") open Libobject diff --git a/library/lib.ml b/library/lib.ml index 690a4fd53d..9c13cdafdb 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -479,7 +479,24 @@ let instance_from_variable_context = let named_of_variable_context = List.map fst - + +let name_instance inst = + (** FIXME: this should probably be done at an upper level, by storing the + name information in the section data structure. *) + let map lvl = match Univ.Level.name lvl with + | None -> (* Having Prop/Set/Var as section universes makes no sense *) + assert false + | Some na -> + try + let qid = Nametab.shortest_qualid_of_universe na in + Name (Libnames.qualid_basename qid) + with Not_found -> + (** Best-effort naming from the string representation of the level. + See univNames.ml for a similar hack. *) + Name (Id.of_string_soft (Univ.Level.to_string lvl)) + in + Array.map map (Univ.Instance.to_array inst) + let add_section_replacement f g poly hyps = match !sectab with | [] -> () @@ -488,7 +505,8 @@ let add_section_replacement f g poly hyps = let sechyps,ctx = extract_hyps (vars,hyps) in let ctx = Univ.ContextSet.to_context ctx in let inst = Univ.UContext.instance ctx in - let subst, ctx = Univ.abstract_universes ctx in + let nas = name_instance inst in + let subst, ctx = Univ.abstract_universes nas ctx in let args = instance_from_variable_context (List.rev sechyps) in let info = { abstr_ctx = sechyps; diff --git a/library/library.ml b/library/library.ml index 0ff82d7cc4..9b9bd07c93 100644 --- a/library/library.ml +++ b/library/library.ml @@ -611,28 +611,6 @@ let import_module export modl = (************************************************************************) (*s Initializing the compilation of a library. *) -let check_coq_overwriting p id = - let l = DirPath.repr p in - let is_empty = match l with [] -> true | _ -> false in - if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then - user_err - (str "Cannot build module " ++ DirPath.print p ++ str "." ++ Id.print id ++ str "." ++ spc () ++ - str "it starts with prefix \"Coq\" which is reserved for the Coq library.") - -let start_library fo = - let ldir0 = - try - let lp = Loadpath.find_load_path (Filename.dirname fo) in - Loadpath.logical lp - with Not_found -> Libnames.default_root_prefix - in - let file = Filename.chop_extension (Filename.basename fo) in - let id = Id.of_string file in - check_coq_overwriting ldir0 id; - let ldir = add_dirpath_suffix ldir0 id in - Declaremods.start_library ldir; - ldir - let load_library_todo f = let longf = Loadpath.locate_file (f^".v") in let f = longf^"io" in diff --git a/library/library.mli b/library/library.mli index d5815afc40..d298a371b5 100644 --- a/library/library.mli +++ b/library/library.mli @@ -38,11 +38,6 @@ type seg_proofs = Constr.constr Future.computation array an export otherwise just a simple import *) val import_module : bool -> qualid list -> unit -(** Start the compilation of a file as a library. The first argument must be - output file, and the - returned path is the associated absolute logical path of the library. *) -val start_library : CUnix.physical_path -> DirPath.t - (** End the compilation of a library and save it to a ".vo" file *) val save_library_to : ?todo:(((Future.UUID.t,'document) Stateid.request * bool) list * 'counters) -> diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index 619718f723..d81ee475b5 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -11,6 +11,7 @@ open Pp open Util open Tok +open Gramlib (** Location utilities *) let ploc_file_of_coq_file = function diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index e4aa8debc1..c0ebdd45ef 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -40,7 +40,7 @@ where tok_text : pattern -> string; tok_comm : mutable option (list location) } *) -include Grammar.GLexerType with type te = Tok.t +include Gramlib.Grammar.GLexerType with type te = Tok.t module Error : sig type t diff --git a/parsing/dune b/parsing/dune index 0669e3a3c2..e91740650f 100644 --- a/parsing/dune +++ b/parsing/dune @@ -2,7 +2,6 @@ (name parsing) (public_name coq.parsing) (wrapped false) - (flags :standard -open Gramlib) (libraries coq.gramlib proofs)) (rule diff --git a/parsing/extend.ml b/parsing/extend.ml index 6fe2956643..5caeab535a 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -10,7 +10,7 @@ (** Entry keys for constr notations *) -type 'a entry = 'a Grammar.GMake(CLexer).Entry.e +type 'a entry = 'a Gramlib.Grammar.GMake(CLexer).Entry.e type side = Left | Right diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index e25f7aa54f..b3ae24e941 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -81,7 +81,7 @@ let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) let lpar_id_coloneq = - Gram.Entry.of_parser "test_lpar_id_coloneq" + Pcoq.Entry.of_parser "test_lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -96,7 +96,7 @@ let lpar_id_coloneq = | _ -> err ()) let impl_ident_head = - Gram.Entry.of_parser "impl_ident_head" + Pcoq.Entry.of_parser "impl_ident_head" (fun strm -> match stream_nth 0 strm with | KEYWORD "{" -> @@ -109,7 +109,7 @@ let impl_ident_head = | _ -> err ()) let name_colon = - Gram.Entry.of_parser "name_colon" + Pcoq.Entry.of_parser "name_colon" (fun strm -> match stream_nth 0 strm with | IDENT s -> diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index dfb788907e..6247a12640 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -13,7 +13,6 @@ open Names open Libnames -open Pcoq open Pcoq.Prim let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"] diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index eb3e633892..170df6ad09 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -12,8 +12,8 @@ open CErrors open Util open Extend open Genarg +open Gramlib -let curry f x y = f (x, y) let uncurry f (x,y) = f x y (** Location Utils *) @@ -59,7 +59,7 @@ module type S = type e 'a = 'y; value create : string -> e 'a; value parse : e 'a -> parsable -> 'a; - value parse_token : e 'a -> Stream.t te -> 'a; + value parse_token_stream : e 'a -> Stream.t te -> 'a; value name : e 'a -> string; value of_parser : string -> (Stream.t te -> 'a) -> e 'a; value print : Format.formatter -> e 'a -> unit; @@ -83,13 +83,9 @@ module type S = *) type 'a entry = 'a Entry.e - type internal_entry = Tok.t Gramext.g_entry - type symbol = Tok.t Gramext.g_symbol - type action = Gramext.g_action type coq_parsable val coq_parsable : ?file:Loc.source -> char Stream.t -> coq_parsable - val action : 'a -> action val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -100,9 +96,6 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct include Grammar.GMake(CLexer) type 'a entry = 'a Entry.e - type internal_entry = Tok.t Gramext.g_entry - type symbol = Tok.t Gramext.g_symbol - type action = Gramext.g_action type coq_parsable = parsable * CLexer.lexer_state ref @@ -113,7 +106,6 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct state := CLexer.get_lexer_state (); (a,state) - let action = Gramext.action let entry_create = Entry.create let entry_parse e (p,state) = @@ -148,6 +140,9 @@ struct let create = G.Entry.create let parse = G.entry_parse let print = G.Entry.print + let of_parser = G.Entry.of_parser + let name = G.Entry.name + let parse_token_stream = G.Entry.parse_token_stream end @@ -166,16 +161,9 @@ let of_coq_position = function | Extend.Level s -> Gramext.Level s module Symbols : sig - val stoken : Tok.t -> G.symbol - val sself : G.symbol - val snext : G.symbol - val slist0 : G.symbol -> G.symbol - val slist0sep : G.symbol * G.symbol -> G.symbol - val slist1 : G.symbol -> G.symbol - val slist1sep : G.symbol * G.symbol -> G.symbol - val sopt : G.symbol -> G.symbol - val snterml : G.internal_entry * string -> G.symbol - val snterm : G.internal_entry -> G.symbol + val stoken : Tok.t -> ('s, string) G.ty_symbol + val slist0sep : ('s, 'a) G.ty_symbol -> ('s, 'b) G.ty_symbol -> ('s, 'a list) G.ty_symbol + val slist1sep : ('s, 'a) G.ty_symbol -> ('s, 'b) G.ty_symbol -> ('s, 'a list) G.ty_symbol end = struct let stoken tok = @@ -190,19 +178,10 @@ end = struct | Tok.BULLET s -> "BULLET", s | Tok.EOI -> "EOI", "" in - Gramext.Stoken pattern - - let slist0sep (x, y) = Gramext.Slist0sep (x, y, false) - let slist1sep (x, y) = Gramext.Slist1sep (x, y, false) - - let snterml (x, y) = Gramext.Snterml (x, y) - let snterm x = Gramext.Snterm x - let sself = Gramext.Sself - let snext = Gramext.Snext - let slist0 x = Gramext.Slist0 x - let slist1 x = Gramext.Slist1 x - let sopt x = Gramext.Sopt x + G.s_token pattern + let slist0sep x y = G.s_list0sep x y false + let slist1sep x y = G.s_list1sep x y false end let camlp5_verbosity silent f x = @@ -224,40 +203,41 @@ let camlp5_verbosity silent f x = (** Binding general entry keys to symbol *) -let rec of_coq_action : type a r. (r, a, Loc.t -> r) Extend.rule -> a -> G.action = function -| Stop -> fun f -> G.action (fun loc -> f (!@ loc)) -| Next (r, _) -> fun f -> G.action (fun x -> of_coq_action r (f x)) - -let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function - | Atoken t -> Symbols.stoken t - | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) - | Alist1sep (s,sep) -> - Symbols.slist1sep (symbol_of_prod_entry_key s, symbol_of_prod_entry_key sep) - | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s) - | Alist0sep (s,sep) -> - Symbols.slist0sep (symbol_of_prod_entry_key s, symbol_of_prod_entry_key sep) - | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) - | Aself -> Symbols.sself - | Anext -> Symbols.snext - | Aentry e -> - Symbols.snterm (G.Entry.obj e) - | Aentryl (e, n) -> - Symbols.snterml (G.Entry.obj e, n) - | Arules rs -> - Gramext.srules (List.map symbol_of_rules rs) - -and symbol_of_rule : type s a r. (s, a, r) Extend.rule -> _ = function -| Stop -> fun accu -> accu -| Next (r, s) -> fun accu -> symbol_of_rule r (symbol_of_prod_entry_key s :: accu) - -and symbol_of_rules : type a. a Extend.rules -> _ = function +type ('s, 'a, 'r) casted_rule = Casted : ('s, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, 'a, 'r) casted_rule + +let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> (s, a) G.ty_symbol = function +| Atoken t -> Symbols.stoken t +| Alist1 s -> G.s_list1 (symbol_of_prod_entry_key s) +| Alist1sep (s,sep) -> + Symbols.slist1sep (symbol_of_prod_entry_key s) (symbol_of_prod_entry_key sep) +| Alist0 s -> G.s_list0 (symbol_of_prod_entry_key s) +| Alist0sep (s,sep) -> + Symbols.slist0sep (symbol_of_prod_entry_key s) (symbol_of_prod_entry_key sep) +| Aopt s -> G.s_opt (symbol_of_prod_entry_key s) +| Aself -> G.s_self +| Anext -> G.s_next +| Aentry e -> G.s_nterm e +| Aentryl (e, n) -> G.s_nterml e n +| Arules rs -> G.s_rules (List.map symbol_of_rules rs) + +and symbol_of_rule : type s a r. (s, a, Loc.t -> r) Extend.rule -> (s, a, Ploc.t -> r) casted_rule = function +| Stop -> Casted (G.r_stop, fun act loc -> act (!@loc)) +| Next (r, s) -> + let Casted (r, cast) = symbol_of_rule r in + Casted (G.r_next r (symbol_of_prod_entry_key s), (fun act x -> cast (act x))) + +and symbol_of_rules : type a. a Extend.rules -> a G.ty_production = function | Rules (r, act) -> - let symb = symbol_of_rule r.norec_rule [] in - let act = of_coq_action r.norec_rule act in - (symb, act) + let Casted (symb, cast) = symbol_of_rule r.norec_rule in + G.production (symb, cast act) + +(** FIXME: This is a hack around a deficient camlp5 API *) +type 'a any_production = AnyProduction : ('a, 'f, Ploc.t -> 'a) G.ty_rule * 'f -> 'a any_production -let of_coq_production_rule : type a. a Extend.production_rule -> _ = function -| Rule (toks, act) -> (symbol_of_rule toks [], of_coq_action toks act) +let of_coq_production_rule : type a. a Extend.production_rule -> a any_production = function +| Rule (toks, act) -> + let Casted (symb, cast) = symbol_of_rule toks in + AnyProduction (symb, cast act) let of_coq_single_extend_statement (lvl, assoc, rule) = (lvl, Option.map of_coq_assoc assoc, List.map of_coq_production_rule rule) @@ -265,6 +245,13 @@ let of_coq_single_extend_statement (lvl, assoc, rule) = let of_coq_extend_statement (pos, st) = (Option.map of_coq_position pos, List.map of_coq_single_extend_statement st) +let fix_extend_statement (pos, st) = + let fix_single_extend_statement (lvl, assoc, rules) = + let fix_production_rule (AnyProduction (s, act)) = G.production (s, act) in + (lvl, assoc, List.map fix_production_rule rules) + in + (pos, List.map fix_single_extend_statement st) + (** Type of reinitialization data *) type gram_reinit = gram_assoc * gram_position @@ -291,7 +278,7 @@ let camlp5_entries = ref EntryDataMap.empty let grammar_delete e reinit (pos,rls) = List.iter (fun (n,ass,lev) -> - List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) + List.iter (fun (AnyProduction (pil,_)) -> G.safe_delete_rule e pil) (List.rev lev)) (List.rev rls); match reinit with | Some (a,ext) -> @@ -301,7 +288,7 @@ let grammar_delete e reinit (pos,rls) = | Some (Gramext.Level n) -> n | _ -> assert false in - (G.extend e) (Some ext) [Some lev,Some a,[]] + (G.safe_extend e) (Some ext) [Some lev,Some a,[]] | None -> () (** Extension *) @@ -309,13 +296,15 @@ let grammar_delete e reinit (pos,rls) = let grammar_extend e reinit ext = let ext = of_coq_extend_statement ext in let undo () = grammar_delete e reinit ext in - let redo () = camlp5_verbosity false (uncurry (G.extend e)) ext in + let ext = fix_extend_statement ext in + let redo () = camlp5_verbosity false (uncurry (G.safe_extend e)) ext in camlp5_state := ByEXTEND (undo, redo) :: !camlp5_state; redo () let grammar_extend_sync e reinit ext = camlp5_state := ByGrammar (ExtendRule (e, reinit, ext)) :: !camlp5_state; - camlp5_verbosity false (uncurry (G.extend e)) (of_coq_extend_statement ext) + let ext = fix_extend_statement (of_coq_extend_statement ext) in + camlp5_verbosity false (uncurry (G.safe_extend e)) ext (** The apparent parser of Coq; encapsulate G to keep track of the extensions. *) @@ -323,25 +312,6 @@ let grammar_extend_sync e reinit ext = module Gram = struct include G - let extend e = - curry - (fun ext -> - camlp5_state := - (ByEXTEND ((fun () -> grammar_delete e None ext), - (fun () -> uncurry (G.extend e) ext))) - :: !camlp5_state; - uncurry (G.extend e) ext) - let delete_rule e pil = - (* spiwack: if you use load an ML module which contains GDELETE_RULE - in a section, God kills a kitty. As it would corrupt remove_grammars. - There does not seem to be a good way to undo a delete rule. As deleting - takes fewer arguments than extending. The production rule isn't returned - by delete_rule. If we could retrieve the necessary information, then - ByEXTEND provides just the framework we need to allow this in section. - I'm not entirely sure it makes sense, but at least it would be more correct. - *) - G.delete_rule e pil - let gram_extend e ext = grammar_extend e None ext end (** Remove extensions @@ -380,16 +350,16 @@ let make_rule r = [None, None, r] let eoi_entry en = let e = Entry.create ((Gram.Entry.name en) ^ "_eoi") in - let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in - let act = Gram.action (fun _ x loc -> x) in - uncurry (Gram.extend e) (None, make_rule [symbs, act]); + let symbs = G.r_next (G.r_next G.r_stop (G.s_nterm en)) (Symbols.stoken Tok.EOI) in + let act = fun _ x loc -> x in + Gram.safe_extend e None (make_rule [G.production (symbs, act)]); e let map_entry f en = let e = Entry.create ((Gram.Entry.name en) ^ "_map") in - let symbs = [Symbols.snterm (Gram.Entry.obj en)] in - let act = Gram.action (fun x loc -> f x) in - uncurry (Gram.extend e) (None, make_rule [symbs, act]); + let symbs = G.r_next G.r_stop (G.s_nterm en) in + let act = fun x loc -> f x in + Gram.safe_extend e None (make_rule [G.production (symbs, act)]); e (* Parse a string, does NOT check if the entire string was read @@ -516,10 +486,10 @@ module Module = end let epsilon_value f e = - let r = Rule (Next (Stop, e), fun x _ -> f x) in - let ext = of_coq_extend_statement (None, [None, None, [r]]) in + let r = G.production (G.r_next G.r_stop (symbol_of_prod_entry_key e), (fun x _ -> f x)) in + let ext = [None, None, [r]] in let entry = Gram.entry_create "epsilon" in - let () = uncurry (G.extend entry) ext in + let () = G.safe_extend entry None ext in try Some (parse_string entry "") with _ -> None (** Synchronized grammar extensions *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index c05229d576..e64c614149 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -13,20 +13,10 @@ open Extend open Genarg open Constrexpr open Libnames +open Gramlib (** The parser of Coq *) -(** DO NOT USE EXTENSION FUNCTIONS IN THIS MODULE. - We only have it here to work with Camlp5. Handwritten grammar extensions - should use the safe [Pcoq.grammar_extend] function below. *) -module Gram : sig - - include Grammar.S with type te = Tok.t - - val gram_extend : 'a Entry.e -> 'a Extend.extend_statement -> unit - -end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e - module Parsable : sig type t @@ -40,6 +30,9 @@ module Entry : sig val create : string -> 'a t val parse : 'a t -> Parsable.t -> 'a val print : Format.formatter -> 'a t -> unit + val of_parser : string -> (Tok.t Stream.t -> 'a) -> 'a t + val parse_token_stream : 'a t -> Tok.t Stream.t -> 'a + val name : 'a t -> string end (** The parser of Coq is built from three kinds of rule declarations: diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index f1095fc9f1..638a4cef21 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -10,7 +10,7 @@ end. Arguments decide P /H. -Hint Extern 5 => progress bool. +Hint Extern 5 => progress bool : core. Ltac define t x H := set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x. @@ -147,7 +147,7 @@ Qed. (** * The core reflexive part. *) -Hint Constructors valid. +Hint Constructors valid : core. Fixpoint beq_poly pl pr := match pl with @@ -315,7 +315,7 @@ Section Validity. (* Decision procedure of validity *) -Hint Constructors valid linear. +Hint Constructors valid linear : core. Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p. Proof. @@ -425,10 +425,10 @@ match goal with | [ |- (?z < Pos.max ?x ?y)%positive ] => apply Pos.max_case_strong; intros; lia | _ => zify; omega -end. -Hint Resolve Pos.le_max_r Pos.le_max_l. +end : core. +Hint Resolve Pos.le_max_r Pos.le_max_l : core. -Hint Constructors valid linear. +Hint Constructors valid linear : core. (* Compatibility of validity w.r.t algebraic operations *) diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v index 4cde08872f..98f5ab067a 100644 --- a/plugins/btauto/Reflect.v +++ b/plugins/btauto/Reflect.v @@ -77,10 +77,10 @@ intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto. end. Qed. -Hint Extern 5 => change 0 with (min 0 0). -Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat. -Local Hint Constructors valid. -Hint Extern 5 => zify; omega. +Hint Extern 5 => change 0 with (min 0 0) : core. +Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat : core. +Local Hint Constructors valid : core. +Hint Extern 5 => zify; omega : core. (* Compatibility with validity *) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index f26ec0f401..a6f432b5bd 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -333,9 +333,6 @@ let get_representative uf i= let get_constructors uf i= uf.map.(i).constructors -let find_pac uf i pac = - PacMap.find pac (get_constructors uf i) - let rec find_oldest_pac uf i pac= try PacMap.find pac (get_constructors uf i) with Not_found -> diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 4ebc6a135a..d52e83dc31 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -145,8 +145,6 @@ val tail_pac : pa_constructor -> pa_constructor val find : forest -> int -> int -val find_pac : forest -> int -> pa_constructor -> int - val find_oldest_pac : forest -> int -> pa_constructor -> int val term : forest -> int -> term diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index 18316bf2cd..df4b647642 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -18,7 +18,7 @@ DECLARE PLUGIN "derive_plugin" { -let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) +let classify_derive_command _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) } diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index b9274cf6b8..a212d13453 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -66,7 +66,7 @@ let default_intuition_tac = let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in Tacenv.register_ml_tactic name [| tac |]; - Tacexpr.TacML (Loc.tag (entry, [])) + Tacexpr.TacML (CAst.make (entry, [])) let (set_default_solver, default_solver, print_default_solver) = Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" @@ -89,8 +89,6 @@ END { -let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") - let gen_ground_tac flag taco ids bases = let backup= !qflag in Proofview.tclOR begin diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 516b04ea21..6a80525200 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -18,16 +18,16 @@ open Tacticals.New open Globnames let update_flags ()= - let f acc coe = - match coe.Classops.coe_value with - | ConstRef c -> Names.Cpred.add c acc - | _ -> acc + let open TransparentState in + let f accu coe = match coe.Classops.coe_value with + | ConstRef kn -> { accu with tr_cst = Names.Cpred.remove kn accu.tr_cst } + | _ -> accu in - let pred = List.fold_left f Names.Cpred.empty (Classops.coercions ()) in + let flags = List.fold_left f TransparentState.full (Classops.coercions ()) in red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta - (Names.Id.Pred.full,Names.Cpred.complement pred) + flags let ground_tac solver startseq = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index b0c4785d7a..832a98b7f8 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -21,7 +21,6 @@ open Termops open Formula open Sequent open Globnames -open Locus module NamedDecl = Context.Named.Declaration @@ -56,10 +55,6 @@ let wrap n b continue seq = continue seq2 end -let basename_of_global=function - VarRef id->id - | _->assert false - let clear_global=function VarRef id-> clear [id] | _->tclIDTAC @@ -230,19 +225,3 @@ let ll_forall_tac prod backtrack id continue seq= backtrack (* rules for instantiation with unification moved to instances.ml *) - -(* special for compatibility with old Intuition *) - -let constant str = Coqlib.lib_ref str - -let defined_connectives = lazy - [AllOccurrences, EvalConstRef (destConstRef (constant "core.not.type")); - AllOccurrences, EvalConstRef (destConstRef (constant "core.iff.type"))] - -let normalize_evaluables= - Proofview.Goal.enter begin fun gl -> - unfold_in_concl (Lazy.force defined_connectives) <*> - tclMAP - (fun id -> unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) - (pf_ids_of_hyps gl) - end diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index 924c26790c..97bc992b26 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -22,8 +22,6 @@ type 'a with_backtracking = tactic -> 'a val wrap : int -> bool -> seqtac -val basename_of_global: GlobRef.t -> Id.t - val clear_global: GlobRef.t -> tactic val axiom_tac : constr -> Sequent.t -> tactic @@ -51,5 +49,3 @@ val forall_tac : seqtac with_backtracking val left_exists_tac : pinductive -> lseqtac with_backtracking val ll_forall_tac : types -> lseqtac with_backtracking - -val normalize_evaluables : tactic diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 651895aa08..ef1d1af199 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -131,8 +131,7 @@ let finish_proof dynamic_infos g = g -let refine c = - Tacmach.refine c +let refine c = Refiner.refiner ~check:true EConstr.Unsafe.(to_constr c) let thin l = Proofview.V82.of_tactic (Tactics.clear l) @@ -1487,7 +1486,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = Eauto.eauto_with_bases (true,5) [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [Hints.Hint_db.empty empty_transparent_state false] + [Hints.Hint_db.empty TransparentState.empty false] ) ) ) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d1e7d8a5a8..1cf952576d 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -320,10 +320,16 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - get_proof_clean true, CEphemeron.create hook - end - + let open Proof_global in + let { id; entries; persistence } = fst @@ close_proof ~keep_body_ucst_separate:false (fun x -> x) in + match entries with + | [entry] -> + discard_current (); + (id,(entry,persistence)), CEphemeron.create hook + | _ -> + CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") + end let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 155df1c1e0..8f0440a2a4 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -145,7 +145,6 @@ END { -module Gram = Pcoq.Gram module Vernac = Pvernac.Vernac_ module Tactic = Pltac @@ -186,8 +185,8 @@ VERNAC COMMAND EXTEND Function Vernac_classifier.classify_vernac (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with - | Vernacexpr.VtSideff ids, _ when hard -> - Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) + | Vernacextend.VtSideff ids, _ when hard -> + Vernacextend.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) | x -> x } -> { do_generate_principle false (List.map snd recsl) } END @@ -225,7 +224,7 @@ let warning_error names e = VERNAC COMMAND EXTEND NewFunctionalScheme | ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] - => { Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater } + => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> { begin @@ -261,7 +260,7 @@ END VERNAC COMMAND EXTEND NewFunctionalCase | ["Functional" "Case" fun_scheme_arg(fas) ] - => { Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater } + => { Vernacextend.(VtSideff[pi1 fas], VtLater) } -> { Functional_principles_types.build_case_scheme fas } END diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 28a9542167..b68b34ca35 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -27,10 +27,6 @@ let array_get_start a = (Array.length a - 1) (fun i -> a.(i)) -let id_of_name = function - Name id -> id - | _ -> raise Not_found - let locate qid = Nametab.locate qid let locate_ind ref = @@ -105,15 +101,6 @@ let const_of_id id = CErrors.user_err ~hdr:"IndFun.const_of_id" (str "cannot find " ++ Id.print id) -let def_of_const t = - match Constr.kind t with - Const sp -> - (try (match Environ.constant_opt_value_in (Global.env()) sp with - | Some c -> c - | _ -> assert false) - with Not_found -> assert false) - |_ -> assert false - [@@@ocaml.warning "-3"] let coq_constant s = UnivGen.constr_of_monomorphic_global @@ @@ -160,17 +147,6 @@ let save with_clean id const (locality,_,kind) hook = CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id - - -let cook_proof _ = - let (id,(entry,_,strength)) = Pfedit.cook_proof () in - (id,(entry,strength)) - -let get_proof_clean do_reduce = - let result = cook_proof do_reduce in - Proof_global.discard_current (); - result - let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 1b4c1248a5..c9d153d89f 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -18,8 +18,6 @@ val get_name : Id.t list -> ?default:string -> Name.t -> Name.t val array_get_start : 'a array -> 'a array -val id_of_name : Name.t -> Id.t - val locate_ind : Libnames.qualid -> inductive val locate_constant : Libnames.qualid -> Constant.t val locate_with_msg : @@ -38,7 +36,6 @@ val chop_rlambda_n : int -> Glob_term.glob_constr -> val chop_rprod_n : int -> Glob_term.glob_constr -> (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr -val def_of_const : Constr.t -> Constr.t val eq : EConstr.constr Lazy.t val refl_equal : EConstr.constr Lazy.t val const_of_id: Id.t -> GlobRef.t(* constantyes *) @@ -48,15 +45,6 @@ val jmeq_refl : unit -> EConstr.constr val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> Lemmas.declaration_hook CEphemeron.key -> unit -(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and - abort the proof -*) -val get_proof_clean : bool -> - Names.Id.t * - (Safe_typing.private_constants Entries.definition_entry * Decl_kinds.goal_kind) - - - (* [with_full_print f a] applies [f] to [a] in full printing environment. This function preserves the print settings diff --git a/plugins/funind/plugin_base.dune b/plugins/funind/plugin_base.dune index 9f583234d8..002eb28eea 100644 --- a/plugins/funind/plugin_base.dune +++ b/plugins/funind/plugin_base.dune @@ -2,5 +2,4 @@ (name recdef_plugin) (public_name coq.plugins.recdef) (synopsis "Coq's functional induction plugin") - (flags :standard -open Gramlib) (libraries coq.plugins.extraction)) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 63a3e0582d..6e5e3f9353 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1359,7 +1359,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp Eauto.eauto_with_bases (true,5) [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] - [Hints.Hint_db.empty empty_transparent_state false] + [Hints.Hint_db.empty TransparentState.empty false] ] ) ) diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index 6388906f5e..d9338f0421 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -333,7 +333,7 @@ open Tacexpr let initial_atomic () = let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in let iter (s, t) = - let body = TacAtom (Loc.tag t) in + let body = TacAtom (CAst.make t) in Tacenv.register_ltac false false (Names.Id.of_string s) body in let () = List.iter iter @@ -348,7 +348,7 @@ let initial_atomic () = List.iter iter [ "idtac",TacId []; "fail", TacFail(TacLocal,ArgArg 0,[]); - "fresh", TacArg(Loc.tag @@ TacFreshId []) + "fresh", TacArg(CAst.make @@ TacFreshId []) ] let () = Mltop.declare_cache_obj initial_atomic "ltac_plugin" @@ -379,8 +379,8 @@ let initial_tacticals () = let varn n = Reference (ArgVar (CAst.make (idn n))) in let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in List.iter iter [ - "first", TacFun ([Name (idn 0)], TacML (None, (initial_entry "first", [varn 0]))); - "solve", TacFun ([Name (idn 0)], TacML (None, (initial_entry "solve", [varn 0]))); + "first", TacFun ([Name (idn 0)], TacML (CAst.make (initial_entry "first", [varn 0]))); + "solve", TacFun ([Name (idn 0)], TacML (CAst.make (initial_entry "solve", [varn 0]))); ] let () = Mltop.declare_cache_obj initial_tacticals "ltac_plugin" diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index c4c4e51ecc..156ee94a66 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -332,7 +332,7 @@ END let local_test_lpar_id_colon = let err () = raise Stream.Failure in - Pcoq.Gram.Entry.of_parser "lpar_id_colon" + Pcoq.Entry.of_parser "lpar_id_colon" (fun strm -> match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 85fb0c73c9..603dd60cf2 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -31,6 +31,7 @@ open Tactypes open Tactics open Proofview.Notations open Attributes +open Vernacextend let wit_hyp = wit_var @@ -48,7 +49,6 @@ let with_delayed_uconstr ist c tac = let flags = { Pretyping.use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } in @@ -316,7 +316,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = let add_hints base = add_rew_rules base eqs in List.iter add_hints bases -let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater +let classify_hint _ = VtSideff [], VtLater } @@ -343,7 +343,6 @@ open Vars let constr_flags () = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); - Pretyping.use_hook = Pfedit.solve_by_implicit_tactic (); Pretyping.fail_evar = false; Pretyping.expand_evars = true } @@ -400,7 +399,7 @@ END open Inv open Leminv -let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater +let seff id = VtSideff [id], VtLater } @@ -571,44 +570,6 @@ VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF { add_transitivity_lemma false t } END -{ - -let cache_implicit_tactic (_,tac) = match tac with - | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) - | None -> Pfedit.clear_implicit_tactic () - -let subst_implicit_tactic (subst,tac) = - Option.map (Tacsubst.subst_tactic subst) tac - -let inImplicitTactic : glob_tactic_expr option -> obj = - declare_object {(default_object "IMPLICIT-TACTIC") with - open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); - cache_function = cache_implicit_tactic; - subst_function = subst_implicit_tactic; - classify_function = (fun o -> Dispose)} - -let warn_deprecated_implicit_tactic = - CWarnings.create ~name:"deprecated-implicit-tactic" ~category:"deprecated" - (fun () -> strbrk "Implicit tactics are deprecated") - -let declare_implicit_tactic tac = - let () = warn_deprecated_implicit_tactic () in - Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) - -let clear_implicit_tactic () = - let () = warn_deprecated_implicit_tactic () in - Lib.add_anonymous_leaf (inImplicitTactic None) - -} - -VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF -| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> { declare_implicit_tactic tac } -| [ "Clear" "Implicit" "Tactic" ] -> { clear_implicit_tactic () } -END - - - - (**********************************************************************) (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) @@ -807,7 +768,7 @@ let case_eq_intros_rewrite x = let rec find_a_destructable_match sigma t = let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in let cl = [cl, (None, None), None], None in - let dest = TacAtom (Loc.tag @@ TacInductionDestruct(false, false, cl)) in + let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with | Case (_,_,x,_) when closed0 sigma x -> if isVar sigma x then @@ -950,7 +911,7 @@ END mode. *) VERNAC COMMAND EXTEND GrabEvars | [ "Grab" "Existential" "Variables" ] - => { Vernac_classifier.classify_as_proofstep } + => { classify_as_proofstep } -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) } END @@ -982,7 +943,7 @@ END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve | [ "Unshelve" ] - => { Vernac_classifier.classify_as_proofstep } + => { classify_as_proofstep } -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) } END @@ -1134,9 +1095,9 @@ END VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => { Vernac_classifier.classify_as_proofstep } -> +| [ "Optimize" "Proof" ] => { classify_as_proofstep } -> { Proof_global.compact_the_proof () } -| [ "Optimize" "Heap" ] => { Vernac_classifier.classify_as_proofstep } -> +| [ "Optimize" "Heap" ] => { classify_as_proofstep } -> { Gc.compact () } END diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 5af393a3e5..7be8f67616 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -55,7 +55,6 @@ let eval_uconstrs ist cs = let flags = { Pretyping.use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } in diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index c58c8556c5..338839ee96 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -33,7 +33,7 @@ open Pltac let fail_default_value = Locus.ArgArg 0 let arg_of_expr = function - TacArg (loc,a) -> a + TacArg { CAst.v } -> v | e -> Tacexp (e:raw_tactic_expr) let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () @@ -70,7 +70,7 @@ let _ = (* Hack to parse "[ id" without dropping [ *) let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" + Pcoq.Entry.of_parser "test_bracket_ident" (fun strm -> match stream_nth 0 strm with | KEYWORD "[" -> @@ -162,9 +162,9 @@ GRAMMAR EXTEND Gram | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } - | a = tactic_arg -> { TacArg(Loc.tag ~loc a) } + | a = tactic_arg -> { TacArg(CAst.make ~loc a) } | r = reference; la = LIST0 tactic_arg_compat -> - { TacArg(Loc.tag ~loc @@ TacCall (Loc.tag ~loc (r,la))) } ] + { TacArg(CAst.make ~loc @@ TacCall (CAst.make ~loc (r,la))) } ] | "0" [ "("; a = tactic_expr; ")" -> { a } | "["; ">"; tg = tactic_then_gen; "]" -> { @@ -173,7 +173,7 @@ GRAMMAR EXTEND Gram | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) | None -> TacDispatch tf end } - | a = tactic_atom -> { TacArg (Loc.tag ~loc a) } ] ] + | a = tactic_atom -> { TacArg (CAst.make ~loc a) } ] ] ; failkw: [ [ IDENT "fail" -> { TacLocal } | IDENT "gfail" -> { TacGlobal } ] ] @@ -223,7 +223,7 @@ GRAMMAR EXTEND Gram ; tactic_atom: [ [ n = integer -> { TacGeneric (genarg_of_int n) } - | r = reference -> { TacCall (Loc.tag ~loc (r,[])) } + | r = reference -> { TacCall (CAst.make ~loc (r,[])) } | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] ; match_key: @@ -367,8 +367,7 @@ GRAMMAR EXTEND Gram open Stdarg open Tacarg -open Vernacexpr -open Vernac_classifier +open Vernacextend open Goptions open Libnames diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index aa78fb5d1e..ef18dd6cdc 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -45,7 +45,6 @@ let with_tac f tac = * Subtac. These entries are named Subtac.<foo> *) -module Gram = Pcoq.Gram module Tactic = Pltac open Pcoq @@ -84,7 +83,7 @@ open Obligations let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac -let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) +let classify_obbl _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) } diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 1c7220ddc0..f7375a0f01 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -26,6 +26,7 @@ open Pcoq.Prim open Pcoq.Constr open Pvernac.Vernac_ open Pltac +open Vernacextend let wit_hyp = wit_var @@ -225,8 +226,6 @@ let () = let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in Pptactic.declare_extra_vernac_genarg_pprule wit_binders raw_printer -open Pcoq - } GRAMMAR EXTEND Gram @@ -280,18 +279,18 @@ VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF } | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) - => { Vernacexpr.VtUnknown, Vernacexpr.VtNow } + => { VtUnknown, VtNow } -> { add_morphism_infer atts m n; } | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) } + => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } -> { add_morphism atts [] m s n; } | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => { Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) } + => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } -> { add_morphism atts binders m s n; } diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 571595be70..46ea3819ac 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -39,7 +39,7 @@ let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) let test_lpar_id_coloneq = - Gram.Entry.of_parser "lpar_id_coloneq" + Pcoq.Entry.of_parser "lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -53,7 +53,7 @@ let test_lpar_id_coloneq = (* Hack to recognize "(x)" *) let test_lpar_id_rpar = - Gram.Entry.of_parser "lpar_id_coloneq" + Pcoq.Entry.of_parser "lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -67,7 +67,7 @@ let test_lpar_id_rpar = (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = - Gram.Entry.of_parser "test_lpar_idnum_coloneq" + Pcoq.Entry.of_parser "test_lpar_idnum_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -84,7 +84,7 @@ open Extraargs (* idem for (x1..xn:t) [n^2 complexity but exceptional use] *) let check_for_coloneq = - Gram.Entry.of_parser "lpar_id_colon" + Pcoq.Entry.of_parser "lpar_id_colon" (fun strm -> let rec skip_to_rpar p n = match List.last (Stream.npeek n strm) with @@ -108,7 +108,7 @@ let check_for_coloneq = | _ -> err ()) let lookup_at_as_comma = - Gram.Entry.of_parser "lookup_at_as_comma" + Pcoq.Entry.of_parser "lookup_at_as_comma" (fun strm -> match stream_nth 0 strm with | KEYWORD (","|"at"|"as") -> () @@ -529,178 +529,178 @@ GRAMMAR EXTEND Gram [ [ (* Basic tactics *) IDENT "intros"; pl = ne_intropatterns -> - { TacAtom (Loc.tag ~loc @@ TacIntroPattern (false,pl)) } + { TacAtom (CAst.make ~loc @@ TacIntroPattern (false,pl)) } | IDENT "intros" -> - { TacAtom (Loc.tag ~loc @@ TacIntroPattern (false,[CAst.make ~loc @@IntroForthcoming false])) } + { TacAtom (CAst.make ~loc @@ TacIntroPattern (false,[CAst.make ~loc @@IntroForthcoming false])) } | IDENT "eintros"; pl = ne_intropatterns -> - { TacAtom (Loc.tag ~loc @@ TacIntroPattern (true,pl)) } + { TacAtom (CAst.make ~loc @@ TacIntroPattern (true,pl)) } | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (true,false,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (true,false,cl,inhyp)) } | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (true,true,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (true,true,cl,inhyp)) } | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (false,false,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (false,false,cl,inhyp)) } | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP","; - inhyp = in_hyp_as -> { TacAtom (Loc.tag ~loc @@ TacApply (false,true,cl,inhyp)) } + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (false,true,cl,inhyp)) } | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - { TacAtom (Loc.tag ~loc @@ TacElim (false,cl,el)) } + { TacAtom (CAst.make ~loc @@ TacElim (false,cl,el)) } | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - { TacAtom (Loc.tag ~loc @@ TacElim (true,cl,el)) } - | IDENT "case"; icl = induction_clause_list -> { TacAtom (Loc.tag ~loc @@ mkTacCase false icl) } - | IDENT "ecase"; icl = induction_clause_list -> { TacAtom (Loc.tag ~loc @@ mkTacCase true icl) } + { TacAtom (CAst.make ~loc @@ TacElim (true,cl,el)) } + | IDENT "case"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase false icl) } + | IDENT "ecase"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase true icl) } | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - { TacAtom (Loc.tag ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } + { TacAtom (CAst.make ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - { TacAtom (Loc.tag ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } + { TacAtom (CAst.make ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } | IDENT "pose"; bl = bindings_with_parameters -> - { let (id,b) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } | IDENT "pose"; b = constr; na = as_name -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } | IDENT "epose"; bl = bindings_with_parameters -> - { let (id,b) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } | IDENT "epose"; b = constr; na = as_name -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } | IDENT "set"; bl = bindings_with_parameters; p = clause_dft_concl -> - { let (id,c) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,c,p,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,c,p,true,None)) } | IDENT "eset"; bl = bindings_with_parameters; p = clause_dft_concl -> - { let (id,c) = bl in TacAtom (Loc.tag ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,c,p,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,c,p,true,None)) } | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (false,na,c,p,false,e)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,c,p,false,e)) } | IDENT "eremember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - { TacAtom (Loc.tag ~loc @@ TacLetTac (true,na,c,p,false,e)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,c,p,false,e)) } (* Alternative syntax for "pose proof c as id" *) | IDENT "assert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "assert c as id by tac" *) | IDENT "assert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "enough c as id by tac" *) | IDENT "enough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eenough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + TacAtom (CAst.make ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - { TacAtom (Loc.tag ~loc @@ TacAssert (false,true,None,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,None,ipat,c)) } | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - { TacAtom (Loc.tag ~loc @@ TacAssert (true,true,None,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,None,ipat,c)) } | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (Loc.tag ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } | IDENT "generalize"; c = constr -> - { TacAtom (Loc.tag ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } + { TacAtom (CAst.make ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } | IDENT "generalize"; c = constr; l = LIST1 constr -> { let gen_everywhere c = ((AllOccurrences,c),Names.Name.Anonymous) in - TacAtom (Loc.tag ~loc @@ TacGeneralize (List.map gen_everywhere (c::l))) } + TacAtom (CAst.make ~loc @@ TacGeneralize (List.map gen_everywhere (c::l))) } | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; na = as_name; l = LIST0 [","; c = pattern_occ; na = as_name -> { (c,na) } ] -> - { TacAtom (Loc.tag ~loc @@ TacGeneralize (((nl,c),na)::l)) } + { TacAtom (CAst.make ~loc @@ TacGeneralize (((nl,c),na)::l)) } (* Derived basic tactics *) | IDENT "induction"; ic = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct (true,false,ic)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct (true,false,ic)) } | IDENT "einduction"; ic = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(true,true,ic)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(true,true,ic)) } | IDENT "destruct"; icl = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(false,false,icl)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,false,icl)) } | IDENT "edestruct"; icl = induction_clause_list -> - { TacAtom (Loc.tag ~loc @@ TacInductionDestruct(false,true,icl)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,true,icl)) } (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> { TacAtom (Loc.tag ~loc @@ TacRewrite (false,l,cl,t)) } + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (false,l,cl,t)) } | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> { TacAtom (Loc.tag ~loc @@ TacRewrite (true,l,cl,t)) } + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (true,l,cl,t)) } | IDENT "dependent"; k = [ IDENT "simple"; IDENT "inversion" -> { SimpleInversion } | IDENT "inversion" -> { FullInversion } | IDENT "inversion_clear" -> { FullInversionClear } ]; hyp = quantified_hypothesis; ids = as_or_and_ipat; co = OPT ["with"; c = constr -> { c } ] -> - { TacAtom (Loc.tag ~loc @@ TacInversion (DepInversion (k,co,ids),hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (DepInversion (k,co,ids),hyp)) } | IDENT "simple"; IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } | IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } | IDENT "inversion_clear"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } | IDENT "inversion"; hyp = quantified_hypothesis; "using"; c = constr; cl = in_hyp_list -> - { TacAtom (Loc.tag ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } + { TacAtom (CAst.make ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } (* Conversion *) | IDENT "red"; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Red false, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Red false, cl)) } | IDENT "hnf"; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Hnf, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Hnf, cl)) } | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Simpl (all_with d, po), cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Simpl (all_with d, po), cl)) } | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Cbv s, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Cbv s, cl)) } | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Cbn s, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Cbn s, cl)) } | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Lazy s, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Lazy s, cl)) } | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Cbv (all_with delta), cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Cbv (all_with delta), cl)) } | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (CbvVm po, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (CbvVm po, cl)) } | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (CbvNative po, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (CbvNative po, cl)) } | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Unfold ul, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Unfold ul, cl)) } | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Fold l, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Fold l, cl)) } | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> - { TacAtom (Loc.tag ~loc @@ TacReduce (Pattern pl, cl)) } + { TacAtom (CAst.make ~loc @@ TacReduce (Pattern pl, cl)) } (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) | IDENT "change"; c = conversion; cl = clause_dft_concl -> { let (oc, c) = c in let p,cl = merge_occurrences loc cl oc in - TacAtom (Loc.tag ~loc @@ TacChange (p,c,cl)) } + TacAtom (CAst.make ~loc @@ TacChange (p,c,cl)) } ] ] ; END diff --git a/plugins/ltac/plugin_base.dune b/plugins/ltac/plugin_base.dune index 1b31655310..5611f5ba16 100644 --- a/plugins/ltac/plugin_base.dune +++ b/plugins/ltac/plugin_base.dune @@ -3,7 +3,6 @@ (public_name coq.plugins.ltac) (synopsis "Coq's LTAC tactic language") (modules :standard \ tauto) - (flags :standard -open Gramlib) (libraries coq.stm)) (library diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index b219ee25ca..50cfb6d004 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -294,7 +294,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr _ = str "_" in KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" - let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.tag arg)) + let pr_farg prtac arg = prtac (1, Any) (TacArg (CAst.make arg)) let is_genarg tag wit = let ArgT.Any tag = tag in @@ -350,9 +350,9 @@ let string_of_genarg_arg (ArgumentType arg) = pr_extend_gen (pr_farg prtac) let pr_raw_alias prtac lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (CAst.make a)))) lev key args let pr_glob_alias prtac lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (CAst.make a)))) lev key args (**********************************************************************) (* The tactic printer *) @@ -579,7 +579,7 @@ let pr_goal_selector ~toplevel s = pr_gen arg else str name ++ str ":" ++ surround (pr_gen arg) - | _ -> pr_arg (TacArg (Loc.tag t)) in + | _ -> pr_arg (TacArg (CAst.make t)) in hov 0 (keyword k ++ spc () ++ pr_lname na ++ prlist pr_funvar bl ++ str " :=" ++ brk (1,1) ++ pr t) @@ -1045,30 +1045,30 @@ let pr_goal_selector ~toplevel s = | TacSelect (s, tac) -> pr_goal_selector ~toplevel:false s ++ spc () ++ pr_tac ltop tac, latom | TacId l -> keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom - | TacAtom (loc,t) -> + | TacAtom { CAst.loc; v=t } -> pr_with_comments ?loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom - | TacArg(_,Tacexp e) -> + | TacArg { CAst.v=Tacexp e } -> pr_tac inherited e, latom - | TacArg(_,ConstrMayEval (ConstrTerm c)) -> + | TacArg { CAst.v=ConstrMayEval (ConstrTerm c) } -> keyword "constr:" ++ pr.pr_constr c, latom - | TacArg(_,ConstrMayEval c) -> + | TacArg { CAst.v=ConstrMayEval c } -> pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval - | TacArg(_,TacFreshId l) -> + | TacArg { CAst.v=TacFreshId l } -> primitive "fresh" ++ pr_fresh_ids l, latom - | TacArg(_,TacGeneric arg) -> + | TacArg { CAst.v=TacGeneric arg } -> pr.pr_generic arg, latom - | TacArg(_,TacCall(_,(f,[]))) -> + | TacArg { CAst.v=TacCall {CAst.v=(f,[])} } -> pr.pr_reference f, latom - | TacArg(_,TacCall(loc,(f,l))) -> + | TacArg { CAst.v=TacCall {CAst.loc; v=(f,l)} } -> pr_with_comments ?loc (hov 1 ( pr.pr_reference f ++ spc () ++ prlist_with_sep spc pr_tacarg l)), lcall - | TacArg (_,a) -> + | TacArg { CAst.v=a } -> pr_tacarg a, latom - | TacML (loc,(s,l)) -> + | TacML { CAst.loc; v=(s,l) } -> pr_with_comments ?loc (pr.pr_extend 1 s l), lcall - | TacAlias (loc,(kn,l)) -> + | TacAlias { CAst.loc; v=(kn,l) } -> pr_with_comments ?loc (pr.pr_alias (level_of inherited) kn l), latom ) in @@ -1087,7 +1087,7 @@ let pr_goal_selector ~toplevel s = | TacNumgoals -> keyword "numgoals" | (TacCall _|Tacexp _ | TacGeneric _) as a -> - hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.tag a)))) + hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (CAst.make a)))) in pr_tac diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index db7dcfa6ef..3eb049dbab 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -251,7 +251,7 @@ let string_of_call ck = | Tacexpr.LtacVarCall (id, t) -> Names.Id.print id | Tacexpr.LtacAtomCall te -> (Pptactic.pr_glob_tactic (Global.env ()) - (Tacexpr.TacAtom (Loc.tag te))) + (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, _) -> pr_glob_constr_env (Global.env ()) c | Tacexpr.LtacMLCall te -> diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 7d917c58fe..fee469032c 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -528,7 +528,7 @@ let decompose_applied_relation env sigma (c,l) = let rewrite_db = "rewrite" -let conv_transparent_state = (Id.Pred.empty, Cpred.full) +let conv_transparent_state = TransparentState.cst_full let rewrite_transparent_state () = Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) @@ -537,8 +537,8 @@ let rewrite_core_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; - Unification.modulo_delta = empty_transparent_state; - Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta = TransparentState.empty; + Unification.modulo_delta_types = TransparentState.full; Unification.check_applied_meta_types = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; @@ -585,12 +585,12 @@ let general_rewrite_unif_flags () = Unification.modulo_conv_on_closed_terms = Some ts; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = ts; - Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta_types = TransparentState.full; Unification.modulo_betaiota = true } in { Unification.core_unify_flags = core_flags; Unification.merge_unify_flags = core_flags; - Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; + Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = TransparentState.empty }; Unification.allow_K_in_toplevel_higher_order_unification = true; Unification.resolve_evars = true } @@ -1958,7 +1958,7 @@ let add_setoid atts binders a aeq t n = let make_tactic name = let open Tacexpr in let tacqid = Libnames.qualid_of_string name in - TacArg (Loc.tag @@ (TacCall (Loc.tag (tacqid, [])))) + TacArg (CAst.make @@ (TacCall (CAst.make (tacqid, [])))) let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 0f88734caf..ac2d88dec2 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -177,7 +177,7 @@ let add_tactic_entry (kn, ml, tg) state = TacGeneric arg in let l = List.map map l in - (TacAlias (Loc.tag ~loc (kn,l)):raw_tactic_expr) + (TacAlias (CAst.make ~loc (kn,l)):raw_tactic_expr) in let () = if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then @@ -349,7 +349,7 @@ let extend_atomic_tactic name entries = | TacNonTerm (_, (symb, _)) -> let EntryName (typ, e) = prod_item_of_symbol 0 symb in let Genarg.Rawwit wit = typ in - let inj x = TacArg (Loc.tag @@ TacGeneric (Genarg.in_gen typ x)) in + let inj x = TacArg (CAst.make @@ TacGeneric (Genarg.in_gen typ x)) in let default = epsilon_value inj e in match default with | None -> raise NonEmptyArgument @@ -363,7 +363,7 @@ let extend_atomic_tactic name entries = | Some (id, args) -> let args = List.map (fun a -> Tacexp a) args in let entry = { mltac_name = name; mltac_index = i } in - let body = TacML (Loc.tag (entry, args)) in + let body = TacML (CAst.make (entry, args)) in Tacenv.register_ltac false false (Names.Id.of_string id) body in List.iteri add_atomic entries @@ -379,7 +379,7 @@ let add_ml_tactic_notation name ~level ?deprecation prods = let ids = List.map_filter get_id prods in let entry = { mltac_name = name; mltac_index = len - i - 1 } in let map id = Reference (Locus.ArgVar (CAst.make id)) in - let tac = TacML (Loc.tag (entry, List.map map ids)) in + let tac = TacML (CAst.make (entry, List.map map ids)) in add_glob_tactic_notation false ~level ?deprecation prods true ids tac in List.iteri iter (List.rev prods); @@ -664,7 +664,7 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = (** Arguments are not passed directly to the ML tactic in the TacML node, the ML tactic retrieves its arguments in the [ist] environment instead. This is the rôle of the [lift_constr_tac_to_ml_tac] function. *) - let body = Tacexpr.TacFun (vars, Tacexpr.TacML (Loc.tag (ml, [])))in + let body = Tacexpr.TacFun (vars, Tacexpr.TacML (CAst.make (ml, [])))in let id = Names.Id.of_string name in let obj () = Tacenv.register_ltac true false id body ?deprecation in let () = Tacenv.register_ml_tactic ml_tactic_name [|tac|] in @@ -697,10 +697,10 @@ type ('b, 'c) argument_interp = | ArgInterpFun : ('b, Val.t) interp_fun -> ('b, 'c) argument_interp | ArgInterpWit : ('a, 'b, 'r) Genarg.genarg_type -> ('b, 'c) argument_interp | ArgInterpLegacy : - (Geninterp.interp_sign -> Proof_type.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp + (Geninterp.interp_sign -> Goal.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp type ('a, 'b, 'c) tactic_argument = { - arg_parsing : 'a Vernacentries.argument_rule; + arg_parsing : 'a Vernacextend.argument_rule; arg_tag : 'c Val.tag option; arg_intern : ('a, 'b) argument_intern; arg_subst : 'b argument_subst; @@ -751,10 +751,10 @@ let argument_extend (type a b c) ~name (arg : (a, b, c) tactic_argument) = in let () = register_interp0 wit (interp_fun name arg tag) in let entry = match arg.arg_parsing with - | Vernacentries.Arg_alias e -> + | Vernacextend.Arg_alias e -> let () = Pcoq.register_grammar wit e in e - | Vernacentries.Arg_rules rules -> + | Vernacextend.Arg_rules rules -> let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in let () = Pcoq.grammar_extend e None (None, [(None, None, rules)]) in e diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index c93d6251e0..309db539d0 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -125,10 +125,10 @@ type ('b, 'c) argument_interp = | ArgInterpFun : ('b, Geninterp.Val.t) Geninterp.interp_fun -> ('b, 'c) argument_interp | ArgInterpWit : ('a, 'b, 'r) Genarg.genarg_type -> ('b, 'c) argument_interp | ArgInterpLegacy : - (Geninterp.interp_sign -> Proof_type.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp + (Geninterp.interp_sign -> Goal.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp type ('a, 'b, 'c) tactic_argument = { - arg_parsing : 'a Vernacentries.argument_rule; + arg_parsing : 'a Vernacextend.argument_rule; arg_tag : 'c Geninterp.Val.tag option; arg_intern : ('a, 'b) argument_intern; arg_subst : 'b argument_subst; diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 8731cbf60d..9435d0b911 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -167,7 +167,7 @@ type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref - | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located + | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t | TacFreshId of string or_var list | Tacexp of 'tacexpr | TacPretype of 'trm @@ -189,7 +189,7 @@ constraint 'a = < 'r : ltac refs, 'n : idents, 'l : levels *) and 'a gen_tactic_expr = - | TacAtom of ('a gen_atomic_tactic_expr) Loc.located + | TacAtom of ('a gen_atomic_tactic_expr) CAst.t | TacThen of 'a gen_tactic_expr * 'a gen_tactic_expr @@ -245,12 +245,12 @@ and 'a gen_tactic_expr = | TacMatchGoal of lazy_flag * direction_flag * ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located + | TacArg of 'a gen_tactic_arg CAst.t | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) - | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) CAst.t (* For syntax extensions *) - | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located + | TacAlias of (KerName.t * 'a gen_tactic_arg list) CAst.t constraint 'a = < term:'t; diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 9958d6dcda..1527724420 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -167,7 +167,7 @@ type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref - | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located + | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t | TacFreshId of string or_var list | Tacexp of 'tacexpr | TacPretype of 'trm @@ -189,7 +189,7 @@ constraint 'a = < 'r : ltac refs, 'n : idents, 'l : levels *) and 'a gen_tactic_expr = - | TacAtom of ('a gen_atomic_tactic_expr) Loc.located + | TacAtom of ('a gen_atomic_tactic_expr) CAst.t | TacThen of 'a gen_tactic_expr * 'a gen_tactic_expr @@ -245,12 +245,12 @@ and 'a gen_tactic_expr = | TacMatchGoal of lazy_flag * direction_flag * ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located + | TacArg of 'a gen_tactic_arg CAst.t | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) - | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) CAst.t (* For syntax extensions *) - | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located + | TacAlias of (KerName.t * 'a gen_tactic_arg list) CAst.t constraint 'a = < term:'t; diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index ebec3c887c..85c6348b52 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -137,7 +137,7 @@ let intern_isolated_global_tactic_reference qid = let kn = Tacenv.locate_tactic qid in Option.iter (fun depr -> warn_deprecated_tactic ?loc (qid,depr)) @@ Tacenv.tac_deprecation kn; - TacCall (Loc.tag ?loc (ArgArg (loc,kn),[])) + TacCall (CAst.make ?loc (ArgArg (loc,kn),[])) let intern_isolated_tactic_reference strict ist qid = (* An ltac reference *) @@ -587,10 +587,10 @@ let rec intern_atomic lf ist x = and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) and intern_tactic_seq onlytac ist = function - | TacAtom (loc,t) -> + | TacAtom { loc; v=t } -> let lf = ref ist.ltacvars in let t = intern_atomic lf ist t in - !lf, TacAtom (Loc.tag ?loc:(adjust_loc loc) t) + !lf, TacAtom (CAst.make ?loc:(adjust_loc loc) t) | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) | TacLetIn (isrec,l,u) -> let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in @@ -659,27 +659,27 @@ and intern_tactic_seq onlytac ist = function | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) - | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a + | TacArg { loc; v=a } -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a | TacSelect (sel, tac) -> ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) (* For extensions *) - | TacAlias (loc,(s,l)) -> + | TacAlias { loc; v=(s,l) } -> let alias = Tacenv.interp_alias s in Option.iter (fun o -> warn_deprecated_alias ?loc (s,o)) @@ alias.Tacenv.alias_deprecation; let l = List.map (intern_tacarg !strict_check false ist) l in - ist.ltacvars, TacAlias (Loc.tag ?loc (s,l)) - | TacML (loc,(opn,l)) -> + ist.ltacvars, TacAlias (CAst.make ?loc (s,l)) + | TacML { loc; v=(opn,l) } -> let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (loc, (opn,List.map (intern_tacarg !strict_check false ist) l)) + ist.ltacvars, TacML CAst.(make ?loc (opn,List.map (intern_tacarg !strict_check false ist) l)) and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with | TacCall _ | Reference _ - | TacGeneric _ as a -> TacArg (loc,a) + | TacGeneric _ as a -> TacArg CAst.(make ?loc a) | Tacexp a -> a | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected ?loc else TacArg (loc,a) + if onlytac then error_tactic_expected ?loc else TacArg CAst.(make ?loc a) and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -692,9 +692,9 @@ and intern_tactic_fun ist (var,body) = and intern_tacarg strict onlytac ist = function | Reference r -> intern_non_tactic_reference strict ist r | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) - | TacCall (loc,(f,[])) -> intern_isolated_tactic_reference strict ist f - | TacCall (loc,(f,l)) -> - TacCall (Loc.tag ?loc ( + | TacCall { loc; v=(f,[]) } -> intern_isolated_tactic_reference strict ist f + | TacCall { loc; v=(f,l) } -> + TacCall (CAst.make ?loc ( intern_applied_tactic_reference ist f, List.map (intern_tacarg !strict_check false ist) l)) | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 2a046a3e65..cb3a0aaed9 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -543,7 +543,6 @@ let interp_gen kind ist pattern_mode flags env sigma c = let constr_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = true; expand_evars = true } @@ -558,21 +557,18 @@ let interp_type = interp_constr_gen IsType let open_constr_use_classes_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } let open_constr_no_classes_flags () = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } let pure_open_constr_flags = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = None; fail_evar = false; expand_evars = false } @@ -987,7 +983,7 @@ let rec read_match_rule lfun ist env sigma = function | [] -> [] (* Fully evaluate an untyped constr *) -let type_uconstr ?(flags = {(constr_flags ()) with use_hook = None }) +let type_uconstr ?(flags = (constr_flags ())) ?(expected_type = WithoutTypeConstraint) ist c = begin fun env sigma -> let { closure; term } = c in @@ -1022,7 +1018,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti | TacLetIn (false,l,u) -> interp_letin ist l u | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr - | TacArg (loc,a) -> interp_tacarg ist a + | TacArg {loc;v} -> interp_tacarg ist v | t -> (** Delayed evaluation *) Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) @@ -1040,7 +1036,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti and eval_tactic ist tac : unit Proofview.tactic = match tac with - | TacAtom (loc,t) -> + | TacAtom {loc;v=t} -> let call = LtacAtomCall t in push_trace(loc,call) ist >>= fun trace -> Profile_ltac.do_profile "eval_tactic:2" trace @@ -1120,7 +1116,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with eval_tactic ist tac | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) - | TacAlias (loc,(s,l)) -> + | TacAlias {loc; v=(s,l)} -> let alias = Tacenv.interp_alias s in let (>>=) = Ftactic.bind in let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in @@ -1151,7 +1147,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - | TacML (loc,(opn,l)) -> + | TacML {loc; v=(opn,l)} -> push_trace (Loc.tag ?loc @@ LtacMLCall tac) ist >>= fun trace -> let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in let tac = Tacenv.interp_ml_tactic opn in @@ -1205,9 +1201,9 @@ and interp_tacarg ist arg : Val.t Ftactic.t = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return (Value.of_constr c_interp)) end - | TacCall (loc,(r,[])) -> + | TacCall { v=(r,[]) } -> interp_ltac_reference true ist r - | TacCall (loc,(f,l)) -> + | TacCall { loc; v=(f,l) } -> let (>>=) = Ftactic.bind in interp_ltac_reference true ist f >>= fun fv -> Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> @@ -1341,7 +1337,7 @@ and interp_letrec ist llc u = Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) let lref = ref ist.lfun in let fold accu ({v=na}, b) = - let v = of_tacvalue (VRec (lref, TacArg (Loc.tag b))) in + let v = of_tacvalue (VRec (lref, TacArg (CAst.make b))) in Name.fold_right (fun id -> Id.Map.add id v) na accu in let lfun = List.fold_left fold ist.lfun llc in @@ -1879,7 +1875,7 @@ module Value = struct let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in let lfun = Id.Map.add (Id.of_string "F") f lfun in let ist = { (default_ist ()) with lfun = lfun; } in - let tac = TacArg(Loc.tag @@ TacCall (Loc.tag (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in eval_tactic_ist ist tac end diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 4626378db6..caaa547a07 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -88,20 +88,9 @@ let subst_reference subst = (*CSC: subst_global_reference is used "only" for RefArgType, that propagates to the syntactic non-terminals "global", used in commands such as Print. It is also used for non-evaluable references. *) -open Pp -open Printer let subst_global_reference subst = - let subst_global ref = - let ref',t' = subst_global subst ref in - if not (is_global ref' t') then - (let sigma, env = Pfedit.get_current_context () in - Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ - str " expanded to \"" ++ pr_lconstr_env env sigma t' ++ str "\", but to " ++ - pr_global ref')); - ref' - in - subst_or_var (subst_located subst_global) + subst_or_var (subst_located (subst_global_reference subst)) let subst_evaluable subst = let subst_eval_ref = subst_evaluable_reference subst in @@ -184,7 +173,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) and subst_tactic subst (t:glob_tactic_expr) = match t with - | TacAtom (_loc,t) -> TacAtom (Loc.tag @@ subst_atomic subst t) + | TacAtom { CAst.v=t } -> TacAtom (CAst.make @@ subst_atomic subst t) | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) | TacLetIn (r,l,u) -> let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in @@ -231,22 +220,22 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) | TacComplete tac -> TacComplete (subst_tactic subst tac) - | TacArg (_,a) -> TacArg (Loc.tag @@ subst_tacarg subst a) + | TacArg { CAst.v=a } -> TacArg (CAst.make @@ subst_tacarg subst a) | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) (* For extensions *) - | TacAlias (_,(s,l)) -> + | TacAlias { CAst.v=(s,l) } -> let s = subst_kn subst s in - TacAlias (Loc.tag (s,List.map (subst_tacarg subst) l)) - | TacML (loc,(opn,l)) -> TacML (loc, (opn,List.map (subst_tacarg subst) l)) + TacAlias (CAst.make (s,List.map (subst_tacarg subst) l)) + | TacML { CAst.loc; v=(opn,l)} -> TacML CAst.(make ?loc (opn,List.map (subst_tacarg subst) l)) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) and subst_tacarg subst = function | Reference r -> Reference (subst_reference subst r) | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) - | TacCall (loc,(f,l)) -> - TacCall (Loc.tag ?loc (subst_reference subst f, List.map (subst_tacarg subst) l)) + | TacCall { CAst.loc; v=(f,l) } -> + TacCall CAst.(make ?loc (subst_reference subst f, List.map (subst_tacarg subst) l)) | TacFreshId _ as x -> x | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 6bab8d0353..877d4ee758 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -365,7 +365,7 @@ let explain_ltac_call_trace last trace loc = Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" | Tacexpr.LtacAtomCall te -> quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (Loc.tag te))) + (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, { Ltac_pretype.ltac_constrs = vars }) -> quote (Printer.pr_glob_constr_env (Global.env()) c) ++ (if not (Id.Map.is_empty vars) then diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 299bc7ea4d..561bfc5d7c 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -191,7 +191,7 @@ let make_unfold name = let u_not = make_unfold "not" let reduction_not_iff _ ist = - let make_reduce c = TacAtom (Loc.tag @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let make_reduce c = TacAtom (CAst.make @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in let tac = match !negation_unfolding with | true -> make_reduce [u_not] | false -> TacId [] @@ -244,7 +244,7 @@ let with_flags flags _ ist = let x = CAst.make @@ Id.of_string "x" in let arg = Val.Dyn (tag_tauto_flags, flags) in let ist = { ist with lfun = Id.Map.add x.CAst.v arg ist.lfun } in - eval_tactic_ist ist (TacArg (Loc.tag @@ TacCall (Loc.tag (Locus.ArgVar f, [Reference (Locus.ArgVar x)])))) + eval_tactic_ist ist (TacArg (CAst.make @@ TacCall (CAst.make (Locus.ArgVar f, [Reference (Locus.ArgVar x)])))) let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in @@ -252,7 +252,7 @@ let register_tauto_tactic tac name0 args = let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in let entry = { mltac_name = name; mltac_index = 0 } in let () = Tacenv.register_ml_tactic name [| tac |] in - let tac = TacFun (ids, TacML (Loc.tag (entry, []))) in + let tac = TacFun (ids, TacML (CAst.make (entry, []))) in let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in Mltop.declare_cache_obj obj tauto_plugin diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/setoid_ring/g_newring.mlg index 3ddea7eb30..f59ca4cef4 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/setoid_ring/g_newring.mlg @@ -86,7 +86,7 @@ END VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_theory id t l } - | [ "Print" "Rings" ] => {Vernac_classifier.classify_as_query} -> { + | [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> let sigma, env = Pfedit.get_current_context () in @@ -130,7 +130,7 @@ END VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_field_theory id t l } -| [ "Print" "Fields" ] => {Vernac_classifier.classify_as_query} -> { +| [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> let sigma, env = Pfedit.get_current_context () in diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index a2dce621d9..4109e9cf38 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -129,7 +129,7 @@ let closed_term_ast = fun l -> let l = List.map (fun gr -> ArgArg(Loc.tag gr)) l in TacFun([Name(Id.of_string"t")], - TacML(Loc.tag (tacname, + TacML(CAst.make (tacname, [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (DAst.make @@ GVar(Id.of_string"t"),None)); TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))) (* @@ -160,7 +160,7 @@ let decl_constant na univs c = (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = - TacArg(Loc.tag @@ TacCall (Loc.tag (ArgArg(Loc.tag @@ Lazy.force tac),args))) + TacArg(CAst.make @@ TacCall (CAst.make (ArgArg(Loc.tag @@ Lazy.force tac),args))) let dummy_goal env sigma = let (gl,_,sigma) = @@ -197,7 +197,7 @@ let exec_tactic env evd n f args = (** Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in - let get_res = TacML (Loc.tag (get_res, [TacGeneric n])) in + let get_res = TacML (CAst.make (get_res, [TacGeneric n])) in let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in @@ -557,7 +557,7 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = closed_term_ast (List.map Smartlocate.global_with_alias lc) | None -> let t = ArgArg(Loc.tag @@ Lazy.force ltac_inv_morph_nothing) in - TacArg(Loc.tag (TacCall(Loc.tag (t,[])))) + TacArg(CAst.make (TacCall(CAst.make (t,[])))) let make_hyp env evd c = let t = Retyping.get_type_of env !evd c in @@ -582,7 +582,7 @@ let interp_power env evdref pow = match pow with | None -> let t = ArgArg(Loc.tag (Lazy.force ltac_inv_morph_nothing)) in - (TacArg(Loc.tag (TacCall(Loc.tag (t,[])))), plapp evdref coq_None [|carrier|]) + (TacArg(CAst.make (TacCall(CAst.make (t,[])))), plapp evdref coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index 0865f75ec5..3a7cf41d43 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -10,264 +10,266 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) + Require Bool. Require Import ssreflect ssrfun. -(******************************************************************************) -(* A theory of boolean predicates and operators. A large part of this file is *) -(* concerned with boolean reflection. *) -(* Definitions and notations: *) -(* is_true b == the coercion of b : bool to Prop (:= b = true). *) -(* This is just input and displayed as `b''. *) -(* reflect P b == the reflection inductive predicate, asserting *) -(* that the logical proposition P : prop with the *) -(* formula b : bool. Lemmas asserting reflect P b *) -(* are often referred to as "views". *) -(* iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection *) -(* views: iffP is used to prove reflection from *) -(* logical equivalence, appP to compose views, and *) -(* sameP and rwP to perform boolean and setoid *) -(* rewriting. *) -(* elimT :: coercion reflect >-> Funclass, which allows the *) -(* direct application of `reflect' views to *) -(* boolean assertions. *) -(* decidable P <-> P is effectively decidable (:= {P} + {~ P}. *) -(* contra, contraL, ... :: contraposition lemmas. *) -(* altP my_viewP :: natural alternative for reflection; given *) -(* lemma myviewP: reflect my_Prop my_formula, *) -(* have [myP | not_myP] := altP my_viewP. *) -(* generates two subgoals, in which my_formula has *) -(* been replaced by true and false, resp., with *) -(* new assumptions myP : my_Prop and *) -(* not_myP: ~~ my_formula. *) -(* Caveat: my_formula must be an APPLICATION, not *) -(* a variable, constant, let-in, etc. (due to the *) -(* poor behaviour of dependent index matching). *) -(* boolP my_formula :: boolean disjunction, equivalent to *) -(* altP (idP my_formula) but circumventing the *) -(* dependent index capture issue; destructing *) -(* boolP my_formula generates two subgoals with *) -(* assumtions my_formula and ~~ myformula. As *) -(* with altP, my_formula must be an application. *) -(* \unless C, P <-> we can assume property P when a something that *) -(* holds under condition C (such as C itself). *) -(* := forall G : Prop, (C -> G) -> (P -> G) -> G. *) -(* This is just C \/ P or rather its impredicative *) -(* encoding, whose usage better fits the above *) -(* description: given a lemma UCP whose conclusion *) -(* is \unless C, P we can assume P by writing: *) -(* wlog hP: / P by apply/UCP; (prove C -> goal). *) -(* or even apply: UCP id _ => hP if the goal is C. *) -(* classically P <-> we can assume P when proving is_true b. *) -(* := forall b : bool, (P -> b) -> b. *) -(* This is equivalent to ~ (~ P) when P : Prop. *) -(* implies P Q == wrapper variant type that coerces to P -> Q and *) -(* can be used as a P -> Q view unambigously. *) -(* Useful to avoid spurious insertion of <-> views *) -(* when Q is a conjunction of foralls, as in Lemma *) -(* all_and2 below; conversely, avoids confusion in *) -(* apply views for impredicative properties, such *) -(* as \unless C, P. Also supports contrapositives. *) -(* a && b == the boolean conjunction of a and b. *) -(* a || b == the boolean disjunction of a and b. *) -(* a ==> b == the boolean implication of b by a. *) -(* ~~ a == the boolean negation of a. *) -(* a (+) b == the boolean exclusive or (or sum) of a and b. *) -(* [ /\ P1 , P2 & P3 ] == multiway logical conjunction, up to 5 terms. *) -(* [ \/ P1 , P2 | P3 ] == multiway logical disjunction, up to 4 terms. *) -(* [&& a, b, c & d] == iterated, right associative boolean conjunction *) -(* with arbitrary arity. *) -(* [|| a, b, c | d] == iterated, right associative boolean disjunction *) -(* with arbitrary arity. *) -(* [==> a, b, c => d] == iterated, right associative boolean implication *) -(* with arbitrary arity. *) -(* and3P, ... == specific reflection lemmas for iterated *) -(* connectives. *) -(* andTb, orbAC, ... == systematic names for boolean connective *) -(* properties (see suffix conventions below). *) -(* prop_congr == a tactic to move a boolean equality from *) -(* its coerced form in Prop to the equality *) -(* in bool. *) -(* bool_congr == resolution tactic for blindly weeding out *) -(* like terms from boolean equalities (can fail). *) -(* This file provides a theory of boolean predicates and relations: *) -(* pred T == the type of bool predicates (:= T -> bool). *) -(* simpl_pred T == the type of simplifying bool predicates, using *) -(* the simpl_fun from ssrfun.v. *) -(* rel T == the type of bool relations. *) -(* := T -> pred T or T -> T -> bool. *) -(* simpl_rel T == type of simplifying relations. *) -(* predType == the generic predicate interface, supported for *) -(* for lists and sets. *) -(* pred_class == a coercion class for the predType projection to *) -(* pred; declaring a coercion to pred_class is an *) -(* alternative way of equipping a type with a *) -(* predType structure, which interoperates better *) -(* with coercion subtyping. This is used, e.g., *) -(* for finite sets, so that finite groups inherit *) -(* the membership operation by coercing to sets. *) -(* If P is a predicate the proposition "x satisfies P" can be written *) -(* applicatively as (P x), or using an explicit connective as (x \in P); in *) -(* the latter case we say that P is a "collective" predicate. We use A, B *) -(* rather than P, Q for collective predicates: *) -(* x \in A == x satisfies the (collective) predicate A. *) -(* x \notin A == x doesn't satisfy the (collective) predicate A. *) -(* The pred T type can be used as a generic predicate type for either kind, *) -(* but the two kinds of predicates should not be confused. When a "generic" *) -(* pred T value of one type needs to be passed as the other the following *) -(* conversions should be used explicitly: *) -(* SimplPred P == a (simplifying) applicative equivalent of P. *) -(* mem A == an applicative equivalent of A: *) -(* mem A x simplifies to x \in A. *) -(* Alternatively one can use the syntax for explicit simplifying predicates *) -(* and relations (in the following x is bound in E): *) -(* [pred x | E] == simplifying (see ssrfun) predicate x => E. *) -(* [pred x : T | E] == predicate x => E, with a cast on the argument. *) -(* [pred : T | P] == constant predicate P on type T. *) -(* [pred x | E1 & E2] == [pred x | E1 && E2]; an x : T cast is allowed. *) -(* [pred x in A] == [pred x | x in A]. *) -(* [pred x in A | E] == [pred x | x in A & E]. *) -(* [pred x in A | E1 & E2] == [pred x in A | E1 && E2]. *) -(* [predU A & B] == union of two collective predicates A and B. *) -(* [predI A & B] == intersection of collective predicates A and B. *) -(* [predD A & B] == difference of collective predicates A and B. *) -(* [predC A] == complement of the collective predicate A. *) -(* [preim f of A] == preimage under f of the collective predicate A. *) -(* predU P Q, ... == union, etc of applicative predicates. *) -(* pred0 == the empty predicate. *) -(* predT == the total (always true) predicate. *) -(* if T : predArgType, then T coerces to predT. *) -(* {: T} == T cast to predArgType (e.g., {: bool * nat}) *) -(* In the following, x and y are bound in E: *) -(* [rel x y | E] == simplifying relation x, y => E. *) -(* [rel x y : T | E] == simplifying relation with arguments cast. *) -(* [rel x y in A & B | E] == [rel x y | [&& x \in A, y \in B & E]]. *) -(* [rel x y in A & B] == [rel x y | (x \in A) && (y \in B)]. *) -(* [rel x y in A | E] == [rel x y in A & A | E]. *) -(* [rel x y in A] == [rel x y in A & A]. *) -(* relU R S == union of relations R and S. *) -(* Explicit values of type pred T (i.e., lamdba terms) should always be used *) -(* applicatively, while values of collection types implementing the predType *) -(* interface, such as sequences or sets should always be used as collective *) -(* predicates. Defined constants and functions of type pred T or simpl_pred T *) -(* as well as the explicit simpl_pred T values described below, can generally *) -(* be used either way. Note however that x \in A will not auto-simplify when *) -(* A is an explicit simpl_pred T value; the generic simplification rule inE *) -(* must be used (when A : pred T, the unfold_in rule can be used). Constants *) -(* of type pred T with an explicit simpl_pred value do not auto-simplify when *) -(* used applicatively, but can still be expanded with inE. This behavior can *) -(* be controlled as follows: *) -(* Let A : collective_pred T := [pred x | ... ]. *) -(* The collective_pred T type is just an alias for pred T, but this cast *) -(* stops rewrite inE from expanding the definition of A, thus treating A *) -(* into an abstract collection (unfold_in or in_collective can be used to *) -(* expand manually). *) -(* Let A : applicative_pred T := [pred x | ...]. *) -(* This cast causes inE to turn x \in A into the applicative A x form; *) -(* A will then have to unfolded explicitly with the /A rule. This will *) -(* also apply to any definition that reduces to A (e.g., Let B := A). *) -(* Canonical A_app_pred := ApplicativePred A. *) -(* This declaration, given after definition of A, similarly causes inE to *) -(* turn x \in A into A x, but in addition allows the app_predE rule to *) -(* turn A x back into x \in A; it can be used for any definition of type *) -(* pred T, which makes it especially useful for ambivalent predicates *) -(* as the relational transitive closure connect, that are used in both *) -(* applicative and collective styles. *) -(* Purely for aesthetics, we provide a subtype of collective predicates: *) -(* qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T *) -(* coerces to pred_class and thus behaves as a collective *) -(* predicate, but x \in A and x \notin A are displayed as: *) -(* x \is A and x \isn't A when q = 0, *) -(* x \is a A and x \isn't a A when q = 1, *) -(* x \is an A and x \isn't an A when q = 2, respectively. *) -(* [qualify x | P] := Qualifier 0 (fun x => P), constructor for the above. *) -(* [qualify x : T | P], [qualify a x | P], [qualify an X | P], etc. *) -(* variants of the above with type constraints and different *) -(* values of q. *) -(* We provide an internal interface to support attaching properties (such as *) -(* being multiplicative) to predicates: *) -(* pred_key p == phantom type that will serve as a support for properties *) -(* to be attached to p : pred_class; instances should be *) -(* created with Fact/Qed so as to be opaque. *) -(* KeyedPred k_p == an instance of the interface structure that attaches *) -(* (k_p : pred_key P) to P; the structure projection is a *) -(* coercion to pred_class. *) -(* KeyedQualifier k_q == an instance of the interface structure that attaches *) -(* (k_q : pred_key q) to (q : qualifier n T). *) -(* DefaultPredKey p == a default value for pred_key p; the vernacular command *) -(* Import DefaultKeying attaches this key to all predicates *) -(* that are not explicitly keyed. *) -(* Keys can be used to attach properties to predicates, qualifiers and *) -(* generic nouns in a way that allows them to be used transparently. The key *) -(* projection of a predicate property structure such as unsignedPred should *) -(* be a pred_key, not a pred, and corresponding lemmas will have the form *) -(* Lemma rpredN R S (oppS : @opprPred R S) (kS : keyed_pred oppS) : *) -(* {mono -%R: x / x \in kS}. *) -(* Because x \in kS will be displayed as x \in S (or x \is S, etc), the *) -(* canonical instance of opprPred will not normally be exposed (it will also *) -(* be erased by /= simplification). In addition each predicate structure *) -(* should have a DefaultPredKey Canonical instance that simply issues the *) -(* property as a proof obligation (which can be caught by the Prop-irrelevant *) -(* feature of the ssreflect plugin). *) -(* Some properties of predicates and relations: *) -(* A =i B <-> A and B are extensionally equivalent. *) -(* {subset A <= B} <-> A is a (collective) subpredicate of B. *) -(* subpred P Q <-> P is an (applicative) subpredicate or Q. *) -(* subrel R S <-> R is a subrelation of S. *) -(* In the following R is in rel T: *) -(* reflexive R <-> R is reflexive. *) -(* irreflexive R <-> R is irreflexive. *) -(* symmetric R <-> R (in rel T) is symmetric (equation). *) -(* pre_symmetric R <-> R is symmetric (implication). *) -(* antisymmetric R <-> R is antisymmetric. *) -(* total R <-> R is total. *) -(* transitive R <-> R is transitive. *) -(* left_transitive R <-> R is a congruence on its left hand side. *) -(* right_transitive R <-> R is a congruence on its right hand side. *) -(* equivalence_rel R <-> R is an equivalence relation. *) -(* Localization of (Prop) predicates; if P1 is convertible to forall x, Qx, *) -(* P2 to forall x y, Qxy and P3 to forall x y z, Qxyz : *) -(* {for y, P1} <-> Qx{y / x}. *) -(* {in A, P1} <-> forall x, x \in A -> Qx. *) -(* {in A1 & A2, P2} <-> forall x y, x \in A1 -> y \in A2 -> Qxy. *) -(* {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. *) -(* {in A1 & A2 & A3, Q3} <-> forall x y z, *) -(* x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. *) -(* {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. *) -(* {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. *) -(* {in A &&, Q3} == {in A & A & A, Q3}. *) -(* {in A, bijective f} == f has a right inverse in A. *) -(* {on C, P1} == forall x, (f x) \in C -> Qx *) -(* when P1 is also convertible to Pf f. *) -(* {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy *) -(* when P2 is also convertible to Pf f. *) -(* {on C, P1' & g} == forall x, (f x) \in cd -> Qx *) -(* when P1' is convertible to Pf f *) -(* and P1' g is convertible to forall x, Qx. *) -(* {on C, bijective f} == f has a right inverse on C. *) -(* This file extends the lemma name suffix conventions of ssrfun as follows: *) -(* A -- associativity, as in andbA : associative andb. *) -(* AC -- right commutativity. *) -(* ACA -- self-interchange (inner commutativity), e.g., *) -(* orbACA : (a || b) || (c || d) = (a || c) || (b || d). *) -(* b -- a boolean argument, as in andbb : idempotent andb. *) -(* C -- commutativity, as in andbC : commutative andb, *) -(* or predicate complement, as in predC. *) -(* CA -- left commutativity. *) -(* D -- predicate difference, as in predD. *) -(* E -- elimination, as in negbFE : ~~ b = false -> b. *) -(* F or f -- boolean false, as in andbF : b && false = false. *) -(* I -- left/right injectivity, as in addbI : right_injective addb, *) -(* or predicate intersection, as in predI. *) -(* l -- a left-hand operation, as andb_orl : left_distributive andb orb. *) -(* N or n -- boolean negation, as in andbN : a && (~~ a) = false. *) -(* P -- a characteristic property, often a reflection lemma, as in *) -(* andP : reflect (a /\ b) (a && b). *) -(* r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. *) -(* T or t -- boolean truth, as in andbT: right_id true andb. *) -(* U -- predicate union, as in predU. *) -(* W -- weakening, as in in1W : {in D, forall x, P} -> forall x, P. *) -(******************************************************************************) +(** + A theory of boolean predicates and operators. A large part of this file is + concerned with boolean reflection. + Definitions and notations: + is_true b == the coercion of b : bool to Prop (:= b = true). + This is just input and displayed as `b''. + reflect P b == the reflection inductive predicate, asserting + that the logical proposition P : prop with the + formula b : bool. Lemmas asserting reflect P b + are often referred to as "views". + iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection + views: iffP is used to prove reflection from + logical equivalence, appP to compose views, and + sameP and rwP to perform boolean and setoid + rewriting. + elimT :: coercion reflect >-> Funclass, which allows the + direct application of `reflect' views to + boolean assertions. + decidable P <-> P is effectively decidable (:= {P} + {~ P}. + contra, contraL, ... :: contraposition lemmas. + altP my_viewP :: natural alternative for reflection; given + lemma myviewP: reflect my_Prop my_formula, + have #[#myP | not_myP#]# := altP my_viewP. + generates two subgoals, in which my_formula has + been replaced by true and false, resp., with + new assumptions myP : my_Prop and + not_myP: ~~ my_formula. + Caveat: my_formula must be an APPLICATION, not + a variable, constant, let-in, etc. (due to the + poor behaviour of dependent index matching). + boolP my_formula :: boolean disjunction, equivalent to + altP (idP my_formula) but circumventing the + dependent index capture issue; destructing + boolP my_formula generates two subgoals with + assumtions my_formula and ~~ myformula. As + with altP, my_formula must be an application. + \unless C, P <-> we can assume property P when a something that + holds under condition C (such as C itself). + := forall G : Prop, (C -> G) -> (P -> G) -> G. + This is just C \/ P or rather its impredicative + encoding, whose usage better fits the above + description: given a lemma UCP whose conclusion + is \unless C, P we can assume P by writing: + wlog hP: / P by apply/UCP; (prove C -> goal). + or even apply: UCP id _ => hP if the goal is C. + classically P <-> we can assume P when proving is_true b. + := forall b : bool, (P -> b) -> b. + This is equivalent to ~ (~ P) when P : Prop. + implies P Q == wrapper variant type that coerces to P -> Q and + can be used as a P -> Q view unambigously. + Useful to avoid spurious insertion of <-> views + when Q is a conjunction of foralls, as in Lemma + all_and2 below; conversely, avoids confusion in + apply views for impredicative properties, such + as \unless C, P. Also supports contrapositives. + a && b == the boolean conjunction of a and b. + a || b == the boolean disjunction of a and b. + a ==> b == the boolean implication of b by a. + ~~ a == the boolean negation of a. + a (+) b == the boolean exclusive or (or sum) of a and b. + #[# /\ P1 , P2 & P3 #]# == multiway logical conjunction, up to 5 terms. + #[# \/ P1 , P2 | P3 #]# == multiway logical disjunction, up to 4 terms. + #[#&& a, b, c & d#]# == iterated, right associative boolean conjunction + with arbitrary arity. + #[#|| a, b, c | d#]# == iterated, right associative boolean disjunction + with arbitrary arity. + #[#==> a, b, c => d#]# == iterated, right associative boolean implication + with arbitrary arity. + and3P, ... == specific reflection lemmas for iterated + connectives. + andTb, orbAC, ... == systematic names for boolean connective + properties (see suffix conventions below). + prop_congr == a tactic to move a boolean equality from + its coerced form in Prop to the equality + in bool. + bool_congr == resolution tactic for blindly weeding out + like terms from boolean equalities (can fail). + This file provides a theory of boolean predicates and relations: + pred T == the type of bool predicates (:= T -> bool). + simpl_pred T == the type of simplifying bool predicates, using + the simpl_fun from ssrfun.v. + rel T == the type of bool relations. + := T -> pred T or T -> T -> bool. + simpl_rel T == type of simplifying relations. + predType == the generic predicate interface, supported for + for lists and sets. + pred_class == a coercion class for the predType projection to + pred; declaring a coercion to pred_class is an + alternative way of equipping a type with a + predType structure, which interoperates better + with coercion subtyping. This is used, e.g., + for finite sets, so that finite groups inherit + the membership operation by coercing to sets. + If P is a predicate the proposition "x satisfies P" can be written + applicatively as (P x), or using an explicit connective as (x \in P); in + the latter case we say that P is a "collective" predicate. We use A, B + rather than P, Q for collective predicates: + x \in A == x satisfies the (collective) predicate A. + x \notin A == x doesn't satisfy the (collective) predicate A. + The pred T type can be used as a generic predicate type for either kind, + but the two kinds of predicates should not be confused. When a "generic" + pred T value of one type needs to be passed as the other the following + conversions should be used explicitly: + SimplPred P == a (simplifying) applicative equivalent of P. + mem A == an applicative equivalent of A: + mem A x simplifies to x \in A. + Alternatively one can use the syntax for explicit simplifying predicates + and relations (in the following x is bound in E): + #[#pred x | E#]# == simplifying (see ssrfun) predicate x => E. + #[#pred x : T | E#]# == predicate x => E, with a cast on the argument. + #[#pred : T | P#]# == constant predicate P on type T. + #[#pred x | E1 & E2#]# == #[#pred x | E1 && E2#]#; an x : T cast is allowed. + #[#pred x in A#]# == #[#pred x | x in A#]#. + #[#pred x in A | E#]# == #[#pred x | x in A & E#]#. + #[#pred x in A | E1 & E2#]# == #[#pred x in A | E1 && E2#]#. + #[#predU A & B#]# == union of two collective predicates A and B. + #[#predI A & B#]# == intersection of collective predicates A and B. + #[#predD A & B#]# == difference of collective predicates A and B. + #[#predC A#]# == complement of the collective predicate A. + #[#preim f of A#]# == preimage under f of the collective predicate A. + predU P Q, ... == union, etc of applicative predicates. + pred0 == the empty predicate. + predT == the total (always true) predicate. + if T : predArgType, then T coerces to predT. + {: T} == T cast to predArgType (e.g., {: bool * nat}) + In the following, x and y are bound in E: + #[#rel x y | E#]# == simplifying relation x, y => E. + #[#rel x y : T | E#]# == simplifying relation with arguments cast. + #[#rel x y in A & B | E#]# == #[#rel x y | #[#&& x \in A, y \in B & E#]# #]#. + #[#rel x y in A & B#]# == #[#rel x y | (x \in A) && (y \in B) #]#. + #[#rel x y in A | E#]# == #[#rel x y in A & A | E#]#. + #[#rel x y in A#]# == #[#rel x y in A & A#]#. + relU R S == union of relations R and S. + Explicit values of type pred T (i.e., lamdba terms) should always be used + applicatively, while values of collection types implementing the predType + interface, such as sequences or sets should always be used as collective + predicates. Defined constants and functions of type pred T or simpl_pred T + as well as the explicit simpl_pred T values described below, can generally + be used either way. Note however that x \in A will not auto-simplify when + A is an explicit simpl_pred T value; the generic simplification rule inE + must be used (when A : pred T, the unfold_in rule can be used). Constants + of type pred T with an explicit simpl_pred value do not auto-simplify when + used applicatively, but can still be expanded with inE. This behavior can + be controlled as follows: + Let A : collective_pred T := #[#pred x | ... #]#. + The collective_pred T type is just an alias for pred T, but this cast + stops rewrite inE from expanding the definition of A, thus treating A + into an abstract collection (unfold_in or in_collective can be used to + expand manually). + Let A : applicative_pred T := #[#pred x | ... #]#. + This cast causes inE to turn x \in A into the applicative A x form; + A will then have to unfolded explicitly with the /A rule. This will + also apply to any definition that reduces to A (e.g., Let B := A). + Canonical A_app_pred := ApplicativePred A. + This declaration, given after definition of A, similarly causes inE to + turn x \in A into A x, but in addition allows the app_predE rule to + turn A x back into x \in A; it can be used for any definition of type + pred T, which makes it especially useful for ambivalent predicates + as the relational transitive closure connect, that are used in both + applicative and collective styles. + Purely for aesthetics, we provide a subtype of collective predicates: + qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T + coerces to pred_class and thus behaves as a collective + predicate, but x \in A and x \notin A are displayed as: + x \is A and x \isn't A when q = 0, + x \is a A and x \isn't a A when q = 1, + x \is an A and x \isn't an A when q = 2, respectively. + #[#qualify x | P#]# := Qualifier 0 (fun x => P), constructor for the above. + #[#qualify x : T | P#]#, #[#qualify a x | P#]#, #[#qualify an X | P#]#, etc. + variants of the above with type constraints and different + values of q. + We provide an internal interface to support attaching properties (such as + being multiplicative) to predicates: + pred_key p == phantom type that will serve as a support for properties + to be attached to p : pred_class; instances should be + created with Fact/Qed so as to be opaque. + KeyedPred k_p == an instance of the interface structure that attaches + (k_p : pred_key P) to P; the structure projection is a + coercion to pred_class. + KeyedQualifier k_q == an instance of the interface structure that attaches + (k_q : pred_key q) to (q : qualifier n T). + DefaultPredKey p == a default value for pred_key p; the vernacular command + Import DefaultKeying attaches this key to all predicates + that are not explicitly keyed. + Keys can be used to attach properties to predicates, qualifiers and + generic nouns in a way that allows them to be used transparently. The key + projection of a predicate property structure such as unsignedPred should + be a pred_key, not a pred, and corresponding lemmas will have the form + Lemma rpredN R S (oppS : @opprPred R S) (kS : keyed_pred oppS) : + {mono -%%R: x / x \in kS}. + Because x \in kS will be displayed as x \in S (or x \is S, etc), the + canonical instance of opprPred will not normally be exposed (it will also + be erased by /= simplification). In addition each predicate structure + should have a DefaultPredKey Canonical instance that simply issues the + property as a proof obligation (which can be caught by the Prop-irrelevant + feature of the ssreflect plugin). + Some properties of predicates and relations: + A =i B <-> A and B are extensionally equivalent. + {subset A <= B} <-> A is a (collective) subpredicate of B. + subpred P Q <-> P is an (applicative) subpredicate or Q. + subrel R S <-> R is a subrelation of S. + In the following R is in rel T: + reflexive R <-> R is reflexive. + irreflexive R <-> R is irreflexive. + symmetric R <-> R (in rel T) is symmetric (equation). + pre_symmetric R <-> R is symmetric (implication). + antisymmetric R <-> R is antisymmetric. + total R <-> R is total. + transitive R <-> R is transitive. + left_transitive R <-> R is a congruence on its left hand side. + right_transitive R <-> R is a congruence on its right hand side. + equivalence_rel R <-> R is an equivalence relation. + Localization of (Prop) predicates; if P1 is convertible to forall x, Qx, + P2 to forall x y, Qxy and P3 to forall x y z, Qxyz : + {for y, P1} <-> Qx{y / x}. + {in A, P1} <-> forall x, x \in A -> Qx. + {in A1 & A2, P2} <-> forall x y, x \in A1 -> y \in A2 -> Qxy. + {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. + {in A1 & A2 & A3, Q3} <-> forall x y z, + x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. + {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. + {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. + {in A &&, Q3} == {in A & A & A, Q3}. + {in A, bijective f} == f has a right inverse in A. + {on C, P1} == forall x, (f x) \in C -> Qx + when P1 is also convertible to Pf f. + {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy + when P2 is also convertible to Pf f. + {on C, P1' & g} == forall x, (f x) \in cd -> Qx + when P1' is convertible to Pf f + and P1' g is convertible to forall x, Qx. + {on C, bijective f} == f has a right inverse on C. + This file extends the lemma name suffix conventions of ssrfun as follows: + A -- associativity, as in andbA : associative andb. + AC -- right commutativity. + ACA -- self-interchange (inner commutativity), e.g., + orbACA : (a || b) || (c || d) = (a || c) || (b || d). + b -- a boolean argument, as in andbb : idempotent andb. + C -- commutativity, as in andbC : commutative andb, + or predicate complement, as in predC. + CA -- left commutativity. + D -- predicate difference, as in predD. + E -- elimination, as in negbFE : ~~ b = false -> b. + F or f -- boolean false, as in andbF : b && false = false. + I -- left/right injectivity, as in addbI : right_injective addb, + or predicate intersection, as in predI. + l -- a left-hand operation, as andb_orl : left_distributive andb orb. + N or n -- boolean negation, as in andbN : a && (~~ a) = false. + P -- a characteristic property, often a reflection lemma, as in + andP : reflect (a /\ b) (a && b). + r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. + T or t -- boolean truth, as in andbT: right_id true andb. + U -- predicate union, as in predU. + W -- weakening, as in in1W : {in D, forall x, P} -> forall x, P. **) + Set Implicit Arguments. Unset Strict Implicit. @@ -288,23 +290,24 @@ Reserved Notation "x \notin A" Reserved Notation "p1 =i p2" (at level 70, format "'[hv' p1 '/ ' =i p2 ']'", no associativity). -(* We introduce a number of n-ary "list-style" notations that share a common *) -(* format, namely *) -(* [op arg1, arg2, ... last_separator last_arg] *) -(* This usually denotes a right-associative applications of op, e.g., *) -(* [&& a, b, c & d] denotes a && (b && (c && d)) *) -(* The last_separator must be a non-operator token. Here we use &, | or =>; *) -(* our default is &, but we try to match the intended meaning of op. The *) -(* separator is a workaround for limitations of the parsing engine; the same *) -(* limitations mean the separator cannot be omitted even when last_arg can. *) -(* The Notation declarations are complicated by the separate treatment for *) -(* some fixed arities (binary for bool operators, and all arities for Prop *) -(* operators). *) -(* We also use the square brackets in comprehension-style notations *) -(* [type var separator expr] *) -(* where "type" is the type of the comprehension (e.g., pred) and "separator" *) -(* is | or => . It is important that in other notations a leading square *) -(* bracket [ is always followed by an operator symbol or a fixed identifier. *) +(** + We introduce a number of n-ary "list-style" notations that share a common + format, namely + #[#op arg1, arg2, ... last_separator last_arg#]# + This usually denotes a right-associative applications of op, e.g., + #[#&& a, b, c & d#]# denotes a && (b && (c && d)) + The last_separator must be a non-operator token. Here we use &, | or =>; + our default is &, but we try to match the intended meaning of op. The + separator is a workaround for limitations of the parsing engine; the same + limitations mean the separator cannot be omitted even when last_arg can. + The Notation declarations are complicated by the separate treatment for + some fixed arities (binary for bool operators, and all arities for Prop + operators). + We also use the square brackets in comprehension-style notations + #[#type var separator expr#]# + where "type" is the type of the comprehension (e.g., pred) and "separator" + is | or => . It is important that in other notations a leading square + bracket #[# is always followed by an operator symbol or a fixed identifier. **) Reserved Notation "[ /\ P1 & P2 ]" (at level 0, only parsing). Reserved Notation "[ /\ P1 , P2 & P3 ]" (at level 0, format @@ -344,19 +347,19 @@ Reserved Notation "[ 'rel' x y => E ]" (at level 0, x, y at level 8, format Reserved Notation "[ 'rel' x y : T => E ]" (at level 0, x, y at level 8, format "'[hv' [ 'rel' x y : T => '/ ' E ] ']'"). -(* Shorter delimiter *) +(** Shorter delimiter **) Delimit Scope bool_scope with B. Open Scope bool_scope. -(* An alternative to xorb that behaves somewhat better wrt simplification. *) +(** An alternative to xorb that behaves somewhat better wrt simplification. **) Definition addb b := if b then negb else id. -(* Notation for && and || is declared in Init.Datatypes. *) +(** Notation for && and || is declared in Init.Datatypes. **) Notation "~~ b" := (negb b) : bool_scope. Notation "b ==> c" := (implb b c) : bool_scope. Notation "b1 (+) b2" := (addb b1 b2) : bool_scope. -(* Constant is_true b := b = true is defined in Init.Datatypes. *) +(** Constant is_true b := b = true is defined in Init.Datatypes. **) Coercion is_true : bool >-> Sortclass. (* Prop *) Lemma prop_congr : forall b b' : bool, b = b' -> b = b' :> Prop. @@ -364,21 +367,22 @@ Proof. by move=> b b' ->. Qed. Ltac prop_congr := apply: prop_congr. -(* Lemmas for trivial. *) +(** Lemmas for trivial. **) Lemma is_true_true : true. Proof. by []. Qed. Lemma not_false_is_true : ~ false. Proof. by []. Qed. Lemma is_true_locked_true : locked true. Proof. by unlock. Qed. -Hint Resolve is_true_true not_false_is_true is_true_locked_true. +Hint Resolve is_true_true not_false_is_true is_true_locked_true : core. -(* Shorter names. *) +(** Shorter names. **) Definition isT := is_true_true. Definition notF := not_false_is_true. -(* Negation lemmas. *) +(** Negation lemmas. **) -(* We generally take NEGATION as the standard form of a false condition: *) -(* negative boolean hypotheses should be of the form ~~ b, rather than ~ b or *) -(* b = false, as much as possible. *) +(** + We generally take NEGATION as the standard form of a false condition: + negative boolean hypotheses should be of the form ~~ b, rather than ~ b or + b = false, as much as possible. **) Lemma negbT b : b = false -> ~~ b. Proof. by case: b. Qed. Lemma negbTE b : ~~ b -> b = false. Proof. by case: b. Qed. @@ -426,8 +430,9 @@ Proof. by move/contra=> notb_notc /notb_notc/negbTE. Qed. Lemma contraFF (c b : bool) : (c -> b) -> b = false -> c = false. Proof. by move/contraFN=> bF_notc /bF_notc/negbTE. Qed. -(* Coercion of sum-style datatypes into bool, which makes it possible *) -(* to use ssr's boolean if rather than Coq's "generic" if. *) +(** + Coercion of sum-style datatypes into bool, which makes it possible + to use ssr's boolean if rather than Coq's "generic" if. **) Coercion isSome T (u : option T) := if u is Some _ then true else false. @@ -441,16 +446,17 @@ Prenex Implicits isSome is_inl is_left is_inleft. Definition decidable P := {P} + {~ P}. -(* Lemmas for ifs with large conditions, which allow reasoning about the *) -(* condition without repeating it inside the proof (the latter IS *) -(* preferable when the condition is short). *) -(* Usage : *) -(* if the goal contains (if cond then ...) = ... *) -(* case: ifP => Hcond. *) -(* generates two subgoal, with the assumption Hcond : cond = true/false *) -(* Rewrite if_same eliminates redundant ifs *) -(* Rewrite (fun_if f) moves a function f inside an if *) -(* Rewrite if_arg moves an argument inside a function-valued if *) +(** + Lemmas for ifs with large conditions, which allow reasoning about the + condition without repeating it inside the proof (the latter IS + preferable when the condition is short). + Usage : + if the goal contains (if cond then ...) = ... + case: ifP => Hcond. + generates two subgoal, with the assumption Hcond : cond = true/false + Rewrite if_same eliminates redundant ifs + Rewrite (fun_if f) moves a function f inside an if + Rewrite if_arg moves an argument inside a function-valued if **) Section BoolIf. @@ -483,13 +489,13 @@ Lemma if_arg (fT fF : A -> B) : (if b then fT else fF) x = if b then fT x else fF x. Proof. by case b. Qed. -(* Turning a boolean "if" form into an application. *) +(** Turning a boolean "if" form into an application. **) Definition if_expr := if b then vT else vF. Lemma ifE : (if b then vT else vF) = if_expr. Proof. by []. Qed. End BoolIf. -(* Core (internal) reflection lemmas, used for the three kinds of views. *) +(** Core (internal) reflection lemmas, used for the three kinds of views. **) Section ReflectCore. @@ -517,7 +523,7 @@ Proof. by case Hb => [? _ H ? | ? H _]; case: H. Qed. End ReflectCore. -(* Internal negated reflection lemmas *) +(** Internal negated reflection lemmas **) Section ReflectNegCore. Variables (P Q : Prop) (b c : bool). @@ -537,7 +543,7 @@ Proof. by rewrite -if_neg; apply: xorPif. Qed. End ReflectNegCore. -(* User-oriented reflection lemmas *) +(** User-oriented reflection lemmas **) Section Reflect. Variables (P Q : Prop) (b b' c : bool). @@ -584,7 +590,7 @@ Lemma rwP : P <-> b. Proof. by split; [apply: introT | apply: elimT]. Qed. Lemma rwP2 : reflect Q b -> (P <-> Q). Proof. by move=> Qb; split=> ?; [apply: appP | apply: elimT; case: Qb]. Qed. -(* Predicate family to reflect excluded middle in bool. *) +(** Predicate family to reflect excluded middle in bool. **) Variant alt_spec : bool -> Type := | AltTrue of P : alt_spec true | AltFalse of ~~ b : alt_spec false. @@ -600,7 +606,7 @@ Hint View for apply/ introTF|3 introNTF|3 introTFn|3 elimT|2 elimTn|2 elimN|2. Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. -(* Allow the direct application of a reflection lemma to a boolean assertion. *) +(** Allow the direct application of a reflection lemma to a boolean assertion. **) Coercion elimT : reflect >-> Funclass. Variant implies P Q := Implies of P -> Q. @@ -611,7 +617,7 @@ Coercion impliesP : implies >-> Funclass. Hint View for move/ impliesPn|2 impliesP|2. Hint View for apply/ impliesPn|2 impliesP|2. -(* Impredicative or, which can emulate a classical not-implies. *) +(** Impredicative or, which can emulate a classical not-implies. **) Definition unless condition property : Prop := forall goal : Prop, (condition -> goal) -> (property -> goal) -> goal. @@ -637,8 +643,9 @@ Proof. by split; apply=> [hC|hP]; [apply/unlessL/unlessL | apply/unlessR]. Qed. Lemma unless_contra b C : implies (~~ b -> C) (\unless C, b). Proof. by split; case: b => [_ | hC]; [apply/unlessR | apply/unlessL/hC]. Qed. -(* Classical reasoning becomes directly accessible for any bool subgoal. *) -(* Note that we cannot use "unless" here for lack of universe polymorphism. *) +(** + Classical reasoning becomes directly accessible for any bool subgoal. + Note that we cannot use "unless" here for lack of universe polymorphism. **) Definition classically P : Prop := forall b : bool, (P -> b) -> b. Lemma classicP (P : Prop) : classically P <-> ~ ~ P. @@ -669,11 +676,12 @@ move=> iPQ []// notPQ; apply/notPQ=> /iPQ-cQ. by case: notF; apply: cQ => hQ; apply: notPQ. Qed. -(* List notations for wider connectives; the Prop connectives have a fixed *) -(* width so as to avoid iterated destruction (we go up to width 5 for /\, and *) -(* width 4 for or). The bool connectives have arbitrary widths, but denote *) -(* expressions that associate to the RIGHT. This is consistent with the right *) -(* associativity of list expressions and thus more convenient in most proofs. *) +(** + List notations for wider connectives; the Prop connectives have a fixed + width so as to avoid iterated destruction (we go up to width 5 for /\, and + width 4 for or). The bool connectives have arbitrary widths, but denote + expressions that associate to the RIGHT. This is consistent with the right + associativity of list expressions and thus more convenient in most proofs. **) Inductive and3 (P1 P2 P3 : Prop) : Prop := And3 of P1 & P2 & P3. @@ -822,7 +830,7 @@ Arguments implyP [b1 b2]. Prenex Implicits idP idPn negP negPn negPf. Prenex Implicits andP and3P and4P and5P orP or3P or4P nandP norP implyP. -(* Shorter, more systematic names for the boolean connectives laws. *) +(** Shorter, more systematic names for the boolean connectives laws. **) Lemma andTb : left_id true andb. Proof. by []. Qed. Lemma andFb : left_zero false andb. Proof. by []. Qed. @@ -880,14 +888,14 @@ Proof. by case: a; case: b. Qed. Lemma negb_or (a b : bool) : ~~ (a || b) = ~~ a && ~~ b. Proof. by case: a; case: b. Qed. -(* Pseudo-cancellation -- i.e, absorbtion *) +(** Pseudo-cancellation -- i.e, absorbtion **) Lemma andbK a b : a && b || a = a. Proof. by case: a; case: b. Qed. Lemma andKb a b : a || b && a = a. Proof. by case: a; case: b. Qed. Lemma orbK a b : (a || b) && a = a. Proof. by case: a; case: b. Qed. Lemma orKb a b : a && (b || a) = a. Proof. by case: a; case: b. Qed. -(* Imply *) +(** Imply **) Lemma implybT b : b ==> true. Proof. by case: b. Qed. Lemma implybF b : (b ==> false) = ~~ b. Proof. by case: b. Qed. @@ -917,7 +925,7 @@ Proof. by case: a; case: b => // ->. Qed. Lemma implyb_id2l (a b c : bool) : (a -> b = c) -> (a ==> b) = (a ==> c). Proof. by case: a; case: b; case: c => // ->. Qed. -(* Addition (xor) *) +(** Addition (xor) **) Lemma addFb : left_id false addb. Proof. by []. Qed. Lemma addbF : right_id false addb. Proof. by case. Qed. @@ -946,9 +954,10 @@ Lemma addbP a b : reflect (~~ a = b) (a (+) b). Proof. by case: a; case: b; constructor. Qed. Arguments addbP [a b]. -(* Resolution tactic for blindly weeding out common terms from boolean *) -(* equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b3 *) -(* they will try to locate b1 in b3 and remove it. This can fail! *) +(** + Resolution tactic for blindly weeding out common terms from boolean + equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b3 + they will try to locate b1 in b3 and remove it. This can fail! **) Ltac bool_congr := match goal with @@ -963,100 +972,101 @@ Ltac bool_congr := | |- (~~ ?X1 = ?X2) => congr 1 negb end. -(******************************************************************************) -(* Predicates, i.e., packaged functions to bool. *) -(* - pred T, the basic type for predicates over a type T, is simply an alias *) -(* for T -> bool. *) -(* We actually distinguish two kinds of predicates, which we call applicative *) -(* and collective, based on the syntax used to test them at some x in T: *) -(* - For an applicative predicate P, one uses prefix syntax: *) -(* P x *) -(* Also, most operations on applicative predicates use prefix syntax as *) -(* well (e.g., predI P Q). *) -(* - For a collective predicate A, one uses infix syntax: *) -(* x \in A *) -(* and all operations on collective predicates use infix syntax as well *) -(* (e.g., [predI A & B]). *) -(* There are only two kinds of applicative predicates: *) -(* - pred T, the alias for T -> bool mentioned above *) -(* - simpl_pred T, an alias for simpl_fun T bool with a coercion to pred T *) -(* that auto-simplifies on application (see ssrfun). *) -(* On the other hand, the set of collective predicate types is open-ended via *) -(* - predType T, a Structure that can be used to put Canonical collective *) -(* predicate interpretation on other types, such as lists, tuples, *) -(* finite sets, etc. *) -(* Indeed, we define such interpretations for applicative predicate types, *) -(* which can therefore also be used with the infix syntax, e.g., *) -(* x \in predI P Q *) -(* Moreover these infix forms are convertible to their prefix counterpart *) -(* (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse *) -(* is not true, however; collective predicate types cannot, in general, be *) -(* general, be used applicatively, because of the "uniform inheritance" *) -(* restriction on implicit coercions. *) -(* However, we do define an explicit generic coercion *) -(* - mem : forall (pT : predType), pT -> mem_pred T *) -(* where mem_pred T is a variant of simpl_pred T that preserves the infix *) -(* syntax, i.e., mem A x auto-simplifies to x \in A. *) -(* Indeed, the infix "collective" operators are notation for a prefix *) -(* operator with arguments of type mem_pred T or pred T, applied to coerced *) -(* collective predicates, e.g., *) -(* Notation "x \in A" := (in_mem x (mem A)). *) -(* This prevents the variability in the predicate type from interfering with *) -(* the application of generic lemmas. Moreover this also makes it much easier *) -(* to define generic lemmas, because the simplest type -- pred T -- can be *) -(* used as the type of generic collective predicates, provided one takes care *) -(* not to use it applicatively; this avoids the burden of having to declare a *) -(* different predicate type for each predicate parameter of each section or *) -(* lemma. *) -(* This trick is made possible by the fact that the constructor of the *) -(* mem_pred T type aligns the unification process, forcing a generic *) -(* "collective" predicate A : pred T to unify with the actual collective B, *) -(* which mem has coerced to pred T via an internal, hidden implicit coercion, *) -(* supplied by the predType structure for B. Users should take care not to *) -(* inadvertently "strip" (mem B) down to the coerced B, since this will *) -(* expose the internal coercion: Coq will display a term B x that cannot be *) -(* typed as such. The topredE lemma can be used to restore the x \in B *) -(* syntax in this case. While -topredE can conversely be used to change *) -(* x \in P into P x, it is safer to use the inE and memE lemmas instead, as *) -(* they do not run the risk of exposing internal coercions. As a consequence *) -(* it is better to explicitly cast a generic applicative pred T to simpl_pred *) -(* using the SimplPred constructor, when it is used as a collective predicate *) -(* (see, e.g., Lemma eq_big in bigop). *) -(* We also sometimes "instantiate" the predType structure by defining a *) -(* coercion to the sort of the predPredType structure. This works better for *) -(* types such as {set T} that have subtypes that coerce to them, since the *) -(* same coercion will be inserted by the application of mem. It also lets us *) -(* turn any Type aT : predArgType into the total predicate over that type, *) -(* i.e., fun _: aT => true. This allows us to write, e.g., #|'I_n| for the *) -(* cardinal of the (finite) type of integers less than n. *) -(* Collective predicates have a specific extensional equality, *) -(* - A =i B, *) -(* while applicative predicates use the extensional equality of functions, *) -(* - P =1 Q *) -(* The two forms are convertible, however. *) -(* We lift boolean operations to predicates, defining: *) -(* - predU (union), predI (intersection), predC (complement), *) -(* predD (difference), and preim (preimage, i.e., composition) *) -(* For each operation we define three forms, typically: *) -(* - predU : pred T -> pred T -> simpl_pred T *) -(* - [predU A & B], a Notation for predU (mem A) (mem B) *) -(* - xpredU, a Notation for the lambda-expression inside predU, *) -(* which is mostly useful as an argument of =1, since it exposes the head *) -(* head constant of the expression to the ssreflect matching algorithm. *) -(* The syntax for the preimage of a collective predicate A is *) -(* - [preim f of A] *) -(* Finally, the generic syntax for defining a simpl_pred T is *) -(* - [pred x : T | P(x)], [pred x | P(x)], [pred x in A | P(x)], etc. *) -(* We also support boolean relations, but only the applicative form, with *) -(* types *) -(* - rel T, an alias for T -> pred T *) -(* - simpl_rel T, an auto-simplifying version, and syntax *) -(* [rel x y | P(x,y)], [rel x y in A & B | P(x,y)], etc. *) -(* The notation [rel of fA] can be used to coerce a function returning a *) -(* collective predicate to one returning pred T. *) -(* Finally, note that there is specific support for ambivalent predicates *) -(* that can work in either style, as per this file's head descriptor. *) -(******************************************************************************) + +(** + Predicates, i.e., packaged functions to bool. + - pred T, the basic type for predicates over a type T, is simply an alias + for T -> bool. + We actually distinguish two kinds of predicates, which we call applicative + and collective, based on the syntax used to test them at some x in T: + - For an applicative predicate P, one uses prefix syntax: + P x + Also, most operations on applicative predicates use prefix syntax as + well (e.g., predI P Q). + - For a collective predicate A, one uses infix syntax: + x \in A + and all operations on collective predicates use infix syntax as well + (e.g., #[#predI A & B#]#). + There are only two kinds of applicative predicates: + - pred T, the alias for T -> bool mentioned above + - simpl_pred T, an alias for simpl_fun T bool with a coercion to pred T + that auto-simplifies on application (see ssrfun). + On the other hand, the set of collective predicate types is open-ended via + - predType T, a Structure that can be used to put Canonical collective + predicate interpretation on other types, such as lists, tuples, + finite sets, etc. + Indeed, we define such interpretations for applicative predicate types, + which can therefore also be used with the infix syntax, e.g., + x \in predI P Q + Moreover these infix forms are convertible to their prefix counterpart + (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse + is not true, however; collective predicate types cannot, in general, be + general, be used applicatively, because of the "uniform inheritance" + restriction on implicit coercions. + However, we do define an explicit generic coercion + - mem : forall (pT : predType), pT -> mem_pred T + where mem_pred T is a variant of simpl_pred T that preserves the infix + syntax, i.e., mem A x auto-simplifies to x \in A. + Indeed, the infix "collective" operators are notation for a prefix + operator with arguments of type mem_pred T or pred T, applied to coerced + collective predicates, e.g., + Notation "x \in A" := (in_mem x (mem A)). + This prevents the variability in the predicate type from interfering with + the application of generic lemmas. Moreover this also makes it much easier + to define generic lemmas, because the simplest type -- pred T -- can be + used as the type of generic collective predicates, provided one takes care + not to use it applicatively; this avoids the burden of having to declare a + different predicate type for each predicate parameter of each section or + lemma. + This trick is made possible by the fact that the constructor of the + mem_pred T type aligns the unification process, forcing a generic + "collective" predicate A : pred T to unify with the actual collective B, + which mem has coerced to pred T via an internal, hidden implicit coercion, + supplied by the predType structure for B. Users should take care not to + inadvertently "strip" (mem B) down to the coerced B, since this will + expose the internal coercion: Coq will display a term B x that cannot be + typed as such. The topredE lemma can be used to restore the x \in B + syntax in this case. While -topredE can conversely be used to change + x \in P into P x, it is safer to use the inE and memE lemmas instead, as + they do not run the risk of exposing internal coercions. As a consequence + it is better to explicitly cast a generic applicative pred T to simpl_pred + using the SimplPred constructor, when it is used as a collective predicate + (see, e.g., Lemma eq_big in bigop). + We also sometimes "instantiate" the predType structure by defining a + coercion to the sort of the predPredType structure. This works better for + types such as {set T} that have subtypes that coerce to them, since the + same coercion will be inserted by the application of mem. It also lets us + turn any Type aT : predArgType into the total predicate over that type, + i.e., fun _: aT => true. This allows us to write, e.g., ##|'I_n| for the + cardinal of the (finite) type of integers less than n. + Collective predicates have a specific extensional equality, + - A =i B, + while applicative predicates use the extensional equality of functions, + - P =1 Q + The two forms are convertible, however. + We lift boolean operations to predicates, defining: + - predU (union), predI (intersection), predC (complement), + predD (difference), and preim (preimage, i.e., composition) + For each operation we define three forms, typically: + - predU : pred T -> pred T -> simpl_pred T + - #[#predU A & B#]#, a Notation for predU (mem A) (mem B) + - xpredU, a Notation for the lambda-expression inside predU, + which is mostly useful as an argument of =1, since it exposes the head + head constant of the expression to the ssreflect matching algorithm. + The syntax for the preimage of a collective predicate A is + - #[#preim f of A#]# + Finally, the generic syntax for defining a simpl_pred T is + - #[#pred x : T | P(x) #]#, #[#pred x | P(x) #]#, #[#pred x in A | P(x) #]#, etc. + We also support boolean relations, but only the applicative form, with + types + - rel T, an alias for T -> pred T + - simpl_rel T, an auto-simplifying version, and syntax + #[#rel x y | P(x,y) #]#, #[#rel x y in A & B | P(x,y) #]#, etc. + The notation #[#rel of fA#]# can be used to coerce a function returning a + collective predicate to one returning pred T. + Finally, note that there is specific support for ambivalent predicates + that can work in either style, as per this file's head descriptor. **) + Definition pred T := T -> bool. @@ -1094,8 +1104,9 @@ Coercion applicative_pred_of_simpl (p : simpl_pred) : applicative_pred := fun_of_simpl p. Coercion collective_pred_of_simpl (p : simpl_pred) : collective_pred := fun x => (let: SimplFun f := p in fun _ => f x) x. -(* Note: applicative_of_simpl is convertible to pred_of_simpl, while *) -(* collective_of_simpl is not. *) +(** + Note: applicative_of_simpl is convertible to pred_of_simpl, while + collective_of_simpl is not. **) Definition pred0 := SimplPred xpred0. Definition predT := SimplPred xpredT. @@ -1166,19 +1177,21 @@ Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ _ id) (at level 0, format "[ 'predType' 'of' T ]") : form_scope. -(* This redundant coercion lets us "inherit" the simpl_predType canonical *) -(* instance by declaring a coercion to simpl_pred. This hack is the only way *) -(* to put a predType structure on a predArgType. We use simpl_pred rather *) -(* than pred to ensure that /= removes the identity coercion. Note that the *) -(* coercion will never be used directly for simpl_pred, since the canonical *) -(* instance should always be resolved. *) +(** + This redundant coercion lets us "inherit" the simpl_predType canonical + instance by declaring a coercion to simpl_pred. This hack is the only way + to put a predType structure on a predArgType. We use simpl_pred rather + than pred to ensure that /= removes the identity coercion. Note that the + coercion will never be used directly for simpl_pred, since the canonical + instance should always be resolved. **) Notation pred_class := (pred_sort (predPredType _)). Coercion sort_of_simpl_pred T (p : simpl_pred T) : pred_class := p : pred T. -(* This lets us use some types as a synonym for their universal predicate. *) -(* Unfortunately, this won't work for existing types like bool, unless we *) -(* redefine bool, true, false and all bool ops. *) +(** + This lets us use some types as a synonym for their universal predicate. + Unfortunately, this won't work for existing types like bool, unless we + redefine bool, true, false and all bool ops. **) Definition predArgType := Type. Bind Scope type_scope with predArgType. Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. @@ -1187,8 +1200,9 @@ Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. Notation "{ : T }" := (T%type : predArgType) (at level 0, format "{ : T }") : type_scope. -(* These must be defined outside a Section because "cooking" kills the *) -(* nosimpl tag. *) +(** + These must be defined outside a Section because "cooking" kills the + nosimpl tag. **) Definition mem T (pT : predType T) : pT -> mem_pred T := nosimpl (let: @PredType _ _ _ (exist _ mem _) := pT return pT -> _ in mem). @@ -1254,12 +1268,13 @@ Section simpl_mem. Variables (T : Type) (pT : predType T). Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). -(* Bespoke structures that provide fine-grained control over matching the *) -(* various forms of the \in predicate; note in particular the different forms *) -(* of hoisting that are used. We had to work around several bugs in the *) -(* 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). *) +(** + Bespoke structures that provide fine-grained control over matching the + various forms of the \in predicate; note in particular the different forms + of hoisting that are used. We had to work around several bugs in the + 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). **) Structure manifest_applicative_pred p := ManifestApplicativePred { manifest_applicative_pred_value :> pred T; _ : manifest_applicative_pred_value = p @@ -1305,10 +1320,11 @@ Lemma in_simpl x p (msp : manifest_simpl_pred p) : in_mem x (Mem [eta fun_of_simpl (msp : simpl_pred T)]) = p x. Proof. by case: msp => _ /= ->. Qed. -(* Because of the explicit eta expansion in the left-hand side, this lemma *) -(* should only be used in a right-to-left direction. The 8.3 hack allowing *) -(* partial right-to-left use does not work with the improved expansion *) -(* heuristics in 8.4. *) +(** + Because of the explicit eta expansion in the left-hand side, this lemma + should only be used in a right-to-left direction. The 8.3 hack allowing + partial right-to-left use does not work with the improved expansion + heuristics in 8.4. **) Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. Proof. by []. Qed. @@ -1327,7 +1343,7 @@ Proof. by rewrite -mem_topred. Qed. End simpl_mem. -(* Qualifiers and keyed predicates. *) +(** Qualifiers and keyed predicates. **) Variant qualifier (q : nat) T := Qualifier of predPredType T. @@ -1371,7 +1387,7 @@ Notation "[ 'qualify' 'an' x | P ]" := (Qualifier 2 (fun x => P%B)) Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) (at level 0, x at level 99, only parsing) : form_scope. -(* Keyed predicates: support for property-bearing predicate interfaces. *) +(** Keyed predicates: support for property-bearing predicate interfaces. **) Section KeyPred. @@ -1388,13 +1404,14 @@ Definition KeyedPred := @PackKeyedPred k p (frefl _). Variable k_p : keyed_pred k. Lemma keyed_predE : k_p =i p. Proof. by case: k_p. Qed. -(* Instances that strip the mem cast; the first one has "pred_of_mem" as its *) -(* projection head value, while the second has "pred_of_simpl". The latter *) -(* has the side benefit of preempting accidental misdeclarations. *) -(* Note: pred_of_mem is the registered mem >-> pred_class coercion, while *) -(* simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We *) -(* must write down the coercions explicitly as the Canonical head constant *) -(* computation does not strip casts !! *) +(** + Instances that strip the mem cast; the first one has "pred_of_mem" as its + projection head value, while the second has "pred_of_simpl". The latter + has the side benefit of preempting accidental misdeclarations. + Note: pred_of_mem is the registered mem >-> pred_class coercion, while + simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We + must write down the coercions explicitly as the Canonical head constant + computation does not strip casts !! **) Canonical keyed_mem := @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. Canonical keyed_mem_simpl := @@ -1434,7 +1451,7 @@ Canonical default_keyed_qualifier T n (q : qualifier n T) := End DefaultKeying. -(* Skolemizing with conditions. *) +(** Skolemizing with conditions. **) Lemma all_tag_cond_dep I T (C : pred I) U : (forall x, T x) -> (forall x, C x -> {y : T x & U x y}) -> @@ -1461,8 +1478,9 @@ Proof. by move=> y0; apply: all_sig_cond_dep. Qed. Section RelationProperties. -(* Caveat: reflexive should not be used to state lemmas, as auto and trivial *) -(* will not expand the constant. *) +(** + Caveat: reflexive should not be used to state lemmas, as auto and trivial + will not expand the constant. **) Variable T : Type. @@ -1496,8 +1514,9 @@ Proof. by move=> x y /sym_left_transitive Rxy z; rewrite !(symR z) Rxy. Qed. End PER. -(* We define the equivalence property with prenex quantification so that it *) -(* can be localized using the {in ..., ..} form defined below. *) +(** + We define the equivalence property with prenex quantification so that it + can be localized using the {in ..., ..} form defined below. **) Definition equivalence_rel := forall x y z, R z z * (R x y -> R x z = R y z). @@ -1512,7 +1531,7 @@ End RelationProperties. Lemma rev_trans T (R : rel T) : transitive R -> transitive (fun x y => R y x). Proof. by move=> trR x y z Ryx Rzy; apply: trR Rzy Ryx. Qed. -(* Property localization *) +(** Property localization **) Local Notation "{ 'all1' P }" := (forall x, P x : Prop) (at level 0). Local Notation "{ 'all2' P }" := (forall x y, P x y : Prop) (at level 0). @@ -1626,11 +1645,12 @@ Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) (at level 0, f at level 8, format "{ 'on' cd , 'bijective' f }") : type_scope. -(* Weakening and monotonicity lemmas for localized predicates. *) -(* Note that using these lemmas in backward reasoning will force expansion of *) -(* the predicate definition, as Coq needs to expose the quantifier to apply *) -(* these lemmas. We define a few specialized variants to avoid this for some *) -(* of the ssrfun predicates. *) +(** + Weakening and monotonicity lemmas for localized predicates. + Note that using these lemmas in backward reasoning will force expansion of + the predicate definition, as Coq needs to expose the quantifier to apply + these lemmas. We define a few specialized variants to avoid this for some + of the ssrfun predicates. **) Section LocalGlobal. diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 1c4508abf4..3e0fbc9a8c 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -104,8 +104,6 @@ let mkRAppView ist gl rv gv = let nb_view_imps = interp_view_nbimps ist gl rv in mkRApp rv (mkRHoles (abs nb_view_imps)) -let prof_apply_interp_with = mk_profiler "ssrapplytac.interp_with";; - let refine_interp_apply_view dbl ist gl gv = let pair i = List.map (fun x -> i, x) in let rv = pf_intern_term ist gl gv in @@ -113,7 +111,6 @@ let refine_interp_apply_view dbl ist gl gv = let interp_with (dbl, hint) = let i = if dbl = Ssrview.AdaptorDb.Equivalence then 2 else 1 in interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in - let interp_with x = prof_apply_interp_with.profile interp_with x in let rec loop = function | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index ebe4aac213..efc4a2c743 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -242,7 +242,6 @@ let interp_refine ist gl rc = let flags = { Pretyping.use_typeclasses = true; solve_unification_constraints = true; - use_hook = None; fail_evar = false; expand_evars = true } in @@ -499,6 +498,22 @@ let pf_e_type_of gl t = let sigma, ty = Typing.type_of env sigma t in re_sig it sigma, ty +let pf_resolve_typeclasses ~where ~fail gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let filter = + let evset = Evarutil.undefined_evars_of_term sigma where in + fun k _ -> Evar.Set.mem k evset in + let sigma = Typeclasses.resolve_typeclasses ~filter ~fail env sigma in + re_sig it sigma + +let resolve_typeclasses ~where ~fail env sigma = + let filter = + let evset = Evarutil.undefined_evars_of_term sigma where in + fun k _ -> Evar.Set.mem k evset in + let sigma = Typeclasses.resolve_typeclasses ~filter ~fail env sigma in + sigma + + let nf_evar sigma t = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr t)) @@ -844,7 +859,7 @@ let ssr_n_tac seed n gl = with Not_found -> if n = -1 then fail "The ssreflect library was not loaded" else fail ("The tactic "^name^" was not found") in - let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in Proofview.V82.of_tactic (Tacinterp.eval_tactic (Tacexpr.TacArg tacexpr)) gl let donetac n gl = ssr_n_tac "done" n gl @@ -985,7 +1000,7 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = | _ -> assert false in loop sigma t [] n in pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); - Tacmach.refine_no_check t gl + Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t) gl let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = let rec mkRels = function 1 -> [] | n -> mkRel n :: mkRels (n-1) in @@ -1002,81 +1017,6 @@ let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = try applyn ~with_evars ~with_shelve:true ?beta n (EConstr.of_constr oc) gl with e when CErrors.noncritical e -> raise dependent_apply_error -(** Profiling *)(* {{{ *************************************************************) -type profiler = { - profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; - reset : unit -> unit; - print : unit -> unit } -let profile_now = ref false -let something_profiled = ref false -let profilers = ref [] -let add_profiler f = profilers := f :: !profilers;; -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssreflect profiling"; - Goptions.optkey = ["SsrProfiling"]; - Goptions.optread = (fun _ -> !profile_now); - Goptions.optdepr = false; - Goptions.optwrite = (fun b -> - Ssrmatching.profile b; - profile_now := b; - if b then List.iter (fun f -> f.reset ()) !profilers; - if not b then List.iter (fun f -> f.print ()) !profilers) } -let () = - let prof_total = - let init = ref 0.0 in { - profile = (fun f x -> assert false); - reset = (fun () -> init := Unix.gettimeofday ()); - print = (fun () -> if !something_profiled then - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in - let prof_legenda = { - profile = (fun f x -> assert false); - reset = (fun () -> ()); - print = (fun () -> if !something_profiled then begin - prerr_endline - (Printf.sprintf "!! %39s ---------- --------- --------- ---------" - (String.make 39 '-')); - prerr_endline - (Printf.sprintf "!! %-39s %10s %9s %9s %9s" - "function" "#calls" "total" "max" "average") end) } in - add_profiler prof_legenda; - add_profiler prof_total -;; - -let mk_profiler s = - let total, calls, max = ref 0.0, ref 0, ref 0.0 in - let reset () = total := 0.0; calls := 0; max := 0.0 in - let profile f x = - if not !profile_now then f x else - let before = Unix.gettimeofday () in - try - incr calls; - let res = f x in - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - res - with exc -> - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - raise exc in - let print () = - if !calls <> 0 then begin - something_profiled := true; - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - s !calls !total !max (!total /. (float_of_int !calls))) end in - let prof = { profile = profile; reset = reset; print = print } in - add_profiler prof; - prof -;; -(* }}} *) - (* We wipe out all the keywords generated by the grammar rules we defined. *) (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) @@ -1152,8 +1092,8 @@ let tclDO n tac = let _, info = CErrors.push e in let e' = CErrors.UserError (l, prefix i ++ s) in Util.iraise (e', info) - | Ploc.Exc(loc, CErrors.UserError (l, s)) -> - raise (Ploc.Exc(loc, CErrors.UserError (l, prefix i ++ s))) in + | Gramlib.Ploc.Exc(loc, CErrors.UserError (l, s)) -> + raise (Gramlib.Ploc.Exc(loc, CErrors.UserError (l, prefix i ++ s))) in let rec loop i gl = if i = n then tac_err_at i gl else (tclTHEN (tac_err_at i) (loop (i + 1))) gl in diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 566a933522..e25c93bf0a 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -164,7 +164,7 @@ val mk_lterm : constr_expr -> ssrterm val mk_ast_closure_term : [ `None | `Parens | `DoubleParens | `At ] -> Constrexpr.constr_expr -> ast_closure_term -val interp_ast_closure_term : Geninterp.interp_sign -> Proof_type.goal +val interp_ast_closure_term : Geninterp.interp_sign -> Goal.goal Evd.sigma -> ast_closure_term -> Evd.evar_map * ast_closure_term val subst_ast_closure_term : Mod_subst.substitution -> ast_closure_term -> ast_closure_term val glob_ast_closure_term : Genintern.glob_sign -> ast_closure_term -> ast_closure_term @@ -335,6 +335,14 @@ val refine_with : ?beta:bool -> ?with_evars:bool -> evar_map * EConstr.t -> v82tac + +val pf_resolve_typeclasses : + where:EConstr.t -> + fail:bool -> Goal.goal Evd.sigma -> Goal.goal Evd.sigma +val resolve_typeclasses : + where:EConstr.t -> + fail:bool -> Environ.env -> Evd.evar_map -> Evd.evar_map + (*********************** Wrapped Coq tactics *****************************) val rewritetac : ssrdir -> EConstr.t -> tactic @@ -370,13 +378,6 @@ val pf_interp_gen_aux : val is_name_in_ipats : Id.t -> ssripats -> bool -type profiler = { - profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; - reset : unit -> unit; - print : unit -> unit } - -val mk_profiler : string -> profiler - (** Basic tactics *) val introid : ?orig:Name.t ref -> Id.t -> v82tac diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index e43cab094b..01af67912a 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -10,50 +10,53 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) + Require Import Bool. (* For bool_scope delimiter 'bool'. *) Require Import ssrmatching. Declare ML Module "ssreflect_plugin". -(******************************************************************************) -(* This file is the Gallina part of the ssreflect plugin implementation. *) -(* Files that use the ssreflect plugin should always Require ssreflect and *) -(* either Import ssreflect or Import ssreflect.SsrSyntax. *) -(* Part of the contents of this file is technical and will only interest *) -(* advanced developers; in addition the following are defined: *) -(* [the str of v by f] == the Canonical s : str such that f s = v. *) -(* [the str of v] == the Canonical s : str that coerces to v. *) -(* argumentType c == the T such that c : forall x : T, P x. *) -(* returnType c == the R such that c : T -> R. *) -(* {type of c for s} == P s where c : forall x : T, P x. *) -(* phantom T v == singleton type with inhabitant Phantom T v. *) -(* phant T == singleton type with inhabitant Phant v. *) -(* =^~ r == the converse of rewriting rule r (e.g., in a *) -(* rewrite multirule). *) -(* unkeyed t == t, but treated as an unkeyed matching pattern by *) -(* the ssreflect matching algorithm. *) -(* nosimpl t == t, but on the right-hand side of Definition C := *) -(* nosimpl disables expansion of C by /=. *) -(* locked t == t, but locked t is not convertible to t. *) -(* locked_with k t == t, but not convertible to t or locked_with k' t *) -(* unless k = k' (with k : unit). Coq type-checking *) -(* will be much more efficient if locked_with with a *) -(* bespoke k is used for sealed definitions. *) -(* unlockable v == interface for sealed constant definitions of v. *) -(* Unlockable def == the unlockable that registers def : C = v. *) -(* [unlockable of C] == a clone for C of the canonical unlockable for the *) -(* definition of C (e.g., if it uses locked_with). *) -(* [unlockable fun C] == [unlockable of C] with the expansion forced to be *) -(* an explicit lambda expression. *) -(* -> The usage pattern for ADT operations is: *) -(* Definition foo_def x1 .. xn := big_foo_expression. *) -(* Fact foo_key : unit. Proof. by []. Qed. *) -(* Definition foo := locked_with foo_key foo_def. *) -(* Canonical foo_unlockable := [unlockable fun foo]. *) -(* This minimizes the comparison overhead for foo, while still allowing *) -(* rewrite unlock to expose big_foo_expression. *) -(* More information about these definitions and their use can be found in the *) -(* ssreflect manual, and in specific comments below. *) -(******************************************************************************) + +(** + This file is the Gallina part of the ssreflect plugin implementation. + Files that use the ssreflect plugin should always Require ssreflect and + either Import ssreflect or Import ssreflect.SsrSyntax. + Part of the contents of this file is technical and will only interest + advanced developers; in addition the following are defined: + #[#the str of v by f#]# == the Canonical s : str such that f s = v. + #[#the str of v#]# == the Canonical s : str that coerces to v. + argumentType c == the T such that c : forall x : T, P x. + returnType c == the R such that c : T -> R. + {type of c for s} == P s where c : forall x : T, P x. + phantom T v == singleton type with inhabitant Phantom T v. + phant T == singleton type with inhabitant Phant v. + =^~ r == the converse of rewriting rule r (e.g., in a + rewrite multirule). + unkeyed t == t, but treated as an unkeyed matching pattern by + the ssreflect matching algorithm. + nosimpl t == t, but on the right-hand side of Definition C := + nosimpl disables expansion of C by /=. + locked t == t, but locked t is not convertible to t. + locked_with k t == t, but not convertible to t or locked_with k' t + unless k = k' (with k : unit). Coq type-checking + will be much more efficient if locked_with with a + bespoke k is used for sealed definitions. + unlockable v == interface for sealed constant definitions of v. + Unlockable def == the unlockable that registers def : C = v. + #[#unlockable of C#]# == a clone for C of the canonical unlockable for the + definition of C (e.g., if it uses locked_with). + #[#unlockable fun C#]# == #[#unlockable of C#]# with the expansion forced to be + an explicit lambda expression. + -> The usage pattern for ADT operations is: + Definition foo_def x1 .. xn := big_foo_expression. + Fact foo_key : unit. Proof. by #[# #]#. Qed. + Definition foo := locked_with foo_key foo_def. + Canonical foo_unlockable := #[#unlockable fun foo#]#. + This minimizes the comparison overhead for foo, while still allowing + rewrite unlock to expose big_foo_expression. + More information about these definitions and their use can be found in the + ssreflect manual, and in specific comments below. **) + Set Implicit Arguments. @@ -62,15 +65,16 @@ Unset Printing Implicit Defensive. Module SsrSyntax. -(* Declare Ssr keywords: 'is' 'of' '//' '/=' and '//='. We also declare the *) -(* parsing level 8, as a workaround for a notation grammar factoring problem. *) -(* Arguments of application-style notations (at level 10) should be declared *) -(* at level 8 rather than 9 or the camlp5 grammar will not factor properly. *) +(** + Declare Ssr keywords: 'is' 'of' '//' '/=' and '//='. We also declare the + parsing level 8, as a workaround for a notation grammar factoring problem. + Arguments of application-style notations (at level 10) should be declared + at level 8 rather than 9 or the camlp5 grammar will not factor properly. **) Reserved Notation "(* x 'is' y 'of' z 'isn't' // /= //= *)" (at level 8). Reserved Notation "(* 69 *)" (at level 69). -(* Non ambiguous keyword to check if the SsrSyntax module is imported *) +(** Non ambiguous keyword to check if the SsrSyntax module is imported **) Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). Reserved Notation "<hidden n >" (at level 200). @@ -81,10 +85,11 @@ End SsrSyntax. Export SsrMatchingSyntax. Export SsrSyntax. -(* 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. *) +(** + 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. **) Declare Scope general_if_scope. Delimit Scope general_if_scope with GEN_IF. @@ -102,7 +107,7 @@ Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := (at level 200, c, t, v1, v2 at level 200, x ident, only parsing) : general_if_scope. -(* Force boolean interpretation of simple if expressions. *) +(** Force boolean interpretation of simple if expressions. **) Declare Scope boolean_if_scope. Delimit Scope boolean_if_scope with BOOL_IF. @@ -118,38 +123,41 @@ Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := Open Scope boolean_if_scope. -(* To allow a wider variety of notations without reserving a large number of *) -(* of identifiers, the ssreflect library systematically uses "forms" to *) -(* enclose complex mixfix syntax. A "form" is simply a mixfix expression *) -(* enclosed in square brackets and introduced by a keyword: *) -(* [keyword ... ] *) -(* Because the keyword follows a bracket it does not need to be reserved. *) -(* Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq *) -(* Lists library) should be loaded before ssreflect so that their notations *) -(* do not mask all ssreflect forms. *) +(** + To allow a wider variety of notations without reserving a large number of + of identifiers, the ssreflect library systematically uses "forms" to + enclose complex mixfix syntax. A "form" is simply a mixfix expression + enclosed in square brackets and introduced by a keyword: + #[#keyword ... #]# + Because the keyword follows a bracket it does not need to be reserved. + Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq + Lists library) should be loaded before ssreflect so that their notations + do not mask all ssreflect forms. **) Declare Scope form_scope. Delimit Scope form_scope with FORM. Open Scope form_scope. -(* Allow overloading of the cast (x : T) syntax, put whitespace around the *) -(* ":" symbol to avoid lexical clashes (and for consistency with the parsing *) -(* precedence of the notation, which binds less tightly than application), *) -(* and put printing boxes that print the type of a long definition on a *) -(* separate line rather than force-fit it at the right margin. *) +(** + Allow overloading of the cast (x : T) syntax, put whitespace around the + ":" symbol to avoid lexical clashes (and for consistency with the parsing + precedence of the notation, which binds less tightly than application), + and put printing boxes that print the type of a long definition on a + separate line rather than force-fit it at the right margin. **) Notation "x : T" := (x : T) (at level 100, right associativity, format "'[hv' x '/ ' : T ']'") : core_scope. -(* Allow the casual use of notations like nat * nat for explicit Type *) -(* declarations. Note that (nat * nat : Type) is NOT equivalent to *) -(* (nat * nat)%type, whose inferred type is legacy type "Set". *) +(** + Allow the casual use of notations like nat * nat for explicit Type + declarations. Note that (nat * nat : Type) is NOT equivalent to + (nat * nat)%%type, whose inferred type is legacy type "Set". **) Notation "T : 'Type'" := (T%type : Type) (at level 100, only parsing) : core_scope. -(* Allow similarly Prop annotation for, e.g., rewrite multirules. *) +(** Allow similarly Prop annotation for, e.g., rewrite multirules. **) Notation "P : 'Prop'" := (P%type : Prop) (at level 100, only parsing) : core_scope. -(* Constants for abstract: and [: name ] intro pattern *) +(** Constants for abstract: and #[#: name #]# intro pattern **) Definition abstract_lock := unit. Definition abstract_key := tt. @@ -163,31 +171,32 @@ Register abstract_lock as plugins.ssreflect.abstract_lock. Register abstract_key as plugins.ssreflect.abstract_key. Register abstract as plugins.ssreflect.abstract. -(* Constants for tactic-views *) +(** Constants for tactic-views **) Inductive external_view : Type := tactic_view of Type. -(* Syntax for referring to canonical structures: *) -(* [the struct_type of proj_val by proj_fun] *) -(* This form denotes the Canonical instance s of the Structure type *) -(* struct_type whose proj_fun projection is proj_val, i.e., such that *) -(* proj_fun s = proj_val. *) -(* Typically proj_fun will be A record field accessors of struct_type, but *) -(* this need not be the case; it can be, for instance, a field of a record *) -(* type to which struct_type coerces; proj_val will likewise be coerced to *) -(* the return type of proj_fun. In all but the simplest cases, proj_fun *) -(* should be eta-expanded to allow for the insertion of implicit arguments. *) -(* In the common case where proj_fun itself is a coercion, the "by" part *) -(* can be omitted entirely; in this case it is inferred by casting s to the *) -(* inferred type of proj_val. Obviously the latter can be fixed by using an *) -(* explicit cast on proj_val, and it is highly recommended to do so when the *) -(* return type intended for proj_fun is "Type", as the type inferred for *) -(* proj_val may vary because of sort polymorphism (it could be Set or Prop). *) -(* Note when using the [the _ of _] form to generate a substructure from a *) -(* telescopes-style canonical hierarchy (implementing inheritance with *) -(* coercions), one should always project or coerce the value to the BASE *) -(* structure, because Coq will only find a Canonical derived structure for *) -(* the Canonical base structure -- not for a base structure that is specific *) -(* to proj_value. *) +(** + Syntax for referring to canonical structures: + #[#the struct_type of proj_val by proj_fun#]# + This form denotes the Canonical instance s of the Structure type + struct_type whose proj_fun projection is proj_val, i.e., such that + proj_fun s = proj_val. + Typically proj_fun will be A record field accessors of struct_type, but + this need not be the case; it can be, for instance, a field of a record + type to which struct_type coerces; proj_val will likewise be coerced to + the return type of proj_fun. In all but the simplest cases, proj_fun + should be eta-expanded to allow for the insertion of implicit arguments. + In the common case where proj_fun itself is a coercion, the "by" part + can be omitted entirely; in this case it is inferred by casting s to the + inferred type of proj_val. Obviously the latter can be fixed by using an + explicit cast on proj_val, and it is highly recommended to do so when the + return type intended for proj_fun is "Type", as the type inferred for + proj_val may vary because of sort polymorphism (it could be Set or Prop). + Note when using the #[#the _ of _ #]# form to generate a substructure from a + telescopes-style canonical hierarchy (implementing inheritance with + coercions), one should always project or coerce the value to the BASE + structure, because Coq will only find a Canonical derived structure for + the Canonical base structure -- not for a base structure that is specific + to proj_value. **) Module TheCanonical. @@ -210,11 +219,12 @@ Notation "[ 'the' sT 'of' v 'by' f ]" := Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*)s s) _)) (at level 0, only parsing) : form_scope. -(* The following are "format only" versions of the above notations. Since Coq *) -(* doesn't provide this facility, we fake it by splitting the "the" keyword. *) -(* We need to do this to prevent the formatter from being be thrown off by *) -(* application collapsing, coercion insertion and beta reduction in the right *) -(* hand side of the notations above. *) +(** + The following are "format only" versions of the above notations. Since Coq + doesn't provide this facility, we fake it by splitting the "the" keyword. + We need to do this to prevent the formatter from being be thrown off by + application collapsing, coercion insertion and beta reduction in the right + hand side of the notations above. **) Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) (at level 0, format "[ 'th' 'e' sT 'of' v 'by' f ]") : form_scope. @@ -222,37 +232,39 @@ Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) Notation "[ 'th' 'e' sT 'of' v ]" := (@get _ sT v _ _) (at level 0, format "[ 'th' 'e' sT 'of' v ]") : form_scope. -(* We would like to recognize -Notation "[ 'th' 'e' sT 'of' v : 'Type' ]" := (@get Type sT v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v : 'Type' ]") : form_scope. -*) - -(* Helper notation for canonical structure inheritance support. *) -(* This is a workaround for the poor interaction between delta reduction and *) -(* canonical projections in Coq's unification algorithm, by which transparent *) -(* definitions hide canonical instances, i.e., in *) -(* Canonical a_type_struct := @Struct a_type ... *) -(* Definition my_type := a_type. *) -(* my_type doesn't effectively inherit the struct structure from a_type. Our *) -(* solution is to redeclare the instance as follows *) -(* Canonical my_type_struct := Eval hnf in [struct of my_type]. *) -(* The special notation [str of _] must be defined for each Strucure "str" *) -(* with constructor "Str", typically as follows *) -(* Definition clone_str s := *) -(* let: Str _ x y ... z := s return {type of Str for s} -> str in *) -(* fun k => k _ x y ... z. *) -(* Notation "[ 'str' 'of' T 'for' s ]" := (@clone_str s (@Str T)) *) -(* (at level 0, format "[ 'str' 'of' T 'for' s ]") : form_scope. *) -(* Notation "[ 'str' 'of' T ]" := (repack_str (fun x => @Str T x)) *) -(* (at level 0, format "[ 'str' 'of' T ]") : form_scope. *) -(* The notation for the match return predicate is defined below; the eta *) -(* expansion in the second form serves both to distinguish it from the first *) -(* and to avoid the delta reduction problem. *) -(* There are several variations on the notation and the definition of the *) -(* the "clone" function, for telescopes, mixin classes, and join (multiple *) -(* inheritance) classes. We describe a different idiom for clones in ssrfun; *) -(* it uses phantom types (see below) and static unification; see fintype and *) -(* ssralg for examples. *) +(** + We would like to recognize +Notation " #[# 'th' 'e' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) + (at level 0, format " #[# 'th' 'e' sT 'of' v : 'Type' #]#") : form_scope. + **) + +(** + Helper notation for canonical structure inheritance support. + This is a workaround for the poor interaction between delta reduction and + canonical projections in Coq's unification algorithm, by which transparent + definitions hide canonical instances, i.e., in + Canonical a_type_struct := @Struct a_type ... + Definition my_type := a_type. + my_type doesn't effectively inherit the struct structure from a_type. Our + solution is to redeclare the instance as follows + Canonical my_type_struct := Eval hnf in #[#struct of my_type#]#. + The special notation #[#str of _ #]# must be defined for each Strucure "str" + with constructor "Str", typically as follows + Definition clone_str s := + let: Str _ x y ... z := s return {type of Str for s} -> str in + fun k => k _ x y ... z. + Notation " #[# 'str' 'of' T 'for' s #]#" := (@clone_str s (@Str T)) + (at level 0, format " #[# 'str' 'of' T 'for' s #]#") : form_scope. + Notation " #[# 'str' 'of' T #]#" := (repack_str (fun x => @Str T x)) + (at level 0, format " #[# 'str' 'of' T #]#") : form_scope. + The notation for the match return predicate is defined below; the eta + expansion in the second form serves both to distinguish it from the first + and to avoid the delta reduction problem. + There are several variations on the notation and the definition of the + the "clone" function, for telescopes, mixin classes, and join (multiple + inheritance) classes. We describe a different idiom for clones in ssrfun; + it uses phantom types (see below) and static unification; see fintype and + ssralg for examples. **) Definition argumentType T P & forall x : T, P x := T. Definition dependentReturnType T P & forall x : T, P x := P. @@ -261,81 +273,84 @@ Definition returnType aT rT & aT -> rT := rT. Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) (at level 0, format "{ 'type' 'of' c 'for' s }") : type_scope. -(* A generic "phantom" type (actually, a unit type with a phantom parameter). *) -(* This type can be used for type definitions that require some Structure *) -(* on one of their parameters, to allow Coq to infer said structure so it *) -(* does not have to be supplied explicitly or via the "[the _ of _]" notation *) -(* (the latter interacts poorly with other Notation). *) -(* The definition of a (co)inductive type with a parameter p : p_type, that *) -(* needs to use the operations of a structure *) -(* Structure p_str : Type := p_Str {p_repr :> p_type; p_op : p_repr -> ...} *) -(* should be given as *) -(* Inductive indt_type (p : p_str) := Indt ... . *) -(* Definition indt_of (p : p_str) & phantom p_type p := indt_type p. *) -(* Notation "{ 'indt' p }" := (indt_of (Phantom p)). *) -(* Definition indt p x y ... z : {indt p} := @Indt p x y ... z. *) -(* Notation "[ 'indt' x y ... z ]" := (indt x y ... z). *) -(* That is, the concrete type and its constructor should be shadowed by *) -(* definitions that use a phantom argument to infer and display the true *) -(* value of p (in practice, the "indt" constructor often performs additional *) -(* functions, like "locking" the representation -- see below). *) -(* We also define a simpler version ("phant" / "Phant") of phantom for the *) -(* common case where p_type is Type. *) +(** + A generic "phantom" type (actually, a unit type with a phantom parameter). + This type can be used for type definitions that require some Structure + on one of their parameters, to allow Coq to infer said structure so it + does not have to be supplied explicitly or via the " #[#the _ of _ #]#" notation + (the latter interacts poorly with other Notation). + The definition of a (co)inductive type with a parameter p : p_type, that + needs to use the operations of a structure + Structure p_str : Type := p_Str {p_repr :> p_type; p_op : p_repr -> ...} + should be given as + Inductive indt_type (p : p_str) := Indt ... . + Definition indt_of (p : p_str) & phantom p_type p := indt_type p. + Notation "{ 'indt' p }" := (indt_of (Phantom p)). + Definition indt p x y ... z : {indt p} := @Indt p x y ... z. + Notation " #[# 'indt' x y ... z #]#" := (indt x y ... z). + That is, the concrete type and its constructor should be shadowed by + definitions that use a phantom argument to infer and display the true + value of p (in practice, the "indt" constructor often performs additional + functions, like "locking" the representation -- see below). + We also define a simpler version ("phant" / "Phant") of phantom for the + common case where p_type is Type. **) Variant phantom T (p : T) := Phantom. Arguments phantom : clear implicits. Arguments Phantom : clear implicits. Variant phant (p : Type) := Phant. -(* Internal tagging used by the implementation of the ssreflect elim. *) +(** Internal tagging used by the implementation of the ssreflect elim. **) Definition protect_term (A : Type) (x : A) : A := x. Register protect_term as plugins.ssreflect.protect_term. -(* The ssreflect idiom for a non-keyed pattern: *) -(* - unkeyed t wiil match any subterm that unifies with t, regardless of *) -(* whether it displays the same head symbol as t. *) -(* - unkeyed t a b will match any application of a term f unifying with t, *) -(* to two arguments unifying with with a and b, repectively, regardless of *) -(* apparent head symbols. *) -(* - unkeyed x where x is a variable will match any subterm with the same *) -(* type as x (when x would raise the 'indeterminate pattern' error). *) +(** + The ssreflect idiom for a non-keyed pattern: + - unkeyed t wiil match any subterm that unifies with t, regardless of + whether it displays the same head symbol as t. + - unkeyed t a b will match any application of a term f unifying with t, + to two arguments unifying with with a and b, repectively, regardless of + apparent head symbols. + - unkeyed x where x is a variable will match any subterm with the same + type as x (when x would raise the 'indeterminate pattern' error). **) Notation unkeyed x := (let flex := x in flex). -(* Ssreflect converse rewrite rule rule idiom. *) +(** Ssreflect converse rewrite rule rule idiom. **) Definition ssr_converse R (r : R) := (Logic.I, r). Notation "=^~ r" := (ssr_converse r) (at level 100) : form_scope. -(* Term tagging (user-level). *) -(* The ssreflect library uses four strengths of term tagging to restrict *) -(* convertibility during type checking: *) -(* nosimpl t simplifies to t EXCEPT in a definition; more precisely, given *) -(* Definition foo := nosimpl bar, foo (or foo t') will NOT be expanded by *) -(* the /= and //= switches unless it is in a forcing context (e.g., in *) -(* match foo t' with ... end, foo t' will be reduced if this allows the *) -(* match to be reduced). Note that nosimpl bar is simply notation for a *) -(* a term that beta-iota reduces to bar; hence rewrite /foo will replace *) -(* foo by bar, and rewrite -/foo will replace bar by foo. *) -(* CAVEAT: nosimpl should not be used inside a Section, because the end of *) -(* section "cooking" removes the iota redex. *) -(* locked t is provably equal to t, but is not convertible to t; 'locked' *) -(* provides support for selective rewriting, via the lock t : t = locked t *) -(* Lemma, and the ssreflect unlock tactic. *) -(* locked_with k t is equal but not convertible to t, much like locked t, *) -(* but supports explicit tagging with a value k : unit. This is used to *) -(* mitigate a flaw in the term comparison heuristic of the Coq kernel, *) -(* which treats all terms of the form locked t as equal and conpares their *) -(* arguments recursively, leading to an exponential blowup of comparison. *) -(* For this reason locked_with should be used rather than locked when *) -(* defining ADT operations. The unlock tactic does not support locked_with *) -(* but the unlock rewrite rule does, via the unlockable interface. *) -(* we also use Module Type ascription to create truly opaque constants, *) -(* because simple expansion of constants to reveal an unreducible term *) -(* doubles the time complexity of a negative comparison. Such opaque *) -(* constants can be expanded generically with the unlock rewrite rule. *) -(* See the definition of card and subset in fintype for examples of this. *) +(** + Term tagging (user-level). + The ssreflect library uses four strengths of term tagging to restrict + convertibility during type checking: + nosimpl t simplifies to t EXCEPT in a definition; more precisely, given + Definition foo := nosimpl bar, foo (or foo t') will NOT be expanded by + the /= and //= switches unless it is in a forcing context (e.g., in + match foo t' with ... end, foo t' will be reduced if this allows the + match to be reduced). Note that nosimpl bar is simply notation for a + a term that beta-iota reduces to bar; hence rewrite /foo will replace + foo by bar, and rewrite -/foo will replace bar by foo. + CAVEAT: nosimpl should not be used inside a Section, because the end of + section "cooking" removes the iota redex. + locked t is provably equal to t, but is not convertible to t; 'locked' + provides support for selective rewriting, via the lock t : t = locked t + Lemma, and the ssreflect unlock tactic. + locked_with k t is equal but not convertible to t, much like locked t, + but supports explicit tagging with a value k : unit. This is used to + mitigate a flaw in the term comparison heuristic of the Coq kernel, + which treats all terms of the form locked t as equal and conpares their + arguments recursively, leading to an exponential blowup of comparison. + For this reason locked_with should be used rather than locked when + defining ADT operations. The unlock tactic does not support locked_with + but the unlock rewrite rule does, via the unlockable interface. + we also use Module Type ascription to create truly opaque constants, + because simple expansion of constants to reveal an unreducible term + doubles the time complexity of a negative comparison. Such opaque + constants can be expanded generically with the unlock rewrite rule. + See the definition of card and subset in fintype for examples of this. **) Notation nosimpl t := (let: tt := tt in t). @@ -347,11 +362,11 @@ Register locked as plugins.ssreflect.locked. Lemma lock A x : x = locked x :> A. Proof. unlock; reflexivity. Qed. -(* Needed for locked predicates, in particular for eqType's. *) +(** Needed for locked predicates, in particular for eqType's. **) Lemma not_locked_false_eq_true : locked false <> true. Proof. unlock; discriminate. Qed. -(* The basic closing tactic "done". *) +(** The basic closing tactic "done". **) Ltac done := trivial; hnf; intros; solve [ do ![solve [trivial | apply: sym_equal; trivial] @@ -359,7 +374,7 @@ Ltac done := | case not_locked_false_eq_true; assumption | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. -(* Quicker done tactic not including split, syntax: /0/ *) +(** Quicker done tactic not including split, syntax: /0/ **) Ltac ssrdone0 := trivial; hnf; intros; solve [ do ![solve [trivial | apply: sym_equal; trivial] @@ -367,7 +382,7 @@ Ltac ssrdone0 := | case not_locked_false_eq_true; assumption | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. -(* To unlock opaque constants. *) +(** To unlock opaque constants. **) Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. @@ -377,25 +392,26 @@ Notation "[ 'unlockable' 'of' C ]" := (@Unlockable _ _ C (unlock _)) Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. -(* Generic keyed constant locking. *) +(** Generic keyed constant locking. **) -(* The argument order ensures that k is always compared before T. *) +(** The argument order ensures that k is always compared before T. **) Definition locked_with k := let: tt := k in fun T x => x : T. -(* This can be used as a cheap alternative to cloning the unlockable instance *) -(* below, but with caution as unkeyed matching can be expensive. *) +(** + This can be used as a cheap alternative to cloning the unlockable instance + below, but with caution as unkeyed matching can be expensive. **) Lemma locked_withE T k x : unkeyed (locked_with k x) = x :> T. Proof. by case: k. Qed. -(* Intensionaly, this instance will not apply to locked u. *) +(** Intensionaly, this instance will not apply to locked u. **) Canonical locked_with_unlockable T k x := @Unlockable T x (locked_with k x) (locked_withE k x). -(* More accurate variant of unlock, and safer alternative to locked_withE. *) +(** More accurate variant of unlock, and safer alternative to locked_withE. **) Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. Proof. exact: unlock. Qed. -(* The internal lemmas for the have tactics. *) +(** The internal lemmas for the have tactics. **) Definition ssr_have Plemma Pgoal (step : Plemma) rest : Pgoal := rest step. Arguments ssr_have Plemma [Pgoal]. @@ -416,7 +432,7 @@ Arguments ssr_wlog Plemma [Pgoal]. Register ssr_suff as plugins.ssreflect.ssr_suff. Register ssr_wlog as plugins.ssreflect.ssr_wlog. -(* Internal N-ary congruence lemmas for the congr tactic. *) +(** Internal N-ary congruence lemmas for the congr tactic. **) Fixpoint nary_congruence_statement (n : nat) : (forall B, (B -> B -> Prop) -> Prop) -> Prop := @@ -443,7 +459,7 @@ Arguments ssr_congr_arrow : clear implicits. Register nary_congruence as plugins.ssreflect.nary_congruence. Register ssr_congr_arrow as plugins.ssreflect.ssr_congr_arrow. -(* View lemmas that don't use reflection. *) +(** View lemmas that don't use reflection. **) Section ApplyIff. @@ -461,14 +477,15 @@ End ApplyIff. Hint View for move/ iffLRn|2 iffRLn|2 iffLR|2 iffRL|2. Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. -(* To focus non-ssreflect tactics on a subterm, eg vm_compute. *) -(* Usage: *) -(* elim/abstract_context: (pattern) => G defG. *) -(* vm_compute; rewrite {}defG {G}. *) -(* Note that vm_cast are not stored in the proof term *) -(* for reductions occuring in the context, hence *) -(* set here := pattern; vm_compute in (value of here) *) -(* blows up at Qed time. *) +(** + To focus non-ssreflect tactics on a subterm, eg vm_compute. + Usage: + elim/abstract_context: (pattern) => G defG. + vm_compute; rewrite {}defG {G}. + Note that vm_cast are not stored in the proof term + for reductions occuring in the context, hence + set here := pattern; vm_compute in (value of here) + blows up at Qed time. **) Lemma abstract_context T (P : T -> Type) x : (forall Q, Q = P -> Q x) -> P x. Proof. by move=> /(_ P); apply. Qed. diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 5067d8af31..2c9ec3a7cf 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -353,6 +353,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac ppdebug(lazy Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); let gl = pf_unify_HO gl pred elim_pred in let elim = fire_subst gl elim in + let gl = pf_resolve_typeclasses ~where:elim ~fail:false gl in let gl, _ = pf_e_type_of gl elim in (* check that the patterns do not contain non instantiated dependent metas *) let () = @@ -397,13 +398,13 @@ let revtoptac n0 gl = let dc, cl = EConstr.decompose_prod_n_assum (project gl) n (pf_concl gl) in let dc' = dc @ [Context.Rel.Declaration.LocalAssum(Name rev_id, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in - refine (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|])) gl + Refiner.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) gl let equality_inj l b id c gl = let msg = ref "" in try Proofview.V82.of_tactic (Equality.inj None l b None c) gl with - | Ploc.Exc(_,CErrors.UserError (_,s)) + | Gramlib.Ploc.Exc(_,CErrors.UserError (_,s)) | CErrors.UserError (_,s) when msg := Pp.string_of_ppcmds s; !msg = "Not a projectable equality but a discriminable one." || diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 036b20bfcd..22475fef34 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -377,6 +377,10 @@ let is_construct_ref sigma c r = let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (IndRef (fst(EConstr.destInd sigma c))) r let rwcltac cl rdx dir sr gl = + let sr = + let sigma, r = sr in + let sigma = resolve_typeclasses ~where:r ~fail:false (pf_env gl) sigma in + sigma, r in let n, r_n,_, ucst = pf_abs_evars gl sr in let r_n' = pf_abs_cterm gl n r_n in let r' = EConstr.Vars.subst_var pattern_id r_n' in @@ -421,11 +425,6 @@ let rwcltac cl rdx dir sr gl = in tclTHEN cvtac' rwtac gl -let prof_rwcltac = mk_profiler "rwrxtac.rwcltac";; -let rwcltac cl rdx dir sr gl = - prof_rwcltac.profile (rwcltac cl rdx dir sr) gl -;; - [@@@ocaml.warning "-3"] let lz_coq_prod = @@ -451,8 +450,6 @@ let ssr_is_setoid env = Rewrite.is_applied_rewrite_relation env sigma [] (EConstr.mkApp (r, args)) <> None -let prof_rwxrtac_find_rule = mk_profiler "rwrxtac.find_rule";; - let closed0_check cl p gl = if closed0 cl then errorstrm Pp.(str"No occurrence of redex "++ pr_constr_env (pf_env gl) (project gl) p) @@ -552,7 +549,6 @@ let rwrxtac occ rdx_pat dir rule gl = d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) with _ -> rwtac rs in rwtac rules in - let find_rule rdx = prof_rwxrtac_find_rule.profile find_rule rdx in let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in let find_R, conclude = match rdx_pat with | Some (_, (In_T _ | In_X_In_T _)) | None -> @@ -578,11 +574,6 @@ let rwrxtac occ rdx_pat dir rule gl = rwcltac (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl ;; -let prof_rwxrtac = mk_profiler "rwrxtac";; -let rwrxtac occ rdx_pat dir rule gl = - prof_rwxrtac.profile (rwrxtac occ rdx_pat dir rule) gl -;; - let ssrinstancesofrule ist dir arg gl = let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in let rule = interp_term ist gl arg in diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index 99ff943e61..6535cad8b7 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -10,207 +10,210 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) + Require Import ssreflect. -(******************************************************************************) -(* This file contains the basic definitions and notations for working with *) -(* functions. The definitions provide for: *) -(* *) -(* - Pair projections: *) -(* p.1 == first element of a pair *) -(* p.2 == second element of a pair *) -(* These notations also apply to p : P /\ Q, via an and >-> pair coercion. *) -(* *) -(* - Simplifying functions, beta-reduced by /= and simpl: *) -(* [fun : T => E] == constant function from type T that returns E *) -(* [fun x => E] == unary function *) -(* [fun x : T => E] == unary function with explicit domain type *) -(* [fun x y => E] == binary function *) -(* [fun x y : T => E] == binary function with common domain type *) -(* [fun (x : T) y => E] \ *) -(* [fun (x : xT) (y : yT) => E] | == binary function with (some) explicit, *) -(* [fun x (y : T) => E] / independent domain types for each argument *) -(* *) -(* - Partial functions using option type: *) -(* oapp f d ox == if ox is Some x returns f x, d otherwise *) -(* odflt d ox == if ox is Some x returns x, d otherwise *) -(* obind f ox == if ox is Some x returns f x, None otherwise *) -(* omap f ox == if ox is Some x returns Some (f x), None otherwise *) -(* *) -(* - Singleton types: *) -(* all_equal_to x0 == x0 is the only value in its type, so any such value *) -(* can be rewritten to x0. *) -(* *) -(* - A generic wrapper type: *) -(* wrapped T == the inductive type with values Wrap x for x : T. *) -(* unwrap w == the projection of w : wrapped T on T. *) -(* wrap x == the canonical injection of x : T into wrapped T; it is *) -(* equivalent to Wrap x, but is declared as a (default) *) -(* Canonical Structure, which lets the Coq HO unification *) -(* automatically expand x into unwrap (wrap x). The delta *) -(* reduction of wrap x to Wrap can be exploited to *) -(* introduce controlled nondeterminism in Canonical *) -(* Structure inference, as in the implementation of *) -(* the mxdirect predicate in matrix.v. *) -(* *) -(* - Sigma types: *) -(* tag w == the i of w : {i : I & T i}. *) -(* tagged w == the T i component of w : {i : I & T i}. *) -(* Tagged T x == the {i : I & T i} with component x : T i. *) -(* tag2 w == the i of w : {i : I & T i & U i}. *) -(* tagged2 w == the T i component of w : {i : I & T i & U i}. *) -(* tagged2' w == the U i component of w : {i : I & T i & U i}. *) -(* Tagged2 T U x y == the {i : I & T i} with components x : T i and y : U i. *) -(* sval u == the x of u : {x : T | P x}. *) -(* s2val u == the x of u : {x : T | P x & Q x}. *) -(* The properties of sval u, s2val u are given by lemmas svalP, s2valP, and *) -(* s2valP'. We provide coercions sigT2 >-> sigT and sig2 >-> sig >-> sigT. *) -(* A suite of lemmas (all_sig, ...) let us skolemize sig, sig2, sigT, sigT2 *) -(* and pair, e.g., *) -(* have /all_sig[f fP] (x : T): {y : U | P y} by ... *) -(* yields an f : T -> U such that fP : forall x, P (f x). *) -(* - Identity functions: *) -(* id == NOTATION for the explicit identity function fun x => x. *) -(* @id T == notation for the explicit identity at type T. *) -(* idfun == an expression with a head constant, convertible to id; *) -(* idfun x simplifies to x. *) -(* @idfun T == the expression above, specialized to type T. *) -(* phant_id x y == the function type phantom _ x -> phantom _ y. *) -(* *** In addition to their casual use in functional programming, identity *) -(* functions are often used to trigger static unification as part of the *) -(* construction of dependent Records and Structures. For example, if we need *) -(* a structure sT over a type T, we take as arguments T, sT, and a "dummy" *) -(* function T -> sort sT: *) -(* Definition foo T sT & T -> sort sT := ... *) -(* We can avoid specifying sT directly by calling foo (@id T), or specify *) -(* the call completely while still ensuring the consistency of T and sT, by *) -(* calling @foo T sT idfun. The phant_id type allows us to extend this trick *) -(* to non-Type canonical projections. It also allows us to sidestep *) -(* dependent type constraints when building explicit records, e.g., given *) -(* Record r := R {x; y : T(x)}. *) -(* if we need to build an r from a given y0 while inferring some x0, such *) -(* that y0 : T(x0), we pose *) -(* Definition mk_r .. y .. (x := ...) y' & phant_id y y' := R x y'. *) -(* Calling @mk_r .. y0 .. id will cause Coq to use y' := y0, while checking *) -(* the dependent type constraint y0 : T(x0). *) -(* *) -(* - Extensional equality for functions and relations (i.e. functions of two *) -(* arguments): *) -(* f1 =1 f2 == f1 x is equal to f2 x for all x. *) -(* f1 =1 f2 :> A == ... and f2 is explicitly typed. *) -(* f1 =2 f2 == f1 x y is equal to f2 x y for all x y. *) -(* f1 =2 f2 :> A == ... and f2 is explicitly typed. *) -(* *) -(* - Composition for total and partial functions: *) -(* f^~ y == function f with second argument specialised to y, *) -(* i.e., fun x => f x y *) -(* CAVEAT: conditional (non-maximal) implicit arguments *) -(* of f are NOT inserted in this context *) -(* @^~ x == application at x, i.e., fun f => f x *) -(* [eta f] == the explicit eta-expansion of f, i.e., fun x => f x *) -(* CAVEAT: conditional (non-maximal) implicit arguments *) -(* of f are NOT inserted in this context. *) -(* fun=> v := the constant function fun _ => v. *) -(* f1 \o f2 == composition of f1 and f2. *) -(* Note: (f1 \o f2) x simplifies to f1 (f2 x). *) -(* f1 \; f2 == categorical composition of f1 and f2. This expands to *) -(* to f2 \o f1 and (f1 \; f2) x simplifies to f2 (f1 x). *) -(* pcomp f1 f2 == composition of partial functions f1 and f2. *) -(* *) -(* *) -(* - Properties of functions: *) -(* injective f <-> f is injective. *) -(* cancel f g <-> g is a left inverse of f / f is a right inverse of g. *) -(* pcancel f g <-> g is a left inverse of f where g is partial. *) -(* ocancel f g <-> g is a left inverse of f where f is partial. *) -(* bijective f <-> f is bijective (has a left and right inverse). *) -(* involutive f <-> f is involutive. *) -(* *) -(* - Properties for operations. *) -(* left_id e op <-> e is a left identity for op (e op x = x). *) -(* right_id e op <-> e is a right identity for op (x op e = x). *) -(* left_inverse e inv op <-> inv is a left inverse for op wrt identity e, *) -(* i.e., (inv x) op x = e. *) -(* right_inverse e inv op <-> inv is a right inverse for op wrt identity e *) -(* i.e., x op (i x) = e. *) -(* self_inverse e op <-> each x is its own op-inverse (x op x = e). *) -(* idempotent op <-> op is idempotent for op (x op x = x). *) -(* associative op <-> op is associative, i.e., *) -(* x op (y op z) = (x op y) op z. *) -(* commutative op <-> op is commutative (x op y = y op x). *) -(* left_commutative op <-> op is left commutative, i.e., *) -(* x op (y op z) = y op (x op z). *) -(* right_commutative op <-> op is right commutative, i.e., *) -(* (x op y) op z = (x op z) op y. *) -(* left_zero z op <-> z is a left zero for op (z op x = z). *) -(* right_zero z op <-> z is a right zero for op (x op z = z). *) -(* left_distributive op1 op2 <-> op1 distributes over op2 to the left: *) -(* (x op2 y) op1 z = (x op1 z) op2 (y op1 z). *) -(* right_distributive op1 op2 <-> op distributes over add to the right: *) -(* x op1 (y op2 z) = (x op1 z) op2 (x op1 z). *) -(* interchange op1 op2 <-> op1 and op2 satisfy an interchange law: *) -(* (x op2 y) op1 (z op2 t) = (x op1 z) op2 (y op1 t). *) -(* Note that interchange op op is a commutativity property. *) -(* left_injective op <-> op is injective in its left argument: *) -(* x op y = z op y -> x = z. *) -(* right_injective op <-> op is injective in its right argument: *) -(* x op y = x op z -> y = z. *) -(* left_loop inv op <-> op, inv obey the inverse loop left axiom: *) -(* (inv x) op (x op y) = y for all x, y, i.e., *) -(* op (inv x) is always a left inverse of op x *) -(* rev_left_loop inv op <-> op, inv obey the inverse loop reverse left *) -(* axiom: x op ((inv x) op y) = y, for all x, y. *) -(* right_loop inv op <-> op, inv obey the inverse loop right axiom: *) -(* (x op y) op (inv y) = x for all x, y. *) -(* rev_right_loop inv op <-> op, inv obey the inverse loop reverse right *) -(* axiom: (x op y) op (inv y) = x for all x, y. *) -(* Note that familiar "cancellation" identities like x + y - y = x or *) -(* x - y + y = x are respectively instances of right_loop and rev_right_loop *) -(* The corresponding lemmas will use the K and NK/VK suffixes, respectively. *) -(* *) -(* - Morphisms for functions and relations: *) -(* {morph f : x / a >-> r} <-> f is a morphism with respect to functions *) -(* (fun x => a) and (fun x => r); if r == R[x], *) -(* this states that f a = R[f x] for all x. *) -(* {morph f : x / a} <-> f is a morphism with respect to the *) -(* function expression (fun x => a). This is *) -(* shorthand for {morph f : x / a >-> a}; note *) -(* that the two instances of a are often *) -(* interpreted at different types. *) -(* {morph f : x y / a >-> r} <-> f is a morphism with respect to functions *) -(* (fun x y => a) and (fun x y => r). *) -(* {morph f : x y / a} <-> f is a morphism with respect to the *) -(* function expression (fun x y => a). *) -(* {homo f : x / a >-> r} <-> f is a homomorphism with respect to the *) -(* predicates (fun x => a) and (fun x => r); *) -(* if r == R[x], this states that a -> R[f x] *) -(* for all x. *) -(* {homo f : x / a} <-> f is a homomorphism with respect to the *) -(* predicate expression (fun x => a). *) -(* {homo f : x y / a >-> r} <-> f is a homomorphism with respect to the *) -(* relations (fun x y => a) and (fun x y => r). *) -(* {homo f : x y / a} <-> f is a homomorphism with respect to the *) -(* relation expression (fun x y => a). *) -(* {mono f : x / a >-> r} <-> f is monotone with respect to projectors *) -(* (fun x => a) and (fun x => r); if r == R[x], *) -(* this states that R[f x] = a for all x. *) -(* {mono f : x / a} <-> f is monotone with respect to the projector *) -(* expression (fun x => a). *) -(* {mono f : x y / a >-> r} <-> f is monotone with respect to relators *) -(* (fun x y => a) and (fun x y => r). *) -(* {mono f : x y / a} <-> f is monotone with respect to the relator *) -(* expression (fun x y => a). *) -(* *) -(* The file also contains some basic lemmas for the above concepts. *) -(* Lemmas relative to cancellation laws use some abbreviated suffixes: *) -(* K - a cancellation rule like esymK : cancel (@esym T x y) (@esym T y x). *) -(* LR - a lemma moving an operation from the left hand side of a relation to *) -(* the right hand side, like canLR: cancel g f -> x = g y -> f x = y. *) -(* RL - a lemma moving an operation from the right to the left, e.g., canRL. *) -(* Beware that the LR and RL orientations refer to an "apply" (back chaining) *) -(* usage; when using the same lemmas with "have" or "move" (forward chaining) *) -(* the directions will be reversed!. *) -(******************************************************************************) + +(** + This file contains the basic definitions and notations for working with + functions. The definitions provide for: + + - Pair projections: + p.1 == first element of a pair + p.2 == second element of a pair + These notations also apply to p : P /\ Q, via an and >-> pair coercion. + + - Simplifying functions, beta-reduced by /= and simpl: + #[#fun : T => E#]# == constant function from type T that returns E + #[#fun x => E#]# == unary function + #[#fun x : T => E#]# == unary function with explicit domain type + #[#fun x y => E#]# == binary function + #[#fun x y : T => E#]# == binary function with common domain type + #[#fun (x : T) y => E#]# \ + #[#fun (x : xT) (y : yT) => E#]# | == binary function with (some) explicit, + #[#fun x (y : T) => E#]# / independent domain types for each argument + + - Partial functions using option type: + oapp f d ox == if ox is Some x returns f x, d otherwise + odflt d ox == if ox is Some x returns x, d otherwise + obind f ox == if ox is Some x returns f x, None otherwise + omap f ox == if ox is Some x returns Some (f x), None otherwise + + - Singleton types: + all_equal_to x0 == x0 is the only value in its type, so any such value + can be rewritten to x0. + + - A generic wrapper type: + wrapped T == the inductive type with values Wrap x for x : T. + unwrap w == the projection of w : wrapped T on T. + wrap x == the canonical injection of x : T into wrapped T; it is + equivalent to Wrap x, but is declared as a (default) + Canonical Structure, which lets the Coq HO unification + automatically expand x into unwrap (wrap x). The delta + reduction of wrap x to Wrap can be exploited to + introduce controlled nondeterminism in Canonical + Structure inference, as in the implementation of + the mxdirect predicate in matrix.v. + + - Sigma types: + tag w == the i of w : {i : I & T i}. + tagged w == the T i component of w : {i : I & T i}. + Tagged T x == the {i : I & T i} with component x : T i. + tag2 w == the i of w : {i : I & T i & U i}. + tagged2 w == the T i component of w : {i : I & T i & U i}. + tagged2' w == the U i component of w : {i : I & T i & U i}. + Tagged2 T U x y == the {i : I & T i} with components x : T i and y : U i. + sval u == the x of u : {x : T | P x}. + s2val u == the x of u : {x : T | P x & Q x}. + The properties of sval u, s2val u are given by lemmas svalP, s2valP, and + s2valP'. We provide coercions sigT2 >-> sigT and sig2 >-> sig >-> sigT. + A suite of lemmas (all_sig, ...) let us skolemize sig, sig2, sigT, sigT2 + and pair, e.g., + have /all_sig#[#f fP#]# (x : T): {y : U | P y} by ... + yields an f : T -> U such that fP : forall x, P (f x). + - Identity functions: + id == NOTATION for the explicit identity function fun x => x. + @id T == notation for the explicit identity at type T. + idfun == an expression with a head constant, convertible to id; + idfun x simplifies to x. + @idfun T == the expression above, specialized to type T. + phant_id x y == the function type phantom _ x -> phantom _ y. + *** In addition to their casual use in functional programming, identity + functions are often used to trigger static unification as part of the + construction of dependent Records and Structures. For example, if we need + a structure sT over a type T, we take as arguments T, sT, and a "dummy" + function T -> sort sT: + Definition foo T sT & T -> sort sT := ... + We can avoid specifying sT directly by calling foo (@id T), or specify + the call completely while still ensuring the consistency of T and sT, by + calling @foo T sT idfun. The phant_id type allows us to extend this trick + to non-Type canonical projections. It also allows us to sidestep + dependent type constraints when building explicit records, e.g., given + Record r := R {x; y : T(x)}. + if we need to build an r from a given y0 while inferring some x0, such + that y0 : T(x0), we pose + Definition mk_r .. y .. (x := ...) y' & phant_id y y' := R x y'. + Calling @mk_r .. y0 .. id will cause Coq to use y' := y0, while checking + the dependent type constraint y0 : T(x0). + + - Extensional equality for functions and relations (i.e. functions of two + arguments): + f1 =1 f2 == f1 x is equal to f2 x for all x. + f1 =1 f2 :> A == ... and f2 is explicitly typed. + f1 =2 f2 == f1 x y is equal to f2 x y for all x y. + f1 =2 f2 :> A == ... and f2 is explicitly typed. + + - Composition for total and partial functions: + f^~ y == function f with second argument specialised to y, + i.e., fun x => f x y + CAVEAT: conditional (non-maximal) implicit arguments + of f are NOT inserted in this context + @^~ x == application at x, i.e., fun f => f x + #[#eta f#]# == the explicit eta-expansion of f, i.e., fun x => f x + CAVEAT: conditional (non-maximal) implicit arguments + of f are NOT inserted in this context. + fun=> v := the constant function fun _ => v. + f1 \o f2 == composition of f1 and f2. + Note: (f1 \o f2) x simplifies to f1 (f2 x). + f1 \; f2 == categorical composition of f1 and f2. This expands to + to f2 \o f1 and (f1 \; f2) x simplifies to f2 (f1 x). + pcomp f1 f2 == composition of partial functions f1 and f2. + + + - Properties of functions: + injective f <-> f is injective. + cancel f g <-> g is a left inverse of f / f is a right inverse of g. + pcancel f g <-> g is a left inverse of f where g is partial. + ocancel f g <-> g is a left inverse of f where f is partial. + bijective f <-> f is bijective (has a left and right inverse). + involutive f <-> f is involutive. + + - Properties for operations. + left_id e op <-> e is a left identity for op (e op x = x). + right_id e op <-> e is a right identity for op (x op e = x). + left_inverse e inv op <-> inv is a left inverse for op wrt identity e, + i.e., (inv x) op x = e. + right_inverse e inv op <-> inv is a right inverse for op wrt identity e + i.e., x op (i x) = e. + self_inverse e op <-> each x is its own op-inverse (x op x = e). + idempotent op <-> op is idempotent for op (x op x = x). + associative op <-> op is associative, i.e., + x op (y op z) = (x op y) op z. + commutative op <-> op is commutative (x op y = y op x). + left_commutative op <-> op is left commutative, i.e., + x op (y op z) = y op (x op z). + right_commutative op <-> op is right commutative, i.e., + (x op y) op z = (x op z) op y. + left_zero z op <-> z is a left zero for op (z op x = z). + right_zero z op <-> z is a right zero for op (x op z = z). + left_distributive op1 op2 <-> op1 distributes over op2 to the left: + (x op2 y) op1 z = (x op1 z) op2 (y op1 z). + right_distributive op1 op2 <-> op distributes over add to the right: + x op1 (y op2 z) = (x op1 z) op2 (x op1 z). + interchange op1 op2 <-> op1 and op2 satisfy an interchange law: + (x op2 y) op1 (z op2 t) = (x op1 z) op2 (y op1 t). + Note that interchange op op is a commutativity property. + left_injective op <-> op is injective in its left argument: + x op y = z op y -> x = z. + right_injective op <-> op is injective in its right argument: + x op y = x op z -> y = z. + left_loop inv op <-> op, inv obey the inverse loop left axiom: + (inv x) op (x op y) = y for all x, y, i.e., + op (inv x) is always a left inverse of op x + rev_left_loop inv op <-> op, inv obey the inverse loop reverse left + axiom: x op ((inv x) op y) = y, for all x, y. + right_loop inv op <-> op, inv obey the inverse loop right axiom: + (x op y) op (inv y) = x for all x, y. + rev_right_loop inv op <-> op, inv obey the inverse loop reverse right + axiom: (x op y) op (inv y) = x for all x, y. + Note that familiar "cancellation" identities like x + y - y = x or + x - y + y = x are respectively instances of right_loop and rev_right_loop + The corresponding lemmas will use the K and NK/VK suffixes, respectively. + + - Morphisms for functions and relations: + {morph f : x / a >-> r} <-> f is a morphism with respect to functions + (fun x => a) and (fun x => r); if r == R#[#x#]#, + this states that f a = R#[#f x#]# for all x. + {morph f : x / a} <-> f is a morphism with respect to the + function expression (fun x => a). This is + shorthand for {morph f : x / a >-> a}; note + that the two instances of a are often + interpreted at different types. + {morph f : x y / a >-> r} <-> f is a morphism with respect to functions + (fun x y => a) and (fun x y => r). + {morph f : x y / a} <-> f is a morphism with respect to the + function expression (fun x y => a). + {homo f : x / a >-> r} <-> f is a homomorphism with respect to the + predicates (fun x => a) and (fun x => r); + if r == R#[#x#]#, this states that a -> R#[#f x#]# + for all x. + {homo f : x / a} <-> f is a homomorphism with respect to the + predicate expression (fun x => a). + {homo f : x y / a >-> r} <-> f is a homomorphism with respect to the + relations (fun x y => a) and (fun x y => r). + {homo f : x y / a} <-> f is a homomorphism with respect to the + relation expression (fun x y => a). + {mono f : x / a >-> r} <-> f is monotone with respect to projectors + (fun x => a) and (fun x => r); if r == R#[#x#]#, + this states that R#[#f x#]# = a for all x. + {mono f : x / a} <-> f is monotone with respect to the projector + expression (fun x => a). + {mono f : x y / a >-> r} <-> f is monotone with respect to relators + (fun x y => a) and (fun x y => r). + {mono f : x y / a} <-> f is monotone with respect to the relator + expression (fun x y => a). + + The file also contains some basic lemmas for the above concepts. + Lemmas relative to cancellation laws use some abbreviated suffixes: + K - a cancellation rule like esymK : cancel (@esym T x y) (@esym T y x). + LR - a lemma moving an operation from the left hand side of a relation to + the right hand side, like canLR: cancel g f -> x = g y -> f x = y. + RL - a lemma moving an operation from the right to the left, e.g., canRL. + Beware that the LR and RL orientations refer to an "apply" (back chaining) + usage; when using the same lemmas with "have" or "move" (forward chaining) + the directions will be reversed!. **) + Set Implicit Arguments. Unset Strict Implicit. @@ -220,7 +223,7 @@ Declare Scope fun_scope. Delimit Scope fun_scope with FUN. Open Scope fun_scope. -(* Notations for argument transpose *) +(** Notations for argument transpose **) Notation "f ^~ y" := (fun x => f x y) (at level 10, y at level 8, no associativity, format "f ^~ y") : fun_scope. Notation "@^~ x" := (fun f => f x) @@ -230,7 +233,7 @@ Declare Scope pair_scope. Delimit Scope pair_scope with PAIR. Open Scope pair_scope. -(* Notations for pair/conjunction projections *) +(** Notations for pair/conjunction projections **) Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1") : pair_scope. Notation "p .2" := (snd p) @@ -241,8 +244,9 @@ Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). Definition all_pair I T U (w : forall i : I, T i * U i) := (fun i => (w i).1, fun i => (w i).2). -(* Complements on the option type constructor, used below to *) -(* encode partial functions. *) +(** + Complements on the option type constructor, used below to + encode partial functions. **) Module Option. @@ -262,7 +266,7 @@ Notation obind := Option.bind. Notation omap := Option.map. Notation some := (@Some _) (only parsing). -(* Shorthand for some basic equality lemmas. *) +(** Shorthand for some basic equality lemmas. **) Notation erefl := refl_equal. Notation ecast i T e x := (let: erefl in _ = i := e return T in x). @@ -271,31 +275,32 @@ Definition nesym := sym_not_eq. Definition etrans := trans_eq. Definition congr1 := f_equal. Definition congr2 := f_equal2. -(* Force at least one implicit when used as a view. *) +(** Force at least one implicit when used as a view. **) Prenex Implicits esym nesym. -(* A predicate for singleton types. *) +(** A predicate for singleton types. **) Definition all_equal_to T (x0 : T) := forall x, unkeyed x = x0. Lemma unitE : all_equal_to tt. Proof. by case. Qed. -(* A generic wrapper type *) +(** A generic wrapper type **) Structure wrapped T := Wrap {unwrap : T}. Canonical wrap T x := @Wrap T x. Prenex Implicits unwrap wrap Wrap. -(* Syntax for defining auxiliary recursive function. *) -(* Usage: *) -(* Section FooDefinition. *) -(* Variables (g1 : T1) (g2 : T2). (globals) *) -(* Fixoint foo_auxiliary (a3 : T3) ... := *) -(* body, using [rec e3, ...] for recursive calls *) -(* where "[ 'rec' a3 , a4 , ... ]" := foo_auxiliary. *) -(* Definition foo x y .. := [rec e1, ...]. *) -(* + proofs about foo *) -(* End FooDefinition. *) +(** + Syntax for defining auxiliary recursive function. + Usage: + Section FooDefinition. + Variables (g1 : T1) (g2 : T2). (globals) + Fixoint foo_auxiliary (a3 : T3) ... := + body, using #[#rec e3, ... #]# for recursive calls + where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. + Definition foo x y .. := #[#rec e1, ... #]#. + + proofs about foo + End FooDefinition. **) Reserved Notation "[ 'rec' a0 ]" (at level 0, format "[ 'rec' a0 ]"). @@ -321,8 +326,9 @@ Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]" (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"). -(* Definitions and notation for explicit functions with simplification, *) -(* i.e., which simpl and /= beta expand (this is complementary to nosimpl). *) +(** + Definitions and notation for explicit functions with simplification, + i.e., which simpl and /= beta expand (this is complementary to nosimpl). **) Section SimplFun. @@ -364,11 +370,12 @@ Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" := (fun x : xT => [fun y : yT => E]) (at level 0, x ident, y ident, only parsing) : fun_scope. -(* For delta functions in eqtype.v. *) +(** For delta functions in eqtype.v. **) Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. -(* Extensional equality, for unary and binary functions, including syntactic *) -(* sugar. *) +(** + Extensional equality, for unary and binary functions, including syntactic + sugar. **) Section ExtensionalEquality. @@ -391,7 +398,7 @@ End ExtensionalEquality. Typeclasses Opaque eqfun. Typeclasses Opaque eqrel. -Hint Resolve frefl rrefl. +Hint Resolve frefl rrefl : core. Notation "f1 =1 f2" := (eqfun f1 f2) (at level 70, no associativity) : fun_scope. @@ -441,7 +448,7 @@ Notation "@ 'idfun' T " := (@id_head T explicit_id_key) Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. -(* Strong sigma types. *) +(** Strong sigma types. **) Section Tag. @@ -475,9 +482,9 @@ Lemma all_tag2 I T U V : {f : forall i, T i & forall i, U i (f i) & forall i, V i (f i)}. Proof. by case/all_tag=> f /all_pair[]; exists f. Qed. -(* Refinement types. *) +(** Refinement types. **) -(* Prenex Implicits and renaming. *) +(** Prenex Implicits and renaming. **) Notation sval := (@proj1_sig _ _). Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'"). @@ -516,16 +523,16 @@ Section Morphism. Variables (aT rT sT : Type) (f : aT -> rT). -(* Morphism property for unary and binary functions *) +(** Morphism property for unary and binary functions **) Definition morphism_1 aF rF := forall x, f (aF x) = rF (f x). Definition morphism_2 aOp rOp := forall x y, f (aOp x y) = rOp (f x) (f y). -(* Homomorphism property for unary and binary relations *) +(** Homomorphism property for unary and binary relations **) Definition homomorphism_1 (aP rP : _ -> Prop) := forall x, aP x -> rP (f x). Definition homomorphism_2 (aR rR : _ -> _ -> Prop) := forall x y, aR x y -> rR (f x) (f y). -(* Stability property for unary and binary relations *) +(** Stability property for unary and binary relations **) Definition monomorphism_1 (aP rP : _ -> sT) := forall x, rP (f x) = aP x. Definition monomorphism_2 (aR rR : _ -> _ -> sT) := forall x y, rR (f x) (f y) = aR x y. @@ -602,16 +609,18 @@ Notation "{ 'mono' f : x y /~ a }" := (at level 0, f at level 99, x ident, y ident, format "{ 'mono' f : x y /~ a }") : type_scope. -(* In an intuitionistic setting, we have two degrees of injectivity. The *) -(* weaker one gives only simplification, and the strong one provides a left *) -(* inverse (we show in `fintype' that they coincide for finite types). *) -(* We also define an intermediate version where the left inverse is only a *) -(* partial function. *) +(** + In an intuitionistic setting, we have two degrees of injectivity. The + weaker one gives only simplification, and the strong one provides a left + inverse (we show in `fintype' that they coincide for finite types). + We also define an intermediate version where the left inverse is only a + partial function. **) Section Injections. -(* rT must come first so we can use @ to mitigate the Coq 1st order *) -(* unification bug (e..g., Coq can't infer rT from a "cancel" lemma). *) +(** + rT must come first so we can use @ to mitigate the Coq 1st order + unification bug (e..g., Coq can't infer rT from a "cancel" lemma). **) Variables (rT aT : Type) (f : aT -> rT). Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. @@ -641,10 +650,10 @@ End Injections. Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed. -(* Force implicits to use as a view. *) +(** Force implicits to use as a view. **) Prenex Implicits Some_inj. -(* cancellation lemmas for dependent type casts. *) +(** cancellation lemmas for dependent type casts. **) Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). Proof. by case: y /. Qed. diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 52240f5896..2dff0cc84f 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -268,16 +268,16 @@ let negate_parser f x = | Some _ -> raise Stream.Failure let test_not_ssrslashnum = - Pcoq.Gram.Entry.of_parser + Pcoq.Entry.of_parser "test_not_ssrslashnum" (negate_parser test_ssrslashnum10) let test_ssrslashnum00 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum00 + Pcoq.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum00 let test_ssrslashnum10 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum10" test_ssrslashnum10 + Pcoq.Entry.of_parser "test_ssrslashnum10" test_ssrslashnum10 let test_ssrslashnum11 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum11" test_ssrslashnum11 + Pcoq.Entry.of_parser "test_ssrslashnum11" test_ssrslashnum11 let test_ssrslashnum01 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum01 + Pcoq.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum01 } @@ -470,7 +470,7 @@ let input_ssrtermkind strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "@" -> xWithAt | _ -> xNoFlag -let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind +let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind (* New kinds of terms *) @@ -481,7 +481,7 @@ let input_term_annotation strm = | Tok.KEYWORD "@" :: _ -> `At | _ -> `None let term_annotation = - Gram.Entry.of_parser "term_annotation" input_term_annotation + Pcoq.Entry.of_parser "term_annotation" input_term_annotation (* terms *) @@ -800,7 +800,7 @@ let reject_ssrhid strm = | _ -> ()) | _ -> () -let test_nohidden = Pcoq.Gram.Entry.of_parser "test_ssrhid" reject_ssrhid +let test_nohidden = Pcoq.Entry.of_parser "test_ssrhid" reject_ssrhid } @@ -961,7 +961,7 @@ let accept_ssrfwdid strm = | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm | _ -> raise Stream.Failure -let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid +let test_ssrfwdid = Pcoq.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid } @@ -1540,14 +1540,14 @@ let accept_ssrseqvar strm = accept_before_syms_or_ids ["["] ["first";"last"] strm | _ -> raise Stream.Failure -let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar +let test_ssrseqvar = Pcoq.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar let swaptacarg (loc, b) = (b, []), Some (TacId []) let check_seqtacarg dir arg = match snd arg, dir with - | ((true, []), Some (TacAtom (loc, _))), L2R -> + | ((true, []), Some (TacAtom { CAst.loc })), L2R -> CErrors.user_err ?loc (str "expected \"last\"") - | ((false, []), Some (TacAtom (loc, _))), R2L -> + | ((false, []), Some (TacAtom { CAst.loc })), R2L -> CErrors.user_err ?loc (str "expected \"first\"") | _, _ -> arg @@ -1628,7 +1628,7 @@ let ssr_id_of_string loc s = ^ "Scripts with explicit references to anonymous variables are fragile.")) end; Id.of_string s -let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) +let ssr_null_entry = Pcoq.Entry.of_parser "ssr_null" (fun _ -> ()) } @@ -1677,7 +1677,7 @@ let set_pr_ssrtac name prec afmt = (* FIXME *) () (* | ArgCoq at -> Egramml.GramTerminal "COQ_ARG") afmt in let tacname = ssrtac_name name in () *) -let ssrtac_atom ?loc name args = TacML (Loc.tag ?loc (ssrtac_entry name 0, args)) +let ssrtac_atom ?loc name args = TacML (CAst.make ?loc (ssrtac_entry name 0, args)) let ssrtac_expr ?loc name args = ssrtac_atom ?loc name args let tclintros_expr ?loc tac ipats = @@ -1704,7 +1704,7 @@ END GRAMMAR EXTEND Gram GLOBAL: tactic_expr; - ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> { Loc.tag ~loc (Tacexp tac) } ]]; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> { CAst.make ~loc (Tacexp tac) } ]]; tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; END @@ -1724,7 +1724,7 @@ let ssrautoprop gl = let tacname = try Tacenv.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) with Not_found -> Tacenv.locate_tactic (ssrqid "ssrautoprop") in - let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl with Not_found -> V82.of_tactic (Auto.full_trivial []) gl @@ -1955,7 +1955,7 @@ let accept_ssreqid strm = accept_before_syms [":"] strm | _ -> raise Stream.Failure -let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid +let test_ssreqid = Pcoq.Entry.of_parser "test_ssreqid" accept_ssreqid } @@ -2373,7 +2373,7 @@ let test_ssr_rw_syntax = match Util.stream_nth 0 strm with | Tok.KEYWORD key when List.mem key.[0] [lbrace; '['; '/'] -> () | _ -> raise Stream.Failure in - Gram.Entry.of_parser "test_ssr_rw_syntax" test + Pcoq.Entry.of_parser "test_ssr_rw_syntax" test } @@ -2583,7 +2583,7 @@ let accept_idcomma strm = | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm | _ -> raise Stream.Failure -let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma +let test_idcomma = Pcoq.Entry.of_parser "test_idcomma" accept_idcomma } diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index 3f0794fdd4..4ddaeb49fd 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -11,7 +11,6 @@ { open Ltac_plugin -open Pcoq open Pcoq.Constr open Ssrmatching open Ssrmatching.Internal @@ -69,7 +68,7 @@ let input_ssrtermkind strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> '(' | Tok.KEYWORD "@" -> '@' | _ -> ' ' -let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind +let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind } diff --git a/plugins/ssrmatching/plugin_base.dune b/plugins/ssrmatching/plugin_base.dune index 1450a94de1..06f67c3774 100644 --- a/plugins/ssrmatching/plugin_base.dune +++ b/plugins/ssrmatching/plugin_base.dune @@ -2,5 +2,4 @@ (name ssrmatching_plugin) (public_name coq.plugins.ssrmatching) (synopsis "Coq ssrmatching plugin") - (flags :standard -open Gramlib) (libraries coq.plugins.ltac)) diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index bb6decd848..8cb0a8b463 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -174,82 +174,6 @@ let nf_evar sigma c = (* }}} *) -(** Profiling *)(* {{{ *************************************************************) -type profiler = { - profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; - reset : unit -> unit; - print : unit -> unit } -let profile_now = ref false -let something_profiled = ref false -let profilers = ref [] -let add_profiler f = profilers := f :: !profilers;; -let profile b = - profile_now := b; - if b then List.iter (fun f -> f.reset ()) !profilers; - if not b then List.iter (fun f -> f.print ()) !profilers -;; -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssrmatching profiling"; - Goptions.optkey = ["SsrMatchingProfiling"]; - Goptions.optread = (fun _ -> !profile_now); - Goptions.optdepr = false; - Goptions.optwrite = profile } -let () = - let prof_total = - let init = ref 0.0 in { - profile = (fun f x -> assert false); - reset = (fun () -> init := Unix.gettimeofday ()); - print = (fun () -> if !something_profiled then - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in - let prof_legenda = { - profile = (fun f x -> assert false); - reset = (fun () -> ()); - print = (fun () -> if !something_profiled then begin - prerr_endline - (Printf.sprintf "!! %39s ---------- --------- --------- ---------" - (String.make 39 '-')); - prerr_endline - (Printf.sprintf "!! %-39s %10s %9s %9s %9s" - "function" "#calls" "total" "max" "average") end) } in - add_profiler prof_legenda; - add_profiler prof_total -;; - -let mk_profiler s = - let total, calls, max = ref 0.0, ref 0, ref 0.0 in - let reset () = total := 0.0; calls := 0; max := 0.0 in - let profile f x = - if not !profile_now then f x else - let before = Unix.gettimeofday () in - try - incr calls; - let res = f x in - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - res - with exc -> - let after = Unix.gettimeofday () in - let delta = after -. before in - total := !total +. delta; - if delta > !max then max := delta; - raise exc in - let print () = - if !calls <> 0 then begin - something_profiled := true; - prerr_endline - (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f" - s !calls !total !max (!total /. (float_of_int !calls))) end in - let prof = { profile = profile; reset = reset; print = print } in - add_profiler prof; - prof -;; -(* }}} *) - exception NoProgress (** Unification procedures. *) @@ -286,11 +210,6 @@ let unif_EQ_args env sigma pa a = let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in loop 0 -let prof_unif_eq_args = mk_profiler "unif_EQ_args";; -let unif_EQ_args env sigma pa a = - prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a -;; - let unif_HO env ise p c = try Evarconv.the_conv_x env p c ise with Evarconv.UnableToUnify(ise, err) -> @@ -354,14 +273,16 @@ let nf_open_term sigma0 ise c = let c' = nf c in let _ = Evd.fold copy_def sigma0 () in !s', Evd.evar_universe_context s, EConstr.of_constr c' -let unif_end env sigma0 ise0 pt ok = +let unif_end ?(solve_TC=true) env sigma0 ise0 pt ok = let ise = Evarconv.solve_unif_constraints_with_heuristics env ise0 in let tcs = Evd.get_typeclass_evars ise in let s, uc, t = nf_open_term sigma0 ise pt in let ise1 = create_evar_defs s in let ise1 = Evd.set_typeclass_evars ise1 (Evar.Set.filter (fun ev -> Evd.is_undefined ise1 ev) tcs) in let ise1 = Evd.set_universe_context ise1 uc in - let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in + let ise2 = + if solve_TC then Typeclasses.resolve_typeclasses ~fail:true env ise1 + else ise1 in if not (ok ise) then raise NoProgress else if ise2 == ise1 then (s, uc, t) else @@ -370,7 +291,7 @@ let unif_end env sigma0 ise0 pt ok = let unify_HO env sigma0 t1 t2 = let sigma = unif_HO env sigma0 t1 t2 in - let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in + let sigma, uc, _ = unif_end ~solve_TC:false env sigma0 sigma t2 (fun _ -> true) in Evd.set_universe_context sigma uc let pf_unify_HO gl t1 t2 = @@ -648,11 +569,6 @@ let match_upats_FO upats env sigma0 ise orig_c = iter_constr_LR loop f; Array.iter loop a in try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO.") -let prof_FO = mk_profiler "match_upats_FO";; -let match_upats_FO upats env sigma0 ise c = - prof_FO.profile (match_upats_FO upats env sigma0) ise c -;; - let match_upats_HO ~on_instance upats env sigma0 ise c = let dont_impact_evars = dont_impact_evars_in c in @@ -704,11 +620,6 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = if !it_did_match then raise NoProgress; !failed_because_of_TC -let prof_HO = mk_profiler "match_upats_HO";; -let match_upats_HO ~on_instance upats env sigma0 ise c = - prof_HO.profile (match_upats_HO ~on_instance upats env sigma0) ise c -;; - let fixed_upat evd = function | {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false @@ -1386,7 +1297,7 @@ let () = let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = TacFun ([Name (Id.of_string "pattern")], - TacML (Loc.tag ({ mltac_name = name; mltac_index = 0 }, []))) in + TacML (CAst.make ({ mltac_name = name; mltac_index = 0 }, []))) in let obj () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in Mltop.declare_cache_obj obj "ssrmatching_plugin" diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index f478d48ea3..93a8c48435 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -201,7 +201,7 @@ val assert_done : 'a option ref -> 'a (** Very low level APIs. these are calls to evarconv's [the_conv_x] followed by - [solve_unif_constraints_with_heuristics] and [resolve_typeclasses]. + [solve_unif_constraints_with_heuristics]. In case of failure they raise [NoMatch] *) val unify_HO : env -> evar_map -> EConstr.constr -> EConstr.constr -> evar_map @@ -221,10 +221,6 @@ val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma (* One can also "Set SsrMatchingDebug" from a .v *) val debug : bool -> unit -(* One should delimit a snippet with "Set SsrMatchingProfiling" and - * "Unset SsrMatchingProfiling" to get timings *) -val profile : bool -> unit - val ssrinstancesof : cpattern -> Tacmach.tactic (** Functions used for grammar extensions. Do not use. *) @@ -234,7 +230,7 @@ sig val wit_rpatternty : (rpattern, rpattern, rpattern) Genarg.genarg_type val glob_rpattern : Genintern.glob_sign -> rpattern -> rpattern val subst_rpattern : Mod_subst.substitution -> rpattern -> rpattern - val interp_rpattern : Geninterp.interp_sign -> Proof_type.goal Evd.sigma -> rpattern -> Evd.evar_map * rpattern + val interp_rpattern : Geninterp.interp_sign -> Goal.goal Evd.sigma -> rpattern -> Evd.evar_map * rpattern val pr_rpattern : rpattern -> Pp.t val mk_rpattern : (cpattern, cpattern) ssrpattern -> rpattern val mk_lterm : Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern @@ -242,7 +238,7 @@ sig val glob_cpattern : Genintern.glob_sign -> cpattern -> cpattern val subst_ssrterm : Mod_subst.substitution -> cpattern -> cpattern - val interp_ssrterm : Geninterp.interp_sign -> Proof_type.goal Evd.sigma -> cpattern -> Evd.evar_map * cpattern + val interp_ssrterm : Geninterp.interp_sign -> Goal.goal Evd.sigma -> cpattern -> Evd.evar_map * cpattern val pr_ssrterm : cpattern -> Pp.t end diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 776d2a2229..d90b7d754c 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -34,10 +34,8 @@ let is_gr c gr = match DAst.get c with | _ -> false let positive_modpath = MPfile (make_dir binnums) -let positive_path = make_path binnums "positive" let positive_kn = MutInd.make2 positive_modpath (Label.make "positive") -let glob_positive = IndRef (positive_kn,0) let path_of_xI = ((positive_kn,0),1) let path_of_xO = ((positive_kn,0),2) let path_of_xH = ((positive_kn,0),3) @@ -71,9 +69,7 @@ let rec bignat_of_pos c = match DAst.get c with (* Parsing Z via scopes *) (**********************************************************************) -let z_path = make_path binnums "Z" let z_kn = MutInd.make2 positive_modpath (Label.make "Z") -let glob_z = IndRef (z_kn,0) let path_of_ZERO = ((z_kn,0),1) let path_of_POS = ((z_kn,0),2) let path_of_NEG = ((z_kn,0),3) diff --git a/vernac/vernacinterp.mli b/plugins/syntax/r_syntax.mli index 0fc02c6915..7c3ee60040 100644 --- a/vernac/vernacinterp.mli +++ b/plugins/syntax/r_syntax.mli @@ -7,15 +7,3 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) - -(** Interpretation of extended vernac phrases. *) - -type 'a vernac_command = 'a -> atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t - -type plugin_args = Genarg.raw_generic_argument list - -val vinterp_init : unit -> unit -val vinterp_add : bool -> Vernacexpr.extend_name -> plugin_args vernac_command -> unit -val overwriting_vinterp_add : Vernacexpr.extend_name -> plugin_args vernac_command -> unit - -val call : Vernacexpr.extend_name -> plugin_args -> atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 164f5ab96d..e02fb33276 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1698,7 +1698,7 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context !!env) in let sigma, ev' = Evarutil.new_evar ~src ~typeclass_candidate:false !!env sigma ty in - begin match solve_simple_eqn (evar_conv_x full_transparent_state) !!env sigma (None,ev,substl inst ev') with + begin match solve_simple_eqn (evar_conv_x TransparentState.full) !!env sigma (None,ev,substl inst ev') with | Success evd -> evdref := evd | UnifFailure _ -> assert false end; diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 6a75be352b..f370ad7ae2 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -16,7 +16,6 @@ open Termops open Environ open EConstr open Vars -open CClosure open Reduction open Reductionops open Recordops @@ -30,7 +29,7 @@ open Context.Named.Declaration module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -type unify_fun = transparent_state -> +type unify_fun = TransparentState.t -> env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> Evarsolve.unification_result let debug_unification = ref (false) @@ -74,14 +73,14 @@ let coq_unit_judge = let unfold_projection env evd ts p c = let cst = Projection.constant p in - if is_transparent_constant ts cst then + if TransparentState.is_transparent_constant ts cst then Some (mkProj (Projection.unfold p, c)) else None let eval_flexible_term ts env evd c = match EConstr.kind evd c with | Const (c, u) -> - if is_transparent_constant ts c + if TransparentState.is_transparent_constant ts c then Option.map EConstr.of_constr (constant_opt_value_in env (c, EInstance.kind evd u)) else None | Rel n -> @@ -91,7 +90,7 @@ let eval_flexible_term ts env evd c = with Not_found -> None) | Var id -> (try - if is_transparent_variable ts id then + if TransparentState.is_transparent_variable ts id then env |> lookup_named id |> NamedDecl.get_value else None with Not_found -> None) @@ -1211,7 +1210,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | [] -> let evd = try Evarsolve.check_evar_instance evd evk rhs - (evar_conv_x full_transparent_state) + (evar_conv_x TransparentState.full) with IllTypedInstance _ -> raise (TypingFailed evd) in Evd.define evk rhs evd @@ -1354,7 +1353,7 @@ let solve_unconstrained_impossible_cases env evd = let j, ctx = coq_unit_judge env in let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in let ty = j_type j in - let conv_algo = evar_conv_x full_transparent_state in + let conv_algo = evar_conv_x TransparentState.full in let evd' = check_evar_instance evd' evk ty conv_algo in Evd.define evk ty evd' | _ -> evd') evd evd @@ -1393,7 +1392,7 @@ let solve_unif_constraints_with_heuristics env exception UnableToUnify of evar_map * unification_error -let default_transparent_state env = full_transparent_state +let default_transparent_state env = TransparentState.full (* Conv_oracle.get_transp_state (Environ.oracle env) *) let the_conv_x env ?(ts=default_transparent_state env) t1 t2 evd = diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 350dece28a..4585fac252 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names open EConstr open Environ open Reductionops @@ -22,20 +21,20 @@ exception UnableToUnify of evar_map * Pretype_errors.unification_error (** {6 Main unification algorithm for type inference. } *) (** returns exception NotUnifiable with best known evar_map if not unifiable *) -val the_conv_x : env -> ?ts:transparent_state -> constr -> constr -> evar_map -> evar_map -val the_conv_x_leq : env -> ?ts:transparent_state -> constr -> constr -> evar_map -> evar_map +val the_conv_x : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map +val the_conv_x_leq : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map (** The same function resolving evars by side-effect and catching the exception *) -val conv : env -> ?ts:transparent_state -> evar_map -> constr -> constr -> evar_map option -val cumul : env -> ?ts:transparent_state -> evar_map -> constr -> constr -> evar_map option +val conv : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option +val cumul : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option (** {6 Unification heuristics. } *) (** Try heuristics to solve pending unification problems and to solve evars with candidates *) -val solve_unif_constraints_with_heuristics : env -> ?ts:transparent_state -> evar_map -> evar_map +val solve_unif_constraints_with_heuristics : env -> ?ts:TransparentState.t -> evar_map -> evar_map (** Check all pending unification problems are solved and raise an error otherwise *) @@ -55,14 +54,14 @@ val check_conv_record : env -> evar_map -> (** Try to solve problems of the form ?x[args] = c by second-order matching, using typing to select occurrences *) -val second_order_matching : transparent_state -> env -> evar_map -> +val second_order_matching : TransparentState.t -> env -> evar_map -> EConstr.existential -> occurrences option list -> constr -> evar_map * bool (** Declare function to enforce evars resolution by using typing constraints *) val set_solve_evars : (env -> evar_map -> constr -> evar_map * constr) -> unit -type unify_fun = transparent_state -> +type unify_fun = TransparentState.t -> env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result (** Override default [evar_conv_x] algorithm. *) @@ -73,7 +72,7 @@ val evar_conv_x : unify_fun (**/**) (* For debugging *) -val evar_eqappr_x : ?rhs_is_already_stuck:bool -> transparent_state * bool -> +val evar_eqappr_x : ?rhs_is_already_stuck:bool -> TransparentState.t * bool -> env -> evar_map -> conv_pb -> state * Cst_stack.t -> state * Cst_stack.t -> Evarsolve.unification_result diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 96213af9c6..4692fe0057 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -66,9 +66,9 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) if not onlyalg then refresh_sort status ~direction s else t | UnivFlexible alg -> - if onlyalg && alg then - (evdref := Evd.make_flexible_variable !evdref ~algebraic:false l; t) - else t)) + (if alg then + evdref := Evd.make_nonalgebraic_variable !evdref l); + t)) | Set when refreshset && not direction -> (* Cannot make a universe "lower" than "Set", only refreshing when we want higher universes. *) diff --git a/pretyping/heads.ml b/pretyping/heads.ml index a3e4eb8971..e533930267 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -26,9 +26,8 @@ open Context.Named.Declaration the evaluation of [phi(0)] and the head of [h] is declared unknown). *) type rigid_head_kind = -| RigidParameter of Constant.t (* a Const without body *) -| RigidVar of variable (* a Var without body *) -| RigidType (* an inductive, a product or a sort *) +| RigidParameter of Constant.t (* a Const without body. Module substitution may instantiate it with something else. *) +| RigidOther (* a Var without body, inductive, product, sort, projection *) type head_approximation = | RigidHead of rigid_head_kind @@ -77,7 +76,7 @@ let kind_of_head env t = str ".")) | Construct _ | CoFix _ -> if b then NotImmediatelyComputableHead else ConstructorHead - | Sort _ | Ind _ | Prod _ -> RigidHead RigidType + | Sort _ | Ind _ | Prod _ -> RigidHead RigidOther | Cast (c,_,_) -> aux k l c b | Lambda (_,_,c) -> begin match l with @@ -89,9 +88,7 @@ let kind_of_head env t = | LetIn _ -> assert false | Meta _ | Evar _ -> NotImmediatelyComputableHead | App (c,al) -> aux k (Array.to_list al @ l) c b - | Proj (p,c) -> - (try on_subterm k (c :: l) b (constant_head (Projection.constant p)) - with Not_found -> assert false) + | Proj (p,c) -> RigidHead RigidOther | Case (_,_,c,_) -> aux k [] c true | Fix ((i,j),_) -> @@ -124,22 +121,16 @@ let kind_of_head env t = (* FIXME: maybe change interface here *) let compute_head = function | EvalConstRef cst -> - let env = Global.env() in - let cb = Environ.lookup_constant cst env in - let is_Def = function Declarations.Def _ -> true | _ -> false in - let body = - if not (Recordops.is_primitive_projection cst) && is_Def cb.Declarations.const_body - then Global.body_of_constant cst else None - in - (match body with - | None -> RigidHead (RigidParameter cst) - | Some (c, _) -> kind_of_head env c) + let env = Global.env() in + let body = Environ.constant_opt_value_in env (cst,Univ.Instance.empty) in + (match body with + | None -> RigidHead (RigidParameter cst) + | Some c -> kind_of_head env c) | EvalVarRef id -> (match Global.lookup_named id with | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> kind_of_head (Global.env()) c - | _ -> - RigidHead (RigidVar id)) + | _ -> RigidHead RigidOther) let is_rigid env t = match kind_of_head env t with diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 14358dd02a..10d8451947 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -759,6 +759,6 @@ let control_only_guard env sigma c = in let rec iter env c = check_fix_cofix env c; - iter_constr_with_full_binders sigma EConstr.push_rel iter env c + EConstr.iter_with_full_binders sigma EConstr.push_rel iter env c in iter env c diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml index 422a05c19a..9762d0f1d9 100644 --- a/pretyping/inferCumulativity.ml +++ b/pretyping/inferCumulativity.ml @@ -188,7 +188,7 @@ let infer_inductive env mie = match mie.mind_entry_universes with | Monomorphic_ind_entry _ | Polymorphic_ind_entry _ as univs -> univs - | Cumulative_ind_entry cumi -> + | Cumulative_ind_entry (nas, cumi) -> let uctx = CumulativityInfo.univ_context cumi in let uarray = Instance.to_array @@ UContext.instance uctx in let env = Environ.push_context uctx env in @@ -207,6 +207,6 @@ let infer_inductive env mie = entries in let variances = Array.map (fun u -> LMap.find u variances) uarray in - Cumulative_ind_entry (CumulativityInfo.make (uctx, variances)) + Cumulative_ind_entry (nas, CumulativityInfo.make (uctx, variances)) in { mie with mind_entry_universes = univs } diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index cba1533da5..abf52d2893 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -193,7 +193,6 @@ type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr type inference_flags = { use_typeclasses : bool; solve_unification_constraints : bool; - use_hook : inference_hook option; fail_evar : bool; expand_evars : bool } @@ -216,7 +215,7 @@ type frozen = (** Proper partition of the evar map as described above. *) let frozen_and_pending_holes (sigma, sigma') = - let undefined0 = Evd.undefined_map sigma in + let undefined0 = Option.cata Evd.undefined_map Evar.Map.empty sigma in (** Fast path when the undefined evars where not modified *) if undefined0 == Evd.undefined_map sigma' then FrozenId undefined0 @@ -247,14 +246,14 @@ let apply_typeclasses env sigma frozen fail_evar = else sigma in sigma -let apply_inference_hook hook sigma frozen = match frozen with +let apply_inference_hook hook env sigma frozen = match frozen with | FrozenId _ -> sigma | FrozenProgress (lazy (_, pending)) -> Evar.Set.fold (fun evk sigma -> if Evd.is_undefined sigma evk (* in particular not defined by side-effect *) then try - let sigma, c = hook sigma evk in + let sigma, c = hook env sigma evk in Evd.define evk c sigma with Exit -> sigma @@ -307,16 +306,16 @@ let check_evars_are_solved env sigma frozen = (* Try typeclasses, hooks, unification heuristics ... *) -let solve_remaining_evars flags env sigma init_sigma = - let frozen = frozen_and_pending_holes (init_sigma, sigma) in +let solve_remaining_evars ?hook flags env ?initial sigma = + let frozen = frozen_and_pending_holes (initial, sigma) in let sigma = if flags.use_typeclasses then apply_typeclasses env sigma frozen false else sigma in - let sigma = if Option.has_some flags.use_hook - then apply_inference_hook (Option.get flags.use_hook env) sigma frozen - else sigma + let sigma = match hook with + | None -> sigma + | Some hook -> apply_inference_hook hook env sigma frozen in let sigma = if flags.solve_unification_constraints then apply_heuristics env sigma false @@ -325,12 +324,12 @@ let solve_remaining_evars flags env sigma init_sigma = if flags.fail_evar then check_evars_are_solved env sigma frozen; sigma -let check_evars_are_solved env current_sigma init_sigma = - let frozen = frozen_and_pending_holes (init_sigma, current_sigma) in +let check_evars_are_solved env ?initial current_sigma = + let frozen = frozen_and_pending_holes (initial, current_sigma) in check_evars_are_solved env current_sigma frozen -let process_inference_flags flags env initial_sigma (sigma,c,cty) = - let sigma = solve_remaining_evars flags env sigma initial_sigma in +let process_inference_flags flags env initial (sigma,c,cty) = + let sigma = solve_remaining_evars flags env ~initial sigma in let c = if flags.expand_evars then nf_evar sigma c else c in sigma,c,cty @@ -1075,14 +1074,12 @@ let ise_pretype_gen flags env sigma lvar kind c = let default_inference_flags fail = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = None; fail_evar = fail; expand_evars = true } let no_classes_no_fail_inference_flags = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = None; fail_evar = false; expand_evars = true } diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 0f95d27528..59e6c00037 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -35,7 +35,6 @@ type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr type inference_flags = { use_typeclasses : bool; solve_unification_constraints : bool; - use_hook : inference_hook option; fail_evar : bool; expand_evars : bool } @@ -95,14 +94,14 @@ val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> with candidate and no other conversion problems that the one in [pending], however, it can contain more evars than the pending ones. *) -val solve_remaining_evars : inference_flags -> - env -> (* current map *) evar_map -> (* initial map *) evar_map -> evar_map +val solve_remaining_evars : ?hook:inference_hook -> inference_flags -> + env -> ?initial:evar_map -> (* current map *) evar_map -> evar_map (** Checking evars and pending conversion problems are all solved, reporting an appropriate error message *) val check_evars_are_solved : - env -> (* current map: *) evar_map -> (* initial map: *) evar_map -> unit + env -> ?initial:evar_map -> (* current map: *) evar_map -> unit (** [check_evars env initial_sigma extended_sigma c] fails if some new unresolved evar remains in [c] *) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 4faa753dfb..fe9b69dbbc 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -106,16 +106,16 @@ let find_projection = function let prim_table = Summary.ref (Cmap_env.empty : Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" -let load_prim i (_,p) = - prim_table := Cmap_env.add (Projection.Repr.constant p) p !prim_table +let load_prim i (_,(p,c)) = + prim_table := Cmap_env.add c p !prim_table let cache_prim p = load_prim 1 p -let subst_prim (subst,p) = subst_proj_repr subst p +let subst_prim (subst,(p,c)) = subst_proj_repr subst p, subst_constant subst c -let discharge_prim (_,p) = Some (Lib.discharge_proj_repr p) +let discharge_prim (_,(p,c)) = Some (Lib.discharge_proj_repr p, c) -let inPrim : Projection.Repr.t -> obj = +let inPrim : (Projection.Repr.t * Constant.t) -> obj = declare_object { (default_object "PRIMPROJS") with cache_function = cache_prim ; @@ -124,7 +124,7 @@ let inPrim : Projection.Repr.t -> obj = classify_function = (fun x -> Substitute x); discharge_function = discharge_prim } -let declare_primitive_projection p = Lib.add_anonymous_leaf (inPrim p) +let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) let is_primitive_projection c = Cmap_env.mem c !prim_table diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 415b964168..3e43372b65 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -45,7 +45,7 @@ val find_projection_nparams : GlobRef.t -> int val find_projection : GlobRef.t -> struc_typ (** Sets up the mapping from constants to primitive projections *) -val declare_primitive_projection : Projection.Repr.t -> unit +val declare_primitive_projection : Projection.Repr.t -> Constant.t -> unit val is_primitive_projection : Constant.t -> bool diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 17003cd1dd..e632976ae5 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -675,10 +675,6 @@ let apply_subst recfun env sigma refold cst_l t stack = let stacklam recfun env sigma t stack = apply_subst (fun _ _ s -> recfun s) env sigma false Cst_stack.empty t stack -let beta_app sigma (c,l) = - let zip s = Stack.zip sigma s in - stacklam zip [] sigma c (Stack.append_app l Stack.empty) - let beta_applist sigma (c,l) = let zip s = Stack.zip sigma s in stacklam zip [] sigma c (Stack.append_app_list l Stack.empty) @@ -1305,13 +1301,13 @@ let test_trans_conversion (f: constr Reduction.extended_conversion_function) red with Reduction.NotConvertible -> false | e when is_anomaly e -> report_anomaly e -let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion f_conv reds env sigma -let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion f_conv_leq reds env sigma -let is_fconv ?(reds=full_transparent_state) = function +let is_conv ?(reds=TransparentState.full) env sigma = test_trans_conversion f_conv reds env sigma +let is_conv_leq ?(reds=TransparentState.full) env sigma = test_trans_conversion f_conv_leq reds env sigma +let is_fconv ?(reds=TransparentState.full) = function | Reduction.CONV -> is_conv ~reds | Reduction.CUMUL -> is_conv_leq ~reds -let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = +let check_conv ?(pb=Reduction.CUMUL) ?(ts=TransparentState.full) env sigma x y = let f = match pb with | Reduction.CONV -> f_conv | Reduction.CUMUL -> f_conv_leq @@ -1345,7 +1341,7 @@ let sigma_univ_state = compare_cumul_instances = sigma_check_inductive_instances; } let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) - ?(ts=full_transparent_state) env sigma x y = + ?(ts=TransparentState.full) env sigma x y = (** FIXME *) try let ans = match pb with @@ -1378,7 +1374,7 @@ let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> Reduction.generic_conv pb ~l2r (safe_evar_value sigma)) (* This reference avoids always having to link C code with the kernel *) -let vm_infer_conv = ref (infer_conv ~catch_incon:true ~ts:full_transparent_state) +let vm_infer_conv = ref (infer_conv ~catch_incon:true ~ts:TransparentState.full) let set_vm_infer_conv f = vm_infer_conv := f let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = !vm_infer_conv ~pb env t1 t2 @@ -1681,25 +1677,6 @@ let meta_reducible_instance evd b = if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus else irec b.rebus - -let head_unfold_under_prod ts env sigma c = - let unfold (cst,u) = - let cstu = (cst, EInstance.kind sigma u) in - if Cpred.mem cst (snd ts) then - match constant_opt_value_in env cstu with - | Some c -> EConstr.of_constr c - | None -> mkConstU (cst, u) - else mkConstU (cst, u) in - let rec aux c = - match EConstr.kind sigma c with - | Prod (n,t,c) -> mkProd (n,aux t, aux c) - | _ -> - let (h,l) = decompose_app_vect sigma c in - match EConstr.kind sigma h with - | Const cst -> beta_app sigma (unfold cst, l) - | _ -> c in - aux c - let betazetaevar_applist sigma n c l = let rec stacklam n env t stack = if Int.equal n 0 then applist (substl env t, stack) else diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 41de779414..088e898a99 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -266,21 +266,21 @@ type conversion_test = Constraint.t -> Constraint.t val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> constr -> constr -> bool +val is_conv : ?reds:TransparentState.t -> env -> evar_map -> constr -> constr -> bool +val is_conv_leq : ?reds:TransparentState.t -> env -> evar_map -> constr -> constr -> bool +val is_fconv : ?reds:TransparentState.t -> conv_pb -> env -> evar_map -> constr -> constr -> bool (** [check_conv] Checks universe constraints only. pb defaults to CUMUL and ts to a full transparent state. *) -val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool +val check_conv : ?pb:conv_pb -> ?ts:TransparentState.t -> env -> evar_map -> constr -> constr -> bool (** [infer_conv] Adds necessary universe constraints to the evar map. pb defaults to CUMUL and ts to a full transparent state. @raise UniverseInconsistency iff catch_incon is set to false, otherwise returns false in that case. *) -val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> +val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:TransparentState.t -> env -> evar_map -> constr -> constr -> evar_map option (** Conversion with inference of universe constraints *) @@ -292,9 +292,9 @@ val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> (** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a conversion function. Used to pretype vm and native casts. *) -val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> +val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> TransparentState.t -> (Constr.constr, evar_map) Reduction.generic_conversion_function) -> - ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> + ?catch_incon:bool -> ?pb:conv_pb -> ?ts:TransparentState.t -> env -> evar_map -> constr -> constr -> evar_map option (** {6 Special-Purpose Reduction Functions } *) @@ -302,13 +302,12 @@ val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> val whd_meta : local_reduction_function val plain_instance : evar_map -> constr Metamap.t -> constr -> constr val instance : evar_map -> constr Metamap.t -> constr -> constr -val head_unfold_under_prod : transparent_state -> reduction_function val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr (** {6 Heuristic for Conversion with Evar } *) val whd_betaiota_deltazeta_for_iota_state : - transparent_state -> Environ.env -> Evd.evar_map -> Cst_stack.t -> state -> + TransparentState.t -> Environ.env -> Evd.evar_map -> Cst_stack.t -> state -> state * Cst_stack.t (** {6 Meta-related reduction functions } *) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 4ec8569dd8..d9df8c8cf8 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -638,7 +638,7 @@ let whd_nothing_for_iota env sigma s = | Meta ev -> (try whrec (Evd.meta_value sigma ev, stack) with Not_found -> s) - | Const (const, u) when is_transparent_constant full_transparent_state const -> + | Const (const, u) -> let u = EInstance.kind sigma u in (match constant_opt_value_in env (const, u) with | Some body -> whrec (EConstr.of_constr body, stack) diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index ee9c83dad3..8bdac0a575 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -119,8 +119,8 @@ val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> EConstr.types -> val set_typeclass_transparency_hook : (evaluable_global_reference -> bool (*local?*) -> bool -> unit) Hook.t val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit -val classes_transparent_state_hook : (unit -> transparent_state) Hook.t -val classes_transparent_state : unit -> transparent_state +val classes_transparent_state_hook : (unit -> TransparentState.t) Hook.t +val classes_transparent_state : unit -> TransparentState.t val add_instance_hint_hook : (global_reference_or_constr -> GlobRef.t list -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e3b942b610..8c1aae26ae 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -149,7 +149,7 @@ let abstract_list_all_with_dependencies env evd typ c l = let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in let evd,b = - Evarconv.second_order_matching empty_transparent_state + Evarconv.second_order_matching TransparentState.empty env evd ev' argoccs c in if b then let p = nf_evar evd ev in @@ -247,7 +247,7 @@ let sort_eqns = unify_r2l *) type core_unify_flags = { - modulo_conv_on_closed_terms : Names.transparent_state option; + modulo_conv_on_closed_terms : TransparentState.t option; (* What this flag controls was activated with all constants transparent, *) (* even for auto, since Coq V5.10 *) @@ -257,11 +257,11 @@ type core_unify_flags = { use_evars_eagerly_in_conv_on_closed_terms : bool; - modulo_delta : Names.transparent_state; + modulo_delta : TransparentState.t; (* This controls which constants are unfoldable; this is on for apply *) (* (but not simple apply) since Feb 2008 for 8.2 *) - modulo_delta_types : Names.transparent_state; + modulo_delta_types : TransparentState.t; check_applied_meta_types : bool; (* This controls whether meta's applied to arguments have their *) @@ -322,7 +322,7 @@ type unify_flags = { (* Default flag for unifying a type against a type (e.g. apply) *) (* We set all conversion flags (no flag should be modified anymore) *) let default_core_unify_flags () = - let ts = Names.full_transparent_state in { + let ts = TransparentState.full in { modulo_conv_on_closed_terms = Some ts; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; @@ -344,14 +344,14 @@ let default_unify_flags () = let flags = default_core_unify_flags () in { core_unify_flags = flags; merge_unify_flags = flags; - subterm_unify_flags = { flags with modulo_delta = var_full_transparent_state }; + subterm_unify_flags = { flags with modulo_delta = TransparentState.var_full }; allow_K_in_toplevel_higher_order_unification = false; (* Why not? *) resolve_evars = false } let set_no_delta_core_flags flags = { flags with modulo_conv_on_closed_terms = None; - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; @@ -370,7 +370,7 @@ let set_no_delta_flags flags = { (* For the first phase of keyed unification, restrict to conversion (including beta-iota) only on closed terms *) let set_no_delta_open_core_flags flags = { flags with - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; modulo_betaiota = false; } @@ -388,7 +388,7 @@ let set_no_delta_open_flags flags = { (* We set only the flags available at the time the new "apply" extended *) (* out of "simple apply" *) let default_no_delta_core_unify_flags () = { (default_core_unify_flags ()) with - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; @@ -425,7 +425,7 @@ let elim_flags_evars sigma = let flags = elim_core_flags sigma in { core_unify_flags = flags; merge_unify_flags = flags; - subterm_unify_flags = { flags with modulo_delta = empty_transparent_state }; + subterm_unify_flags = { flags with modulo_delta = TransparentState.empty }; allow_K_in_toplevel_higher_order_unification = true; resolve_evars = false } @@ -433,7 +433,7 @@ let elim_flags_evars sigma = let elim_flags () = elim_flags_evars Evd.empty let elim_no_delta_core_flags () = { (elim_core_flags Evd.empty) with - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; check_applied_meta_types = false; use_pattern_unification = false; modulo_betaiota = false; @@ -504,16 +504,16 @@ let key_of env sigma b flags f = if subterm_restriction b flags then None else match EConstr.kind sigma f with | Const (cst, u) when is_transparent env (ConstKey cst) && - (Cpred.mem cst (snd flags.modulo_delta) + (TransparentState.is_transparent_constant flags.modulo_delta cst || Recordops.is_primitive_projection cst) -> let u = EInstance.kind sigma u in Some (IsKey (ConstKey (cst, u))) | Var id when is_transparent env (VarKey id) && - Id.Pred.mem id (fst flags.modulo_delta) -> + TransparentState.is_transparent_variable flags.modulo_delta id -> Some (IsKey (VarKey id)) | Proj (p, c) when Projection.unfolded p || (is_transparent env (ConstKey (Projection.constant p)) && - (Cpred.mem (Projection.constant p) (snd flags.modulo_delta))) -> + (TransparentState.is_transparent_constant flags.modulo_delta (Projection.constant p))) -> Some (IsProj (p, c)) | _ -> None @@ -550,7 +550,7 @@ let oracle_order env cf1 cf2 = let is_rigid_head sigma flags t = match EConstr.kind sigma t with - | Const (cst,u) -> not (Cpred.mem cst (snd flags.modulo_delta)) + | Const (cst,u) -> not (TransparentState.is_transparent_constant flags.modulo_delta cst) | Ind (i,u) -> true | Construct _ -> true | Fix _ | CoFix _ -> true @@ -633,11 +633,11 @@ let rec is_neutral env sigma ts t = | Const (c, u) -> not (Environ.evaluable_constant c env) || not (is_transparent env (ConstKey c)) || - not (Cpred.mem c (snd ts)) + not (TransparentState.is_transparent_constant ts c) | Var id -> not (Environ.evaluable_named id env) || not (is_transparent env (VarKey id)) || - not (Id.Pred.mem id (fst ts)) + not (TransparentState.is_transparent_variable ts id) | Rel n -> true | Evar _ | Meta _ -> true | Case (_, p, c, cl) -> is_neutral env sigma ts c @@ -935,8 +935,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let ty1 = get_type_of curenv ~lax:true sigma c1 in let ty2 = get_type_of curenv ~lax:true sigma c2 in unify_0_with_initial_metas substn true curenv cv_pb - { flags with modulo_conv_on_closed_terms = Some full_transparent_state; - modulo_delta = full_transparent_state; + { flags with modulo_conv_on_closed_terms = Some TransparentState.full; + modulo_delta = TransparentState.full; modulo_eta = true; modulo_betaiota = true } ty1 ty2 @@ -1120,10 +1120,10 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | Some sigma -> ans | None -> if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with - | Some (cv_id, cv_k), (dl_id, dl_k) -> - Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k - | None,(dl_id, dl_k) -> - Id.Pred.is_empty dl_id && Cpred.is_empty dl_k) + | Some cv, dl -> + let open TransparentState in + Id.Pred.subset dl.tr_var cv.tr_var && Cpred.subset dl.tr_cst cv.tr_cst + | None, dl -> TransparentState.is_empty dl) then error_cannot_unify env sigma (m, n) else None in let a = match res with @@ -1263,8 +1263,8 @@ let applyHead env evd n c = let is_mimick_head sigma ts f = match EConstr.kind sigma f with - | Const (c,u) -> not (CClosure.is_transparent_constant ts c) - | Var id -> not (CClosure.is_transparent_variable ts id) + | Const (c,u) -> not (TransparentState.is_transparent_constant ts c) + | Var id -> not (TransparentState.is_transparent_variable ts id) | (Rel _|Construct _|Ind _) -> true | _ -> false @@ -1530,15 +1530,15 @@ let indirectly_dependent sigma c d decls = List.exists (fun d' -> exists (fun c -> Termops.local_occur_var sigma (NamedDecl.get_id d') c) d) decls let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = - let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in + let sigma = Pretyping.solve_remaining_evars flags env current_sigma ~initial:pending in (sigma, nf_evar sigma c) let default_matching_core_flags sigma = - let ts = Names.full_transparent_state in { - modulo_conv_on_closed_terms = Some empty_transparent_state; + let ts = TransparentState.full in { + modulo_conv_on_closed_terms = Some TransparentState.empty; use_metas_eagerly_in_conv_on_closed_terms = false; use_evars_eagerly_in_conv_on_closed_terms = false; - modulo_delta = empty_transparent_state; + modulo_delta = TransparentState.empty; modulo_delta_types = ts; check_applied_meta_types = true; use_pattern_unification = false; @@ -1550,7 +1550,7 @@ let default_matching_core_flags sigma = } let default_matching_merge_flags sigma = - let ts = Names.full_transparent_state in + let ts = TransparentState.full in let flags = default_matching_core_flags sigma in { flags with modulo_conv_on_closed_terms = Some ts; @@ -1580,7 +1580,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = if from_prefix_of_ind then let flags = default_matching_flags pending in { flags with core_unify_flags = { flags.core_unify_flags with - modulo_conv_on_closed_terms = Some Names.full_transparent_state; + modulo_conv_on_closed_terms = Some TransparentState.full; restrict_conv_on_strict_subterms = true } } else default_matching_flags pending in let n = Array.length (snd (decompose_app_vect sigma c)) in diff --git a/pretyping/unification.mli b/pretyping/unification.mli index e2e261ae7a..a45b8f1dd8 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -8,18 +8,17 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names open Constr open EConstr open Environ open Evd type core_unify_flags = { - modulo_conv_on_closed_terms : Names.transparent_state option; + modulo_conv_on_closed_terms : TransparentState.t option; use_metas_eagerly_in_conv_on_closed_terms : bool; use_evars_eagerly_in_conv_on_closed_terms : bool; - modulo_delta : Names.transparent_state; - modulo_delta_types : Names.transparent_state; + modulo_delta : TransparentState.t; + modulo_delta_types : TransparentState.t; check_applied_meta_types : bool; use_pattern_unification : bool; use_meta_bound_pattern_unification : bool; @@ -41,7 +40,7 @@ val default_core_unify_flags : unit -> core_unify_flags val default_no_delta_core_unify_flags : unit -> core_unify_flags val default_unify_flags : unit -> unify_flags -val default_no_delta_unify_flags : transparent_state -> unify_flags +val default_no_delta_unify_flags : TransparentState.t -> unify_flags val elim_flags : unit -> unify_flags val elim_no_delta_flags : unit -> unify_flags diff --git a/printing/dune b/printing/dune index 837ac48009..3392342165 100644 --- a/printing/dune +++ b/printing/dune @@ -2,6 +2,5 @@ (name printing) (synopsis "Coq's Term Pretty Printing Library") (public_name coq.printing) - (flags :standard -open Gramlib) (wrapped false) (libraries parsing proofs)) diff --git a/printing/prettyp.ml b/printing/prettyp.ml index e698ba9f8f..712eb21ee6 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -71,27 +71,26 @@ let int_or_no n = if Int.equal n 0 then str "no" else int n let print_basename sp = pr_global (ConstRef sp) let print_ref reduce ref udecl = - let typ, univs = Typeops.type_of_global_in_context (Global.env ()) ref in + let env = Global.env () in + let typ, univs = Typeops.type_of_global_in_context env ref in let inst = Univ.make_abstract_instance univs in - let bl = UnivNames.universe_binders_with_opt_names ref udecl in + let bl = UnivNames.universe_binders_with_opt_names (Environ.universes_of_global env ref) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in let typ = EConstr.of_constr typ in let typ = if reduce then - let env = Global.env () in let ctx,ccl = Reductionops.splay_prod_assum env sigma typ in EConstr.it_mkProd_or_LetIn ccl ctx else typ in let variance = match ref with | VarRef _ | ConstRef _ -> None | IndRef (ind,_) | ConstructRef ((ind,_),_) -> - let mind = Environ.lookup_mind ind (Global.env ()) in + let mind = Environ.lookup_mind ind env in begin match mind.Declarations.mind_universes with | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> None | Declarations.Cumulative_ind cumi -> Some (Univ.ACumulativityInfo.variance cumi) end in - let env = Global.env () in let inst = if Global.is_polymorphic ref then Printer.pr_universe_instance sigma inst @@ -571,7 +570,7 @@ let print_constant with_values sep sp udecl = in let ctx = UState.of_binders - (UnivNames.universe_binders_with_opt_names (ConstRef sp) udecl) + (UnivNames.universe_binders_with_opt_names (Declareops.constant_polymorphic_context cb) udecl) in let env = Global.env () and sigma = Evd.from_ctx ctx in let pr_ltype = pr_ltype_env env sigma in diff --git a/printing/printer.ml b/printing/printer.ml index da364c8b9e..4840577cbf 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -244,8 +244,19 @@ let pr_abstract_cumulativity_info sigma cumi = let pr_global_env = Nametab.pr_global_env let pr_global = pr_global_env Id.Set.empty +let pr_universe_instance_constraints evd inst csts = + let open Univ in + let prlev = Termops.pr_evd_level evd in + let pcsts = if Constraint.is_empty csts then mt() + else str " |= " ++ + prlist_with_sep (fun () -> str "," ++ spc()) + (fun (u,d,v) -> hov 0 (prlev u ++ pr_constraint_type d ++ prlev v)) + (Constraint.elements csts) + in + str"@{" ++ Instance.pr prlev inst ++ pcsts ++ str"}" + let pr_universe_instance evd inst = - str"@{" ++ Univ.Instance.pr (Termops.pr_evd_level evd) inst ++ str"}" + pr_universe_instance_constraints evd inst Univ.Constraint.empty let pr_puniverses f env sigma (c,u) = if !Constrextern.print_universes @@ -445,9 +456,9 @@ let pr_predicate pr_elt (b, elts) = let pr_cpred p = pr_predicate (pr_constant (Global.env())) (Cpred.elements p) let pr_idpred p = pr_predicate Id.print (Id.Pred.elements p) -let pr_transparent_state (ids, csts) = - hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++ - str"CONSTANTS: " ++ pr_cpred csts ++ fnl ()) +let pr_transparent_state ts = + hv 0 (str"VARIABLES: " ++ pr_idpred ts.TransparentState.tr_var ++ fnl () ++ + str"CONSTANTS: " ++ pr_cpred ts.TransparentState.tr_cst ++ fnl ()) (* display complete goal og_s has goal+sigma on the previous proof step for diffs @@ -674,10 +685,6 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map | None -> GoalMap.empty in - let map_goal_for_diff ng = (* todo: move to proof_diffs.ml *) - try GoalMap.find ng diff_goal_map with Not_found -> ng - in - (** Printing functions for the extra informations. *) let rec print_stack a = function | [] -> Pp.int a @@ -713,7 +720,12 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map let get_ogs g = match os_map with - | Some (osigma, _) -> Some { it = map_goal_for_diff g; sigma = osigma } + | Some (osigma, _) -> + (* if Not_found, returning None treats the goal as new and it will be highlighted; + returning Some { it = g; sigma = sigma } will compare the new goal + to itself and it won't be highlighted *) + (try Some { it = GoalMap.find g diff_goal_map; sigma = osigma } + with Not_found -> raise (Pp_diff.Diff_Failure "Unable to match goals between old and new proof states (7)")) | None -> None in let rec pr_rec n = function diff --git a/printing/printer.mli b/printing/printer.mli index f9d1a62895..cefc005c74 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -13,7 +13,6 @@ open Constr open Environ open Pattern open Evd -open Proof_type open Glob_term open Ltac_pretype @@ -85,6 +84,7 @@ val pr_sort : evar_map -> Sorts.t -> Pp.t val pr_polymorphic : bool -> Pp.t val pr_cumulative : bool -> bool -> Pp.t val pr_universe_instance : evar_map -> Univ.Instance.t -> Pp.t +val pr_universe_instance_constraints : evar_map -> Univ.Instance.t -> Univ.Constraint.t -> Pp.t val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> Univ.UContext.t -> Pp.t val pr_abstract_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> @@ -134,7 +134,7 @@ val pr_context_of : env -> evar_map -> Pp.t val pr_predicate : ('a -> Pp.t) -> (bool * 'a list) -> Pp.t val pr_cpred : Cpred.t -> Pp.t val pr_idpred : Id.Pred.t -> Pp.t -val pr_transparent_state : transparent_state -> Pp.t +val pr_transparent_state : TransparentState.t -> Pp.t (** Proofs, these functions obey [Hyps Limit] and [Compact contexts]. *) @@ -143,7 +143,7 @@ val pr_transparent_state : transparent_state -> Pp.t records containing the goal and sigma for, respectively, the new and old proof steps, e.g. [{ it = g ; sigma = sigma }]. *) -val pr_goal : ?diffs:bool -> ?og_s:(goal sigma) -> goal sigma -> Pp.t +val pr_goal : ?diffs:bool -> ?og_s:(Goal.goal sigma) -> Goal.goal sigma -> Pp.t (** [pr_subgoals ~pr_first ~diffs ~os_map close_cmd sigma ~seeds ~shelf ~stack ~unfocused ~goals] prints the goals in [goals] followed by the goals in [unfocused] in a compact form @@ -160,17 +160,17 @@ val pr_goal : ?diffs:bool -> ?og_s:(goal sigma) -> goal sigma -> there are non-instantiated existential variables. [stack] is used to print summary info on unfocused goals. *) -val pr_subgoals : ?pr_first:bool -> ?diffs:bool -> ?os_map:(evar_map * Evar.t Evar.Map.t) -> Pp.t option -> evar_map - -> seeds:goal list -> shelf:goal list -> stack:int list - -> unfocused: goal list -> goals:goal list -> Pp.t +val pr_subgoals : ?pr_first:bool -> ?diffs:bool -> ?os_map:(evar_map * Goal.goal Evar.Map.t) -> Pp.t option -> evar_map + -> seeds:Goal.goal list -> shelf:Goal.goal list -> stack:int list + -> unfocused:Goal.goal list -> goals:Goal.goal list -> Pp.t -val pr_subgoal : int -> evar_map -> goal list -> Pp.t +val pr_subgoal : int -> evar_map -> Goal.goal list -> Pp.t (** [pr_concl n ~diffs ~og_s sigma g] prints the conclusion of the goal [g] using [sigma]. The output is labelled "subgoal [n]". If [diffs] is true, highlight the differences between the old conclusion, [og_s], and [g]+[sigma]. [og_s] is a record containing the old goal and sigma, e.g. [{ it = g ; sigma = sigma }]. *) -val pr_concl : int -> ?diffs:bool -> ?og_s:(goal sigma) -> evar_map -> goal -> Pp.t +val pr_concl : int -> ?diffs:bool -> ?og_s:(Goal.goal sigma) -> evar_map -> Goal.goal -> Pp.t (** [pr_open_subgoals_diff ~quiet ~diffs ~oproof proof] shows the context for [proof] as used by, for example, coqtop. The first active goal is printed with all its antecedents and the conclusion. The other active goals only show their @@ -181,7 +181,7 @@ val pr_open_subgoals_diff : ?quiet:bool -> ?diffs:bool -> ?oproof:Proof.t -> Pr val pr_open_subgoals : proof:Proof.t -> Pp.t val pr_nth_open_subgoal : proof:Proof.t -> int -> Pp.t val pr_evar : evar_map -> (Evar.t * evar_info) -> Pp.t -val pr_evars_int : evar_map -> shelf:goal list -> givenup:goal list -> int -> evar_info Evar.Map.t -> Pp.t +val pr_evars_int : evar_map -> shelf:Goal.goal list -> givenup:Goal.goal list -> int -> evar_info Evar.Map.t -> Pp.t val pr_evars : evar_map -> evar_info Evar.Map.t -> Pp.t val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> Evar.Set.t -> Pp.t diff --git a/printing/printmod.ml b/printing/printmod.ml index cc40c74998..2c3ab46670 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -119,7 +119,9 @@ let print_mutual_inductive env mind mib udecl = | BiFinite -> "Variant" | CoFinite -> "CoInductive" in - let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind, 0)) udecl in + let bl = UnivNames.universe_binders_with_opt_names + (Declareops.inductive_polymorphic_context mib) udecl + in let sigma = Evd.from_ctx (UState.of_binders bl) in hov 0 (Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ Printer.pr_cumulative @@ -157,7 +159,9 @@ let print_record env mind mib udecl = let cstrtype = hnf_prod_applist_assum env nparamdecls cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in - let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind,0)) udecl in + let bl = UnivNames.universe_binders_with_opt_names (Declareops.inductive_polymorphic_context mib) + udecl + in let sigma = Evd.from_ctx (UState.of_binders bl) in let keyword = let open Declarations in @@ -296,7 +300,7 @@ let print_body is_impl extent env mp (l,body) = (match extent with | OnlyNames -> mt () | WithContents -> - let bl = UnivNames.universe_binders_with_opt_names (ConstRef (Constant.make2 mp l)) None in + let bl = UnivNames.universe_binders_with_opt_names ctx None in let sigma = Evd.from_ctx (UState.of_binders bl) in str " :" ++ spc () ++ hov 0 (Printer.pr_ltype_env env sigma cb.const_type) ++ diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 0b630b39b5..cc1bcc66ae 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -88,7 +88,7 @@ let tokenize_string s = let st = CLexer.get_lexer_state () in try let istr = Stream.of_string s in - let lex = CLexer.lexer.Plexing.tok_func istr in + let lex = CLexer.lexer.Gramlib.Plexing.tok_func istr in let toks = stream_tok [] (fst lex) in CLexer.set_lexer_state st; toks @@ -214,26 +214,22 @@ module CDC = Context.Compacted.Declaration let to_tuple : Constr.compacted_declaration -> (Names.Id.t list * 'pc option * 'pc) = let open CDC in function - | LocalAssum(idl, tm) -> (idl, None, tm) - | LocalDef(idl,tdef,tm) -> (idl, Some tdef, tm);; + | LocalAssum(idl, tm) -> (idl, None, EConstr.of_constr tm) + | LocalDef(idl,tdef,tm) -> (idl, Some (EConstr.of_constr tdef), EConstr.of_constr tm);; (* XXX: Very unfortunately we cannot use the Proofview interface as Proof is still using the "legacy" one. *) -let process_goal_concl sigma g : Constr.t * Environ.env = +let process_goal_concl sigma g : EConstr.t * Environ.env = let env = Goal.V82.env sigma g in let ty = Goal.V82.concl sigma g in - let ty = EConstr.to_constr sigma ty in (ty, env) -let process_goal sigma g : Constr.t reified_goal = +let process_goal sigma g : EConstr.t reified_goal = let env = Goal.V82.env sigma g in - let hyps = Goal.V82.hyps sigma g in let ty = Goal.V82.concl sigma g in let name = Goal.uid g in - (* There is a Constr/Econstr mess here... *) - let ty = EConstr.to_constr sigma ty in (* compaction is usually desired [eg for better display] *) - let hyps = Termops.compact_named_context (Environ.named_context_of_val hyps) in + let hyps = Termops.compact_named_context (Environ.named_context env) in let hyps = List.map to_tuple hyps in { name; ty; hyps; env; sigma };; @@ -241,13 +237,15 @@ let pr_letype_core goal_concl_style env sigma t = Ppconstr.pr_lconstr_expr (Constrextern.extern_type goal_concl_style env sigma t) let pp_of_type env sigma ty = - pr_letype_core true env sigma EConstr.(of_constr ty) + pr_letype_core true env sigma ty let pr_leconstr_core goal_concl_style env sigma t = Ppconstr.pr_lconstr_expr (Constrextern.extern_constr goal_concl_style env sigma t) let pr_lconstr_env env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c) +let pr_lconstr_env_econstr env sigma c = pr_leconstr_core false env sigma c + let diff_concl ?og_s nsigma ng = let open Evd in let o_concl_pp = match og_s with @@ -291,8 +289,8 @@ let goal_info goal sigma = line_idents := idents :: !line_idents; let mid = match body with | Some c -> - let pb = pr_lconstr_env env sigma c in - let pb = if Constr.isCast c then surround pb else pb in + let pb = pr_lconstr_env_econstr env sigma c in + let pb = if EConstr.isCast sigma c then surround pb else pb in str " := " ++ pb | None -> mt() in let ts = pp_of_type env sigma ty in @@ -409,7 +407,7 @@ let match_goals ot nt = match exp, exp2 with | Some expa, Some expb -> constr_expr ogname expa expb | None, None -> () - | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (1)") + | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (1)") in let local_binder_expr ogname exp exp2 = match exp, exp2 with @@ -421,7 +419,7 @@ let match_goals ot nt = | CLocalPattern p, CLocalPattern p2 -> let (p,ty), (p2,ty2) = p.v,p2.v in constr_expr_opt ogname ty ty2 - | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (2)") + | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (2)") in let recursion_order_expr ogname exp exp2 = match exp, exp2 with @@ -431,7 +429,7 @@ let match_goals ot nt = | CMeasureRec (m,r), CMeasureRec (m2,r2) -> constr_expr ogname m m2; constr_expr_opt ogname r r2 - | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (3)") + | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (3)") in let fix_expr ogname exp exp2 = let (l,(lo,ro),lb,ce1,ce2), (l2,(lo2,ro2),lb2,ce12,ce22) = exp,exp2 in @@ -515,7 +513,7 @@ let match_goals ot nt = | CastNative a, CastNative a2 -> constr_expr ogname a a2 | CastCoerce, CastCoerce -> () - | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (4)")) + | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (4)")) | CNotation (ntn,args), CNotation (ntn2,args2) -> constr_notation_substitution ogname args args2 | CGeneralization (b,a,c), CGeneralization (b2,a2,c2) -> @@ -523,7 +521,7 @@ let match_goals ot nt = | CPrim p, CPrim p2 -> () | CDelimiters (key,e), CDelimiters (key2,e2) -> constr_expr ogname e e2 - | _, _ -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (5)") + | _, _ -> raise (Diff_Failure "Unable to match goals between old and new proof states (5)") end in @@ -563,9 +561,8 @@ let db_goal_map op np ng_to_og = Printf.printf "\n" [@@@ocaml.warning "+32"] -(* Create a map from new goals to old goals for proof diff. The map only - has entries for new goals that are not the same as the corresponding old - goal; there are no entries for unchanged goals. +(* Create a map from new goals to old goals for proof diff. New goals + that are evars not appearing in the proof will not have a mapping. It proceeds as follows: 1. Find the goal ids that were removed from the old proof and that were @@ -583,7 +580,7 @@ let db_goal_map op np ng_to_og = the removed goal. - if there are more than 2 removals and more than one addition, call match_goals to get a map between old and new evar names, then use this - to create the map from new goal ids to old goal ids for the differing goals. + to create the map from new goal ids to old goal ids. *) let make_goal_map_i op np = let ng_to_og = ref GoalMap.empty in @@ -598,6 +595,9 @@ let make_goal_map_i op np = let add_gs = diff ngs ogs in let num_adds = cardinal add_gs in + (* add common goals *) + Goal.Set.iter (fun x -> ng_to_og := GoalMap.add x x !ng_to_og) (inter ogs ngs); + if num_rems = 0 then !ng_to_og (* proofs are the same *) else if num_adds = 0 then @@ -616,17 +616,16 @@ let make_goal_map_i op np = List.iter (fun og -> oevar_to_og := StringMap.add (goal_to_evar og osigma) og !oevar_to_og) (Goal.Set.elements rem_gs); - try - let (_,_,_,_,nsigma) = Proof.proof np in - let get_og ng = - let nevar = goal_to_evar ng nsigma in - let oevar = StringMap.find nevar nevar_to_oevar in - let og = StringMap.find oevar !oevar_to_og in - og - in - Goal.Set.iter (fun ng -> ng_to_og := GoalMap.add ng (get_og ng) !ng_to_og) add_gs; - !ng_to_og - with Not_found -> raise (Diff_Failure "Unable to match goals betwen old and new proof states (6)") + let (_,_,_,_,nsigma) = Proof.proof np in + let get_og ng = + let nevar = goal_to_evar ng nsigma in + let oevar = StringMap.find nevar nevar_to_oevar in + let og = StringMap.find oevar !oevar_to_og in + og + in + Goal.Set.iter (fun ng -> + try ng_to_og := GoalMap.add ng (get_og ng) !ng_to_og with Not_found -> ()) add_gs; + !ng_to_og end let make_goal_map op np = diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index 832393e15f..ce9ee5ae6f 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -16,7 +16,6 @@ val write_diffs_option : string -> unit val show_diffs : unit -> bool open Evd -open Proof_type open Environ open Constr @@ -31,7 +30,7 @@ If you want to make your call especially bulletproof, catch these exceptions, print a user-visible message, then recall this routine with the first argument set to None, which will skip the diff. *) -val diff_goal_ide : goal sigma option -> goal -> Evd.evar_map -> Pp.t list * Pp.t +val diff_goal_ide : Goal.goal sigma option -> Goal.goal -> Evd.evar_map -> Pp.t list * Pp.t (** Computes the diff between two goals @@ -43,7 +42,7 @@ If you want to make your call especially bulletproof, catch these exceptions, print a user-visible message, then recall this routine with the first argument set to None, which will skip the diff. *) -val diff_goal : ?og_s:(goal sigma) -> goal -> Evd.evar_map -> Pp.t +val diff_goal : ?og_s:(Goal.goal sigma) -> Goal.goal -> Evd.evar_map -> Pp.t (** Convert a string to a list of token strings using the lexer *) val tokenize_string : string -> string list @@ -53,7 +52,7 @@ val pr_leconstr_core : bool -> Environ.env -> Evd.evar_map -> EConstr.cons val pr_lconstr_env : env -> evar_map -> constr -> Pp.t (** Computes diffs for a single conclusion *) -val diff_concl : ?og_s:goal sigma -> Evd.evar_map -> Goal.goal -> Pp.t +val diff_concl : ?og_s:Goal.goal sigma -> Evd.evar_map -> Goal.goal -> Pp.t (** Generates a map from [np] to [op] that maps changed goals to their prior forms. The map doesn't include entries for unchanged goals; unchanged goals @@ -61,7 +60,7 @@ will have the same goal id in both versions. [op] and [np] must be from the same proof document and [op] must be for a state before [np]. *) -val make_goal_map : Proof.t option -> Proof.t -> Evar.t Evar.Map.t +val make_goal_map : Proof.t option -> Proof.t -> Goal.goal Evar.Map.t (* Exposed for unit test, don't use these otherwise *) (* output channel for the test log file *) diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index b99cf245fe..4720328893 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -9,7 +9,6 @@ (************************************************************************) open Util -open Names open Constr open Termops open Evd @@ -17,7 +16,6 @@ open EConstr open Refiner open Logic open Reduction -open Tacmach open Clenv (* This function put casts around metavariables whose type could not be @@ -80,7 +78,7 @@ let clenv_refine ?(with_evars=false) ?(with_classes=true) clenv = let clenv = { clenv with evd = evd' } in tclTHEN (tclEVARS (Evd.clear_metas evd')) - (refine_no_check (clenv_cast_meta clenv (clenv_value clenv))) gl + (refiner ~check:false EConstr.Unsafe.(to_constr (clenv_cast_meta clenv (clenv_value clenv)))) gl end let clenv_pose_dependent_evars ?(with_evars=false) clenv = @@ -102,11 +100,11 @@ let res_pf ?with_evars ?(with_classes=true) ?(flags=dft ()) clenv = provenant de w_Unify. (Utilisé seulement dans prolog.ml) *) let fail_quick_core_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some TransparentState.full; use_metas_eagerly_in_conv_on_closed_terms = false; use_evars_eagerly_in_conv_on_closed_terms = false; - modulo_delta = empty_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = TransparentState.empty; + modulo_delta_types = TransparentState.full; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; (* ? *) diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index c80f370fdc..6c4193c66b 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -10,7 +10,6 @@ open CErrors open Util -open Names open Evd open Evarutil open Evarsolve @@ -38,7 +37,7 @@ let define_and_solve_constraints evk c env evd = match List.fold_left (fun p (pbty,env,t1,t2) -> match p with - | Success evd -> Evarconv.evar_conv_x full_transparent_state env evd pbty t1 t2 + | Success evd -> Evarconv.evar_conv_x TransparentState.full env evd pbty t1 t2 | UnifFailure _ as x -> x) (Success evd) pbs with @@ -53,7 +52,6 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = let flags = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; - Pretyping.use_hook = None; Pretyping.fail_evar = false; Pretyping.expand_evars = true } in try Pretyping.understand_ltac flags diff --git a/proofs/logic.ml b/proofs/logic.ml index 4d5711c195..15ba0a704f 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -20,7 +20,6 @@ open Environ open Reductionops open Inductiveops open Typing -open Proof_type open Type_errors open Retyping @@ -62,6 +61,8 @@ let is_unification_error = function let catchable_exception = function | CErrors.UserError _ | TypeError _ + | Proof.OpenProof _ + (* abstract will call close_proof inside a tactic *) | Notation.NumeralNotationError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ @@ -583,12 +584,15 @@ let convert_hyp check sign sigma d = let prim_refiner r sigma goal = let env = Goal.V82.env sigma goal in let cl = Goal.V82.concl sigma goal in - match r with - (* Logical rules *) - | Refine c -> - let cl = EConstr.Unsafe.to_constr cl in - check_meta_variables env sigma c; - let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl c in - let sgl = List.rev sgl in - let sigma = Goal.V82.partial_solution env sigma goal (EConstr.of_constr oterm) in - (sgl, sigma) + let cl = EConstr.Unsafe.to_constr cl in + check_meta_variables env sigma r; + let (sgl,cl',sigma,oterm) = mk_refgoals sigma goal [] cl r in + let sgl = List.rev sgl in + let sigma = Goal.V82.partial_solution env sigma goal (EConstr.of_constr oterm) in + (sgl, sigma) + +let prim_refiner ~check r sigma goal = + if check then + with_check (prim_refiner r sigma) goal + else + prim_refiner r sigma goal diff --git a/proofs/logic.mli b/proofs/logic.mli index 2cad278e10..f99076db23 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -13,27 +13,20 @@ open Names open Constr open Evd -open Proof_type -(** This suppresses check done in [prim_refiner] for the tactic given in - argument; works by side-effect *) - -val with_check : tactic -> tactic - -(** [without_check] respectively means:\\ - [Intro]: no check that the name does not exist\\ - [Intro_after]: no check that the name does not exist and that variables in +(** [check] respectively means:\\ + [Intro]: check that the name does not exist\\ + [Intro_after]: check that the name does not exist and that variables in its type does not escape their scope\\ - [Intro_replacing]: no check that the name does not exist and that + [Intro_replacing]: check that the name does not exist and that variables in its type does not escape their scope\\ [Convert_hyp]: - no check that the name exist and that its type is convertible\\ + check that the name exist and that its type is convertible\\ *) (** The primitive refiner. *) -val prim_refiner : prim_rule -> evar_map -> goal -> goal list * evar_map - +val prim_refiner : check:bool -> constr -> evar_map -> Goal.goal -> Goal.goal list * evar_map (** {6 Refiner errors. } *) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index e6507332b1..81122e6858 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -26,25 +26,6 @@ let _ = Goptions.declare_bool_option { let use_unification_heuristics () = !use_unification_heuristics_ref -let start_proof (id : Id.t) ?pl str sigma hyps c ?init_tac terminator = - let goals = [ (Global.env_of_context hyps , c) ] in - Proof_global.start_proof sigma id ?pl str goals terminator; - let env = Global.env () in - ignore (Proof_global.with_current_proof (fun _ p -> - match init_tac with - | None -> p,(true,[]) - | Some tac -> Proof.run_tactic env tac p)) - -let cook_this_proof p = - match p with - | { Proof_global.id;entries=[constr];persistence;universes } -> - (id,(constr,universes,persistence)) - | _ -> CErrors.anomaly ~label:"Pfedit.cook_proof" (Pp.str "more than one proof term.") - -let cook_proof () = - cook_this_proof (fst - (Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x))) - exception NoSuchGoal let _ = CErrors.register_handler begin function | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") @@ -152,13 +133,19 @@ let next = let n = ref 0 in fun () -> incr n; !n let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac = let evd = Evd.from_ctx ctx in let terminator = Proof_global.make_terminator (fun _ -> ()) in - start_proof id goal_kind evd sign typ terminator; + let goals = [ (Global.env_of_context sign , typ) ] in + Proof_global.start_proof evd id goal_kind goals terminator; try let status = by tac in - let _,(const,univs,_) = cook_proof () in - Proof_global.discard_current (); - let univs = UState.demote_seff_univs const univs in - const, status, univs + let open Proof_global in + let { entries; universes } = fst @@ close_proof ~keep_body_ucst_separate:false (fun x -> x) in + match entries with + | [entry] -> + discard_current (); + let univs = UState.demote_seff_univs entry universes in + entry, status, univs + | _ -> + CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") with reraise -> let reraise = CErrors.push reraise in Proof_global.discard_current (); @@ -227,36 +214,3 @@ let refine_by_tactic env sigma ty tac = this hack will work in most cases. *) let ans = Safe_typing.inline_private_constants_in_constr env ans neff in ans, sigma - -(**********************************************************************) -(* Support for resolution of evars in tactic interpretation, including - resolution by application of tactics *) - -let implicit_tactic = Summary.ref None ~name:"implicit-tactic" - -let declare_implicit_tactic tac = implicit_tactic := Some tac - -let clear_implicit_tactic () = implicit_tactic := None - -let apply_implicit_tactic tac = (); fun env sigma evk -> - let evi = Evd.find_undefined sigma evk in - match snd (evar_source evk sigma) with - | (Evar_kinds.ImplicitArg _ | Evar_kinds.QuestionMark _) - when - Context.Named.equal Constr.equal (Environ.named_context_of_val evi.evar_hyps) - (Environ.named_context env) -> - let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError (None,Pp.str"Proof is not complete."))) []) in - (try - let c = Evarutil.nf_evars_universes sigma (EConstr.Unsafe.to_constr evi.evar_concl) in - let c = EConstr.of_constr c in - if Evarutil.has_undefined_evars sigma c then raise Exit; - let (ans, _, ctx) = - build_by_tactic env (Evd.evar_universe_context sigma) c tac in - let sigma = Evd.set_universe_context sigma ctx in - sigma, EConstr.of_constr ans - with e when Logic.catchable_exception e -> raise Exit) - | _ -> raise Exit - -let solve_by_implicit_tactic () = match !implicit_tactic with -| None -> None -| Some tac -> Some (apply_implicit_tactic tac) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 5feb5bd645..155221947a 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -16,34 +16,6 @@ open Environ open Decl_kinds (** {6 ... } *) -(** [start_proof s str env t hook tac] starts a proof of name [s] and - conclusion [t]; [hook] is optionally a function to be applied at - proof end (e.g. to declare the built constructions as a coercion - or a setoid morphism); init_tac is possibly a tactic to - systematically apply at initialization time (e.g. to start the - proof of mutually dependent theorems) *) - -val start_proof : - Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> - ?init_tac:unit Proofview.tactic -> - Proof_global.proof_terminator -> unit - -(** {6 ... } *) -(** [cook_proof opacity] turns the current proof (assumed completed) into - a constant with its name, kind and possible hook (see [start_proof]); - it fails if there is no current proof of if it is not completed; - it also tells if the guardness condition has to be inferred. *) - -val cook_this_proof : - Proof_global.proof_object -> - (Id.t * - (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind)) - -val cook_proof : unit -> - (Id.t * - (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind)) - -(** {6 ... } *) (** [get_goal_context n] returns the context of the [n]th subgoal of the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) @@ -116,13 +88,3 @@ val refine_by_tactic : env -> Evd.evar_map -> EConstr.types -> unit Proofview.ta evars solved by side-effects are NOT purged, so that unexpected failures may occur. Ideally all code using this function should be rewritten in the monad. *) - -(** Declare the default tactic to fill implicit arguments *) - -val declare_implicit_tactic : unit Proofview.tactic -> unit - -(** To remove the default tactic *) -val clear_implicit_tactic : unit -> unit - -(* Raise Exit if cannot solve *) -val solve_by_implicit_tactic : unit -> Pretyping.inference_hook option diff --git a/proofs/proof.ml b/proofs/proof.ml index 8220949856..6c13c4946a 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -335,28 +335,42 @@ let dependent_start goals = let number_of_goals = List.length (Proofview.initial_goals pr.entry) in _focus end_of_stack (Obj.repr ()) 1 number_of_goals pr -exception UnfinishedProof -exception HasShelvedGoals -exception HasGivenUpGoals -exception HasUnresolvedEvar +type open_error_reason = + | UnfinishedProof + | HasShelvedGoals + | HasGivenUpGoals + | HasUnresolvedEvar + +let print_open_error_reason er = let open Pp in match er with + | UnfinishedProof -> + str "Attempt to save an incomplete proof" + | HasShelvedGoals -> + str "Attempt to save a proof with shelved goals" + | HasGivenUpGoals -> + strbrk "Attempt to save a proof with given up goals. If this is really what you want to do, use Admitted in place of Qed." + | HasUnresolvedEvar -> + strbrk "Attempt to save a proof with existential variables still non-instantiated" + +exception OpenProof of Names.Id.t option * open_error_reason + let _ = CErrors.register_handler begin function - | UnfinishedProof -> CErrors.user_err Pp.(str "Some goals have not been solved.") - | HasShelvedGoals -> CErrors.user_err Pp.(str "Some goals have been left on the shelf.") - | HasGivenUpGoals -> CErrors.user_err Pp.(str "Some goals have been given up.") - | HasUnresolvedEvar -> CErrors.user_err Pp.(str "Some existential variables are uninstantiated.") - | _ -> raise CErrors.Unhandled -end + | OpenProof (pid, reason) -> + let open Pp in + Option.cata (fun pid -> + str " (in proof " ++ Names.Id.print pid ++ str "): ") (mt()) pid ++ print_open_error_reason reason + | _ -> raise CErrors.Unhandled + end -let return p = +let return ?pid (p : t) = if not (is_done p) then - raise UnfinishedProof + raise (OpenProof(pid, UnfinishedProof)) else if has_shelved_goals p then - raise HasShelvedGoals + raise (OpenProof(pid, HasShelvedGoals)) else if has_given_up_goals p then - raise HasGivenUpGoals + raise (OpenProof(pid, HasGivenUpGoals)) else if has_unresolved_evar p then (* spiwack: for compatibility with <= 8.3 proof engine *) - raise HasUnresolvedEvar + raise (OpenProof(pid, HasUnresolvedEvar)) else let p = unfocus end_of_stack_kind p () in Proofview.return p.proofview @@ -449,11 +463,10 @@ module V82 = struct let grab_evars p = if not (is_done p) then - raise UnfinishedProof + raise (OpenProof(None, UnfinishedProof)) else { p with proofview = Proofview.V82.grab p.proofview } - (* Main component of vernac command Existential *) let instantiate_evar n com pr = let tac = @@ -491,4 +504,6 @@ let all_goals p = let set = add goals Goal.Set.empty in let set = List.fold_left (fun s gs -> let (g1, g2) = gs in add g1 (add g2 set)) set stack in let set = add shelf set in - add given_up set + let set = add given_up set in + let { Evd.it = bgoals ; sigma = bsigma } = V82.background_subgoals p in + add bgoals set diff --git a/proofs/proof.mli b/proofs/proof.mli index 8cf543557b..aaabea3454 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -89,11 +89,15 @@ val compact : t -> t Raises [HasShelvedGoals] if some goals are left on the shelf. Raises [HasGivenUpGoals] if some goals have been given up. Raises [HasUnresolvedEvar] if some evars have been left undefined. *) -exception UnfinishedProof -exception HasShelvedGoals -exception HasGivenUpGoals -exception HasUnresolvedEvar -val return : t -> Evd.evar_map +type open_error_reason = + | UnfinishedProof + | HasShelvedGoals + | HasGivenUpGoals + | HasUnresolvedEvar + +exception OpenProof of Names.Id.t option * open_error_reason + +val return : ?pid:Names.Id.t -> t -> Evd.evar_map (*** Focusing actions ***) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 25cf789193..cb4b5759dc 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -176,7 +176,6 @@ let simple_with_current_proof f = with_current_proof (fun t p -> f t p , ()) let compact_the_proof () = simple_with_current_proof (fun _ -> Proof.compact) - (* Sets the tactic to be used when a tactic line is closed with [...] *) let set_endline_tactic tac = match !pstates with @@ -416,20 +415,7 @@ let return_proof ?(allow_partial=false) () = proofs, Evd.evar_universe_context evd end else let initial_goals = Proof.initial_goals proof in - let evd = - let error s = - let prf = str " (in proof " ++ Id.print pid ++ str ")" in - raise (CErrors.UserError(Some "last tactic before Qed",s ++ prf)) - in - try Proof.return proof with - | Proof.UnfinishedProof -> - error(str"Attempt to save an incomplete proof") - | Proof.HasShelvedGoals -> - error(str"Attempt to save a proof with shelved goals") - | Proof.HasGivenUpGoals -> - error(strbrk"Attempt to save a proof with given up goals. If this is really what you want to do, use Admitted in place of Qed.") - | Proof.HasUnresolvedEvar-> - error(strbrk"Attempt to save a proof with existential variables still non-instantiated") in + let evd = Proof.return ~pid proof in let eff = Evd.eval_side_effects evd in let evd = Evd.minimize_universes evd in (** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 2b04bfab57..e3808bc36d 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -60,14 +60,14 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit -(** [start_proof id str pl goals terminator] starts a proof of name [id] - with goals [goals] (a list of pairs of environment and - conclusion); [str] describes what kind of theorem/definition this - is (spiwack: for potential printing, I believe is used only by - closing commands and the xml plugin); [terminator] is used at the - end of the proof to close the proof. The proof is started in the - evar map [sigma] (which can typically contain universe - constraints), and with universe bindings pl. *) +(** [start_proof id str pl goals terminator] starts a proof of name + [id] with goals [goals] (a list of pairs of environment and + conclusion); [str] describes what kind of theorem/definition this + is; [terminator] is used at the end of the proof to close the proof + (e.g. to declare the built constructions as a coercion or a setoid + morphism). The proof is started in the evar map [sigma] (which can + typically contain universe constraints), and with universe bindings + pl. *) val start_proof : Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 197f71ca91..dbd5be23ab 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -1,10 +1,9 @@ Miscprint Goal Evar_refiner -Proof_type -Logic Refine Proof +Logic Goal_select Proof_bullet Proof_global diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 56ce744bc1..0981584bb5 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -160,7 +160,7 @@ let make_flag env f = (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) all_opaque in + 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 diff --git a/proofs/refiner.ml b/proofs/refiner.ml index be32aadd91..bce227dabb 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -12,9 +12,10 @@ open Pp open CErrors open Util open Evd -open Proof_type open Logic +type tactic = Proofview.V82.tac + module NamedDecl = Context.Named.Declaration let sig_it x = x.it @@ -25,16 +26,16 @@ let project x = x.sigma let pf_env gls = Global.env_of_context (Goal.V82.hyps (project gls) (sig_it gls)) let pf_hyps gls = EConstr.named_context_of_val (Goal.V82.hyps (project gls) (sig_it gls)) -let refiner pr goal_sigma = - let (sgl,sigma') = prim_refiner pr goal_sigma.sigma goal_sigma.it in +let refiner ~check pr goal_sigma = + let (sgl,sigma') = prim_refiner ~check pr goal_sigma.sigma goal_sigma.it in { it = sgl; sigma = sigma'; } (* Profiling refiner *) -let refiner = +let refiner ~check = if Flags.profile then let refiner_key = CProfile.declare_profile "refiner" in - CProfile.profile2 refiner_key refiner - else refiner + CProfile.profile2 refiner_key (refiner ~check) + else refiner ~check (*********************) (* Tacticals *) @@ -178,9 +179,9 @@ let tclPROGRESS tac ptree = NOTE: some tactics delete hypothesis and reuse names (induction, destruct), this is not detected by this tactical. *) let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) - :Proof_type.goal list Evd.sigma = + : Goal.goal list Evd.sigma = let oldhyps = pf_hyps goal in - let rslt:Proof_type.goal list Evd.sigma = tac goal in + let rslt:Goal.goal list Evd.sigma = tac goal in let { it = gls; sigma = sigma; } = rslt in let hyps = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 30af6d8e1a..52cbf7658b 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -11,18 +11,18 @@ (** Legacy proof engine. Do not use in newly written code. *) open Evd -open Proof_type open EConstr (** The refiner (handles primitive rules and high-level tactics). *) +type tactic = Proofview.V82.tac val sig_it : 'a sigma -> 'a val project : 'a sigma -> evar_map -val pf_env : goal sigma -> Environ.env -val pf_hyps : goal sigma -> named_context +val pf_env : Goal.goal sigma -> Environ.env +val pf_hyps : Goal.goal sigma -> named_context -val refiner : rule -> tactic +val refiner : check:bool -> Constr.t -> tactic (** {6 Tacticals. } *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 231a8fe266..64d7630d55 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -17,9 +17,7 @@ open Evd open Typing open Redexpr open Tacred -open Proof_type open Logic -open Refiner open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -30,7 +28,7 @@ let re_sig it gc = { it = it; sigma = gc; } (* Operations for handling terms under a local typing context *) (**************************************************************) -type tactic = Proof_type.tactic +type tactic = Proofview.V82.tac let sig_it = Refiner.sig_it let project = Refiner.project @@ -103,20 +101,6 @@ let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls -(********************************************) -(* Definition of the most primitive tactics *) -(********************************************) - -let refiner = refiner - -let refine_no_check c gl = - let c = EConstr.Unsafe.to_constr c in - refiner (Refine c) gl - -(* Versions with consistency checks *) - -let refine c = with_check (refine_no_check c) - (* Pretty-printers *) open Pp diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 14c83a6802..ef6a1544e4 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -12,85 +12,78 @@ open Names open Constr open Environ open EConstr -open Proof_type open Redexpr open Locus (** Operations for handling terms under a local typing context. *) open Evd -type tactic = Proof_type.tactic;; + +type tactic = Proofview.V82.tac val sig_it : 'a sigma -> 'a -val project : goal sigma -> evar_map +val project : Goal.goal sigma -> evar_map val re_sig : 'a -> evar_map -> 'a sigma -val pf_concl : goal sigma -> types -val pf_env : goal sigma -> env -val pf_hyps : goal sigma -> named_context -(*i val pf_untyped_hyps : goal sigma -> (Id.t * constr) list i*) -val pf_hyps_types : goal sigma -> (Id.t * types) list -val pf_nth_hyp_id : goal sigma -> int -> Id.t -val pf_last_hyp : goal sigma -> named_declaration -val pf_ids_of_hyps : goal sigma -> Id.t list -val pf_global : goal sigma -> Id.t -> evar_map * constr -val pf_unsafe_type_of : goal sigma -> constr -> types -val pf_type_of : goal sigma -> constr -> evar_map * types -val pf_hnf_type_of : goal sigma -> constr -> types +val pf_concl : Goal.goal sigma -> types +val pf_env : Goal.goal sigma -> env +val pf_hyps : Goal.goal sigma -> named_context +(*i val pf_untyped_hyps : Goal.goal sigma -> (Id.t * constr) list i*) +val pf_hyps_types : Goal.goal sigma -> (Id.t * types) list +val pf_nth_hyp_id : Goal.goal sigma -> int -> Id.t +val pf_last_hyp : Goal.goal sigma -> named_declaration +val pf_ids_of_hyps : Goal.goal sigma -> Id.t list +val pf_global : Goal.goal sigma -> Id.t -> evar_map * constr +val pf_unsafe_type_of : Goal.goal sigma -> constr -> types +val pf_type_of : Goal.goal sigma -> constr -> evar_map * types +val pf_hnf_type_of : Goal.goal sigma -> constr -> types -val pf_get_hyp : goal sigma -> Id.t -> named_declaration -val pf_get_hyp_typ : goal sigma -> Id.t -> types +val pf_get_hyp : Goal.goal sigma -> Id.t -> named_declaration +val pf_get_hyp_typ : Goal.goal sigma -> Id.t -> types -val pf_get_new_id : Id.t -> goal sigma -> Id.t +val pf_get_new_id : Id.t -> Goal.goal sigma -> Id.t -val pf_reduction_of_red_expr : goal sigma -> red_expr -> constr -> evar_map * constr +val pf_reduction_of_red_expr : Goal.goal sigma -> red_expr -> constr -> evar_map * constr -val pf_apply : (env -> evar_map -> 'a) -> goal sigma -> 'a +val pf_apply : (env -> evar_map -> 'a) -> Goal.goal sigma -> 'a val pf_eapply : (env -> evar_map -> 'a -> evar_map * 'b) -> - goal sigma -> 'a -> goal sigma * 'b + Goal.goal sigma -> 'a -> Goal.goal sigma * 'b val pf_reduce : (env -> evar_map -> constr -> constr) -> - goal sigma -> constr -> constr + Goal.goal sigma -> constr -> constr val pf_e_reduce : (env -> evar_map -> constr -> evar_map * constr) -> - goal sigma -> constr -> evar_map * constr - -val pf_whd_all : goal sigma -> constr -> constr -val pf_hnf_constr : goal sigma -> constr -> constr -val pf_nf : goal sigma -> constr -> constr -val pf_nf_betaiota : goal sigma -> constr -> constr -val pf_reduce_to_quantified_ind : goal sigma -> types -> (inductive * EInstance.t) * types -val pf_reduce_to_atomic_ind : goal sigma -> types -> (inductive * EInstance.t) * types -val pf_compute : goal sigma -> constr -> constr + Goal.goal sigma -> constr -> evar_map * constr + +val pf_whd_all : Goal.goal sigma -> constr -> constr +val pf_hnf_constr : Goal.goal sigma -> constr -> constr +val pf_nf : Goal.goal sigma -> constr -> constr +val pf_nf_betaiota : Goal.goal sigma -> constr -> constr +val pf_reduce_to_quantified_ind : Goal.goal sigma -> types -> (inductive * EInstance.t) * types +val pf_reduce_to_atomic_ind : Goal.goal sigma -> types -> (inductive * EInstance.t) * types +val pf_compute : Goal.goal sigma -> constr -> constr val pf_unfoldn : (occurrences * evaluable_global_reference) list - -> goal sigma -> constr -> constr - -val pf_const_value : goal sigma -> pconstant -> constr -val pf_conv_x : goal sigma -> constr -> constr -> bool -val pf_conv_x_leq : goal sigma -> constr -> constr -> bool - -(** {6 The most primitive tactics. } *) - -val refiner : rule -> tactic -val refine_no_check : constr -> tactic + -> Goal.goal sigma -> constr -> constr -(** {6 The most primitive tactics with consistency and type checking } *) - -val refine : constr -> tactic +val pf_const_value : Goal.goal sigma -> pconstant -> constr +val pf_conv_x : Goal.goal sigma -> constr -> constr -> bool +val pf_conv_x_leq : Goal.goal sigma -> constr -> constr -> bool (** {6 Pretty-printing functions (debug only). } *) -val pr_gls : goal sigma -> Pp.t -val pr_glls : goal list sigma -> Pp.t +val pr_gls : Goal.goal sigma -> Pp.t +val pr_glls : Goal.goal list sigma -> Pp.t [@@ocaml.deprecated "Please move to \"new\" proof engine"] (** Variants of [Tacmach] functions built with the new proof engine *) module New : sig + val pf_apply : (env -> evar_map -> 'a) -> Proofview.Goal.t -> 'a val pf_global : Id.t -> Proofview.Goal.t -> GlobRef.t + (** FIXME: encapsulate the level in an existential type. *) - val of_old : (Proof_type.goal Evd.sigma -> 'a) -> Proofview.Goal.t -> 'a + val of_old : (Goal.goal Evd.sigma -> 'a) -> Proofview.Goal.t -> 'a val project : Proofview.Goal.t -> Evd.evar_map val pf_env : Proofview.Goal.t -> Environ.env diff --git a/stm/stm.ml b/stm/stm.ml index 514b364af3..9359ab15e2 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -25,6 +25,7 @@ open CErrors open Names open Feedback open Vernacexpr +open Vernacextend module AsyncOpts = struct @@ -162,7 +163,7 @@ type branch_type = [ `Master | `Proof of proof_mode * depth | `Edit of - proof_mode * Stateid.t * Stateid.t * vernac_qed_type * Vcs_.Branch.t ] + proof_mode * Stateid.t * Stateid.t * Vernacextend.vernac_qed_type * Vcs_.Branch.t ] (* TODO 8.7 : split commands and tactics, since this type is too messy now *) type cmd_t = { ctac : bool; (* is a tactic *) @@ -174,7 +175,7 @@ type cmd_t = { | `TacQueue of solving_tac * anon_abstracting_tac * AsyncTaskQueue.cancel_switch | `QueryQueue of AsyncTaskQueue.cancel_switch | `SkipQueue ] } -type fork_t = aast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Names.Id.t list +type fork_t = aast * Vcs_.Branch.t * opacity_guarantee * Names.Id.t list type qed_t = { qast : aast; keep : vernac_qed_type; @@ -308,11 +309,13 @@ end (* }}} *) (*************************** THE DOCUMENT *************************************) (******************************************************************************) +type interactive_top = TopLogical of DirPath.t | TopPhysical of string + (* The main document type associated to a VCS *) type stm_doc_type = | VoDoc of string | VioDoc of string - | Interactive of Names.DirPath.t + | Interactive of interactive_top (* Dummy until we land the functional interp patch + fixed start_library *) type doc = int @@ -522,7 +525,7 @@ end = struct (* {{{ *) type vcs = (branch_type, transaction, vcs state_info, box) t let vcs : vcs ref = ref (empty Stateid.dummy) - let doc_type = ref (Interactive (Names.DirPath.make [])) + let doc_type = ref (Interactive (TopLogical (Names.DirPath.make []))) let ldir = ref Names.DirPath.empty let init dt id = @@ -2585,6 +2588,27 @@ let init_core () = if !cur_opt.async_proofs_mode = APon then Control.enable_thread_delay := true; State.register_root_state () +let check_coq_overwriting p = + let l = DirPath.repr p in + let id, l = match l with id::l -> id,l | [] -> assert false in + let is_empty = match l with [] -> true | _ -> false in + if not !Flags.boot && not is_empty && Id.equal (CList.last l) Libnames.coq_root then + user_err + (str "Cannot build module " ++ DirPath.print p ++ str "." ++ spc () ++ + str "it starts with prefix \"Coq\" which is reserved for the Coq library.") + +let dirpath_of_file f = + let ldir0 = + try + let lp = Loadpath.find_load_path (Filename.dirname f) in + Loadpath.logical lp + with Not_found -> Libnames.default_root_prefix + in + let file = Filename.chop_extension (Filename.basename f) in + let id = Id.of_string file in + let ldir = Libnames.add_dirpath_suffix ldir0 id in + ldir + let new_doc { doc_type ; iload_path; require_libs; stm_options } = let load_objs libs = @@ -2609,20 +2633,28 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = List.iter Mltop.add_coq_path iload_path; begin match doc_type with - | Interactive ln -> - Safe_typing.allow_delayed_constants := true; - Declaremods.start_library ln - - | VoDoc ln -> - let ldir = Flags.verbosely Library.start_library ln in - VCS.set_ldir ldir; - set_compilation_hints ln - - | VioDoc ln -> - Safe_typing.allow_delayed_constants := true; - let ldir = Flags.verbosely Library.start_library ln in - VCS.set_ldir ldir; - set_compilation_hints ln + | Interactive ln -> + let dp = match ln with + | TopLogical dp -> dp + | TopPhysical f -> dirpath_of_file f + in + Safe_typing.allow_delayed_constants := true; + Declaremods.start_library dp + + | VoDoc f -> + let ldir = dirpath_of_file f in + check_coq_overwriting ldir; + let () = Flags.verbosely Declaremods.start_library ldir in + VCS.set_ldir ldir; + set_compilation_hints f + + | VioDoc f -> + Safe_typing.allow_delayed_constants := true; + let ldir = dirpath_of_file f in + check_coq_overwriting ldir; + let () = Flags.verbosely Declaremods.start_library ldir in + VCS.set_ldir ldir; + set_compilation_hints f end; (* Import initial libraries. *) diff --git a/stm/stm.mli b/stm/stm.mli index 1e5ceb7e23..0c0e19ce5c 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -39,13 +39,15 @@ module AsyncOpts : sig end +type interactive_top = TopLogical of DirPath.t | TopPhysical of string + (** The STM document type [stm_doc_type] determines some properties such as what uncompleted proofs are allowed and what gets recorded to aux files. *) type stm_doc_type = | VoDoc of string (* file path *) | VioDoc of string (* file path *) - | Interactive of DirPath.t (* module path *) + | Interactive of interactive_top (* module path *) (** Coq initalization options: @@ -256,7 +258,7 @@ type dynamic_block_error_recovery = doc -> static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] val register_proof_block_delimiter : - Vernacexpr.proof_block_name -> + Vernacextend.proof_block_name -> static_block_detection -> dynamic_block_error_recovery -> unit diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index c93487d377..526858bd73 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -12,6 +12,7 @@ open CErrors open Util open Pp open CAst +open Vernacextend open Vernacexpr let default_proof_mode () = Proof_global.get_default_proof_mode_name () [@ocaml.warning "-3"] @@ -189,7 +190,7 @@ let classify_vernac e = | VernacWriteState _ -> VtSideff [], VtNow (* Plugins should classify their commands *) | VernacExtend (s,l) -> - try Vernacentries.get_vernac_classifier s l + try Vernacextend.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in let rec static_control_classifier = function @@ -209,7 +210,3 @@ let classify_vernac e = | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow) in static_control_classifier e - -let classify_as_query = VtQuery, VtLater -let classify_as_sideeff = VtSideff [], VtLater -let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None}, VtLater diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli index e82b191418..9d93ad1f39 100644 --- a/stm/vernac_classifier.mli +++ b/stm/vernac_classifier.mli @@ -8,16 +8,12 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Vernacexpr +open Vernacextend val string_of_vernac_classification : vernac_classification -> string (** What does a vernacular do *) -val classify_vernac : vernac_control -> vernac_classification - -(** Standard constant classifiers *) -val classify_as_query : vernac_classification -val classify_as_sideeff : vernac_classification -val classify_as_proofstep : vernac_classification +val classify_vernac : Vernacexpr.vernac_control -> vernac_classification +(** *) val stm_allow_nested_proofs_option_name : string list diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 2b4d9a7adf..3c262de910 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -148,7 +148,7 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = let cst = Impargs.with_implicit_protection cst () in let inst = match const.Entries.const_entry_universes with | Entries.Monomorphic_const_entry _ -> EInstance.empty - | Entries.Polymorphic_const_entry ctx -> + | Entries.Polymorphic_const_entry (_, ctx) -> (** We mimick what the kernel does, that is ensuring that no additional constraints appear in the body of polymorphic constants. Ideally this should be enforced statically. *) diff --git a/tactics/auto.ml b/tactics/auto.ml index 65b2615b6b..81e487b77d 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -45,7 +45,7 @@ let auto_core_unif_flags_of st1 st2 = { use_metas_eagerly_in_conv_on_closed_terms = false; use_evars_eagerly_in_conv_on_closed_terms = false; modulo_delta = st2; - modulo_delta_types = full_transparent_state; + modulo_delta_types = TransparentState.full; check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; @@ -59,13 +59,13 @@ let auto_unif_flags_of st1 st2 = let flags = auto_core_unif_flags_of st1 st2 in { core_unify_flags = flags; merge_unify_flags = flags; - subterm_unify_flags = { flags with modulo_delta = empty_transparent_state }; + subterm_unify_flags = { flags with modulo_delta = TransparentState.empty }; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = true } let auto_unif_flags = - auto_unif_flags_of full_transparent_state empty_transparent_state + auto_unif_flags_of TransparentState.full TransparentState.empty (* Try unification with the precompiled clause, then use registered Apply *) @@ -291,7 +291,7 @@ let flags_of_state st = auto_unif_flags_of st st let auto_flags_of_state st = - auto_unif_flags_of full_transparent_state st + auto_unif_flags_of TransparentState.full st let hintmap_of sigma secvars hdc concl = match hdc with @@ -358,12 +358,12 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl = let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags, x)) (f db) else - let (ids, csts as st) = Hint_db.transparent_state db in + let st = Hint_db.transparent_state db in let flags, l = let l = match hdc with None -> Hint_db.map_none ~secvars db | Some hdc -> - if (Id.Pred.is_empty ids && Cpred.is_empty csts) + if TransparentState.is_empty st then Hint_db.map_auto sigma ~secvars hdc concl db else Hint_db.map_existential sigma ~secvars hdc concl db in auto_flags_of_state st, l diff --git a/tactics/auto.mli b/tactics/auto.mli index a835c1ed95..72d2292ffb 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -22,7 +22,7 @@ val compute_secvars : Proofview.Goal.t -> Id.Pred.t val default_search_depth : int ref -val auto_flags_of_state : transparent_state -> Unification.unify_flags +val auto_flags_of_state : TransparentState.t -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> Proofview.Goal.t -> clausenv * constr diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index bfee0422e7..2f2bd8d2bc 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -69,13 +69,13 @@ let constr_pat_discr t = | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) | _ -> None -let constr_val_discr_st sigma (idpred,cpred) t = +let constr_val_discr_st sigma ts t = let c, l = decomp sigma t in match EConstr.kind sigma c with - | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) + | Const (c,u) -> if TransparentState.is_transparent_constant ts c then Everything else Label(GRLabel (ConstRef c),l) | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) - | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l) + | Var id when not (TransparentState.is_transparent_variable ts id) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> if List.is_empty l then @@ -85,15 +85,15 @@ let constr_val_discr_st sigma (idpred,cpred) t = | Evar _ -> Everything | _ -> Nothing -let constr_pat_discr_st (idpred,cpred) t = +let constr_pat_discr_st ts t = match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) - | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) -> + | PRef ((VarRef v) as ref), args when not (TransparentState.is_transparent_variable ts v) -> Some(GRLabel ref,args) - | PVar v, args when not (Id.Pred.mem v idpred) -> + | PVar v, args when not (TransparentState.is_transparent_variable ts v) -> Some(GRLabel (VarRef v),args) - | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) -> + | PRef ((ConstRef c) as ref), args when not (TransparentState.is_transparent_constant ts c) -> Some (GRLabel ref, args) | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) | PLambda (_, d, c), [] -> Some (LambdaLabel, [d ; c]) diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 861c9b6250..cc31fb0599 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -9,7 +9,6 @@ (************************************************************************) open Pattern -open Names (** Discrimination nets with bounded depth. *) @@ -19,7 +18,7 @@ open Names order in such a way patterns having the same prefix have this common prefix shared and the seek for the action associated to the patterns that a term matches are found in time proportional to the maximal -number of nodes of the patterns matching the term. The [transparent_state] +number of nodes of the patterns matching the term. The [TransparentState.t] indicates which constants and variables can be considered as rigid. These dnets are able to cope with existential variables as well, which match [Everything]. *) @@ -31,10 +30,10 @@ sig val empty : t - val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t - val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t + val add : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t + val rmv : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t - val lookup : Evd.evar_map -> transparent_state option -> t -> EConstr.constr -> Z.t list + val lookup : Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> Z.t list val app : (Z.t -> unit) -> t -> unit end diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 81cf9289d1..5959dd54b1 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -358,7 +358,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = Eauto.registered_e_assumption :: (tclTHEN Tactics.intro trivial_fail :: [trivial_resolve]) in - tclFIRST (List.map tclCOMPLETE tacl) + tclSOLVE tacl and e_my_find_search db_list local_db secvars hdc complete only_classes env sigma concl = let open Proofview.Notations in @@ -585,9 +585,9 @@ module Search = struct (** Local hints *) let autogoal_cache = Summary.ref ~name:"autogoal_cache" (DirPath.empty, true, Context.Named.empty, - Hint_db.empty full_transparent_state true) + Hint_db.empty TransparentState.full true) - let make_autogoal_hints only_classes ?(st=full_transparent_state) g = + let make_autogoal_hints only_classes ?(st=TransparentState.full) g = let open Proofview in let open Tacmach.New in let sign = Goal.hyps g in @@ -605,7 +605,7 @@ module Search = struct in autogoal_cache := (cwd, only_classes, sign, hints); hints - let make_autogoal ?(st=full_transparent_state) only_classes dep cut i g = + let make_autogoal ?(st=TransparentState.full) only_classes dep cut i g = let hints = make_autogoal_hints only_classes ~st g in { search_hints = hints; search_depth = [i]; last_tac = lazy (str"none"); @@ -843,7 +843,7 @@ module Search = struct let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in search_tac hints depth 1 info - let search_tac ?(st=full_transparent_state) only_classes dep hints depth = + let search_tac ?(st=TransparentState.full) only_classes dep hints depth = let open Proofview in let tac sigma gls i = Goal.enter @@ -873,7 +873,7 @@ module Search = struct | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 - let eauto_tac ?(st=full_transparent_state) ?(unique=false) + let eauto_tac ?(st=TransparentState.full) ?(unique=false) ~only_classes ?strategy ~depth ~dep hints = let open Proofview in let tac = @@ -985,7 +985,7 @@ end (** Binding to either V85 or Search implementations. *) -let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) +let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) ?strategy ~depth dbs = let dbs = List.map_filter (fun db -> try Some (searchtable_map db) diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index 9ba69a0584..46dff34f89 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -25,7 +25,7 @@ type search_strategy = Dfs | Bfs val set_typeclasses_strategy : search_strategy -> unit -val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> ?strategy:search_strategy -> +val typeclasses_eauto : ?only_classes:bool -> ?st:TransparentState.t -> ?strategy:search_strategy -> depth:(Int.t option) -> Hints.hint_db_name list -> unit Proofview.tactic @@ -39,7 +39,7 @@ val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic module Search : sig val eauto_tac : - ?st:Names.transparent_state -> + ?st:TransparentState.t -> (** The transparent_state used when working with local hypotheses *) ?unique:bool -> (** Should we force a unique solution *) diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 5067315d08..b8adb792e8 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -15,7 +15,6 @@ open Names open Constr open Termops open EConstr -open Proof_type open Tacticals open Tacmach open Evd @@ -29,7 +28,7 @@ open Locusops open Hints open Proofview.Notations -let eauto_unif_flags = auto_flags_of_state full_transparent_state +let eauto_unif_flags = auto_flags_of_state TransparentState.full let e_give_exact ?(flags=eauto_unif_flags) c = Proofview.Goal.enter begin fun gl -> @@ -151,7 +150,7 @@ let rec e_trivial_fail_db db_list local_db = (Tacticals.New.tclTHEN Tactics.intro next) :: (List.map fst (e_trivial_resolve (Tacmach.New.pf_env gl) (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_concl gl))) in - Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) + Tacticals.New.tclSOLVE tacl end and e_my_find_search env sigma db_list local_db secvars hdc concl = @@ -203,7 +202,7 @@ let find_first_goal gls = type search_state = { priority : int; depth : int; (*r depth of search before failing *) - tacres : goal list sigma; + tacres : Goal.goal list sigma; last_tactic : Pp.t Lazy.t; dblist : hint_db list; localdb : hint_db list; @@ -307,7 +306,7 @@ module SearchProblem = struct let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in let hyps' = pf_hyps gls in if hyps' == hyps then List.hd s.localdb - else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) + else make_local_hint_db (pf_env gls) (project gls) ~ts:TransparentState.full true s.local_lemmas) (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) in { depth = pred s.depth; priority = cost; tacres = lgls; @@ -388,7 +387,7 @@ let make_initial_state dbg n gl dblist localdb lems = } let e_search_auto debug (in_depth,p) lems db_list gl = - let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in + let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:TransparentState.full true lems in let d = mk_eauto_dbg debug in let tac = match in_depth,d with | (true,Debug) -> Search.debug_depth_first diff --git a/tactics/eauto.mli b/tactics/eauto.mli index e161d88824..5aa2f42de1 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -26,7 +26,7 @@ val gen_eauto : ?debug:debug -> bool * int -> delayed_open_constr list -> val eauto_with_bases : ?debug:debug -> bool * int -> - delayed_open_constr list -> hint_db list -> Proof_type.tactic + delayed_open_constr list -> hint_db list -> Proofview.V82.tac val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic diff --git a/tactics/equality.ml b/tactics/equality.ml index c4a6b1605d..b8967775bf 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -101,8 +101,8 @@ let rewrite_core_unif_flags = { modulo_conv_on_closed_terms = None; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; - modulo_delta = empty_transparent_state; - modulo_delta_types = empty_transparent_state; + modulo_delta = TransparentState.empty; + modulo_delta_types = TransparentState.empty; check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; @@ -169,7 +169,7 @@ let instantiate_lemma gl c ty l l2r concl = [eqclause] let rewrite_conv_closed_core_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some TransparentState.full; (* We have this flag for historical reasons, it has e.g. the consequence *) (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) @@ -178,8 +178,8 @@ let rewrite_conv_closed_core_unif_flags = { (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) - modulo_delta = empty_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = TransparentState.empty; + modulo_delta_types = TransparentState.full; check_applied_meta_types = true; use_pattern_unification = true; (* To rewrite "?n x y" in "y+x=0" when ?n is *) @@ -204,7 +204,7 @@ let rewrite_conv_closed_unif_flags = { } let rewrite_keyed_core_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some TransparentState.full; (* We have this flag for historical reasons, it has e.g. the consequence *) (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) @@ -213,8 +213,8 @@ let rewrite_keyed_core_unif_flags = { (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) - modulo_delta = full_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = TransparentState.full; + modulo_delta_types = TransparentState.full; check_applied_meta_types = true; use_pattern_unification = true; (* To rewrite "?n x y" in "y+x=0" when ?n is *) @@ -1028,7 +1028,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in tclTHENS (assert_after Anonymous absurd_term) - [onLastHypId gen_absurdity; (Proofview.V82.tactic (Tacmach.refine pf))] + [onLastHypId gen_absurdity; (Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf)))] let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in @@ -1354,8 +1354,8 @@ let inject_if_homogenous_dependent_pair ty = tclTHENS (cut (mkApp (ceq,new_eq_args))) [clear [destVar sigma hyp]; Tacticals.New.pf_constr_of_global inj2 >>= fun inj2 -> - Proofview.V82.tactic (Tacmach.refine - (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) + Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr + (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))) ])] with Exit -> Proofview.tclUNIT () @@ -1400,7 +1400,7 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [inject_if_homogenous_dependent_pair ty; - Proofview.V82.tactic (Tacmach.refine pf)]) + Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf))]) (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) diff --git a/tactics/hints.ml b/tactics/hints.ml index 2f2d32e887..e64e08dbde 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -290,9 +290,9 @@ let lookup_tacs sigma concl st se = module Constr_map = Map.Make(GlobRef.Ordered) -let is_transparent_gr (ids, csts) = function - | VarRef id -> Id.Pred.mem id ids - | ConstRef cst -> Cpred.mem cst csts +let is_transparent_gr ts = function + | VarRef id -> TransparentState.is_transparent_variable ts id + | ConstRef cst -> TransparentState.is_transparent_constant ts cst | IndRef _ | ConstructRef _ -> false let strip_params env sigma c = @@ -497,7 +497,7 @@ type hint_db_name = string module Hint_db : sig type t -val empty : ?name:hint_db_name -> transparent_state -> bool -> t +val empty : ?name:hint_db_name -> TransparentState.t -> bool -> t val find : GlobRef.t -> t -> search_entry val map_none : secvars:Id.Pred.t -> t -> full_hint list val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list @@ -513,8 +513,8 @@ val remove_one : GlobRef.t -> t -> t val remove_list : GlobRef.t list -> t -> t val iter : (GlobRef.t option -> hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool -val transparent_state : t -> transparent_state -val set_transparent_state : t -> transparent_state -> t +val transparent_state : t -> TransparentState.t +val set_transparent_state : t -> TransparentState.t -> t val add_cut : hints_path -> t -> t val add_mode : GlobRef.t -> hint_mode array -> t -> t val cut : t -> hints_path @@ -526,7 +526,7 @@ end = struct type t = { - hintdb_state : Names.transparent_state; + hintdb_state : TransparentState.t; hintdb_cut : hints_path; hintdb_unfolds : Id.Set.t * Cset.t; hintdb_max_id : int; @@ -663,10 +663,13 @@ struct let st',db,rebuild = match v.code.obj with | Unfold_nth egr -> - let addunf (ids,csts) (ids',csts') = + let addunf ts (ids, csts) = + let open TransparentState in match egr with - | EvalVarRef id -> (Id.Pred.add id ids, csts), (Id.Set.add id ids', csts') - | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts') + | EvalVarRef id -> + { ts with tr_var = Id.Pred.add id ts.tr_var }, (Id.Set.add id ids, csts) + | EvalConstRef cst -> + { ts with tr_cst = Cpred.add cst ts.tr_cst }, (ids, Cset.add cst csts) in let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in state, { db with hintdb_unfolds = unfs }, true @@ -740,8 +743,8 @@ let typeclasses_db = "typeclass_instances" let rewrite_db = "rewrite" let auto_init_db = - Hintdbmap.add typeclasses_db (Hint_db.empty full_transparent_state true) - (Hintdbmap.add rewrite_db (Hint_db.empty cst_full_transparent_state true) + Hintdbmap.add typeclasses_db (Hint_db.empty TransparentState.full true) + (Hintdbmap.add rewrite_db (Hint_db.empty TransparentState.cst_full true) Hintdbmap.empty) let searchtable = Summary.ref ~name:"searchtable" auto_init_db @@ -977,7 +980,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let get_db dbname = try searchtable_map dbname - with Not_found -> Hint_db.empty ~name:dbname empty_transparent_state false + with Not_found -> Hint_db.empty ~name:dbname TransparentState.empty false let add_hint dbname hintlist = let check (_, h) = @@ -995,18 +998,19 @@ let add_hint dbname hintlist = searchtable_add (dbname,db') let add_transparency dbname target b = + let open TransparentState in let db = get_db dbname in - let (ids, csts as st) = Hint_db.transparent_state db in + let st = Hint_db.transparent_state db in let st' = match target with - | HintsVariables -> (if b then Id.Pred.full else Id.Pred.empty), csts - | HintsConstants -> ids, if b then Cpred.full else Cpred.empty + | HintsVariables -> { st with tr_var = (if b then Id.Pred.full else Id.Pred.empty) } + | HintsConstants -> { st with tr_cst = (if b then Cpred.full else Cpred.empty) } | HintsReferences grs -> - List.fold_left (fun (ids, csts) gr -> - match gr with - | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts) - | EvalVarRef v -> (if b then Id.Pred.add else Id.Pred.remove) v ids, csts) - st grs + List.fold_left (fun st gr -> + match gr with + | EvalConstRef c -> { st with tr_cst = (if b then Cpred.add else Cpred.remove) c st.tr_cst } + | EvalVarRef v -> { st with tr_var = (if b then Id.Pred.add else Id.Pred.remove) v st.tr_var }) + st grs in searchtable_add (dbname, Hint_db.set_transparent_state db st') let remove_hint dbname grs = @@ -1015,7 +1019,7 @@ let remove_hint dbname grs = searchtable_add (dbname, db') type hint_action = - | CreateDB of bool * transparent_state + | CreateDB of bool * TransparentState.t | AddTransparency of evaluable_global_reference hints_transparency_target * bool | AddHints of hint_entry list | RemoveHints of GlobRef.t list @@ -1373,10 +1377,10 @@ let interp_hints poly = let _, tacexp = Genintern.generic_intern env tacexp in HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) -let add_hints ~local dbnames0 h = - if String.List.mem "nocore" dbnames0 then +let add_hints ~local dbnames h = + if String.List.mem "nocore" dbnames then user_err Pp.(str "The hint database \"nocore\" is meant to stay empty."); - let dbnames = if List.is_empty dbnames0 then ["core"] else dbnames0 in + assert (not (List.is_empty dbnames)); let env = Global.env() in let sigma = Evd.from_env env in match h with @@ -1543,7 +1547,7 @@ let pr_hint_db_env env sigma db = in Hint_db.fold fold db (mt ()) in - let (ids, csts) = Hint_db.transparent_state db in + let { TransparentState.tr_var = ids; tr_cst = csts } = Hint_db.transparent_state db in hov 0 ((if Hint_db.use_dn db then str"Discriminated database" else str"Non-discriminated database")) ++ fnl () ++ diff --git a/tactics/hints.mli b/tactics/hints.mli index 6db8feccd0..dd2c63d351 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -122,7 +122,7 @@ val glob_hints_path : module Hint_db : sig type t - val empty : ?name:hint_db_name -> transparent_state -> bool -> t + val empty : ?name:hint_db_name -> TransparentState.t -> bool -> t val find : GlobRef.t -> t -> search_entry (** All hints which have no pattern. @@ -155,8 +155,8 @@ module Hint_db : hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool - val transparent_state : t -> transparent_state - val set_transparent_state : t -> transparent_state -> t + val transparent_state : t -> TransparentState.t + val set_transparent_state : t -> TransparentState.t -> t val add_cut : hints_path -> t -> t val cut : t -> hints_path @@ -191,7 +191,7 @@ val searchtable_add : (hint_db_name * hint_db) -> unit [use_dn] switches the use of the discrimination net for all hints and patterns. *) -val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit +val create_hint_db : bool -> hint_db_name -> TransparentState.t -> bool -> unit val remove_hints : bool -> hint_db_name list -> GlobRef.t list -> unit @@ -273,7 +273,7 @@ val repr_hint : hint -> (raw_hint * clausenv) hint_ast Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) -val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> delayed_open_constr list -> hint_db +val make_local_hint_db : env -> evar_map -> ?ts:TransparentState.t -> bool -> delayed_open_constr list -> hint_db val make_db_list : hint_db_name list -> hint_db list diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index b81967c781..a53e3bf20d 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -118,15 +118,12 @@ let compute_name internal id = | InternalTacticRequest -> Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name -let define internal id c p univs = +let define internal id c poly univs = let fd = declare_constant ~internal in let id = compute_name internal id in let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in - let univs = - if p then Polymorphic_const_entry (UState.context ctx) - else Monomorphic_const_entry (UState.context_set ctx) - in + let univs = UState.const_univ_entry ~poly ctx in let entry = { const_entry_body = Future.from_val ((c,Univ.ContextSet.empty), diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index f2cf915fe3..224cd68cf9 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -26,6 +26,8 @@ module NamedDecl = Context.Named.Declaration (* Tacticals re-exported from the Refiner module *) (************************************************************************) +type tactic = Proofview.V82.tac + let tclIDTAC = Refiner.tclIDTAC let tclIDTAC_MESSAGE = Refiner.tclIDTAC_MESSAGE let tclORELSE0 = Refiner.tclORELSE0 diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index cc15469d0e..2947e44f7a 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -12,12 +12,13 @@ open Names open Constr open EConstr open Evd -open Proof_type open Locus open Tactypes (** Tacticals i.e. functions from tactics to tactics. *) +type tactic = Proofview.V82.tac + val tclIDTAC : tactic val tclIDTAC_MESSAGE : Pp.t -> tactic val tclORELSE0 : tactic -> tactic -> tactic @@ -65,20 +66,20 @@ val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic val onNLastHyps : int -> (constr list -> tactic) -> tactic val onNLastDecls : int -> (named_context -> tactic) -> tactic -val lastHypId : goal sigma -> Id.t -val lastHyp : goal sigma -> constr -val lastDecl : goal sigma -> named_declaration -val nLastHypsId : int -> goal sigma -> Id.t list -val nLastHyps : int -> goal sigma -> constr list -val nLastDecls : int -> goal sigma -> named_context +val lastHypId : Goal.goal sigma -> Id.t +val lastHyp : Goal.goal sigma -> constr +val lastDecl : Goal.goal sigma -> named_declaration +val nLastHypsId : int -> Goal.goal sigma -> Id.t list +val nLastHyps : int -> Goal.goal sigma -> constr list +val nLastDecls : int -> Goal.goal sigma -> named_context -val afterHyp : Id.t -> goal sigma -> named_context +val afterHyp : Id.t -> Goal.goal sigma -> named_context val ifOnHyp : (Id.t * types -> bool) -> (Id.t -> tactic) -> (Id.t -> tactic) -> Id.t -> tactic -val onHyps : (goal sigma -> named_context) -> +val onHyps : (Goal.goal sigma -> named_context) -> (named_context -> tactic) -> tactic (** {6 Tacticals applying to goal components } *) @@ -127,11 +128,11 @@ val compute_constructor_signatures : rec_flag:bool -> inductive * 'a -> bool lis val compute_induction_names : bool list array -> or_and_intro_pattern option -> intro_patterns array -val elimination_sort_of_goal : goal sigma -> Sorts.family -val elimination_sort_of_hyp : Id.t -> goal sigma -> Sorts.family -val elimination_sort_of_clause : Id.t option -> goal sigma -> Sorts.family +val elimination_sort_of_goal : Goal.goal sigma -> Sorts.family +val elimination_sort_of_hyp : Id.t -> Goal.goal sigma -> Sorts.family +val elimination_sort_of_clause : Id.t option -> Goal.goal sigma -> Sorts.family -val pf_with_evars : (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic +val pf_with_evars : (Goal.goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic val pf_constr_of_global : GlobRef.t -> (constr -> tactic) -> tactic (** Tacticals defined directly in term of Proofview *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 5cead11a5c..0beafb7e31 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -142,7 +142,6 @@ let introduction id = | _ -> raise (RefinerError (env, sigma, IntroNeedsProduct)) end -let refine = Tacmach.refine let error msg = CErrors.user_err Pp.(str msg) let convert_concl ?(check=true) ty k = @@ -1062,6 +1061,12 @@ let intros_replacing ids = (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) end +(* 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) + (* User-level introduction tactics *) let lookup_hypothesis_as_renamed env sigma ccl = function @@ -1146,7 +1151,6 @@ let rec intros_move = function let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; - Pretyping.use_hook = Pfedit.solve_by_implicit_tactic (); Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true } @@ -1295,7 +1299,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) if not with_evars && occur_meta clenv.evd new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in - let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in + let exact_tac = Proofview.V82.tactic (Refiner.refiner ~check:false EConstr.Unsafe.(to_constr new_hyp_prf)) in let naming = NamingMustBe (CAst.make targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN @@ -1619,7 +1623,7 @@ let descend_in_conjunctions avoid tac (err, info) c = | Some (p,pt) -> Tacticals.New.tclTHENS (assert_before_gen false (NamingAvoid avoid) pt) - [Proofview.V82.tactic (refine p); + [Proofview.V82.tactic (refiner ~check:true EConstr.Unsafe.(to_constr p)); (* Might be ill-typed due to forbidden elimination. *) Tacticals.New.onLastHypId (tac (not isrec))] end))) @@ -1655,7 +1659,7 @@ let general_apply ?(respect_opaque=false) with_delta with_destruct with_evars let sigma = Tacmach.New.project gl in let ts = if respect_opaque then Conv_oracle.get_transp_state (oracle env) - else full_transparent_state + else TransparentState.full in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in @@ -1821,7 +1825,7 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta let sigma = Tacmach.New.project gl in let ts = if respect_opaque then Conv_oracle.get_transp_state (oracle env) - else full_transparent_state + else TransparentState.full in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in @@ -4904,7 +4908,7 @@ let constr_eq ~strict x y = | None -> fail end -let unify ?(state=full_transparent_state) x y = +let unify ?(state=TransparentState.full) x y = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in @@ -4917,7 +4921,7 @@ let unify ?(state=full_transparent_state) x y = let flags = { (default_unify_flags ()) with core_unify_flags = core_flags; merge_unify_flags = core_flags; - subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } } + subterm_unify_flags = { core_flags with modulo_delta = TransparentState.empty } } in let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in Proofview.Unsafe.tclEVARS sigma diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 7efadb2c28..75b5caaa36 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -12,7 +12,6 @@ open Names open Constr open EConstr open Environ -open Proof_type open Evd open Clenv open Redexpr @@ -50,8 +49,8 @@ val convert_leq : constr -> constr -> unit Proofview.tactic (** {6 Introduction tactics. } *) val fresh_id_in_env : Id.Set.t -> Id.t -> env -> Id.t -val fresh_id : Id.Set.t -> Id.t -> goal sigma -> Id.t -val find_intro_names : rel_context -> goal sigma -> Id.t list +val fresh_id : Id.Set.t -> Id.t -> Goal.goal sigma -> Id.t +val find_intro_names : rel_context -> Goal.goal sigma -> Id.t list val intro : unit Proofview.tactic val introf : unit Proofview.tactic @@ -70,6 +69,9 @@ val intros_using : Id.t list -> unit Proofview.tactic val intros_replacing : Id.t list -> unit Proofview.tactic val intros_possibly_replacing : Id.t list -> unit Proofview.tactic +(** [auto_intros_tac names] handles Automatic Introduction of binders *) +val auto_intros_tac : Names.Name.t list -> unit Proofview.tactic + val intros : unit Proofview.tactic (** [depth_of_quantified_hypothesis b h g] returns the index of [h] in @@ -416,7 +418,7 @@ val generalize_dep : ?with_let:bool (** Don't lose let bindings *) -> constr - are added to the evar map. *) val constr_eq : strict:bool -> constr -> constr -> unit Proofview.tactic -val unify : ?state:Names.transparent_state -> constr -> constr -> unit Proofview.tactic +val unify : ?state:TransparentState.t -> constr -> constr -> unit Proofview.tactic val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.tactic val specialize_eqs : Id.t -> unit Proofview.tactic diff --git a/test-suite/Makefile b/test-suite/Makefile index 928a77cb8e..1db97f43c5 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -187,14 +187,6 @@ summary.log: $(SHOW) BUILDING SUMMARY FILE $(HIDE)$(MAKE) --quiet summary > "$@" -# if not on travis we can get the log files (they're just there for a -# local build, and downloadable on GitLab) -PRINT_LOGS?= -TRAVIS?= # special because we want to print travis_fold directives -ifdef APPVEYOR -PRINT_LOGS:=APPVEYOR -endif #APPVEYOR - report: summary.log $(HIDE)bash report.sh diff --git a/test-suite/bugs/closed/bug_2001.v b/test-suite/bugs/closed/bug_2001.v index 652c65706a..31c62b7b36 100644 --- a/test-suite/bugs/closed/bug_2001.v +++ b/test-suite/bugs/closed/bug_2001.v @@ -1,12 +1,10 @@ (* Automatic computing of guard in "Theorem with"; check that guard is not computed when the user explicitly indicated it *) -Unset Automatic Introduction. - Inductive T : Set := | v : T. -Definition f (s:nat) (t:T) : nat. +Definition f : forall (s:nat) (t:T), nat. fix f 2. intros s t. refine diff --git a/test-suite/bugs/closed/bug_4771.v b/test-suite/bugs/closed/bug_4771.v new file mode 100644 index 0000000000..e25e5a1be5 --- /dev/null +++ b/test-suite/bugs/closed/bug_4771.v @@ -0,0 +1,21 @@ +(* The following code used to trigger an anomaly in functor substitutions *) + +Module Type Foo. + +Parameter Inline t : nat. + +End Foo. + +Module F(X : Foo). + +Tactic Notation "foo" ref(x) := idtac. + +Ltac g := foo X.t. + +End F. + +Module N. +Definition t := 0 + 0. +End N. + +Module K := F(N). diff --git a/test-suite/bugs/closed/gh6165.v b/test-suite/bugs/closed/bug_6165.v index b87a7caaf2..b87a7caaf2 100644 --- a/test-suite/bugs/closed/gh6165.v +++ b/test-suite/bugs/closed/bug_6165.v diff --git a/test-suite/bugs/closed/gh6384.v b/test-suite/bugs/closed/bug_6384.v index cec84642fb..cec84642fb 100644 --- a/test-suite/bugs/closed/gh6384.v +++ b/test-suite/bugs/closed/bug_6384.v diff --git a/test-suite/bugs/closed/gh6385.v b/test-suite/bugs/closed/bug_6385.v index 3bbb664f4f..3bbb664f4f 100644 --- a/test-suite/bugs/closed/gh6385.v +++ b/test-suite/bugs/closed/bug_6385.v diff --git a/test-suite/bugs/closed/bug_6661.v b/test-suite/bugs/closed/bug_6661.v index e88a3704d8..28a9ffc7bd 100644 --- a/test-suite/bugs/closed/bug_6661.v +++ b/test-suite/bugs/closed/bug_6661.v @@ -53,8 +53,6 @@ Definition foo (X:Type) (xy : @total2 X (λ _, X)) : X. exact x. Defined. -Unset Automatic Introduction. - Definition idfun (T : UU) := λ t:T, t. Definition pathscomp0 {X : UU} {a b c : X} (e1 : a = b) (e2 : b = c) : a = c. diff --git a/test-suite/bugs/closed/bug_8224.v b/test-suite/bugs/closed/bug_8224.v new file mode 100644 index 0000000000..42dd47d48c --- /dev/null +++ b/test-suite/bugs/closed/bug_8224.v @@ -0,0 +1,9 @@ +(* Checking that terms are evar-free before being grounded *) + +(* This used to raise an anomaly in 8.9 beta *) + +Fail Fixpoint restrict f n := + match n with + | O => nil + | S n => cons (f n) (restrict f n) + end. diff --git a/test-suite/bugs/closed/bug_8791.v b/test-suite/bugs/closed/bug_8791.v new file mode 100644 index 0000000000..9be1936cdf --- /dev/null +++ b/test-suite/bugs/closed/bug_8791.v @@ -0,0 +1,9 @@ +Class Inhabited (A : Type) : Type := populate { inhabitant : A }. + +Definition A := 42. + +Instance foo (A: Type): Inhabited (list A). +Check A. +Abort. + +Fail Instance foo (A : nat) (A : Type) : Inhabited nat. diff --git a/test-suite/bugs/closed/bug_8885.v b/test-suite/bugs/closed/bug_8885.v new file mode 100644 index 0000000000..9d86c08d71 --- /dev/null +++ b/test-suite/bugs/closed/bug_8885.v @@ -0,0 +1,8 @@ +From Coq Require Import Cyclic31. + +Definition Nat `(int31) := nat. +Definition Zero (_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _: digits) := 0. + +Check (eq_refl (int31_rect Nat Zero 1) : 0 = 0). +Check (eq_refl (int31_rect Nat Zero 1) <: 0 = 0). +Check (eq_refl (int31_rect Nat Zero 1) <<: 0 = 0). diff --git a/test-suite/bugs/closed/bug_8908.v b/test-suite/bugs/closed/bug_8908.v new file mode 100644 index 0000000000..9c85839b75 --- /dev/null +++ b/test-suite/bugs/closed/bug_8908.v @@ -0,0 +1,8 @@ +Record foo : Type := + { fooA : Type; fooB : Type }. +Definition id {A : Type} (a : A) := a. +Definition untypable : Type. + unshelve refine (let X := _ in let Y : _ := ltac:(let ty := type of X in exact ty) in id Y). + exact foo. + constructor. exact unit. exact unit. +Defined. diff --git a/test-suite/coq-makefile/camldep/_CoqProject b/test-suite/coq-makefile/camldep/_CoqProject new file mode 100644 index 0000000000..0b7ebd14e4 --- /dev/null +++ b/test-suite/coq-makefile/camldep/_CoqProject @@ -0,0 +1,4 @@ +-Q . Foo +-I src +src/file1.mlg +src/file2.ml diff --git a/test-suite/coq-makefile/camldep/run.sh b/test-suite/coq-makefile/camldep/run.sh new file mode 100755 index 0000000000..aa62ee56eb --- /dev/null +++ b/test-suite/coq-makefile/camldep/run.sh @@ -0,0 +1,17 @@ +#!/usr/bin/env bash + +set -e +export PATH=$COQBIN:$PATH +export LC_ALL=C + +rm -rf _test +mkdir _test +cp _CoqProject _test/ +cd _test +mkdir src + +echo '{ let foo = () }' > src/file1.mlg +echo 'let bar = File1.foo' > src/file2.ml +coq_makefile -f _CoqProject -o Makefile +make src/file2.cmx +[ -f src/file2.cmx ] diff --git a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml index 6d8ce7c5d7..047f4cd080 100644 --- a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml +++ b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml @@ -15,7 +15,7 @@ let evil t f = let tc = mkConst tc in let fe = Declare.definition_entry - ~univs:(Polymorphic_const_entry (UContext.make (Instance.of_array [|u|],Constraint.empty))) + ~univs:(Polymorphic_const_entry ([|Anonymous|], UContext.make (Instance.of_array [|u|],Constraint.empty))) ~types:(Term.mkArrow tc tu) (mkLambda (Name.Name (Id.of_string "x"), tc, mkRel 1)) in diff --git a/test-suite/misc/quick-include.sh b/test-suite/misc/quick-include.sh new file mode 100755 index 0000000000..96bdee2fc2 --- /dev/null +++ b/test-suite/misc/quick-include.sh @@ -0,0 +1,5 @@ +#!/bin/sh +set -e + +$coqc -R misc/quick-include/ QuickInclude -quick misc/quick-include/file1.v +$coqc -R misc/quick-include/ QuickInclude -quick misc/quick-include/file2.v diff --git a/test-suite/misc/quick-include/file1.v b/test-suite/misc/quick-include/file1.v new file mode 100644 index 0000000000..fa48e240cb --- /dev/null +++ b/test-suite/misc/quick-include/file1.v @@ -0,0 +1,18 @@ + +Module Type E. End E. + +Module M. + Lemma x : True. + Proof. trivial. Qed. +End M. + + +Module Type T. + Lemma x : True. + Proof. trivial. Qed. +End T. + +Module F(A:E). + Lemma x : True. + Proof. trivial. Qed. +End F. diff --git a/test-suite/misc/quick-include/file2.v b/test-suite/misc/quick-include/file2.v new file mode 100644 index 0000000000..ab10dfd8de --- /dev/null +++ b/test-suite/misc/quick-include/file2.v @@ -0,0 +1,6 @@ + +From QuickInclude Require file1. + +Module M. Include file1.M. End M. +Module T. Include file1.T. End T. +Module F. Include file1.F. End F. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 46784d1897..d25ad5dca8 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -17,3 +17,7 @@ end : Expr -> Expr [(1 + 1)] : Expr +Let "x" e1 e2 + : expr +Let "x" e1 e2 + : expr diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 6bdbf1bed5..7800e91ee5 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -70,3 +70,27 @@ Notation "( x )" := x (in custom expr at level 0, x at level 2). Check [1 + 1]. End C. + +(* An example of interaction between coercion and notations from + Robbert Krebbers. *) + +Require Import String. + +Module D. + +Inductive expr := + | Var : string -> expr + | Lam : string -> expr -> expr + | App : expr -> expr -> expr. + +Notation Let x e1 e2 := (App (Lam x e2) e1). + +Parameter e1 e2 : expr. + +Check (Let "x" e1 e2). + +Coercion App : expr >-> Funclass. + +Check (Let "x" e1 e2). + +End D. diff --git a/test-suite/output/PrintUnivsSubgraph.out b/test-suite/output/PrintUnivsSubgraph.out new file mode 100644 index 0000000000..c42e15e4e8 --- /dev/null +++ b/test-suite/output/PrintUnivsSubgraph.out @@ -0,0 +1,5 @@ +Prop < Set +Set < i + < j +i < j + diff --git a/test-suite/output/PrintUnivsSubgraph.v b/test-suite/output/PrintUnivsSubgraph.v new file mode 100644 index 0000000000..ec9cf44d4f --- /dev/null +++ b/test-suite/output/PrintUnivsSubgraph.v @@ -0,0 +1,9 @@ + +Universes i j k l. + +Definition foo : Type@{j} := Type@{i}. + +Definition baz : Type@{k} := Type@{l}. + +Print Universes Subgraph(i j). +(* should print [i < j], not [l < k] (and not prelude universes) *) diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 49c292c501..4d3f7419e6 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -41,8 +41,7 @@ Arguments A, Wrap are implicit and maximally inserted Argument scopes are [type_scope _] Polymorphic bar@{u} = nat : Wrap@{u} Set -(* u |= Set < u - *) +(* u |= Set < u *) bar is universe polymorphic Polymorphic foo@{u UnivBinders.17 v} = @@ -79,8 +78,9 @@ mono The command has indeed failed with message: Universe u already exists. Monomorphic bobmorane = -let tt := Type@{tt.v} in let ff := Type@{ff.v} in tt -> ff - : Type@{max(tt.u,ff.u)} +let tt := Type@{UnivBinders.32} in +let ff := Type@{UnivBinders.34} in tt -> ff + : Type@{max(UnivBinders.31,UnivBinders.33)} bobmorane is not universe polymorphic The command has indeed failed with message: @@ -150,6 +150,11 @@ Polymorphic NonCumulative Inductive insecind@{u k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{u k} For inseccstr: Argument scope is [type_scope] +Polymorphic insec2@{u} = Prop + : Type@{Set+1} +(* u |= *) + +insec2 is universe polymorphic Polymorphic inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) @@ -171,26 +176,26 @@ inmod@{u} -> Type@{v} (* u v |= *) Applied.infunct is universe polymorphic -axfoo@{i UnivBinders.55 UnivBinders.56} : -Type@{UnivBinders.55} -> Type@{i} -(* i UnivBinders.55 UnivBinders.56 |= *) +axfoo@{i UnivBinders.56 UnivBinders.57} : +Type@{UnivBinders.56} -> Type@{i} +(* i UnivBinders.56 UnivBinders.57 |= *) axfoo is universe polymorphic Argument scope is [type_scope] Expands to: Constant UnivBinders.axfoo -axbar@{i UnivBinders.55 UnivBinders.56} : -Type@{UnivBinders.56} -> Type@{i} -(* i UnivBinders.55 UnivBinders.56 |= *) +axbar@{i UnivBinders.56 UnivBinders.57} : +Type@{UnivBinders.57} -> Type@{i} +(* i UnivBinders.56 UnivBinders.57 |= *) axbar is universe polymorphic Argument scope is [type_scope] Expands to: Constant UnivBinders.axbar -axfoo' : Type@{UnivBinders.58} -> Type@{axbar'.i} +axfoo' : Type@{axbar'.u0} -> Type@{axbar'.i} axfoo' is not universe polymorphic Argument scope is [type_scope] Expands to: Constant UnivBinders.axfoo' -axbar' : Type@{UnivBinders.58} -> Type@{axbar'.i} +axbar' : Type@{axbar'.u0} -> Type@{axbar'.i} axbar' is not universe polymorphic Argument scope is [type_scope] diff --git a/test-suite/output/UnivBinders.v b/test-suite/output/UnivBinders.v index 56474a0723..582a5e969a 100644 --- a/test-suite/output/UnivBinders.v +++ b/test-suite/output/UnivBinders.v @@ -1,4 +1,5 @@ -(* coq-prog-args: ("-top" "UnivBinders") *) +(* -*- coq-prog-args: ("-top" "UnivBinders"); -*- *) + Set Universe Polymorphism. Set Printing Universes. (* Unset Strict Universe Declaration. *) @@ -73,19 +74,10 @@ Module SecLet. (* Fail Let foo@{} := Type@{u}. (* doesn't parse: Let foo@{...} doesn't exist *) *) Unset Strict Universe Declaration. Let tt : Type@{u} := Type@{v}. (* names disappear in the ether *) - Let ff : Type@{u}. Proof. exact Type@{v}. Qed. (* if Set Universe Polymorphism: universes are named ff.u and ff.v. Otherwise names disappear into space *) + Let ff : Type@{u}. Proof. exact Type@{v}. Qed. (* names disappear into space *) Definition bobmorane := tt -> ff. End foo. - Print bobmorane. (* - bobmorane@{UnivBinders.15 UnivBinders.16 ff.u ff.v} = - let tt := Type@{UnivBinders.16} in let ff := Type@{ff.v} in tt -> ff - : Type@{max(UnivBinders.15,ff.u)} - (* UnivBinders.15 UnivBinders.16 ff.u ff.v |= UnivBinders.16 < UnivBinders.15 - ff.v < ff.u - *) - - bobmorane is universe polymorphic - *) + Print bobmorane. End SecLet. (* fun x x => foo is nonsense with local binders *) @@ -130,6 +122,12 @@ End SomeSec. Print insec. Print insecind. +Section SomeSec2. + Universe u. + Definition insec2@{} := Prop. +End SomeSec2. +Print insec2. + Module SomeMod. Definition inmod@{u} := Type@{u}. Print inmod. diff --git a/test-suite/report.sh b/test-suite/report.sh index 05f39b4b02..c5e698232f 100755 --- a/test-suite/report.sh +++ b/test-suite/report.sh @@ -24,7 +24,7 @@ cp summary.log "$SAVEDIR"/ rm "$FAILED" # print info -if [ -n "$TRAVIS" ] || [ -n "$PRINT_LOGS" ]; then +if [ -n "$TRAVIS" ] || [ -n "$APPVEYOR" ] || [ -n "$PRINT_LOGS" ]; then find logs/ -name '*.log' -not -name 'summary.log' -print0 | while IFS= read -r -d '' file; do if [ -n "$TRAVIS" ]; then # ${foo////.} replaces every / by . in $foo @@ -40,12 +40,13 @@ if [ -n "$TRAVIS" ] || [ -n "$PRINT_LOGS" ]; then else printf '\n' fi done + printed_logs=1 fi if grep -q -F 'Error!' summary.log ; then echo FAILURES; grep -F 'Error!' summary.log; - if [ -z "$TRAVIS" ] && [ -z "$PRINT_LOGS" ]; then + if [ -z "$printed_logs" ]; then echo 'To print details of failed tests, rerun with environment variable PRINT_LOGS=1' echo 'eg "make report PRINT_LOGS=1" from the test suite directory"' echo 'See README.md in the test suite directory for more information.' diff --git a/test-suite/ssr/case_TC.v b/test-suite/ssr/case_TC.v new file mode 100644 index 0000000000..78ed374432 --- /dev/null +++ b/test-suite/ssr/case_TC.v @@ -0,0 +1,18 @@ +From Coq Require Import ssreflect. +From Coq Require Import ssrbool. + +Set Printing All. +Set Debug Ssreflect. + +Class Class := { sort : Type ; op : sort -> bool }. +Coercion sort : Class >-> Sortclass. +Arguments op [_] _. + +Section Section. + Context (A B: Class) (a: A). + + Goal op a || ~~ op a. + by case: op. + Abort. + +End Section. diff --git a/test-suite/ssr/case_TC2.v b/test-suite/ssr/case_TC2.v new file mode 100644 index 0000000000..37504d662d --- /dev/null +++ b/test-suite/ssr/case_TC2.v @@ -0,0 +1,20 @@ +From Coq Require Import Bool ssreflect. + +Set Printing All. +Set Debug Ssreflect. + +Class Class := { sort : Type ; op : sort -> bool }. +Coercion sort : Class >-> Sortclass. +Arguments op [_] _. + +Lemma opP (A: Class) (a: A) : reflect True (op a). +Proof. Admitted. + +Section Section. + Context (A B: Class) (a: A). + + Goal is_true (op a). + by case: opP. + Abort. + +End Section. diff --git a/test-suite/ssr/case_TC3.v b/test-suite/ssr/case_TC3.v new file mode 100644 index 0000000000..92e166e85d --- /dev/null +++ b/test-suite/ssr/case_TC3.v @@ -0,0 +1,21 @@ +From Coq Require Import Utf8 Bool ssreflect. + +Set Printing All. +Set Debug Ssreflect. + +Class Class sort := { op : sort → bool }. +Arguments op {_ _}. +Hint Mode Class !. + +Lemma opP A (C: Class A) (a: A) : reflect True (op a). +Proof. Admitted. +Arguments op {_ _}. + +Section Section. + Context A B (CA : Class A) (CB : Class B) (a: A). + + Goal is_true (op a). + by case: opP. + Abort. + +End Section. diff --git a/test-suite/success/Fixpoint.v b/test-suite/success/Fixpoint.v index efb32ef6f7..81c9763ccd 100644 --- a/test-suite/success/Fixpoint.v +++ b/test-suite/success/Fixpoint.v @@ -50,8 +50,6 @@ End folding. (* Check definition by tactics *) -Set Automatic Introduction. - Inductive even : nat -> Type := | even_O : even 0 | even_S : forall n, odd n -> even (S n) diff --git a/test-suite/success/Require.v b/test-suite/success/Require.v index f851d8c7d9..de5987c4f7 100644 --- a/test-suite/success/Require.v +++ b/test-suite/success/Require.v @@ -1,3 +1,8 @@ +(* -*- coq-prog-args: ("-noinit"); -*- *) + Require Import Coq.Arith.Plus. Require Coq.Arith.Minus. Locate Library Coq.Arith.Minus. + +(* Check that Init didn't get exported by the import above *) +Fail Check nat. diff --git a/test-suite/success/autointros.v b/test-suite/success/autointros.v index 0a0812711c..1140a537fc 100644 --- a/test-suite/success/autointros.v +++ b/test-suite/success/autointros.v @@ -1,5 +1,3 @@ -Set Automatic Introduction. - Inductive even : nat -> Prop := | even_0 : even 0 | even_odd : forall n, odd n -> even (S n) diff --git a/test-suite/success/unidecls.v b/test-suite/success/unidecls.v index 7c298c98b6..1bc565cbb5 100644 --- a/test-suite/success/unidecls.v +++ b/test-suite/success/unidecls.v @@ -1,4 +1,4 @@ -(* coq-prog-args: ("-top" "unidecls") *) +(* -*- coq-prog-args: ("-top" "unidecls"); -*- *) Set Printing Universes. Module decls. @@ -46,12 +46,12 @@ Universe secfoo. Section Foo'. Fail Universe secfoo. Universe secfoo2. - Check Type@{Foo'.secfoo2}. + Fail Check Type@{Foo'.secfoo2}. + Check Type@{secfoo2}. Constraint secfoo2 < a. End Foo'. Check Type@{secfoo2}. -Fail Check Type@{Foo'.secfoo2}. Fail Check eq_refl : Type@{secfoo2} = Type@{a}. (** Below, u and v are global, fixed universes *) diff --git a/test-suite/unit-tests/printing/proof_diffs_test.ml b/test-suite/unit-tests/printing/proof_diffs_test.ml index 526cefec44..7f9e6cc6e0 100644 --- a/test-suite/unit-tests/printing/proof_diffs_test.ml +++ b/test-suite/unit-tests/printing/proof_diffs_test.ml @@ -71,6 +71,13 @@ let _ = add_test "tokenize_string examples" t open Pp +(* example that was failing from #8922 *) +let t () = + Proof_diffs.write_diffs_option "removed"; + ignore (diff_str "X : ?Goal" "X : forall x : ?Goal0, ?Goal1"); + Proof_diffs.write_diffs_option "on" +let _ = add_test "shorten_diff_span failure from #8922" t + (* note pp_to_string concatenates adjacent strings, could become one token, e.g. str " a" ++ str "b " will give a token "ab" *) (* checks background is present and correct *) diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 42af3583d4..075288e216 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -48,7 +48,7 @@ Proof. discriminate. Qed. Hint Resolve diff_false_true : bool. -Hint Extern 1 (false <> true) => exact diff_false_true. +Hint Extern 1 (false <> true) => exact diff_false_true : core. Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False. Proof. @@ -621,7 +621,7 @@ Lemma absurd_eq_true : forall b, False -> b = true. Proof. contradiction. Qed. -Hint Resolve absurd_eq_true. +Hint Resolve absurd_eq_true : core. (* A specific instance of eq_trans that preserves compatibility with old hint bool_2 *) @@ -630,7 +630,7 @@ Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z. Proof. apply eq_trans. Qed. -Hint Resolve trans_eq_bool. +Hint Resolve trans_eq_bool : core. (*****************************************) (** * Reflection of [bool] into [Prop] *) diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index 7af2b0fc45..3e6358c8f3 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -157,6 +157,6 @@ Section RelProd_Instances. Proof. unfold RelCompFun; firstorder. Qed. End RelProd_Instances. -Hint Unfold RelProd RelCompFun. -Hint Extern 2 (RelProd _ _ _ _) => split. +Hint Unfold RelProd RelCompFun : core. +Hint Extern 2 (RelProd _ _ _ _) => split : core. diff --git a/theories/Compat/Coq87.v b/theories/Compat/Coq87.v index dc1397aff2..5e031efa85 100644 --- a/theories/Compat/Coq87.v +++ b/theories/Compat/Coq87.v @@ -9,6 +9,8 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.7 *) +Local Set Warnings "-deprecated". + Require Export Coq.Compat.Coq88. (* In 8.7, omega wasn't taking advantage of local abbreviations, diff --git a/theories/Compat/Coq88.v b/theories/Compat/Coq88.v index 950cd8242b..989072940a 100644 --- a/theories/Compat/Coq88.v +++ b/theories/Compat/Coq88.v @@ -9,17 +9,18 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.8 *) +Local Set Warnings "-deprecated". + Require Export Coq.Compat.Coq89. (** In Coq 8.9, prim token notations follow [Import] rather than [Require]. So we make all of the relevant notations accessible in compatibility mode. *) Require Coq.Strings.Ascii Coq.Strings.String. +Export String.StringSyntax Ascii.AsciiSyntax. Require Coq.ZArith.BinIntDef Coq.PArith.BinPosDef Coq.NArith.BinNatDef. Require Coq.Reals.Rdefinitions. Require Coq.Numbers.Cyclic.Int31.Int31. -Declare ML Module "string_syntax_plugin". -Declare ML Module "ascii_syntax_plugin". Declare ML Module "r_syntax_plugin". Declare ML Module "int31_syntax_plugin". Numeral Notation BinNums.Z BinIntDef.Z.of_int BinIntDef.Z.to_int : Z_scope. diff --git a/theories/Compat/Coq89.v b/theories/Compat/Coq89.v index d25671887f..49b9e4c951 100644 --- a/theories/Compat/Coq89.v +++ b/theories/Compat/Coq89.v @@ -9,3 +9,4 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.9 *) +Local Set Warnings "-deprecated". diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index b0d1824827..8fc04d81e6 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -41,7 +41,7 @@ Local Open Scope Int_scope. Local Notation int := I.t. Definition key := X.t. -Hint Transparent key. +Hint Transparent key : core. (** * Trees *) @@ -488,8 +488,8 @@ Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop. (** * Automation and dedicated tactics. *) -Hint Constructors tree MapsTo In bst. -Hint Unfold lt_tree gt_tree. +Hint Constructors tree MapsTo In bst : core. +Hint Unfold lt_tree gt_tree : core. Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) "as" ident(s) := @@ -569,7 +569,7 @@ Lemma MapsTo_In : forall k e m, MapsTo k e m -> In k m. Proof. induction 1; auto. Qed. -Hint Resolve MapsTo_In. +Hint Resolve MapsTo_In : core. Lemma In_MapsTo : forall k m, In k m -> exists e, MapsTo k e m. Proof. @@ -588,7 +588,7 @@ Lemma MapsTo_1 : Proof. induction m; simpl; intuition_in; eauto. Qed. -Hint Immediate MapsTo_1. +Hint Immediate MapsTo_1 : core. Lemma In_1 : forall m x y, X.eq x y -> In x m -> In y m. @@ -627,7 +627,7 @@ Proof. unfold gt_tree in *; intuition_in; order. Qed. -Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. +Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. Lemma lt_left : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x l. @@ -653,7 +653,7 @@ Proof. intuition_in. Qed. -Hint Resolve lt_left lt_right gt_left gt_right. +Hint Resolve lt_left lt_right gt_left gt_right : core. Lemma lt_tree_not_in : forall x m, lt_tree x m -> ~ In x m. @@ -679,7 +679,7 @@ Proof. eauto. Qed. -Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. +Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. (** * Empty map *) @@ -811,7 +811,7 @@ Lemma create_bst : Proof. unfold create; auto. Qed. -Hint Resolve create_bst. +Hint Resolve create_bst : core. Lemma create_in : forall l x e r y, @@ -828,7 +828,7 @@ Proof. (apply lt_tree_node || apply gt_tree_node); auto; (eapply lt_tree_trans || eapply gt_tree_trans); eauto. Qed. -Hint Resolve bal_bst. +Hint Resolve bal_bst : core. Lemma bal_in : forall l x e r y, In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r. @@ -869,7 +869,7 @@ Proof. apply MX.eq_lt with x; auto. apply MX.lt_eq with x; auto. Qed. -Hint Resolve add_bst. +Hint Resolve add_bst : core. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. @@ -949,7 +949,7 @@ Proof. destruct 1. apply H2; intuition. Qed. -Hint Resolve remove_min_bst. +Hint Resolve remove_min_bst : core. Lemma remove_min_gt_tree : forall l x e r h, bst (Node l x e r h) -> @@ -968,7 +968,7 @@ Proof. assert (X.lt m#1 x) by order. decompose [or] H; order. Qed. -Hint Resolve remove_min_gt_tree. +Hint Resolve remove_min_gt_tree : core. Lemma remove_min_find : forall l x e r h y, bst (Node l x e r h) -> @@ -1120,7 +1120,7 @@ Proof. intuition; [ apply MX.lt_eq with x | ]; eauto. intuition; [ apply MX.eq_lt with x | ]; eauto. Qed. -Hint Resolve join_bst. +Hint Resolve join_bst : core. Lemma join_find : forall l x d r y, bst l -> bst r -> lt_tree x l -> gt_tree x r -> @@ -1256,7 +1256,7 @@ Proof. rewrite remove_min_in, e1; simpl; auto. change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto. Qed. -Hint Resolve concat_bst. +Hint Resolve concat_bst : core. Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> @@ -1344,7 +1344,7 @@ Proof. intros; unfold elements; apply elements_aux_sort; auto. intros; inversion H0. Qed. -Hint Resolve elements_sort. +Hint Resolve elements_sort : core. Lemma elements_nodup : forall s : t elt, bst s -> NoDupA eqk (elements s). Proof. @@ -1612,7 +1612,7 @@ destruct (map_option_2 H) as (d0 & ? & ?). destruct (map_option_2 H') as (d0' & ? & ?). eapply X.lt_trans with x; eauto using MapsTo_In. Qed. -Hint Resolve map_option_bst. +Hint Resolve map_option_bst : core. Ltac nonify e := replace e with (@None elt) by @@ -1711,7 +1711,7 @@ apply X.lt_trans with x1. destruct (map2_opt_2 H1 H6 Hy); intuition. destruct (map2_opt_2 H2 H7 Hy'); intuition. Qed. -Hint Resolve map2_opt_bst. +Hint Resolve map2_opt_bst : core. Ltac map2_aux := match goal with @@ -2066,7 +2066,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Proof. destruct c; simpl; intros; P.MX.elim_comp; auto. Qed. - Hint Resolve cons_Cmp. + Hint Resolve cons_Cmp : core. Lemma compare_end_Cmp : forall e2, Cmp (compare_end e2) nil (P.flatten_e e2). diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 2d5a79838a..d19c5558d8 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -20,7 +20,7 @@ Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. -Hint Extern 1 (Equivalence _) => constructor; congruence. +Hint Extern 1 (Equivalence _) => constructor; congruence : core. (** * Facts about weak maps *) diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index c0db8646c7..950b30ee4d 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -63,7 +63,7 @@ Inductive avl : t elt -> Prop := (** * Automation and dedicated tactics about [avl]. *) -Hint Constructors avl. +Hint Constructors avl : core. Lemma height_non_negative : forall (s : t elt), avl s -> height s >= 0. @@ -100,7 +100,7 @@ Lemma avl_node : forall x e l r, avl l -> avl r -> Proof. intros; auto. Qed. -Hint Resolve avl_node. +Hint Resolve avl_node : core. (** Results about [height] *) @@ -193,7 +193,7 @@ Lemma add_avl : forall m x e, avl m -> avl (add x e m). Proof. intros; generalize (add_avl_1 x e H); intuition. Qed. -Hint Resolve add_avl. +Hint Resolve add_avl : core. (** * Extraction of minimum binding *) @@ -274,7 +274,7 @@ Lemma remove_avl : forall m x, avl m -> avl (remove x m). Proof. intros; generalize (remove_avl_1 x H); intuition. Qed. -Hint Resolve remove_avl. +Hint Resolve remove_avl : core. (** * Join *) @@ -331,7 +331,7 @@ Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r). Proof. intros; destruct (join_avl_1 x d H H0); auto. Qed. -Hint Resolve join_avl. +Hint Resolve join_avl : core. (** concat *) @@ -341,7 +341,7 @@ Proof. intros; apply join_avl; auto. generalize (remove_min_avl H0); rewrite e1; simpl; auto. Qed. -Hint Resolve concat_avl. +Hint Resolve concat_avl : core. (** split *) @@ -355,7 +355,7 @@ Proof. Qed. End Elt. -Hint Constructors avl. +Hint Constructors avl : core. Section Map. Variable elt elt' : Type. @@ -713,7 +713,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Proof. destruct c; simpl; intros; MX.elim_comp; auto. Qed. - Hint Resolve cons_Cmp. + Hint Resolve cons_Cmp : core. Lemma compare_aux_Cmp : forall e, Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)). diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index 38a96dc393..8970529103 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -58,7 +58,7 @@ Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. Module Type WSfun (E : DecidableType). Definition key := E.t. - Hint Transparent key. + Hint Transparent key : core. Parameter t : Type -> Type. (** the abstract type of maps *) diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 3e98d11976..6ca158a277 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -51,7 +51,7 @@ Proof. intro abs. inversion abs. Qed. -Hint Resolve empty_1. +Hint Resolve empty_1 : core. Lemma empty_sorted : Sort empty. Proof. @@ -216,7 +216,7 @@ Proof. compute in H0,H1. simpl; case (X.compare x x''); intuition. Qed. -Hint Resolve add_Inf. +Hint Resolve add_Inf : core. Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). Proof. @@ -302,7 +302,7 @@ Proof. inversion_clear Hm. apply Inf_lt with (x'',e''); auto. Qed. -Hint Resolve remove_Inf. +Hint Resolve remove_Inf : core. Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). Proof. @@ -586,7 +586,7 @@ Proof. inversion_clear H; auto. Qed. -Hint Resolve map_lelistA. +Hint Resolve map_lelistA : core. Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), sort (@ltk elt') (map f m). @@ -654,7 +654,7 @@ Proof. inversion_clear H; auto. Qed. -Hint Resolve mapi_lelistA. +Hint Resolve mapi_lelistA : core. Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), sort (@ltk elt') (mapi f m). @@ -781,7 +781,7 @@ Proof. inversion_clear H; auto. inversion_clear H0; auto. Qed. -Hint Resolve combine_lelistA. +Hint Resolve combine_lelistA : core. Lemma combine_sorted : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 6736096509..03dce9666d 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -49,7 +49,7 @@ Proof. inversion abs. Qed. -Hint Resolve empty_1. +Hint Resolve empty_1 : core. Lemma empty_NoDup : NoDupA empty. Proof. @@ -621,7 +621,7 @@ Proof. inversion_clear 1. intros; apply add_NoDup; auto. Qed. -Hint Resolve fold_right_pair_NoDup. +Hint Resolve fold_right_pair_NoDup : core. Lemma combine_NoDup : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 0c4ecb1f31..3952c28061 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -137,7 +137,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. Qed. - Hint Resolve compat_P_aux. + Hint Resolve compat_P_aux : core. Definition filter : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), @@ -467,7 +467,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros; unfold elements; case (M.elements s); firstorder. Qed. - Hint Resolve elements_3. + Hint Resolve elements_3 : core. Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). Proof. auto. Qed. @@ -666,7 +666,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. rewrite <- H1; firstorder. Qed. - Hint Resolve compat_P_aux. + Hint Resolve compat_P_aux : core. Definition filter (f : elt -> bool) (s : t) : t := let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'. diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 0926d3ae9f..fa7f1c5f4e 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -253,7 +253,7 @@ Module Type WSfun (E : DecidableType). End Spec. - Hint Transparent elt. + Hint Transparent elt : core. Hint Resolve mem_1 equal_1 subset_1 empty_1 is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index c9cfb94ace..17f0e25e7a 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -21,8 +21,8 @@ Require Import DecidableTypeEx FSetFacts FSetDecide. Set Implicit Arguments. Unset Strict Implicit. -Hint Unfold transpose compat_op Proper respectful. -Hint Extern 1 (Equivalence _) => constructor; congruence. +Hint Unfold transpose compat_op Proper respectful : core. +Hint Extern 1 (Equivalence _) => constructor; congruence : core. (** First, a functor for Weak Sets in functorial version. *) @@ -732,7 +732,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; rewrite cardinal_Empty; auto. Qed. - Hint Resolve cardinal_inv_1. + Hint Resolve cardinal_inv_1 : core. Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. @@ -769,7 +769,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). exact Equal_cardinal. Qed. - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. (** ** Cardinal and set operators *) @@ -887,7 +887,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). auto with set. Qed. - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. + Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. End WProperties_fun. @@ -952,7 +952,7 @@ Module OrdProperties (M:S). red; intros x a b H; unfold leb. f_equal; apply gtb_compat; auto. Qed. - Hint Resolve gtb_compat leb_compat. + Hint Resolve gtb_compat leb_compat : core. Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 75f14bb4da..7f0387dd12 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -136,7 +136,7 @@ Defined. Inductive BoolSpec (P Q : Prop) : bool -> Prop := | BoolSpecT : P -> BoolSpec P Q true | BoolSpecF : Q -> BoolSpec P Q false. -Hint Constructors BoolSpec. +Hint Constructors BoolSpec : core. (********************************************************************) @@ -344,7 +344,7 @@ Inductive CompareSpec (Peq Plt Pgt : Prop) : comparison -> Prop := | CompEq : Peq -> CompareSpec Peq Plt Pgt Eq | CompLt : Plt -> CompareSpec Peq Plt Pgt Lt | CompGt : Pgt -> CompareSpec Peq Plt Pgt Gt. -Hint Constructors CompareSpec. +Hint Constructors CompareSpec : core. (** For having clean interfaces after extraction, [CompareSpec] is declared in Prop. For some situations, it is nonetheless useful to have a @@ -354,7 +354,7 @@ Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. -Hint Constructors CompareSpecT. +Hint Constructors CompareSpecT : core. Lemma CompareSpec2Type : forall Peq Plt Pgt c, CompareSpec Peq Plt Pgt c -> CompareSpecT Peq Plt Pgt c. @@ -371,7 +371,7 @@ Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := CompareSpecT (eq x y) (lt x y) (lt y x). -Hint Unfold CompSpec CompSpecT. +Hint Unfold CompSpec CompSpecT : core. Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c, CompSpec eq lt x y c -> CompSpecT eq lt x y c. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 4614d215eb..d5241e622c 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -219,7 +219,7 @@ Section Facts. Proof. auto using app_assoc. Qed. - Hint Resolve app_assoc_reverse. + Hint Resolve app_assoc_reverse : core. (* end hide *) (** [app] commutes with [cons] *) @@ -1569,19 +1569,19 @@ Section SetIncl. Variable A : Type. Definition incl (l m:list A) := forall a:A, In a l -> In a m. - Hint Unfold incl. + Hint Unfold incl : core. Lemma incl_refl : forall l:list A, incl l l. Proof. auto. Qed. - Hint Resolve incl_refl. + Hint Resolve incl_refl : core. Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m). Proof. auto with datatypes. Qed. - Hint Immediate incl_tl. + Hint Immediate incl_tl : core. Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n. Proof. @@ -1592,13 +1592,13 @@ Section SetIncl. Proof. auto with datatypes. Qed. - Hint Immediate incl_appl. + Hint Immediate incl_appl : core. Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n). Proof. auto with datatypes. Qed. - Hint Immediate incl_appr. + Hint Immediate incl_appr : core. Lemma incl_cons : forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m. @@ -1613,7 +1613,7 @@ Section SetIncl. now_show (In a0 l -> In a0 m). auto. Qed. - Hint Resolve incl_cons. + Hint Resolve incl_cons : core. Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n. Proof. @@ -1621,7 +1621,7 @@ Section SetIncl. now_show (In a n). elim (in_app_or _ _ _ H1); auto. Qed. - Hint Resolve incl_app. + Hint Resolve incl_app : core. End SetIncl. @@ -2180,7 +2180,7 @@ Section Exists_Forall. | Exists_cons_hd : forall x l, P x -> Exists (x::l) | Exists_cons_tl : forall x l, Exists l -> Exists (x::l). - Hint Constructors Exists. + Hint Constructors Exists : core. Lemma Exists_exists (l:list A) : Exists l <-> (exists x, In x l /\ P x). @@ -2214,7 +2214,7 @@ Section Exists_Forall. | Forall_nil : Forall nil | Forall_cons : forall x l, P x -> Forall l -> Forall (x::l). - Hint Constructors Forall. + Hint Constructors Forall : core. Lemma Forall_forall (l:list A): Forall l <-> (forall x, In x l -> P x). @@ -2299,8 +2299,8 @@ Section Exists_Forall. End Exists_Forall. -Hint Constructors Exists. -Hint Constructors Forall. +Hint Constructors Exists : core. +Hint Constructors Forall : core. Section Forall2. @@ -2314,7 +2314,7 @@ Section Forall2. | Forall2_cons : forall x y l l', R x y -> Forall2 l l' -> Forall2 (x::l) (y::l'). - Hint Constructors Forall2. + Hint Constructors Forall2 : core. Theorem Forall2_refl : Forall2 [] []. Proof. intros; apply Forall2_nil. Qed. @@ -2348,7 +2348,7 @@ Section Forall2. Qed. End Forall2. -Hint Constructors Forall2. +Hint Constructors Forall2 : core. Section ForallPairs. @@ -2369,7 +2369,7 @@ Section ForallPairs. | FOP_cons : forall a l, Forall (R a) l -> ForallOrdPairs l -> ForallOrdPairs (a::l). - Hint Constructors ForallOrdPairs. + Hint Constructors ForallOrdPairs : core. Lemma ForallOrdPairs_In : forall l, ForallOrdPairs l -> diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index cc7d6f5536..3afdd8df27 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -193,7 +193,7 @@ Section first_definitions. | auto with datatypes ]. Qed. - Hint Resolve set_add_intro1 set_add_intro2. + Hint Resolve set_add_intro1 set_add_intro2 : core. Lemma set_add_intro : forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x). @@ -224,7 +224,7 @@ Section first_definitions. case H1; trivial. Qed. - Hint Resolve set_add_intro set_add_elim set_add_elim2. + Hint Resolve set_add_intro set_add_elim set_add_elim2 : core. Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set. Proof. @@ -310,7 +310,7 @@ Section first_definitions. intros; elim H0; auto with datatypes. Qed. - Hint Resolve set_union_intro2 set_union_intro1. + Hint Resolve set_union_intro2 set_union_intro1 : core. Lemma set_union_intro : forall (a:A) (x y:set), @@ -393,7 +393,7 @@ Section first_definitions. eauto with datatypes. Qed. - Hint Resolve set_inter_elim1 set_inter_elim2. + Hint Resolve set_inter_elim1 set_inter_elim2 : core. Lemma set_inter_elim : forall (a:A) (x y:set), @@ -471,7 +471,7 @@ Section first_definitions. apply (set_diff_elim1 _ _ _ H). Qed. -Hint Resolve set_diff_intro set_diff_trivial. +Hint Resolve set_diff_intro set_diff_trivial : core. End first_definitions. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 0c5fe55b27..cab4c23df1 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -30,7 +30,7 @@ Inductive InA (x : A) : list A -> Prop := | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l) | InA_cons_tl : forall y l, InA x l -> InA x (y :: l). -Hint Constructors InA. +Hint Constructors InA : core. (** TODO: it would be nice to have a generic definition instead of the previous one. Having [InA = Exists eqA] raises too @@ -62,7 +62,7 @@ Inductive NoDupA : list A -> Prop := | NoDupA_nil : NoDupA nil | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l). -Hint Constructors NoDupA. +Hint Constructors NoDupA : core. (** An alternative definition of [NoDupA] based on [ForallOrdPairs] *) @@ -93,7 +93,7 @@ Inductive eqlistA : list A -> list A -> Prop := | eqlistA_cons : forall x x' l l', eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). -Hint Constructors eqlistA. +Hint Constructors eqlistA : core. (** We could also have written [eqlistA = Forall2 eqA]. *) @@ -107,8 +107,8 @@ Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). -Hint Resolve eqarefl eqatrans. -Hint Immediate eqasym. +Hint Resolve eqarefl eqatrans : core. +Hint Immediate eqasym : core. Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. @@ -154,14 +154,14 @@ Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. Proof. intros l x y H H'. rewrite <- H. auto. Qed. -Hint Immediate InA_eqA. +Hint Immediate InA_eqA : core. Lemma In_InA : forall l x, In x l -> InA x l. Proof. simple induction l; simpl; intuition. subst; auto. Qed. -Hint Resolve In_InA. +Hint Resolve In_InA : core. Lemma InA_split : forall l x, InA x l -> exists l1 y l2, eqA x y /\ l = l1++y::l2. @@ -786,12 +786,12 @@ Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder). -Hint Resolve sotrans. +Hint Resolve sotrans : core. Notation InfA:=(lelistA ltA). Notation SortA:=(sort ltA). -Hint Constructors lelistA sort. +Hint Constructors lelistA sort : core. Lemma InfA_ltA : forall l x y, ltA x y -> InfA y l -> InfA x l. @@ -814,7 +814,7 @@ Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l. Proof using eqA_equiv ltA_compat. intros H; now rewrite H. Qed. -Hint Immediate InfA_ltA InfA_eqA. +Hint Immediate InfA_ltA InfA_eqA : core. Lemma SortA_InfA_InA : forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. @@ -1005,7 +1005,7 @@ Qed. End Filter. End Type_with_equality. -Hint Constructors InA eqlistA NoDupA sort lelistA. +Hint Constructors InA eqlistA NoDupA sort lelistA : core. Arguments equivlistA_cons_nil {A} eqA {eqA_equiv} x l _. Arguments equivlistA_nil_eq {A} eqA {eqA_equiv} l _. diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v index 24b96514fd..f5ea303343 100644 --- a/theories/Lists/SetoidPermutation.v +++ b/theories/Lists/SetoidPermutation.v @@ -28,7 +28,7 @@ Inductive PermutationA : list A -> list A -> Prop := | permA_swap x y l : PermutationA (y :: x :: l) (x :: y :: l) | permA_trans l₁ l₂ l₃ : PermutationA l₁ l₂ -> PermutationA l₂ l₃ -> PermutationA l₁ l₃. -Local Hint Constructors PermutationA. +Local Hint Constructors PermutationA : core. Global Instance: Equivalence PermutationA. Proof. diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v index 6e3da423e8..04e3981001 100644 --- a/theories/Logic/ConstructiveEpsilon.v +++ b/theories/Logic/ConstructiveEpsilon.v @@ -42,6 +42,8 @@ For the first one we provide explicit and short proof terms. *) (* Direct version *) +Require Import Arith. + Section ConstructiveIndefiniteGroundDescription_Direct. Variable P : nat -> Prop. @@ -84,14 +86,38 @@ Definition constructive_indefinite_ground_description_nat : (exists n, P n) -> {n:nat | P n} := fun e => linear_search O (let (n, p) := e in O_witness n (stop n p)). +Fixpoint linear_search_smallest (start : nat) (pr : before_witness start) : + forall k : nat, start <= k < proj1_sig (linear_search start pr) -> ~P k. +Proof. + (* Recursion on pr, which is the distance between start and linear_search *) + intros. destruct (P_dec start) eqn:Pstart. + - (* P start, k cannot exist *) + intros. assert (proj1_sig (linear_search start pr) = start). + { unfold linear_search. destruct pr; rewrite -> Pstart; reflexivity. } + rewrite -> H0 in H. destruct H. apply (le_lt_trans start k) in H1. + apply lt_irrefl in H1. contradiction. assumption. + - (* ~P start, step once in the search and use induction hypothesis *) + destruct pr. contradiction. destruct H. apply le_lt_or_eq in H. destruct H. + apply (linear_search_smallest (S start) pr). split. assumption. + simpl in H0. rewrite -> Pstart in H0. assumption. subst. assumption. +Defined. + +Definition epsilon_smallest : + (exists n : nat, P n) + -> { n : nat | P n /\ forall k : nat, k < n -> ~P k }. +Proof. + intros. pose (wit := (let (n, p) := H in O_witness n (stop n p))). + destruct (linear_search 0 wit) as [n pr] eqn:ls. exists n. split. assumption. intros. + apply (linear_search_smallest 0 wit). split. apply le_0_n. + rewrite -> ls. assumption. +Qed. + End ConstructiveIndefiniteGroundDescription_Direct. (************************************************************************) (* Version using the predicate [Acc] *) -Require Import Arith. - Section ConstructiveIndefiniteGroundDescription_Acc. Variable P : nat -> Prop. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 25b7811417..3914f44a2c 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -31,7 +31,7 @@ Arguments JMeq_refl {A x} , [A] x. Register JMeq as core.JMeq.type. Register JMeq_refl as core.JMeq.refl. -Hint Resolve JMeq_refl. +Hint Resolve JMeq_refl : core. Definition JMeq_hom {A : Type} (x y : A) := JMeq x y. @@ -42,7 +42,7 @@ Proof. intros; destruct H; trivial. Qed. -Hint Immediate JMeq_sym. +Hint Immediate JMeq_sym : core. Register JMeq_sym as core.JMeq.sym. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index aec88f93bf..ac2a143472 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -305,13 +305,13 @@ Include MSetGenTree.Props X I. (** Automation and dedicated tactics *) -Local Hint Immediate MX.eq_sym. -Local Hint Unfold In lt_tree gt_tree Ok. -Local Hint Constructors InT bst. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok. -Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. -Local Hint Resolve elements_spec2. +Local Hint Immediate MX.eq_sym : core. +Local Hint Unfold In lt_tree gt_tree Ok : core. +Local Hint Constructors InT bst : core. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. +Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. +Local Hint Resolve elements_spec2 : core. (* Sometimes functional induction will expose too much of a tree structure. The following tactic allows factoring back @@ -496,7 +496,7 @@ Proof. specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L; [setoid_replace y with x|inv]; eauto. Qed. -Local Hint Resolve remove_min_gt_tree. +Local Hint Resolve remove_min_gt_tree : core. (** ** Merging two trees *) diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 95868861fa..888f9850c1 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -46,7 +46,7 @@ End InfoTyp. Module Type Ops (X:OrderedType)(Info:InfoTyp). Definition elt := X.t. -Hint Transparent elt. +Hint Transparent elt : core. Inductive tree : Type := | Leaf : tree @@ -342,11 +342,11 @@ Module Import MX := OrderedTypeFacts X. Scheme tree_ind := Induction for tree Sort Prop. Scheme bst_ind := Induction for bst Sort Prop. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok. -Local Hint Immediate MX.eq_sym. -Local Hint Unfold In lt_tree gt_tree. -Local Hint Constructors InT bst. -Local Hint Unfold Ok. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. +Local Hint Immediate MX.eq_sym : core. +Local Hint Unfold In lt_tree gt_tree : core. +Local Hint Constructors InT bst : core. +Local Hint Unfold Ok : core. (** Automatic treatment of [Ok] hypothesis *) @@ -432,7 +432,7 @@ Lemma In_1 : Proof. induction s; simpl; intuition_in; eauto. Qed. -Local Hint Immediate In_1. +Local Hint Immediate In_1 : core. Instance In_compat : Proper (X.eq==>eq==>iff) InT. Proof. @@ -478,7 +478,7 @@ Proof. unfold gt_tree; intuition_in; order. Qed. -Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. +Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. Lemma lt_tree_not_in : forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t. @@ -516,7 +516,7 @@ Proof. intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. Qed. -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. Ltac induct s x := induction s as [|i l IHl x' r IHr]; simpl; intros; @@ -699,7 +699,7 @@ Proof. intros; unfold elements; apply elements_spec2'; auto. intros; inversion H0. Qed. -Local Hint Resolve elements_spec2. +Local Hint Resolve elements_spec2 : core. Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s). Proof. @@ -1035,7 +1035,7 @@ Qed. Definition Cmp c x y := CompSpec L.eq L.lt x y c. -Local Hint Unfold Cmp flip. +Local Hint Unfold Cmp flip : core. Lemma compare_end_Cmp : forall e2, Cmp (compare_end e2) nil (flatten_e e2). diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index f0e757157d..a4bbaef52d 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -884,10 +884,10 @@ Module MakeListOrdering (O:OrderedType). O.lt x y -> lt_list (x :: s) (y :: s') | lt_cons_eq : forall x y s s', O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s'). - Hint Constructors lt_list. + Hint Constructors lt_list : core. Definition lt := lt_list. - Hint Unfold lt. + Hint Unfold lt : core. Instance lt_strorder : StrictOrder lt. Proof. @@ -933,13 +933,13 @@ Module MakeListOrdering (O:OrderedType). left; MO.order. right; rewrite <- E12; auto. left; MO.order. right; rewrite E12; auto. Qed. - Hint Resolve eq_cons. + Hint Resolve eq_cons : core. Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 -> CompSpec eq lt l1 l2 c -> CompSpec eq lt (x1::l1) (x2::l2) c. Proof. destruct c; simpl; inversion_clear 2; auto with relations. Qed. - Hint Resolve cons_CompSpec. + Hint Resolve cons_CompSpec : core. End MakeListOrdering. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index 35fe4cee4e..7b64818b24 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -231,14 +231,14 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Notation In := (InA X.eq). Existing Instance X.eq_equiv. - Hint Extern 20 => solve [order]. + Hint Extern 20 => solve [order] : core. Definition IsOk s := Sort s. Class Ok (s:t) : Prop := ok : Sort s. - Hint Resolve ok. - Hint Unfold Ok. + Hint Resolve ok : core. + Hint Unfold Ok : core. Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }. @@ -276,7 +276,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. destruct H; constructor; tauto. Qed. - Hint Extern 1 (Ok _) => rewrite <- isok_iff. + Hint Extern 1 (Ok _) => rewrite <- isok_iff : core. Ltac inv_ok := match goal with | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok @@ -326,7 +326,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. intuition. intros; elim_compare x a; inv; intuition. Qed. - Hint Resolve add_inf. + Hint Resolve add_inf : core. Global Instance add_ok s x : forall `(Ok s), Ok (add x s). Proof. @@ -353,7 +353,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. intros; elim_compare x a; inv; auto. apply Inf_lt with a; auto. Qed. - Hint Resolve remove_inf. + Hint Resolve remove_inf : core. Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s). Proof. @@ -396,7 +396,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Proof. induction2. Qed. - Hint Resolve union_inf. + Hint Resolve union_inf : core. Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s'). Proof. @@ -422,7 +422,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. apply Hrec'; auto. apply Inf_lt with x'; auto. Qed. - Hint Resolve inter_inf. + Hint Resolve inter_inf : core. Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s'). Proof. @@ -452,7 +452,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. apply Hrec'; auto. apply Inf_lt with x'; auto. Qed. - Hint Resolve diff_inf. + Hint Resolve diff_inf : core. Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s'). Proof. diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v index 3c7dea736b..29e57ff0a2 100644 --- a/theories/MSets/MSetProperties.v +++ b/theories/MSets/MSetProperties.v @@ -21,7 +21,7 @@ Require Import DecidableTypeEx OrdersLists MSetFacts MSetDecide. Set Implicit Arguments. Unset Strict Implicit. -Hint Unfold transpose. +Hint Unfold transpose : core. (** First, a functor for Weak Sets in functorial version. *) @@ -735,7 +735,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). Proof. intros; rewrite cardinal_Empty; auto. Qed. - Hint Resolve cardinal_inv_1. + Hint Resolve cardinal_inv_1 : core. Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. @@ -774,7 +774,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). exact Equal_cardinal. Qed. - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. (** ** Cardinal and set operators *) @@ -898,7 +898,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). auto with set. Qed. - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. + Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. End WPropertiesOn. @@ -922,7 +922,7 @@ Module OrdProperties (M:Sets). Import M.E. Import M. - Hint Resolve elements_spec2. + Hint Resolve elements_spec2 : core. Hint Immediate min_elt_spec1 min_elt_spec2 min_elt_spec3 max_elt_spec1 max_elt_spec2 max_elt_spec3 : set. @@ -961,7 +961,7 @@ Module OrdProperties (M:Sets). Proof. intros a b H; unfold leb. rewrite H; auto. Qed. - Hint Resolve gtb_compat leb_compat. + Hint Resolve gtb_compat leb_compat : core. Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index eab01a55b0..f9105fdf74 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -450,13 +450,13 @@ Include MSetGenTree.Props X Color. Local Notation Rd := (Node Red). Local Notation Bk := (Node Black). -Local Hint Immediate MX.eq_sym. -Local Hint Unfold In lt_tree gt_tree Ok. -Local Hint Constructors InT bst. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok. -Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. -Local Hint Resolve elements_spec2. +Local Hint Immediate MX.eq_sym : core. +Local Hint Unfold In lt_tree gt_tree Ok : core. +Local Hint Constructors InT bst : core. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok : core. +Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. +Local Hint Resolve elements_spec2 : core. (** ** Singleton set *) @@ -1136,7 +1136,7 @@ Record INV l1 l2 acc : Prop := { acc_sorted : sort X.lt acc; l1_lt_acc x y : InA X.eq x l1 -> InA X.eq y acc -> X.lt x y; l2_lt_acc x y : InA X.eq x l2 -> InA X.eq y acc -> X.lt x y}. -Local Hint Resolve l1_sorted l2_sorted acc_sorted. +Local Hint Resolve l1_sorted l2_sorted acc_sorted : core. Lemma INV_init s1 s2 `(Ok s1, Ok s2) : INV (rev_elements s1) (rev_elements s2) nil. @@ -1506,8 +1506,8 @@ Class Rbt (t:tree) := RBT : exists d, rbt d t. (** ** Basic tactics and results about red-black *) Scheme rbt_ind := Induction for rbt Sort Prop. -Local Hint Constructors rbt rrt arbt. -Local Hint Extern 0 (notred _) => (exact I). +Local Hint Constructors rbt rrt arbt : core. +Local Hint Extern 0 (notred _) => (exact I) : core. Ltac invrb := intros; invtree rrt; invtree rbt; try contradiction. Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end. Ltac nonzero n := destruct n as [|n]; [try split; invrb|]. @@ -1519,7 +1519,7 @@ Proof. destruct l, r; descolor; invrb; auto. Qed. -Local Hint Resolve rr_nrr_rb. +Local Hint Resolve rr_nrr_rb : core. Lemma arb_nrr_rb n t : arbt n t -> notredred t -> rbt n t. @@ -1533,7 +1533,7 @@ Proof. destruct 1; destruct t; descolor; invrb; auto. Qed. -Local Hint Resolve arb_nrr_rb arb_nr_rb. +Local Hint Resolve arb_nrr_rb arb_nr_rb : core. (** ** A Red-Black tree has indeed a logarithmic depth *) diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v index 8df1ff1cdb..19058a767e 100644 --- a/theories/MSets/MSetWeakList.v +++ b/theories/MSets/MSetWeakList.v @@ -123,15 +123,15 @@ Module MakeRaw (X:DecidableType) <: WRawSets X. Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv). Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv). Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv). - Hint Resolve eqr eqtrans. - Hint Immediate eqsym. + Hint Resolve eqr eqtrans : core. + Hint Immediate eqsym : core. Definition IsOk := NoDup. Class Ok (s:t) : Prop := ok : NoDup s. - Hint Unfold Ok. - Hint Resolve ok. + Hint Unfold Ok : core. + Hint Resolve ok : core. Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index 3a2503d6b7..ce540775e3 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -15,6 +15,8 @@ Require Import Wf_nat. Require Export ZArith. Require Export DoubleType. +Local Unset Elimination Schemes. + (** * 31-bit integers *) (** This file contains basic definitions of a 31-bit integer @@ -48,6 +50,10 @@ Inductive int31 : Type := I31 : digits31 int31. Register digits as int31.bits. Register int31 as int31.type. +Scheme int31_ind := Induction for int31 Sort Prop. +Scheme int31_rec := Induction for int31 Sort Set. +Scheme int31_rect := Induction for int31 Sort Type. + Declare Scope int31_scope. Declare ML Module "int31_syntax_plugin". Delimit Scope int31_scope with int31. diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 784e81758c..4bcd22543f 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -60,7 +60,7 @@ Section ZModulo. apply Z.lt_gt. unfold wB, base; auto with zarith. Qed. - Hint Resolve wB_pos. + Hint Resolve wB_pos : core. Lemma spec_to_Z_1 : forall x, 0 <= [|x|]. Proof. @@ -71,7 +71,7 @@ Section ZModulo. Proof. unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. Qed. - Hint Resolve spec_to_Z_1 spec_to_Z_2. + Hint Resolve spec_to_Z_1 spec_to_Z_2 : core. Lemma spec_to_Z : forall x, 0 <= [|x|] < wB. Proof. @@ -732,7 +732,7 @@ Section ZModulo. Proof. induction p; simpl; auto with zarith. Qed. - Hint Resolve Ptail_pos. + Hint Resolve Ptail_pos : core. Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d. Proof. diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index 8e1be0d702..4539dea276 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -383,7 +383,7 @@ f_equiv. apply E, half_decrease. rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. order'. Qed. -Hint Resolve log_good_step. +Hint Resolve log_good_step : core. Theorem log_init : forall n, n < 2 -> log n == 0. Proof. diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index c2316689fc..d86112abc0 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -26,7 +26,7 @@ Arguments id {A} x. Definition compose {A B C} (g : B -> C) (f : A -> B) := fun x : A => g (f x). -Hint Unfold compose. +Hint Unfold compose : core. Declare Scope program_scope. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index 8479b9a2bb..f9d23e3cf6 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -110,7 +110,7 @@ Section Measure_well_founded. End Measure_well_founded. -Hint Resolve measure_wf. +Hint Resolve measure_wf : core. Section Fix_rects. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 81c318138e..f18fca99a0 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -66,7 +66,7 @@ Proof. rewrite hq, hq' in H'. subst q'. f_equal. apply eq_proofs_unicity. intros. repeat decide equality. Qed. -Hint Resolve Qc_is_canon. +Hint Resolve Qc_is_canon : core. Theorem Qc_decomp: forall q q': Qc, (q:Q) = q' -> q = q'. Proof. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index c832962590..b4c869b4dd 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -21,7 +21,7 @@ intros. now apply not_O_IZR. Qed. -Hint Resolve IZR_nz Rmult_integral_contrapositive. +Hint Resolve IZR_nz Rmult_integral_contrapositive : core. Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y. Proof. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 59a1049654..ec283b886e 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1087,7 +1087,7 @@ Proof. replace (r2 + r1 + - r2) with r1 by ring. exact H. Qed. -Hint Resolve Ropp_gt_lt_contravar. +Hint Resolve Ropp_gt_lt_contravar : core. Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. Proof. @@ -1204,7 +1204,7 @@ Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r. Proof. intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real. Qed. -Hint Resolve Rmult_lt_compat_r. +Hint Resolve Rmult_lt_compat_r : core. Lemma Rmult_gt_compat_r : forall r r1 r2, r > 0 -> r1 > r2 -> r1 * r > r2 * r. Proof. eauto using Rmult_lt_compat_r with rorders. Qed. diff --git a/theories/Reals/Runcountable.v b/theories/Reals/Runcountable.v new file mode 100644 index 0000000000..ed5f75b74e --- /dev/null +++ b/theories/Reals/Runcountable.v @@ -0,0 +1,399 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + + +Require Import Coq.Reals.Rdefinitions. +Require Import Coq.Reals.Raxioms. +Require Import Rfunctions. +Require Import Coq.Reals.RIneq. +Require Import Coq.Logic.FinFun. +Require Import Coq.Logic.ConstructiveEpsilon. + + +Definition enumeration (A : Type) (u : nat -> A) (v : A -> nat) : Prop := + (forall x : A, u (v x) = x) /\ (forall n : nat, v (u n) = n). + +Definition in_holed_interval (a b hole : R) (u : nat -> R) (n : nat) : Prop := + Rlt a (u n) /\ Rlt (u n) b /\ u n <> hole. + +(* Here we use axiom total_order_T, which is not constructive *) +Lemma in_holed_interval_dec (a b h : R) (u : nat -> R) (n : nat) + : {in_holed_interval a b h u n} + {~in_holed_interval a b h u n}. +Proof. + destruct (total_order_T a (u n)) as [[l|e]|hi]. + - destruct (total_order_T b (u n)) as [[lb|eb]|hb]. + + right. intro H. destruct H. destruct H0. apply Rlt_asym in H0. contradiction. + + subst. right. intro H. destruct H. destruct H0. + pose proof (Rlt_asym (u n) (u n) H0). contradiction. + + destruct (Req_EM_T h (u n)). subst. right. intro H. destruct H. destruct H0. + exact (H1 eq_refl). left. split. assumption. split. assumption. intro H. subst. + exact (n0 eq_refl). + - subst. right. intro H. destruct H. pose proof (Rlt_asym (u n) (u n) H). contradiction. + - right. intro H. destruct H. apply Rlt_asym in H. contradiction. +Qed. + +Definition point_in_holed_interval (a b h : R) : R := + if Req_EM_T h (Rdiv (Rplus a b) (INR 2)) then (Rdiv (Rplus a h) (INR 2)) + else (Rdiv (Rplus a b) (INR 2)). + +Lemma middle_in_interval : forall a b : R, Rlt a b -> (a < (a + b) / INR 2 < b)%R. +Proof. + intros. + assert (twoNotZero: INR 2 <> 0%R). + { apply not_0_INR. intro abs. inversion abs. } + assert (twoAboveZero : (0 < / INR 2)%R). + { apply Rinv_0_lt_compat. apply lt_0_INR. apply le_n_S. apply le_S. apply le_n. } + assert (double : forall x : R, Rplus x x = ((INR 2) * x)%R). + { intro x. rewrite -> S_O_plus_INR. rewrite -> Rmult_plus_distr_r. + rewrite -> Rmult_1_l. reflexivity. } + split. + - assert (a + a < a + b)%R. { apply (Rplus_lt_compat_l a a b). assumption. } + rewrite -> double in H0. apply (Rmult_lt_compat_l (/ (INR 2))) in H0. + rewrite <- Rmult_assoc in H0. rewrite -> Rinv_l in H0. simpl in H0. + rewrite -> Rmult_1_l in H0. rewrite -> Rmult_comm in H0. assumption. + assumption. assumption. + - assert (b + a < b + b)%R. { apply (Rplus_lt_compat_l b a b). assumption. } + rewrite -> Rplus_comm in H0. rewrite -> double in H0. + apply (Rmult_lt_compat_l (/ (INR 2))) in H0. + rewrite <- Rmult_assoc in H0. rewrite -> Rinv_l in H0. simpl in H0. + rewrite -> Rmult_1_l in H0. rewrite -> Rmult_comm in H0. assumption. + assumption. assumption. +Qed. + +Lemma point_in_holed_interval_works (a b h : R) : + Rlt a b -> let p := point_in_holed_interval a b h in + Rlt a p /\ Rlt p b /\ p <> h. +Proof. + intros. unfold point_in_holed_interval in p. + pose proof (middle_in_interval a b H). destruct H0. + destruct (Req_EM_T h ((a + b) / INR 2)). + - (* middle hole, p is quarter *) subst. + pose proof (middle_in_interval a ((a + b) / INR 2) H0). destruct H2. + split. assumption. split. apply (Rlt_trans p ((a + b) / INR 2)%R). assumption. + assumption. apply Rlt_not_eq. assumption. + - split. assumption. split. assumption. intro abs. subst. contradiction. +Qed. + +(* An enumeration of R reaches any open interval of R, + extract the first two real numbers in it. *) +Definition first_in_holed_interval (u : nat -> R) (v : R -> nat) (a b h : R) + : enumeration R u v -> Rlt a b + -> { n : nat | in_holed_interval a b h u n + /\ forall k : nat, k < n -> ~in_holed_interval a b h u k }. +Proof. + intros. apply epsilon_smallest. apply (in_holed_interval_dec a b h u). + exists (v (point_in_holed_interval a b h)). + destruct H. unfold in_holed_interval. rewrite -> H. + apply point_in_holed_interval_works. assumption. +Defined. + +Lemma first_in_holed_interval_works (u : nat -> R) (v : R -> nat) (a b h : R) + (pen : enumeration R u v) (plow : Rlt a b) : + let (c,_) := first_in_holed_interval u v a b h pen plow in + forall x:R, Rlt a x -> Rlt x b -> x <> h -> x <> u c -> c < v x. +Proof. + destruct (first_in_holed_interval u v a b h pen plow) as [c]. intros. + destruct (c ?= v x) eqn:order. + - exfalso. apply Nat.compare_eq_iff in order. rewrite -> order in H2. + destruct pen. rewrite -> H3 in H2. exact (H2 eq_refl). + - apply Nat.compare_lt_iff in order. assumption. + - exfalso. apply Nat.compare_gt_iff in order. + destruct a0. specialize (H4 (v x) order). assert (in_holed_interval a b h u (v x)). + { destruct pen. split. rewrite -> H5. assumption. rewrite -> H5. split; assumption. } + contradiction. +Qed. + +Definition first_two_in_interval (u : nat -> R) (v : R -> nat) (a b : R) + (pen : enumeration R u v) (plow : Rlt a b) + : prod R R := + let (first_index, pr) := first_in_holed_interval u v a b b pen plow in + let (second_index, pr2) := first_in_holed_interval u v a b (u first_index) pen plow in + if Rle_dec (u first_index) (u second_index) then (u first_index, u second_index) + else (u second_index, u first_index). + + +Lemma split_couple_eq : forall a b c d : R, (a,b) = (c,d) -> a = c /\ b = d. +Proof. + intros. injection H. intros. split. subst. reflexivity. subst. reflexivity. +Qed. + +Lemma first_two_in_interval_works (u : nat -> R) (v : R -> nat) (a b : R) + (pen : enumeration R u v) (plow : Rlt a b) : + let (c,d) := first_two_in_interval u v a b pen plow in + Rlt a c /\ Rlt c b + /\ Rlt a d /\ Rlt d b + /\ Rlt c d + /\ (forall x:R, Rlt a x -> Rlt x b -> x <> c -> x <> d -> v c < v x). +Proof. + intros. destruct (first_two_in_interval u v a b) eqn:ft. + unfold first_two_in_interval in ft. + pose proof (first_in_holed_interval_works u v a b b pen plow). + destruct (first_in_holed_interval u v a b b pen plow) as [first_index pr]. + pose proof (first_in_holed_interval_works u v a b (u first_index) pen plow). + destruct pr. destruct H1. destruct H3. + destruct (first_in_holed_interval u v a b (u first_index) pen plow) + as [second_index pr2]. + destruct pr2. destruct H5. destruct H7. + destruct (Rle_dec (u first_index) (u second_index)). + - apply split_couple_eq in ft as [ft ft0]. subst. split. assumption. + split. assumption. split. assumption. split. assumption. split. + apply Rle_lt_or_eq_dec in r1. destruct r1. assumption. exfalso. + rewrite -> e in H8. exact (H8 eq_refl). intros. destruct pen. rewrite -> H14. + apply H. assumption. assumption. apply Rlt_not_eq. assumption. assumption. + - apply split_couple_eq in ft as [ft ft0]. subst. split. assumption. + split. assumption. split. assumption. split. assumption. split. + apply Rnot_le_lt in n. assumption. intros. destruct pen. rewrite -> H14. + apply H0. assumption. assumption. assumption. assumption. +Qed. + +(* If u,v is an enumeration of R, this sequence of open intervals + tears the segment [0,1]. The recursive definition needs the proof that the + previous interval is ordered, hence the type. + + The first sequence is increasing, the second decreasing. + The first is below the second. + Therefore the first sequence has a limit, a least upper bound b, that u cannot reach, + which contradicts u (v b) = b. *) +Definition tearing_sequences (u : nat -> R) (v : R -> nat) + : (enumeration R u v) -> nat -> { ab : prod R R | Rlt (fst ab) (snd ab) }. +Proof. + intro pen. apply nat_rec. + - exists (INR 0, INR 1). simpl. apply Rlt_0_1. + - intros n [[a b] pr]. exists (first_two_in_interval u v a b pen pr). + pose proof (first_two_in_interval_works u v a b pen pr). + destruct (first_two_in_interval u v a b pen pr). apply H. +Defined. + +Lemma tearing_sequences_projsig (u : nat -> R) (v : R -> nat) (en : enumeration R u v) + (n : nat) + : let (I,pr) := tearing_sequences u v en n in + proj1_sig (tearing_sequences u v en (S n)) + = first_two_in_interval u v (fst I) (snd I) en pr. +Proof. + simpl. destruct (tearing_sequences u v en n) as [[a b] pr]. simpl. reflexivity. +Qed. + +(* The first tearing sequence in increasing, the second decreasing. + That means the tearing sequences are nested intervals. *) +Lemma tearing_sequences_inc_dec (u : nat -> R) (v : R -> nat) (pen : enumeration R u v) + : forall n : nat, + let I := proj1_sig (tearing_sequences u v pen n) in + let SI := proj1_sig (tearing_sequences u v pen (S n)) in + Rlt (fst I) (fst SI) /\ Rlt (snd SI) (snd I). +Proof. + intro n. simpl. destruct (tearing_sequences u v pen n) as [[a b] pr]. + simpl. pose proof (first_two_in_interval_works u v a b pen pr). + destruct (first_two_in_interval u v a b pen pr). + simpl. split. destruct H. assumption. + destruct H as [H1 [H2 [H3 [H4 H5]]]]. assumption. +Qed. + +Lemma split_lt_succ : forall n m : nat, lt n (S m) -> lt n m \/ n = m. +Proof. + intros n m. generalize dependent n. induction m. + - intros. destruct n. right. reflexivity. exfalso. inversion H. inversion H1. + - intros. destruct n. left. unfold lt. apply le_n_S. apply le_0_n. + apply lt_pred in H. simpl in H. specialize (IHm n H). destruct IHm. left. apply lt_n_S. assumption. + subst. right. reflexivity. +Qed. + +Lemma increase_seq_transit (u : nat -> R) : + (forall n : nat, Rlt (u n) (u (S n))) -> (forall n m : nat, n < m -> Rlt (u n) (u m)). +Proof. + intros. induction m. + - intros. inversion H0. + - intros. destruct (split_lt_succ n m H0). + + apply (Rlt_trans (u n) (u m)). apply IHm. assumption. apply H. + + subst. apply H. +Qed. + +Lemma decrease_seq_transit (u : nat -> R) : + (forall n : nat, Rlt (u (S n)) (u n)) -> (forall n m : nat, n < m -> Rlt (u m) (u n)). +Proof. + intros. induction m. + - intros. inversion H0. + - intros. destruct (split_lt_succ n m H0). + + apply (Rlt_trans (u (S m)) (u m)). apply H. apply IHm. assumption. + + subst. apply H. +Qed. + +(* Either increase the first sequence, or decrease the second sequence, + until n = m and conclude by tearing_sequences_ordered *) +Lemma tearing_sequences_ordered_forall (u : nat -> R) (v : R -> nat) + (pen : enumeration R u v) : + forall n m : nat, let In := proj1_sig (tearing_sequences u v pen n) in + let Im := proj1_sig (tearing_sequences u v pen m) in + Rlt (fst In) (snd Im). +Proof. + intros. destruct (tearing_sequences u v pen n) eqn:tn. simpl in In. + destruct (tearing_sequences u v pen m) eqn:tm. simpl in Im. + destruct (n ?= m) eqn:order. + - apply Nat.compare_eq_iff in order. subst. rewrite -> tm in tn. + inversion tn. subst. assumption. + - apply Nat.compare_lt_iff in order. (* increase first sequence *) + apply (Rlt_trans (fst In) (fst Im)). + remember (fun n => fst (proj1_sig (tearing_sequences u v pen n))) as fseq. + pose proof (increase_seq_transit fseq). + assert ((forall n : nat, (fseq n < fseq (S n))%R)). + { intro n0. rewrite -> Heqfseq. pose proof (tearing_sequences_inc_dec u v pen n0). + destruct (tearing_sequences u v pen (S n0)). simpl. + destruct ((tearing_sequences u v pen n0)). apply H0. } + specialize (H H0). rewrite -> Heqfseq in H. specialize (H n m order). + rewrite -> tn in H. rewrite -> tm in H. simpl in H. apply H. assumption. + - apply Nat.compare_gt_iff in order. (* decrease second sequence *) + apply (Rlt_trans (fst In) (snd In)). assumption. + remember (fun n => snd (proj1_sig (tearing_sequences u v pen n))) as sseq. + pose proof (decrease_seq_transit sseq). + assert ((forall n : nat, (sseq (S n) < sseq n)%R)). + { intro n0. rewrite -> Heqsseq. pose proof (tearing_sequences_inc_dec u v pen n0). + destruct (tearing_sequences u v pen (S n0)). simpl. + destruct ((tearing_sequences u v pen n0)). apply H0. } + specialize (H H0). rewrite -> Heqsseq in H. specialize (H m n order). + rewrite -> tn in H. rewrite -> tm in H. apply H. +Qed. + +Definition tearing_elem_fst (u : nat -> R) (v : R -> nat) (pen : enumeration R u v) (x : R) + := exists n : nat, x = fst (proj1_sig (tearing_sequences u v pen n)). + +(* The limit of the first tearing sequence cannot be reached by u *) +Definition torn_number (u : nat -> R) (v : R -> nat) (pen : enumeration R u v) : + {m : R | is_lub (tearing_elem_fst u v pen) m}. +Proof. + intros. assert (bound (tearing_elem_fst u v pen)). + { exists (INR 1). intros x H0. destruct H0 as [n H0]. subst. left. + apply (tearing_sequences_ordered_forall u v pen n 0). } + apply (completeness (tearing_elem_fst u v pen) H). + exists (INR 0). exists 0. reflexivity. +Defined. + +Lemma torn_number_above_first_sequence (u : nat -> R) (v : R -> nat) (en : enumeration R u v) + : forall n : nat, Rlt (fst (proj1_sig (tearing_sequences u v en n))) + (proj1_sig (torn_number u v en)). +Proof. + intros. destruct (torn_number u v en) as [torn i]. simpl. + destruct (Rlt_le_dec (fst (proj1_sig (tearing_sequences u v en n))) torn). + assumption. exfalso. + destruct i. (* Apply the first sequence once to make the inequality strict *) + assert (Rlt torn (fst (proj1_sig (tearing_sequences u v en (S n))))). + { apply (Rle_lt_trans torn (fst (proj1_sig (tearing_sequences u v en n)))). + assumption. apply tearing_sequences_inc_dec. } + clear r. specialize (H (fst (proj1_sig (tearing_sequences u v en (S n))))). + assert (tearing_elem_fst u v en (fst (proj1_sig (tearing_sequences u v en (S n))))). + { exists (S n). reflexivity. } + specialize (H H2). assert (Rlt torn torn). + { apply (Rlt_le_trans torn (fst (proj1_sig (tearing_sequences u v en (S n))))); + assumption. } + apply Rlt_irrefl in H3. contradiction. +Qed. + +(* The torn number is between both tearing sequences, so it could have been chosen + at each step. *) +Lemma torn_number_below_second_sequence (u : nat -> R) (v : R -> nat) + (en : enumeration R u v) : + forall n : nat, Rlt (proj1_sig (torn_number u v en)) + (snd (proj1_sig (tearing_sequences u v en n))). +Proof. + intros. destruct (torn_number u v en) as [torn i]. simpl. + destruct (Rlt_le_dec torn (snd (proj1_sig (tearing_sequences u v en n)))) + as [l|h]. + - assumption. + - exfalso. (* Apply the second sequence once to make the inequality strict *) + assert (Rlt (snd (proj1_sig (tearing_sequences u v en (S n)))) torn). + { apply (Rlt_le_trans (snd (proj1_sig (tearing_sequences u v en (S n)))) + (snd (proj1_sig (tearing_sequences u v en n))) torn). + apply (tearing_sequences_inc_dec u v en n). assumption. } + clear h. (* Then prove snd (tearing_sequences u v (S n)) is an upper bound of the first + sequence. It will yield the contradiction torn < torn. *) + assert (is_upper_bound (tearing_elem_fst u v en) + (snd (proj1_sig (tearing_sequences u v en (S n))))). + { intros x H0. destruct H0. subst. left. apply tearing_sequences_ordered_forall. } + destruct i. apply H2 in H0. + pose proof (Rle_lt_trans torn (snd (proj1_sig (tearing_sequences u v en (S n)))) torn H0 H). + apply Rlt_irrefl in H3. contradiction. +Qed. + +(* Here is the contradiction : the torn number's index is above a sequence + that tends to infinity *) +Lemma limit_index_above_all_indices (u : nat -> R) (v : R -> nat) (en : enumeration R u v) : + forall n : nat, v (fst (proj1_sig (tearing_sequences u v en (S n)))) + < v (proj1_sig (torn_number u v en)). +Proof. + intros. simpl. destruct (tearing_sequences u v en n) as [[r r0] H] eqn:tear. + (* The torn number was not chosen, so its index is above *) + simpl. + pose proof (first_two_in_interval_works u v r r0 en H). + destruct (first_two_in_interval u v r r0) eqn:ft. simpl. + assert (proj1_sig (tearing_sequences u v en (S n)) = (r1, r2)). + { simpl. rewrite -> tear. assumption. } + apply H0. + - pose proof (torn_number_above_first_sequence u v en n). rewrite -> tear in H2. assumption. + - pose proof (torn_number_below_second_sequence u v en n). rewrite -> tear in H2. assumption. + - pose proof (torn_number_above_first_sequence u v en (S n)). rewrite -> H1 in H2. simpl in H2. + intro H5. subst. apply Rlt_irrefl in H2. contradiction. + - pose proof (torn_number_below_second_sequence u v en (S n)). rewrite -> H1 in H2. simpl in H2. + intro H5. subst. apply Rlt_irrefl in H2. contradiction. +Qed. + +(* The indices increase because each time the minimum index is chosen *) +Lemma first_indices_increasing (u : nat -> R) (v : R -> nat) (H : enumeration R u v) + : forall n : nat, n <> 0 -> v (fst (proj1_sig (tearing_sequences u v H n))) + < v (fst (proj1_sig (tearing_sequences u v H (S n)))). +Proof. + intros. destruct n. contradiction. + (* The n+1 and n+2 intervals are drawn from the n-th interval, which we note r r0 *) + destruct (tearing_sequences u v H n) as [[r r0] H1] eqn:In. simpl in H1. + (* Draw the n+1 interval *) + destruct (tearing_sequences u v H (S n)) as [[r1 r2] H2] eqn:ISn. simpl in H2. + (* Draw the n+2 interval *) + destruct (tearing_sequences u v H (S (S n))) as [[r3 r4] H3] eqn:ISSn. simpl in H3. + simpl. + + assert ((r1,r2) = first_two_in_interval u v r r0 H H1). + { simpl in ISn. rewrite -> In in ISn. inversion ISn. reflexivity. } + assert ((r3,r4) = first_two_in_interval u v r1 r2 H H2). + { pose proof (tearing_sequences_projsig u v H (S n)). rewrite -> ISn in H5. + rewrite -> ISSn in H5. apply H5. } + + pose proof (first_two_in_interval_works u v r r0 H H1) as firstChoiceWorks. + rewrite <- H4 in firstChoiceWorks. + destruct firstChoiceWorks as [fth [fth0 [fth1 [fth2 [fth3 fth4]]]]]. + + (* to prove the n+2 left bound in between r1 and r2 *) + pose proof (first_two_in_interval_works u v r1 r2 H H2). + rewrite <- H5 in H6. destruct H6 as [H6 [H7 [H8 [H9 [H10 H11]]]]]. apply fth4. + - apply (Rlt_trans r r1); assumption. + - apply (Rlt_trans r3 r2); assumption. + - intro abs. subst. apply Rlt_irrefl in H6. contradiction. + - intro abs. subst. apply Rlt_irrefl in H7. contradiction. +Qed. + +Theorem R_uncountable : forall u : nat -> R, ~Bijective u. +Proof. + intros u [v [H3 H4]]. pose proof (conj H4 H3) as H. + assert (forall n : nat, n + v (fst (proj1_sig (tearing_sequences u v H 1))) + <= v (fst (proj1_sig (tearing_sequences u v H (S n))))). + { induction n. simpl. apply le_refl. + apply (le_trans (S n + v (fst (proj1_sig (tearing_sequences u v H 1)))) + (S (v (fst (proj1_sig (tearing_sequences u v H (S n))))))). + simpl. apply le_n_S. assumption. apply first_indices_increasing. + intro H1. discriminate. } + assert (v (proj1_sig (torn_number u v H)) + v (fst (proj1_sig (tearing_sequences u v H 1))) + < v (proj1_sig (torn_number u v H))). + { pose proof (limit_index_above_all_indices u v H (v (proj1_sig (torn_number u v H)))). + specialize (H0 (v (proj1_sig (torn_number u v H)))). + apply (le_lt_trans (v (proj1_sig (torn_number u v H)) + + v (fst (proj1_sig (tearing_sequences u v H 1)))) + (v (fst (proj1_sig (tearing_sequences u v H (S (v (proj1_sig (torn_number u v H))))))))). + assumption. assumption. } + assert (forall n m : nat, ~(n + m < n)). + { induction n. intros. intro H2. inversion H2. intro m. intro H2. simpl in H2. + apply lt_pred in H2. simpl in H2. apply IHn in H2. contradiction. } + apply H2 in H1. contradiction. +Qed. diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 3977097e8c..61fe55770b 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -95,7 +95,7 @@ End Bounds. Hint Resolve Totally_ordered_definition Upper_Bound_definition Lower_Bound_definition Lub_definition Glb_definition Bottom_definition Definition_of_Complete Definition_of_Complete - Definition_of_Conditionally_complete. + Definition_of_Conditionally_complete : core. Section Specific_orders. Variable U : Type. diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index bdeeb6a7c7..a0271a88a3 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -46,7 +46,7 @@ Section Approx. Defn_of_Approximant : Finite U X -> Included U X A -> Approximant A X. End Approx. -Hint Resolve Defn_of_Approximant. +Hint Resolve Defn_of_Approximant : core. Section Infinite_sets. Variable U : Type. diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index 88bcd6555c..50a7e401f8 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -38,43 +38,43 @@ Variable U : Type. Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) := Definition_of_Power_set : forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X. -Hint Resolve Definition_of_Power_set. +Hint Resolve Definition_of_Power_set : core. Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X. intro X; red. intros x H'; elim H'. Qed. -Hint Resolve Empty_set_minimal. +Hint Resolve Empty_set_minimal : core. Theorem Power_set_Inhabited : forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X). intro X. apply Inhabited_intro with (Empty_set U); auto with sets. Qed. -Hint Resolve Power_set_Inhabited. +Hint Resolve Power_set_Inhabited : core. Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U). auto 6 with sets. Qed. -Hint Resolve Inclusion_is_an_order. +Hint Resolve Inclusion_is_an_order : core. Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U). elim Inclusion_is_an_order; auto with sets. Qed. -Hint Resolve Inclusion_is_transitive. +Hint Resolve Inclusion_is_transitive : core. Definition Power_set_PO : Ensemble U -> PO (Ensemble U). intro A; try assumption. apply Definition_of_PO with (Power_set A) (Included U); auto with sets. Defined. -Hint Unfold Power_set_PO. +Hint Unfold Power_set_PO : core. Theorem Strict_Rel_is_Strict_Included : same_relation (Ensemble U) (Strict_Included U) (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))). auto with sets. Qed. -Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included. +Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included : core. Lemma Strict_inclusion_is_transitive_with_inclusion : forall x y z:Ensemble U, @@ -109,7 +109,7 @@ Theorem Empty_set_is_Bottom : forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U). intro A; apply Bottom_definition; simpl; auto with sets. Qed. -Hint Resolve Empty_set_is_Bottom. +Hint Resolve Empty_set_is_Bottom : core. Theorem Union_minimal : forall a b X:Ensemble U, @@ -117,7 +117,7 @@ Theorem Union_minimal : intros a b X H' H'0; red. intros x H'1; elim H'1; auto with sets. Qed. -Hint Resolve Union_minimal. +Hint Resolve Union_minimal : core. Theorem Intersection_maximal : forall a b X:Ensemble U, @@ -145,7 +145,7 @@ intros a b; red. intros x H'; elim H'; auto with sets. Qed. Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l - Intersection_decreases_r. + Intersection_decreases_r : core. Theorem Union_is_Lub : forall A a b:Ensemble U, diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index 296ec42add..d275487e15 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -52,7 +52,7 @@ intros x y z h; elim h; intros H'3 H'4; clear h. intro h; elim h; intros H'5 H'6; clear h. split; apply H'1 with y; auto 10 with sets. Qed. -Hint Resolve Equiv_from_preorder. +Hint Resolve Equiv_from_preorder : core. Theorem Equiv_from_order : forall (U:Type) (R:Relation U), @@ -60,21 +60,21 @@ Theorem Equiv_from_order : Proof. intros U R H'; elim H'; auto 10 with sets. Qed. -Hint Resolve Equiv_from_order. +Hint Resolve Equiv_from_order : core. Theorem contains_is_preorder : forall U:Type, Preorder (Relation U) (contains U). Proof. auto 10 with sets. Qed. -Hint Resolve contains_is_preorder. +Hint Resolve contains_is_preorder : core. Theorem same_relation_is_equivalence : forall U:Type, Equivalence (Relation U) (same_relation U). Proof. unfold same_relation at 1; auto 10 with sets. Qed. -Hint Resolve same_relation_is_equivalence. +Hint Resolve same_relation_is_equivalence : core. Theorem cong_reflexive_same_relation : forall (U:Type) (R R':Relation U), diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index 0c1f670d0e..18ea019526 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -38,7 +38,7 @@ Proof. intros U R x y H'; red. exists y; auto with sets. Qed. -Hint Resolve Rstar_imp_coherent. +Hint Resolve Rstar_imp_coherent : core. Theorem coherent_symmetric : forall (U:Type) (R:Relation U), Symmetric U (coherent U R). diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 7940bda1a7..0ff304ed6b 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -41,21 +41,21 @@ Definition Singleton (a:A) := end). Definition In (s:uniset) (a:A) : Prop := charac s a = true. -Hint Unfold In. +Hint Unfold In : core. (** uniset inclusion *) Definition incl (s1 s2:uniset) := forall a:A, leb (charac s1 a) (charac s2 a). -Hint Unfold incl. +Hint Unfold incl : core. (** uniset equality *) Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a. -Hint Unfold seq. +Hint Unfold seq : core. Lemma leb_refl : forall b:bool, leb b b. Proof. destruct b; simpl; auto. Qed. -Hint Resolve leb_refl. +Hint Resolve leb_refl : core. Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2. Proof. @@ -71,7 +71,7 @@ Lemma seq_refl : forall x:uniset, seq x x. Proof. destruct x; unfold seq; auto. Qed. -Hint Resolve seq_refl. +Hint Resolve seq_refl : core. Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z. Proof. @@ -94,21 +94,21 @@ Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). Proof. unfold seq; unfold union; simpl; auto. Qed. -Hint Resolve union_empty_left. +Hint Resolve union_empty_left : core. Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). Proof. unfold seq; unfold union; simpl. intros x a; rewrite (orb_b_false (charac x a)); auto. Qed. -Hint Resolve union_empty_right. +Hint Resolve union_empty_right : core. Lemma union_comm : forall x y:uniset, seq (union x y) (union y x). Proof. unfold seq; unfold charac; unfold union. destruct x; destruct y; auto with bool. Qed. -Hint Resolve union_comm. +Hint Resolve union_comm : core. Lemma union_ass : forall x y z:uniset, seq (union (union x y) z) (union x (union y z)). @@ -116,7 +116,7 @@ Proof. unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z; auto with bool. Qed. -Hint Resolve union_ass. +Hint Resolve union_ass : core. Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z). Proof. @@ -124,7 +124,7 @@ unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. -Hint Resolve seq_left. +Hint Resolve seq_left : core. Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y). Proof. @@ -132,7 +132,7 @@ unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. -Hint Resolve seq_right. +Hint Resolve seq_right : core. (** All the proofs that follow duplicate [Multiset_of_A] *) diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 2ef162be4e..6a22501afa 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -36,8 +36,8 @@ Section defs. Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z. Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y. - Hint Resolve leA_refl. - Hint Immediate eqA_dec leA_dec leA_antisym. + Hint Resolve leA_refl : core. + Hint Immediate eqA_dec leA_dec leA_antisym : core. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 7b99b3626f..f5bc9eee4e 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -31,7 +31,7 @@ Inductive Permutation : list A -> list A -> Prop := | perm_trans l l' l'' : Permutation l l' -> Permutation l' l'' -> Permutation l l''. -Local Hint Constructors Permutation. +Local Hint Constructors Permutation : core. (** Some facts about [Permutation] *) @@ -71,13 +71,13 @@ Qed. End Permutation. -Hint Resolve Permutation_refl perm_nil perm_skip. +Hint Resolve Permutation_refl perm_nil perm_skip : core. (* These hints do not reduce the size of the problem to solve and they must be used with care to avoid combinatoric explosions *) -Local Hint Resolve perm_swap perm_trans. -Local Hint Resolve Permutation_sym Permutation_trans. +Local Hint Resolve perm_swap perm_trans : core. +Local Hint Resolve Permutation_sym Permutation_trans : core. (* This provides reflexivity, symmetry and transitivity and rewriting on morphims to come *) @@ -156,7 +156,7 @@ Qed. Lemma Permutation_cons_append : forall (l : list A) x, Permutation (x :: l) (l ++ x :: nil). Proof. induction l; intros; auto. simpl. rewrite <- IHl; auto. Qed. -Local Hint Resolve Permutation_cons_append. +Local Hint Resolve Permutation_cons_append : core. Theorem Permutation_app_comm : forall (l l' : list A), Permutation (l ++ l') (l' ++ l). @@ -166,7 +166,7 @@ Proof. rewrite app_comm_cons, Permutation_cons_append. now rewrite <- app_assoc. Qed. -Local Hint Resolve Permutation_app_comm. +Local Hint Resolve Permutation_app_comm : core. Theorem Permutation_cons_app : forall (l l1 l2:list A) a, Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2). @@ -175,7 +175,7 @@ Proof. rewrite app_comm_cons, Permutation_cons_append. now rewrite <- app_assoc. Qed. -Local Hint Resolve Permutation_cons_app. +Local Hint Resolve Permutation_cons_app : core. Lemma Permutation_Add a l l' : Add a l l' -> Permutation (a::l) l'. Proof. @@ -188,7 +188,7 @@ Theorem Permutation_middle : forall (l1 l2:list A) a, Proof. auto. Qed. -Local Hint Resolve Permutation_middle. +Local Hint Resolve Permutation_middle : core. Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). Proof. diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 89e9c7f3e1..6782dd9ca3 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -137,8 +137,8 @@ Section defs. End defs. -Hint Constructors HdRel. -Hint Constructors Sorted. +Hint Constructors HdRel : core. +Hint Constructors Sorted : core. (* begin hide *) (* Compatibility with deprecated file Sorting.v *) diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index d1168694b2..b7c1eaa788 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -23,7 +23,7 @@ Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool). Register Ascii as plugins.syntax.Ascii. Declare Scope char_scope. -Declare ML Module "ascii_syntax_plugin". +Module Export AsciiSyntax. Declare ML Module "ascii_syntax_plugin". End AsciiSyntax. Delimit Scope char_scope with char. Bind Scope char_scope with ascii. diff --git a/theories/Strings/String.v b/theories/Strings/String.v index f6cc8c99ed..a09d518892 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -25,7 +25,7 @@ Inductive string : Set := | String : ascii -> string -> string. Declare Scope string_scope. -Declare ML Module "string_syntax_plugin". +Module Export StringSyntax. Declare ML Module "string_syntax_plugin". End StringSyntax. Delimit Scope string_scope with string. Bind Scope string_scope with string. Local Open Scope string_scope. diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 24333ad815..f82ca5fa3c 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -38,8 +38,8 @@ Module KeyDecidableType(D:DecidableType). Definition eqke (p p':key*elt) := eq (fst p) (fst p') /\ (snd p) = (snd p'). - Hint Unfold eqk eqke. - Hint Extern 2 (eqke ?a ?b) => split. + Hint Unfold eqk eqke : core. + Hint Extern 2 (eqke ?a ?b) => split : core. (* eqke is stricter than eqk *) @@ -70,8 +70,8 @@ Module KeyDecidableType(D:DecidableType). unfold eqke; intuition; [ eauto | congruence ]. Qed. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Immediate eqk_sym eqke_sym. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + Hint Immediate eqk_sym eqke_sym : core. Global Instance eqk_equiv : Equivalence eqk. Proof. split; eauto. Qed. @@ -84,7 +84,7 @@ Module KeyDecidableType(D:DecidableType). Proof. unfold eqke; induction 1; intuition. Qed. - Hint Resolve InA_eqke_eqk. + Hint Resolve InA_eqke_eqk : core. Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. @@ -94,7 +94,7 @@ Module KeyDecidableType(D:DecidableType). Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. - Hint Unfold MapsTo In. + Hint Unfold MapsTo In : core. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) @@ -140,13 +140,13 @@ Module KeyDecidableType(D:DecidableType). End Elt. - Hint Unfold eqk eqke. - Hint Extern 2 (eqke ?a ?b) => split. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Immediate eqk_sym eqke_sym. - Hint Resolve InA_eqke_eqk. - Hint Unfold MapsTo In. - Hint Resolve In_inv_2 In_inv_3. + Hint Unfold eqk eqke : core. + Hint Extern 2 (eqke ?a ?b) => split : core. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + Hint Immediate eqk_sym eqke_sym : core. + Hint Resolve InA_eqke_eqk : core. + Hint Unfold MapsTo In : core. + Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 5f60a979c6..4143dba547 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -53,8 +53,8 @@ Module Type IsEqOrig (Import E:Eq'). Axiom eq_refl : forall x : t, x==x. Axiom eq_sym : forall x y : t, x==y -> y==x. Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z. - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans. + Hint Immediate eq_sym : core. + Hint Resolve eq_refl eq_trans : core. End IsEqOrig. (** * Types with decidable equality *) diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index 7b6ee2eaca..c738b57f44 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -22,7 +22,7 @@ Module KeyDecidableType(D:DecidableType). Definition eqk {elt} : relation (key*elt) := D.eq @@1. Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq. - Hint Unfold eqk eqke. + Hint Unfold eqk eqke : core. (** eqk, eqke are equalities *) @@ -60,7 +60,7 @@ Module KeyDecidableType(D:DecidableType). Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'. Proof. trivial. Qed. - Hint Resolve eqke_1 eqke_2 eqk_1. + Hint Resolve eqke_1 eqke_2 eqk_1 : core. (* Additional facts *) @@ -69,7 +69,7 @@ Module KeyDecidableType(D:DecidableType). Proof. induction 1; firstorder. Qed. - Hint Resolve InA_eqke_eqk. + Hint Resolve InA_eqke_eqk : core. Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) : InA eqk p m -> exists q, eqk p q /\ InA eqke q m. @@ -86,7 +86,7 @@ Module KeyDecidableType(D:DecidableType). Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e). Definition In {elt} k m := exists e:elt, MapsTo k e m. - Hint Unfold MapsTo In. + Hint Unfold MapsTo In : core. (* Alternative formulations for [In k l] *) @@ -167,9 +167,9 @@ Module KeyDecidableType(D:DecidableType). eauto with *. Qed. - Hint Extern 2 (eqke ?a ?b) => split. - Hint Resolve InA_eqke_eqk. - Hint Resolve In_inv_2 In_inv_3. + Hint Extern 2 (eqke ?a ?b) => split : core. + Hint Resolve InA_eqke_eqk : core. + Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index f6fc247d5a..d000b75bf4 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -42,8 +42,8 @@ Module Type MiniOrderedType. Parameter compare : forall x y : t, Compare lt eq x y. - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. + Hint Immediate eq_sym : core. + Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : core. End MiniOrderedType. @@ -143,9 +143,9 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. - Hint Resolve gt_not_eq eq_not_lt. - Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq. - Hint Resolve eq_not_gt lt_antirefl lt_not_gt. + Hint Resolve gt_not_eq eq_not_lt : core. + Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : core. + Hint Resolve eq_not_gt lt_antirefl lt_not_gt : core. Lemma elim_compare_eq : forall x y : t, @@ -247,8 +247,8 @@ Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. End ForNotations. -Hint Resolve ListIn_In Sort_NoDup Inf_lt. -Hint Immediate In_eq Inf_lt. +Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. +Hint Immediate In_eq Inf_lt : core. End OrderedTypeFacts. @@ -266,8 +266,8 @@ Module KeyOrderedType(O:OrderedType). eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition ltk (p p':key*elt) := lt (fst p) (fst p'). - Hint Unfold eqk eqke ltk. - Hint Extern 2 (eqke ?a ?b) => split. + Hint Unfold eqk eqke ltk : core. + Hint Extern 2 (eqke ?a ?b) => split : core. (* eqke is stricter than eqk *) @@ -283,7 +283,7 @@ Module KeyOrderedType(O:OrderedType). Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. Proof. auto. Qed. - Hint Immediate ltk_right_r ltk_right_l. + Hint Immediate ltk_right_r ltk_right_l : core. (* eqk, eqke are equalities, ltk is a strict order *) @@ -319,9 +319,9 @@ Module KeyOrderedType(O:OrderedType). exact (lt_not_eq H H1). Qed. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : core. + Hint Immediate eqk_sym eqke_sym : core. Global Instance eqk_equiv : Equivalence eqk. Proof. constructor; eauto. Qed. @@ -359,22 +359,22 @@ Module KeyOrderedType(O:OrderedType). intros (k,e) (k',e') (k'',e''). unfold ltk, eqk; simpl; eauto. Qed. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. + Hint Resolve eqk_not_ltk : core. + Hint Immediate ltk_eqk eqk_ltk : core. Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. unfold eqke; induction 1; intuition. Qed. - Hint Resolve InA_eqke_eqk. + Hint Resolve InA_eqke_eqk : core. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. Notation Sort := (sort ltk). Notation Inf := (lelistA ltk). - Hint Unfold MapsTo In. + Hint Unfold MapsTo In : core. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) @@ -405,8 +405,8 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_ltA ltk_strorder). Qed. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. + Hint Immediate Inf_eq : core. + Hint Resolve Inf_lt : core. Lemma Sort_Inf_In : forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. @@ -469,19 +469,19 @@ Module KeyOrderedType(O:OrderedType). End Elt. - Hint Unfold eqk eqke ltk. - Hint Extern 2 (eqke ?a ?b) => split. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. - Hint Resolve InA_eqke_eqk. - Hint Unfold MapsTo In. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. - Hint Resolve Sort_Inf_NotIn. - Hint Resolve In_inv_2 In_inv_3. + Hint Unfold eqk eqke ltk : core. + Hint Extern 2 (eqke ?a ?b) => split : core. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : core. + Hint Immediate eqk_sym eqke_sym : core. + Hint Resolve eqk_not_ltk : core. + Hint Immediate ltk_eqk eqk_ltk : core. + Hint Resolve InA_eqke_eqk : core. + Hint Unfold MapsTo In : core. + Hint Immediate Inf_eq : core. + Hint Resolve Inf_lt : core. + Hint Resolve Sort_Inf_NotIn : core. + Hint Resolve In_inv_2 In_inv_3 : core. End KeyOrderedType. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index 42756ad339..310a22a0a4 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -181,7 +181,7 @@ Module OTF_to_TotalOrder (O:OrderedTypeFull) <: TotalOrder we coerce [bool] into [Prop]. *) Local Coercion is_true : bool >-> Sortclass. -Hint Unfold is_true. +Hint Unfold is_true : core. Module Type HasLeb (Import T:Typ). Parameter Inline leb : t -> t -> bool. diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v index abdb9eff05..fef9b14a9e 100644 --- a/theories/Structures/OrdersLists.v +++ b/theories/Structures/OrdersLists.v @@ -50,8 +50,8 @@ Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed. Lemma Sort_NoDup : forall l, Sort l -> NoDup l. Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed. -Hint Resolve ListIn_In Sort_NoDup Inf_lt. -Hint Immediate In_eq Inf_lt. +Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. +Hint Immediate In_eq Inf_lt : core. End OrderedTypeLists. @@ -66,7 +66,7 @@ Module KeyOrderedType(O:OrderedType). Definition ltk {elt} : relation (key*elt) := O.lt @@1. - Hint Unfold ltk. + Hint Unfold ltk : core. (* ltk is a strict order *) @@ -109,8 +109,8 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l. Proof. apply InfA_ltA; auto with *. Qed. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. + Hint Immediate Inf_eq : core. + Hint Resolve Inf_lt : core. Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p. Proof. apply SortA_InfA_InA; auto with *. Qed. @@ -148,10 +148,10 @@ Module KeyOrderedType(O:OrderedType). End Elt. - Hint Resolve ltk_not_eqk ltk_not_eqke. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. - Hint Resolve Sort_Inf_NotIn. + Hint Resolve ltk_not_eqk ltk_not_eqke : core. + Hint Immediate Inf_eq : core. + Hint Resolve Inf_lt : core. + Hint Resolve Sort_Inf_NotIn : core. End KeyOrderedType. diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 4a2bddf35c..7f96aa6b87 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -269,28 +269,28 @@ Section SCANNING. Inductive Forall {A} (P: A -> Prop): forall {n} (v: t A n), Prop := |Forall_nil: Forall P [] |Forall_cons {n} x (v: t A n): P x -> Forall P v -> Forall P (x::v). -Hint Constructors Forall. +Hint Constructors Forall : core. Inductive Exists {A} (P:A->Prop): forall {n}, t A n -> Prop := |Exists_cons_hd {m} x (v: t A m): P x -> Exists P (x::v) |Exists_cons_tl {m} x (v: t A m): Exists P v -> Exists P (x::v). -Hint Constructors Exists. +Hint Constructors Exists : core. Inductive In {A} (a:A): forall {n}, t A n -> Prop := |In_cons_hd {m} (v: t A m): In a (a::v) |In_cons_tl {m} x (v: t A m): In a v -> In a (x::v). -Hint Constructors In. +Hint Constructors In : core. Inductive Forall2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Forall2_nil: Forall2 P [] [] |Forall2_cons {m} x1 x2 (v1:t A m) v2: P x1 x2 -> Forall2 P v1 v2 -> Forall2 P (x1::v1) (x2::v2). -Hint Constructors Forall2. +Hint Constructors Forall2 : core. Inductive Exists2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Exists2_cons_hd {m} x1 x2 (v1: t A m) (v2: t B m): P x1 x2 -> Exists2 P (x1::v1) (x2::v2) |Exists2_cons_tl {m} x1 x2 (v1:t A m) v2: Exists2 P v1 v2 -> Exists2 P (x1::v1) (x2::v2). -Hint Constructors Exists2. +Hint Constructors Exists2 : core. End SCANNING. diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index ff233ef9c6..18c4bedd9a 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -22,7 +22,7 @@ Section WfInclusion. apply Acc_intro; auto with sets. Qed. - Hint Resolve Acc_incl. + Hint Resolve Acc_incl : core. Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1. Proof. diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index 59068623ae..0d56d88869 100644 --- a/theories/Wellfounded/Transitive_Closure.v +++ b/theories/Wellfounded/Transitive_Closure.v @@ -31,7 +31,7 @@ Section Wf_Transitive_Closure. apply Acc_inv with y; auto with sets. Defined. - Hint Resolve Acc_clos_trans. + Hint Resolve Acc_clos_trans : core. Lemma Acc_inv_trans : forall x y:A, trans_clos y x -> Acc R x -> Acc R y. Proof. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 74614e114a..c278cada61 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -73,7 +73,7 @@ Proof. intros; unfold Remainder, Remainder_alt; omega with *. Qed. -Hint Unfold Remainder. +Hint Unfold Remainder : core. (** Now comes the fully general result about Euclidean division. *) diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v index 24412e9431..b8c7319939 100644 --- a/theories/ZArith/Zlogarithm.v +++ b/theories/ZArith/Zlogarithm.v @@ -47,7 +47,7 @@ Section Log_pos. (* Log of positive integers *) | xI n => Z.succ (Z.succ (log_inf n)) (* 2n+1 *) end. - Hint Unfold log_inf log_sup. + Hint Unfold log_inf log_sup : core. Lemma Psize_log_inf : forall p, Zpos (Pos.size p) = Z.succ (log_inf p). Proof. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index e3fa0c24fe..b673225e40 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -20,7 +20,6 @@ include @CONF_FILE@ VFILES := $(COQMF_VFILES) MLIFILES := $(COQMF_MLIFILES) MLFILES := $(COQMF_MLFILES) -ML4FILES := $(COQMF_ML4FILES) MLGFILES := $(COQMF_MLGFILES) MLPACKFILES := $(COQMF_MLPACKFILES) MLLIBFILES := $(COQMF_MLLIBFILES) @@ -37,10 +36,6 @@ LOCAL := $(COQMF_LOCAL) COQLIB := $(COQMF_COQLIB) DOCDIR := $(COQMF_DOCDIR) OCAMLFIND := $(COQMF_OCAMLFIND) -CAMLP5O := $(COQMF_CAMLP5O) -CAMLP5BIN := $(COQMF_CAMLP5BIN) -CAMLP5LIB := $(COQMF_CAMLP5LIB) -CAMLP5OPTIONS := $(COQMF_CAMLP5OPTIONS) CAMLFLAGS := $(COQMF_CAMLFLAGS) HASNATDYNLINK := $(COQMF_HASNATDYNLINK) @@ -99,7 +94,7 @@ BEFORE ?= AFTER ?= # FIXME this should be generated by Coq (modules already linked by Coq) -CAMLDONTLINK=camlp5.gramlib,unix,str +CAMLDONTLINK=unix,str # OCaml binaries CAMLC ?= "$(OCAMLFIND)" ocamlc -c @@ -192,22 +187,11 @@ COQMAKEFILE_VERSION:=@COQ_VERSION@ COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)$(d)") -CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP5LIB) +CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) # ocamldoc fails with unknown argument otherwise CAMLDOCFLAGS=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) -# FIXME This should be generated by Coq -GRAMMARS:=grammar.cma -CAMLP5EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo - -CAMLLIB:=$(shell "$(OCAMLFIND)" printconf stdlib 2> /dev/null) -ifeq (,$(CAMLLIB)) -PP=$(error "Cannot find the 'ocamlfind' binary used to build Coq ($(OCAMLFIND)). Pre-compiled binary packages of Coq do not support compiling plugins this way. Please download the sources of Coq and run the Windows build script.") -else -PP:=-pp '$(CAMLP5O) -I $(CAMLLIB) -I "$(COQLIB)/grammar" $(CAMLP5EXTEND) $(GRAMMARS) $(CAMLP5OPTIONS) -impl' -endif - ifneq (,$(TIMING)) TIMING_ARG=-time ifeq (after,$(TIMING)) @@ -719,6 +703,9 @@ endif redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) +GENMLFILES:=$(MLGFILES:.mlg=.ml) $(ML4FILES:.ml4=.ml) +$(addsuffix .d,$(ALLSRCFILES)): $(GENMLFILES) + $(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli $(SHOW)'CAMLDEP $<' $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) @@ -771,10 +758,6 @@ printenv:: @echo 'COQLIB = $(COQLIB)' @echo 'DOCDIR = $(DOCDIR)' @echo 'OCAMLFIND = $(OCAMLFIND)' - @echo 'CAMLP5O = $(CAMLP5O)' - @echo 'CAMLP5BIN = $(CAMLP5BIN)' - @echo 'CAMLP5LIB = $(CAMLP5LIB)' - @echo 'CAMLP5OPTIONS = $(CAMLP5OPTIONS)' @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index ca5a232edb..8560bac786 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -396,8 +396,9 @@ let _ = | "-destination-of" :: tgt :: rest -> Some tgt, rest | _ -> None, args in - let project = - try cmdline_args_to_project ~curdir:Filename.current_dir_name args + let project = + let warning_fn x = Format.eprintf "%s@\n%!" x in + try cmdline_args_to_project ~warning_fn ~curdir:Filename.current_dir_name args with Parsing_error s -> prerr_endline s; usage_coq_makefile () in if only_destination <> None then begin diff --git a/tools/coqc.ml b/tools/coqc.ml index ad845470ec..ae841212a7 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -109,7 +109,7 @@ let parse_args () = | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir"|"-color" |"-load-vernac-source"|"-l"|"-load-vernac-object" |"-load-ml-source"|"-require"|"-load-ml-object" - |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top" + |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top"|"-topfile" |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" |"-o"|"-profile-ltac-cutoff"|"-mangle-names"|"-bytecode-compiler"|"-native-compiler" as o) :: rem -> diff --git a/tools/coqdep.ml b/tools/coqdep.ml index ba88069be9..226a19678f 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -473,7 +473,8 @@ let add_r_include path l = add_rec_dir_import add_known path (split_period l) let treat_coqproject f = let open CoqProject_file in let iter_sourced f = List.iter (fun {thing} -> f thing) in - let project = read_project_file f in + let warning_fn x = coqdep_warning "%s" x in + let project = read_project_file ~warning_fn f in iter_sourced (fun { path } -> add_caml_dir path) project.ml_includes; iter_sourced (fun ({ path }, l) -> add_q_include path l) project.q_includes; iter_sourced (fun ({ path }, l) -> add_r_include path l) project.r_includes; diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 6478465af7..15411d55d0 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -49,7 +49,7 @@ type coq_cmdopts = { batch_mode : bool; compilation_mode : compilation_mode; - toplevel_name : Names.DirPath.t; + toplevel_name : Stm.interactive_top; compile_list: (string * bool) list; (* bool is verbosity *) compilation_output_name : string option; @@ -88,6 +88,8 @@ type coq_cmdopts = { } +let default_toplevel = Names.(DirPath.make [Id.of_string "Top"]) + let init_args = { load_init = true; @@ -101,7 +103,7 @@ let init_args = { batch_mode = false; compilation_mode = BuildVo; - toplevel_name = Names.(DirPath.make [Id.of_string "Top"]); + toplevel_name = Stm.TopLogical default_toplevel; compile_list = []; compilation_output_name = None; @@ -487,7 +489,10 @@ let parse_args arglist : coq_cmdopts * string list = let topname = Libnames.dirpath_of_string (next ()) in if Names.DirPath.is_empty topname then CErrors.user_err Pp.(str "Need a non empty toplevel module name"); - { oval with toplevel_name = topname } + { oval with toplevel_name = Stm.TopLogical topname } + + |"-topfile" -> + { oval with toplevel_name = Stm.TopPhysical (next()) } |"-main-channel" -> Spawned.main_channel := get_host_port opt (next()); oval diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index accb6c2beb..b709788dde 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -11,6 +11,8 @@ type compilation_mode = BuildVo | BuildVio | Vio2Vo type color = [`ON | `AUTO | `OFF] +val default_toplevel : Names.DirPath.t + type coq_cmdopts = { load_init : bool; @@ -26,7 +28,7 @@ type coq_cmdopts = { batch_mode : bool; compilation_mode : compilation_mode; - toplevel_name : Names.DirPath.t; + toplevel_name : Stm.interactive_top; compile_list: (string * bool) list; (* bool is verbosity *) compilation_output_name : string option; diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 7185e7a39d..5cf2157044 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -246,7 +246,7 @@ let parse_to_dot = | Tok.EOI -> raise Stm.End_of_input | _ -> dot st in - Pcoq.Gram.Entry.of_parser "Coqtoplevel.dot" dot + Pcoq.Entry.of_parser "Coqtoplevel.dot" dot (* If an error occurred while parsing, we try to read the input until a dot token is encountered. @@ -256,7 +256,7 @@ let rec discard_to_dot () = try Pcoq.Entry.parse parse_to_dot top_buffer.tokens with - | Plexing.Error _ | CLexer.Error.E _ -> discard_to_dot () + | Gramlib.Plexing.Error _ | CLexer.Error.E _ -> discard_to_dot () | Stm.End_of_input -> raise Stm.End_of_input | e when CErrors.noncritical e -> () diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index e486589f7e..66af7f7cdf 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -93,7 +93,7 @@ let load_init_vernaculars opts ~state = (* Startup LoadPath and Modules *) (******************************************************************************) (* prelude_data == From Coq Require Export Prelude. *) -let prelude_data = "Prelude", Some "Coq", Some true +let prelude_data = "Prelude", Some "Coq", Some false let require_libs opts = if opts.load_init then prelude_data :: opts.vo_requires else opts.vo_requires diff --git a/toplevel/dune b/toplevel/dune index c2f9cd662e..f51e50aaa3 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -3,7 +3,6 @@ (public_name coq.toplevel) (synopsis "Coq's Interactive Shell [terminal-based]") (wrapped false) - (flags :standard -open Gramlib) (libraries num coq.stm)) ; Coqlevel provides the `Num` library to plugins, we could also use ; -linkall in the plugins file, to be discussed. diff --git a/toplevel/usage.ml b/toplevel/usage.ml index c2437836f3..c43538017c 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -32,6 +32,7 @@ let print_usage_channel co command = \n -R dir coqdir recursively map physical dir to logical coqdir\ \n -Q dir coqdir map physical dir to logical coqdir\ \n -top coqdir set the toplevel name to be coqdir instead of Top\ +\n -topfile f set the toplevel name as though compiling f\ \n -coqlib dir set the coq standard library directory\ \n -exclude-dir f exclude subdirectories named f for option -R\ \n\ diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 6beac2032d..3ca2a4ad6b 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -294,7 +294,6 @@ let traverse current t = let type_of_constant cb = cb.Declarations.const_type let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = - let (idts, knst) = st in (** Only keep the transitive dependencies *) let (_, graph, ax2ty) = traverse (label_of gr) t in let fold obj _ accu = match obj with @@ -316,7 +315,7 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let t = type_of_constant cb in let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (Constant kn,l)) t accu - else if add_opaque && (Declareops.is_opaque cb || not (Cpred.mem kn knst)) then + else if add_opaque && (Declareops.is_opaque cb || not (TransparentState.is_transparent_constant st kn)) then let t = type_of_constant cb in ContextObjectMap.add (Opaque kn) t accu else if add_transparent then diff --git a/vernac/assumptions.mli b/vernac/assumptions.mli index aead345d8c..536185f4aa 100644 --- a/vernac/assumptions.mli +++ b/vernac/assumptions.mli @@ -28,5 +28,5 @@ val traverse : on which a term relies (together with their type). The above warning of {!traverse} also applies. *) val assumptions : - ?add_opaque:bool -> ?add_transparent:bool -> transparent_state -> + ?add_opaque:bool -> ?add_transparent:bool -> TransparentState.t -> GlobRef.t -> constr -> types ContextObjectMap.t diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 88638b295b..bc0b0310b3 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -9,7 +9,14 @@ (************************************************************************) open CErrors -open Vernacexpr + +(** The type of parsing attribute data *) +type vernac_flags = vernac_flag list +and vernac_flag = string * vernac_flag_value +and vernac_flag_value = + | VernacFlagEmpty + | VernacFlagLeaf of string + | VernacFlagList of vernac_flags let unsupported_attributes = function | [] -> () diff --git a/vernac/attributes.mli b/vernac/attributes.mli index c81082d5ad..c2dde4cbcc 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -8,7 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Vernacexpr +(** The type of parsing attribute data *) +type vernac_flags = vernac_flag list +and vernac_flag = string * vernac_flag_value +and vernac_flag_value = + | VernacFlagEmpty + | VernacFlagLeaf of string + | VernacFlagList of vernac_flags type +'a attribute (** The type of attributes. When parsing attributes if an ['a @@ -80,7 +86,7 @@ val parse_with_extra : 'a attribute -> vernac_flags -> vernac_flags * 'a (** * Defining attributes. *) -type 'a key_parser = 'a option -> Vernacexpr.vernac_flag_value -> 'a +type 'a key_parser = 'a option -> vernac_flag_value -> 'a (** A parser for some key in an attribute. It is given a nonempty ['a option] when the attribute is multiply set for some command. diff --git a/vernac/classes.ml b/vernac/classes.ml index f4b0015851..95e46b252b 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -146,7 +146,7 @@ let do_abstract_instance env sigma ?hook ~global ~poly k u ctx ctx' pri decl imp Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); instance_hook k pri global imps ?hook (ConstRef cst); id -let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl len term termtype = +let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl ids term termtype = let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if program_mode then let hook _ _ vis gr = @@ -188,11 +188,10 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id ] in ignore (Pfedit.by init_refine) - else if Flags.is_auto_intros () then - ignore (Pfedit.by (Tacticals.New.tclDO len Tactics.intro)); + else ignore (Pfedit.by (Tactics.auto_intros_tac ids)); (match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) () -let do_transparent_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props len = +let do_transparent_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode cty k u ctx ctx' pri decl imps subst id props = let props = match props with | Some (true, { CAst.v = CRecord fs }) -> @@ -275,7 +274,7 @@ let do_transparent_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~pro if not (Evd.has_undefined sigma) && not (Option.is_empty term) then declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype else if program_mode || refine || Option.is_empty term then - declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl len term termtype + declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype else CErrors.user_err Pp.(str "Unsolved obligations remaining."); id @@ -341,7 +340,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) ~ do_abstract_instance env sigma ?hook ~global ~poly k u ctx ctx' pri decl imps subst id else do_transparent_instance env env' sigma ?hook ~refine ~tac ~global ~poly ~program_mode - cty k u ctx ctx' pri decl imps subst id props len + cty k u ctx ctx' pri decl imps subst id props let named_of_rel_context l = let open Vars in @@ -370,25 +369,24 @@ let context poly l = user_err Pp.(str "Anonymous variables not allowed in contexts.") in let univs = - let uctx = Evd.universe_context_set sigma in match ctx with | [] -> assert false - | [_] -> - if poly - then Polymorphic_const_entry (Univ.ContextSet.to_context uctx) - else Monomorphic_const_entry uctx + | [_] -> Evd.const_univ_entry ~poly sigma | _::_::_ -> + (** TODO: explain this little belly dance *) if Lib.sections_are_opened () then begin + let uctx = Evd.universe_context_set sigma in Declare.declare_universe_context poly uctx; - if poly then Polymorphic_const_entry Univ.UContext.empty + if poly then Polymorphic_const_entry ([||], Univ.UContext.empty) else Monomorphic_const_entry Univ.ContextSet.empty end - else if poly - then Polymorphic_const_entry (Univ.ContextSet.to_context uctx) + else if poly then + Evd.const_univ_entry ~poly sigma else begin + let uctx = Evd.universe_context_set sigma in Declare.declare_universe_context poly uctx; Monomorphic_const_entry Univ.ContextSet.empty end diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index e990f0cd15..4cdc60216e 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -29,7 +29,7 @@ let axiom_into_instance = ref false let _ = let open Goptions in declare_bool_option - { optdepr = false; + { optdepr = true; optname = "automatically declare axioms whose type is a typeclass as instances"; optkey = ["Typeclasses";"Axioms";"Are";"Instances"]; optread = (fun _ -> !axiom_into_instance); @@ -47,7 +47,7 @@ match local with | Discharge when Lib.sections_are_opened () -> let ctx = match ctx with | Monomorphic_const_entry ctx -> ctx - | Polymorphic_const_entry ctx -> Univ.ContextSet.of_context ctx + | Polymorphic_const_entry (_, ctx) -> Univ.ContextSet.of_context ctx in let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in let _ = declare_variable ident decl in @@ -79,7 +79,7 @@ match local with let () = if do_instance then Typeclasses.declare_instance None false gr in let () = if is_coe then Class.try_add_new_coercion gr ~local p in let inst = match ctx with - | Polymorphic_const_entry ctx -> Univ.UContext.instance ctx + | Polymorphic_const_entry (_, ctx) -> Univ.UContext.instance ctx | Monomorphic_const_entry _ -> Univ.Instance.empty in (gr,inst,Lib.is_modtype_strict ()) @@ -156,7 +156,7 @@ let do_assumptions kind nl l = ((sigma,env,ienv),((is_coe,idl),t,imps))) (sigma,env,empty_internalization_env) l in - let sigma = solve_remaining_evars all_and_fail_flags env sigma (Evd.from_env env) in + let sigma = solve_remaining_evars all_and_fail_flags env sigma in (* The universe constraints come from the whole telescope. *) let sigma = Evd.minimize_universes sigma in let nf_evar c = EConstr.to_constr sigma c in diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 472411ac3a..9c80f1d2f5 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -87,8 +87,7 @@ let interp_definition pl bl poly red_option c ctypopt = let check_definition (ce, evd, _, imps) = let env = Global.env () in - let empty_sigma = Evd.from_env env in - check_evars_are_solved env evd empty_sigma; + check_evars_are_solved env evd; ce let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook = diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 138696e3a7..274c99107f 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -99,7 +99,7 @@ let check_mutuality env evd isfix fixl = let names = List.map fst fixl in let preorder = List.map (fun (id,def) -> - (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env evd id' (EConstr.of_constr def)) names)) + (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env evd id' def) names)) fixl in let po = partial_order Id.equal preorder in match List.filter (function (_,Inr _) -> true | _ -> false) po with @@ -227,25 +227,28 @@ let interp_recursive ~program_mode ~cofix fixl notations = (* Instantiate evars and check all are resolved *) let sigma = solve_unif_constraints_with_heuristics env_rec sigma in let sigma = Evd.minimize_universes sigma in - (* XXX: We still have evars here in Program *) - let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr ~abort_on_undefined_evars:false sigma) c) fixdefs in - let fixtypes = List.map EConstr.(to_constr sigma) fixtypes in let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in (* Build the fix declaration block *) (env,rec_sign,decl,sigma), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots let check_recursive isfix env evd (fixnames,fixdefs,_) = - check_evars_are_solved env evd (Evd.from_env env); if List.for_all Option.has_some fixdefs then begin let fixdefs = List.map Option.get fixdefs in check_mutuality env evd isfix (List.combine fixnames fixdefs) end +let ground_fixpoint env evd (fixnames,fixdefs,fixtypes) = + check_evars_are_solved env evd; + let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr evd) c) fixdefs in + let fixtypes = List.map EConstr.(to_constr evd) fixtypes in + Evd.evar_universe_context evd, (fixnames,fixdefs,fixtypes) + let interp_fixpoint ~cofix l ntns = let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l ntns in check_recursive true env evd fix; - (fix,pl,Evd.evar_universe_context evd,info) + let uctx,fix = ground_fixpoint env evd fix in + (fix,pl,uctx,info) let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = if List.exists Option.is_empty fixdefs then diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index b1a9c8a5a3..f4569ed3e2 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -51,7 +51,7 @@ val interp_recursive : (* env / signature / univs / evar_map *) (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) * (* names / defs / types *) - (Id.t list * Constr.constr option list * Constr.types list) * + (Id.t list * EConstr.constr option list * EConstr.types list) * (* ctx per mutual def / implicits / struct annotations *) (EConstr.rel_context * Impargs.manual_explicitation list * int option) list diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 5ff3032ec4..fbfa997555 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -402,7 +402,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let env_ar_params = EConstr.push_rel_context ctx_params env_ar in (* Try further to solve evars, and instantiate them *) - let sigma = solve_remaining_evars all_and_fail_flags env_params sigma (Evd.from_env env_params) in + let sigma = solve_remaining_evars all_and_fail_flags env_params sigma in (* Compute renewed arities *) let sigma = Evd.minimize_universes sigma in let nf = Evarutil.nf_evars_universes sigma in @@ -450,10 +450,10 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not in let univs = match uctx with - | Polymorphic_const_entry uctx -> + | Polymorphic_const_entry (nas, uctx) -> if cum then - Cumulative_ind_entry (Univ.CumulativityInfo.from_universe_context uctx) - else Polymorphic_ind_entry uctx + Cumulative_ind_entry (nas, Univ.CumulativityInfo.from_universe_context uctx) + else Polymorphic_ind_entry (nas, uctx) | Monomorphic_const_entry uctx -> Monomorphic_ind_entry uctx in @@ -535,11 +535,11 @@ let declare_mutual_inductive_with_eliminations mie pl impls = let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in let (_, kn), prim = declare_mind mie in let mind = Global.mind_of_delta_kn kn in + Declare.declare_univ_binders (IndRef (mind,0)) pl; List.iteri (fun i (indimpls, constrimpls) -> let ind = (mind,i) in let gr = IndRef ind in maybe_declare_manual_implicits false gr indimpls; - Declare.declare_univ_binders gr pl; List.iteri (fun j impls -> maybe_declare_manual_implicits false diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3d3d825bd0..ebedfb1e0d 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -1,3 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + open Pp open CErrors open Util @@ -204,7 +214,6 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = (** FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in - let () = UnivNames.register_universe_binders gr (Evd.universe_binders sigma) in if Impargs.is_implicit_args () || not (List.is_empty impls) then Impargs.declare_manual_implicits false gr [impls] in @@ -252,10 +261,10 @@ let do_program_recursive local poly fixkind fixl ntns = let collect_evars id def typ imps = (* Generalize by the recursive prototypes *) let def = - EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign) + EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) and typ = (* Worrying... *) - EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign) + EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = @@ -269,6 +278,9 @@ let do_program_recursive local poly fixkind fixl ntns = let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in let () = if not cofix then begin let possible_indexes = List.map ComFixpoint.compute_possible_guardness_evidences info in + (* XXX: are we allowed to have evars here? *) + let fixtypes = List.map (EConstr.to_constr ~abort_on_undefined_evars:false evd) fixtypes in + let fixdefs = List.map (EConstr.to_constr ~abort_on_undefined_evars:false evd) fixdefs in let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), Array.of_list fixtypes, Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 35fb18e292..2fe03a8ec5 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -43,9 +43,11 @@ let declare_definition ident (local, p, k) ce pl imps hook = | Discharge | Local | Global -> let local = get_locality ident ~kind:"definition" local in let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in - ConstRef kn in + let gr = ConstRef kn in + let () = Declare.declare_univ_binders gr pl in + gr + in let () = maybe_declare_manual_implicits false gr imps in - let () = Declare.declare_univ_binders gr pl in let () = definition_message ident in Lemmas.call_hook fix_exn hook local gr; gr diff --git a/vernac/dune b/vernac/dune index 4673251002..45b567d631 100644 --- a/vernac/dune +++ b/vernac/dune @@ -3,7 +3,6 @@ (synopsis "Coq's Vernacular Language") (public_name coq.vernac) (wrapped false) - (flags :standard -open Gramlib) (libraries tactics parsing)) (rule diff --git a/vernac/egramml.mli b/vernac/egramml.mli index a90ef97e7d..3689f60383 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -21,10 +21,10 @@ type 's grammar_prod_item = ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item val extend_vernac_command_grammar : - Vernacexpr.extend_name -> vernac_expr Pcoq.Entry.t option -> + extend_name -> vernac_expr Pcoq.Entry.t option -> vernac_expr grammar_prod_item list -> unit -val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_item list +val get_extend_vernac_rule : extend_name -> vernac_expr grammar_prod_item list val proj_symbol : ('a, 'b, 'c) Extend.ty_user_symbol -> ('a, 'b, 'c) Genarg.genarg_type diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index e6803443b3..befb4d7ccf 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -29,7 +29,7 @@ exception EvaluatedError of Pp.t * exn option let explain_exn_default = function (* Basic interaction exceptions *) | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Plexing.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") + | Gramlib.Plexing.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") | CLexer.Error.E err -> hov 0 (str (CLexer.Error.to_string err)) | Sys_error msg -> hov 0 (str "System error: " ++ guill msg) | Out_of_memory -> hov 0 (str "Out of memory.") diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 1d0a5ab0a3..e3f6a87541 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -30,6 +30,7 @@ open Pcoq.Prim open Pcoq.Constr open Pcoq.Module open Pvernac.Vernac_ +open Attributes let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ] let _ = List.iter CLexer.add_keyword vernac_kw @@ -473,7 +474,7 @@ END { let only_starredidentrefs = - Gram.Entry.of_parser "test_only_starredidentrefs" + Pcoq.Entry.of_parser "test_only_starredidentrefs" (fun strm -> let rec aux n = match Util.stream_nth n strm with @@ -989,8 +990,9 @@ GRAMMAR EXTEND Gram | IDENT "Scope"; s = IDENT -> { PrintScope s } | IDENT "Visibility"; s = OPT IDENT -> { PrintVisibility s } | IDENT "Implicit"; qid = smart_global -> { PrintImplicit qid } - | IDENT "Universes"; fopt = OPT ne_string -> { PrintUniverses (false, fopt) } - | IDENT "Sorted"; IDENT "Universes"; fopt = OPT ne_string -> { PrintUniverses (true, fopt) } + | b = [ IDENT "Sorted" -> { true } | -> { false } ]; IDENT "Universes"; + g = OPT printunivs_subgraph; fopt = OPT ne_string -> + { PrintUniverses (b, g, fopt) } | IDENT "Assumptions"; qid = smart_global -> { PrintAssumptions (false, false, qid) } | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> { PrintAssumptions (true, false, qid) } | IDENT "Transparent"; IDENT "Dependencies"; qid = smart_global -> { PrintAssumptions (false, true, qid) } @@ -1000,6 +1002,9 @@ GRAMMAR EXTEND Gram | IDENT "Registered" -> { PrintRegistered } ] ] ; + printunivs_subgraph: + [ [ IDENT "Subgraph"; "("; l = LIST0 reference; ")" -> { l } ] ] + ; class_rawexpr: [ [ IDENT "Funclass" -> { FunClass } | IDENT "Sortclass" -> { SortClass } diff --git a/vernac/himsg.ml b/vernac/himsg.ml index ba31f73030..6c7117b513 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -884,8 +884,6 @@ let explain_not_match_error = function let status b = if b then str"polymorphic" else str"monomorphic" in str "a " ++ status b ++ str" declaration was expected, but a " ++ status (not b) ++ str" declaration was found" - | IncompatibleInstances -> - str"polymorphic universe instances do not match" | IncompatibleUniverses incon -> str"the universe constraints are inconsistent: " ++ Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes incon @@ -894,11 +892,22 @@ let explain_not_match_error = function quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t1) ++ spc () ++ str "compared to " ++ spc () ++ quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t2) - | IncompatibleConstraints cst -> - str " the expected (polymorphic) constraints do not imply " ++ - let cst = Univ.UContext.constraints (Univ.AUContext.repr cst) in - (** FIXME: provide a proper naming for the bound variables *) - quote (Univ.pr_constraints (Termops.pr_evd_level Evd.empty) cst) + | IncompatibleConstraints { got; expect } -> + let open Univ in + let pr_auctx auctx = + let sigma = Evd.from_ctx + (UState.of_binders + (UnivNames.universe_binders_with_opt_names auctx None)) + in + let uctx = AUContext.repr auctx in + Printer.pr_universe_instance_constraints sigma + (UContext.instance uctx) + (UContext.constraints uctx) + in + str "incompatible polymorphic binders: got" ++ spc () ++ h 0 (pr_auctx got) ++ spc() ++ + str "but expected" ++ spc() ++ h 0 (pr_auctx expect) ++ + (if not (Int.equal (AUContext.size got) (AUContext.size expect)) then mt() else + fnl() ++ str "(incompatible constraints)") let explain_signature_mismatch l spec why = str "Signature components for label " ++ Label.print l ++ diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 8aa459729c..2443c5d12a 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -197,10 +197,11 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook = let () = if should_suggest then Proof_using.suggest_constant (Global.env ()) kn in - ConstRef kn + let gr = ConstRef kn in + Declare.declare_univ_binders gr (UState.universe_binders uctx); + gr in definition_message id; - Declare.declare_univ_binders r (UState.universe_binders uctx); call_hook (fun exn -> exn) hook locality r with e when CErrors.noncritical e -> let e = CErrors.push e in @@ -228,7 +229,7 @@ let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_, | Discharge -> let impl = false in (* copy values from Vernacentries *) let univs = match univs with - | Polymorphic_const_entry univs -> + | Polymorphic_const_entry (_, univs) -> (* What is going on here? *) Univ.ContextSet.of_context univs | Monomorphic_const_entry univs -> univs @@ -305,17 +306,18 @@ let universe_proof_terminator compute_guard hook = | Admitted (id,k,pe,ctx) -> admit (id,k,pe) (UState.universe_binders ctx) (hook (Some ctx)) (); Feedback.feedback Feedback.AddedAxiom - | Proved (opaque,idopt,proof) -> - let is_opaque, export_seff = match opaque with - | Transparent -> false, true - | Opaque -> true, false - in - let (id,(const,univs,persistence)) = Pfedit.cook_this_proof proof in - let const = {const with const_entry_opaque = is_opaque} in - let id = match idopt with - | None -> id - | Some { CAst.v = save_id } -> check_anonymity id save_id; save_id in - save ~export_seff id const univs compute_guard persistence (hook (Some univs)) + | Proved (opaque,idopt, { id; entries=[const]; persistence; universes } ) -> + let is_opaque, export_seff = match opaque with + | Transparent -> false, true + | Opaque -> true, false + in + let const = {const with const_entry_opaque = is_opaque} in + let id = match idopt with + | None -> id + | Some { CAst.v = save_id } -> check_anonymity id save_id; save_id in + save ~export_seff id const universes compute_guard persistence (hook (Some universes)) + | Proved (opaque,idopt, _ ) -> + CErrors.anomaly Pp.(str "[universe_proof_terminator] close_proof returned more than one proof term") end let standard_proof_terminator compute_guard hook = @@ -329,7 +331,7 @@ let initialize_named_context_for_proof () = let d = if variable_opacity id then NamedDecl.LocalAssum (id, NamedDecl.get_type d) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val -let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof id ?pl kind sigma ?terminator ?sign c ?(compute_guard=[]) hook = let terminator = match terminator with | None -> standard_proof_terminator compute_guard hook | Some terminator -> terminator compute_guard hook @@ -339,19 +341,21 @@ let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard= | Some sign -> sign | None -> initialize_named_context_for_proof () in - Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator + let goals = [ Global.env_of_context sign , c ] in + Proof_global.start_proof sigma id ?pl kind goals terminator -let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?(compute_guard=[]) hook = let terminator = match terminator with | None -> universe_proof_terminator compute_guard hook | Some terminator -> terminator compute_guard hook in - let sign = + let sign = match sign with | Some sign -> sign | None -> initialize_named_context_for_proof () in - Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator + let goals = [ Global.env_of_context sign , c ] in + Proof_global.start_proof sigma id ?pl kind goals terminator let rec_tac_initializer finite guard thms snl = if finite then @@ -368,28 +372,20 @@ let rec_tac_initializer finite guard thms snl = | _ -> assert false let start_proof_with_initialization kind sigma decl recguard thms snl hook = - let intro_tac (_, (_, (ids, _))) = - Tacticals.New.tclMAP (function - | Name id -> Tactics.intro_mustbe_force id - | Anonymous -> Tactics.intro) (List.rev ids) in + let intro_tac (_, (_, (ids, _))) = Tactics.auto_intros_tac ids in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> - let rec_tac = rec_tac_initializer finite guard thms snl in - Some (match init_tac with - | None -> - if Flags.is_auto_intros () then - Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms) - else - rec_tac + let rec_tac = rec_tac_initializer finite guard thms snl in + Some (match init_tac with + | None -> + Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms) | Some tacl -> - Tacticals.New.tclTHENS rec_tac - (if Flags.is_auto_intros () then - List.map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms - else - tacl)),guard + Tacticals.New.tclTHENS rec_tac + List.(map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms) + ),guard | None -> - let () = match thms with [_] -> () | _ -> assert false in - (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in + let () = match thms with [_] -> () | _ -> assert false in + Some (intro_tac (List.hd thms)), [] in match thms with | [] -> anomaly (Pp.str "No proof to start.") | (id,(t,(_,imps)))::other_thms -> @@ -410,7 +406,11 @@ let start_proof_with_initialization kind sigma decl recguard thms snl hook = List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook (fun exn -> exn) hook strength ref) thms_data in - start_proof_univs id ~pl:decl kind sigma t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + start_proof_univs id ~pl:decl kind sigma t (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard; + ignore (Proof_global.with_current_proof (fun _ p -> + match init_tac with + | None -> p,(true,[]) + | Some tac -> Proof.run_tactic Global.(env ()) tac p)) let start_proof_com ?inference_hook kind thms hook = let env0 = Global.env () in @@ -420,8 +420,8 @@ let start_proof_com ?inference_hook kind thms hook = let evd, (impls, ((env, ctx), imps)) = interp_context_evars env0 evd bl in let evd, (t', imps') = interp_type_evars_impls ~impls env evd t in let flags = all_and_fail_flags in - let flags = { flags with use_hook = inference_hook } in - let evd = solve_remaining_evars flags env evd Evd.empty in + let hook = inference_hook in + let evd = solve_remaining_evars ?hook flags env evd in let ids = List.map RelDecl.get_name ctx in check_name_freshness (pi1 kind) id; (* XXX: The nf_evar is critical !! *) diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 195fcbf4ca..246d8cbe6d 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -18,13 +18,13 @@ val call_hook : Future.fix_exn -> declaration_hook -> Decl_kinds.locality -> Glo val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> + ?compute_guard:Proof_global.lemma_possible_guards -> declaration_hook -> unit val start_proof_univs : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> (UState.t option -> declaration_hook) -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> + ?compute_guard:Proof_global.lemma_possible_guards -> (UState.t option -> declaration_hook) -> unit val start_proof_com : diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 2e5e11bb09..5ab877fae2 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -58,7 +58,7 @@ let pr_registered_grammar name = | None -> user_err Pp.(str "Unknown or unprintable grammar entry.") | Some entries -> let pr_one (Pcoq.AnyEntry e) = - str "Entry " ++ str (Pcoq.Gram.Entry.name e) ++ str " is" ++ fnl () ++ + str "Entry " ++ str (Pcoq.Entry.name e) ++ str " is" ++ fnl () ++ pr_entry e in prlist pr_one entries diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 97ed43c5f4..8baf391c70 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -667,7 +667,7 @@ let declare_obligation prg obl body ty uctx = if not opaque then add_hint (Locality.make_section_locality None) prg constant; definition_message obl.obl_name; let body = match uctx with - | Polymorphic_const_entry uctx -> + | Polymorphic_const_entry (_, uctx) -> Some (DefinedObl (constant, Univ.UContext.instance uctx)) | Monomorphic_const_entry _ -> Some (TermObl (it_mkLambda_or_LetIn_or_clean (mkApp (mkConst constant, args)) ctx)) @@ -826,26 +826,41 @@ let rec string_of_list sep f = function | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl (* Solve an obligation using tactics, return the corresponding proof term *) +let warn_solve_errored = CWarnings.create ~name:"solve_obligation_error" ~category:"tactics" (fun err -> + Pp.seq [str "Solve Obligations tactic returned error: "; err; fnl (); + str "This will become an error in the future"]) -let solve_by_tac name evi t poly ctx = +let solve_by_tac ?loc name evi t poly ctx = let id = name in (* spiwack: the status is dropped. *) - let (entry,_,ctx') = Pfedit.build_constant_by_tactic - id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps evi.evar_concl (Tacticals.New.tclCOMPLETE t) in - let env = Global.env () in - let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in - let body, () = Future.force entry.const_entry_body in - let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in - Inductiveops.control_only_guard env ctx' (EConstr.of_constr (fst body)); - (fst body), entry.const_entry_type, Evd.evar_universe_context ctx' + try + let (entry,_,ctx') = + Pfedit.build_constant_by_tactic + id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps evi.evar_concl t in + let env = Global.env () in + let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in + let body, () = Future.force entry.const_entry_body in + let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in + Inductiveops.control_only_guard env ctx' (EConstr.of_constr (fst body)); + Some (fst body, entry.const_entry_type, Evd.evar_universe_context ctx') + with + | Refiner.FailError (_, s) as exn -> + let _ = CErrors.push exn in + user_err ?loc ~hdr:"solve_obligation" (Lazy.force s) + (* If the proof is open we absorb the error and leave the obligation open *) + | Proof.OpenProof _ -> + None + | e when CErrors.noncritical e -> + let err = CErrors.print e in + warn_solve_errored ?loc err; + None let obligation_terminator name num guard hook auto pf = let open Proof_global in let term = Lemmas.universe_proof_terminator guard hook in match pf with | Admitted _ -> apply_terminator term pf - | Proved (opq, id, proof) -> - let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in + | Proved (opq, id, { entries=[entry]; universes=uctx } ) -> begin let env = Global.env () in let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in let ty = entry.Entries.const_entry_type in @@ -904,6 +919,9 @@ let obligation_terminator name num guard hook auto pf = with e when CErrors.noncritical e -> let e = CErrors.push e in pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) + end + | Proved (_, _, _ ) -> + CErrors.anomaly Pp.(str "[obligation_terminator] close_proof returned more than one proof term") let obligation_hook prg obl num auto ctx' _ gr = let obls, rem = prg.prg_obligations in @@ -987,44 +1005,34 @@ and solve_obligation_by_tac prg obls i tac = match obl.obl_body with | Some _ -> None | None -> - try - if List.is_empty (deps_remaining obls obl.obl_deps) then - let obl = subst_deps_obl obls obl in - let tac = - match tac with - | Some t -> t - | None -> - match obl.obl_tac with - | Some t -> t - | None -> !default_tactic - in - let evd = Evd.from_ctx prg.prg_ctx in - let evd = Evd.update_sigma_env evd (Global.env ()) in - let t, ty, ctx = - solve_by_tac obl.obl_name (evar_of_obligation obl) tac - (pi2 prg.prg_kind) (Evd.evar_universe_context evd) - in - let uctx = if pi2 prg.prg_kind - then Polymorphic_const_entry (UState.context ctx) - else Monomorphic_const_entry (UState.context_set ctx) - in - let prg = {prg with prg_ctx = ctx} in - let def, obl' = declare_obligation prg obl t ty uctx in - obls.(i) <- obl'; - if def && not (pi2 prg.prg_kind) then ( - (* Declare the term constraints with the first obligation only *) - let evd = Evd.from_env (Global.env ()) in - let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in - let ctx' = Evd.evar_universe_context evd in - Some {prg with prg_ctx = ctx'}) - else Some prg - else None - with e when CErrors.noncritical e -> - let (e, _) = CErrors.push e in - match e with - | Refiner.FailError (_, s) -> - user_err ?loc:(fst obl.obl_location) ~hdr:"solve_obligation" (Lazy.force s) - | e -> None (* FIXME really ? *) + if List.is_empty (deps_remaining obls obl.obl_deps) then + let obl = subst_deps_obl obls obl in + let tac = + match tac with + | Some t -> t + | None -> + match obl.obl_tac with + | Some t -> t + | None -> !default_tactic + in + let evd = Evd.from_ctx prg.prg_ctx in + let evd = Evd.update_sigma_env evd (Global.env ()) in + match solve_by_tac ?loc:(fst obl.obl_location) obl.obl_name (evar_of_obligation obl) tac + (pi2 prg.prg_kind) (Evd.evar_universe_context evd) with + | None -> None + | Some (t, ty, ctx) -> + let uctx = UState.const_univ_entry ~poly:(pi2 prg.prg_kind) ctx in + let prg = {prg with prg_ctx = ctx} in + let def, obl' = declare_obligation prg obl t ty uctx in + obls.(i) <- obl'; + if def && not (pi2 prg.prg_kind) then ( + (* Declare the term constraints with the first obligation only *) + let evd = Evd.from_env (Global.env ()) in + let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in + let ctx' = Evd.evar_universe_context evd in + Some {prg with prg_ctx = ctx'}) + else Some prg + else None and solve_prg_obligations prg ?oblset tac = let obls, rem = prg.prg_obligations in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 1c1faca599..2ddd210365 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -492,12 +492,13 @@ open Pputils keyword "Print Hint *" | PrintHintDbName s -> keyword "Print HintDb" ++ spc () ++ str s - | PrintUniverses (b, fopt) -> + | PrintUniverses (b, g, fopt) -> let cmd = if b then "Print Sorted Universes" else "Print Universes" in - keyword cmd ++ pr_opt str fopt + let pr_subgraph = prlist_with_sep spc pr_qualid in + keyword cmd ++ pr_opt pr_subgraph g ++ pr_opt str fopt | PrintName (qid,udecl) -> keyword "Print" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list udecl | PrintModuleType qid -> @@ -1213,6 +1214,7 @@ open Pputils let rec pr_vernac_flag (k, v) = let k = keyword k in + let open Attributes in match v with | VernacFlagEmpty -> k | VernacFlagLeaf v -> k ++ str " = " ++ qs v diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index b2fa8ec99f..f26e0d0885 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -41,8 +41,8 @@ module Vernac_ = let command_entry_ref = ref noedit_mode let command_entry = - Gram.Entry.of_parser "command_entry" - (fun strm -> Gram.Entry.parse_token !command_entry_ref strm) + Pcoq.Entry.of_parser "command_entry" + (fun strm -> Pcoq.Entry.parse_token_stream !command_entry_ref strm) end diff --git a/vernac/record.ml b/vernac/record.ml index 7a4c38e972..7bdf6a973f 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -160,7 +160,7 @@ let typecheck_params_and_fields finite def poly pl ps records = in let (sigma, data) = List.fold_left2_map fold sigma records arities in let sigma = - Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma (Evd.from_env env_ar) in + Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma in let fold sigma (typ, sort) (_, newfs) = let _, univ = compute_constructor_level sigma env_ar newfs in if not def && (Sorts.is_prop sort || @@ -277,12 +277,12 @@ let warn_non_primitive_record = strbrk" could not be defined as a primitive record"))) (* We build projections *) -let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers ubinders fieldimpls fields = +let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let poly = Declareops.inductive_is_polymorphic mib in let u = match ctx with - | Polymorphic_const_entry ctx -> Univ.UContext.instance ctx + | Polymorphic_const_entry (_, ctx) -> Univ.UContext.instance ctx | Monomorphic_const_entry ctx -> Univ.Instance.empty in let paramdecls = Inductive.inductive_paramdecls (mib, u) in @@ -324,7 +324,6 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u (** Already defined by declare_mind silently *) let kn = Projection.Repr.constant p in Declare.definition_message fid; - UnivNames.register_universe_binders (ConstRef kn) ubinders; kn, mkProj (Projection.make p false,mkRel 1) else let ccl = subst_projection fid subst ti in @@ -360,7 +359,6 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u applist (mkConstU (kn,u),proj_args) in Declare.definition_message fid; - UnivNames.register_universe_binders (ConstRef kn) ubinders; kn, constr_fip with Type_errors.TypeError (ctx,te) -> raise (NotDefinable (BadTypedProj (fid,ctx,te))) @@ -389,10 +387,10 @@ let declare_structure finite ubinders univs paramimpls params template ?(kind=St match univs with | Monomorphic_ind_entry ctx -> false, Monomorphic_const_entry Univ.ContextSet.empty - | Polymorphic_ind_entry ctx -> - true, Polymorphic_const_entry ctx - | Cumulative_ind_entry cumi -> - true, Polymorphic_const_entry (Univ.CumulativityInfo.univ_context cumi) + | Polymorphic_ind_entry (nas, ctx) -> + true, Polymorphic_const_entry (nas, ctx) + | Cumulative_ind_entry (nas, cumi) -> + true, Polymorphic_const_entry (nas, Univ.CumulativityInfo.univ_context cumi) in let binder_name = match name with @@ -443,7 +441,7 @@ let declare_structure finite ubinders univs paramimpls params template ?(kind=St let map i (_, _, _, fieldimpls, fields, is_coe, coers) = let rsp = (kn, i) in (* This is ind path of idstruc *) let cstr = (rsp, 1) in - let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers ubinders fieldimpls fields in + let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in let build = ConstructRef cstr in let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in let () = Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs) in @@ -480,7 +478,7 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari (DefinitionEntry class_entry, IsDefinition Definition) in let inst, univs = match univs with - | Polymorphic_const_entry uctx -> Univ.UContext.instance uctx, univs + | Polymorphic_const_entry (_, uctx) -> Univ.UContext.instance uctx, univs | Monomorphic_const_entry _ -> Univ.Instance.empty, Monomorphic_const_entry Univ.ContextSet.empty in let cstu = (cst, inst) in @@ -496,9 +494,7 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari in let cref = ConstRef cst in Impargs.declare_manual_implicits false cref [paramimpls]; - UnivNames.register_universe_binders cref ubinders; Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; - UnivNames.register_universe_binders (ConstRef proj_cst) ubinders; Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with | Some b -> Some ((if b then Backward else Forward), List.hd priorities) @@ -508,11 +504,11 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari | _ -> let univs = match univs with - | Polymorphic_const_entry univs -> + | Polymorphic_const_entry (nas, univs) -> if cum then - Cumulative_ind_entry (Univ.CumulativityInfo.from_universe_context univs) + Cumulative_ind_entry (nas, Univ.CumulativityInfo.from_universe_context univs) else - Polymorphic_ind_entry univs + Polymorphic_ind_entry (nas, univs) | Monomorphic_const_entry univs -> Monomorphic_ind_entry univs in @@ -541,8 +537,8 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari in let univs, ctx_context, fields = match univs with - | Polymorphic_const_entry univs -> - let usubst, auctx = Univ.abstract_universes univs in + | Polymorphic_const_entry (nas, univs) -> + let usubst, auctx = Univ.abstract_universes nas univs in let usubst = Univ.make_instance_subst usubst in let map c = Vars.subst_univs_level_constr usubst c in let fields = Context.Rel.map map fields in @@ -682,11 +678,11 @@ let definition_structure udecl kind ~template cum poly finite records = let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in let univs = match univs with - | Polymorphic_const_entry univs -> + | Polymorphic_const_entry (nas, univs) -> if cum then - Cumulative_ind_entry (Univ.CumulativityInfo.from_universe_context univs) + Cumulative_ind_entry (nas, Univ.CumulativityInfo.from_universe_context univs) else - Polymorphic_ind_entry univs + Polymorphic_ind_entry (nas, univs) | Monomorphic_const_entry univs -> Monomorphic_ind_entry univs in diff --git a/vernac/record.mli b/vernac/record.mli index 953d5ec3b6..04984030f7 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -20,7 +20,6 @@ val declare_projections : ?kind:Decl_kinds.definition_object_kind -> Id.t -> bool list -> - UnivNames.universe_binders -> Impargs.manual_implicits list -> Constr.rel_context -> (Name.t * bool) list * Constant.t option list diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 30fae756e9..ce93a8baaf 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -8,7 +8,7 @@ Himsg ExplainErr Locality Egramml -Vernacinterp +Vernacextend Ppvernac Proof_using Lemmas diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 74423d482e..a78329ad1d 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -30,7 +30,6 @@ open Constrexpr open Redexpr open Lemmas open Locality -open Vernacinterp open Attributes module NamedDecl = Context.Named.Declaration @@ -320,7 +319,7 @@ let print_registered () = hov 0 (prlist_with_sep fnl pr_lib_ref @@ Coqlib.get_lib_refs ()) -let dump_universes_gen g s = +let dump_universes_gen prl g s = let output = open_out s in let output_constraint, close = if Filename.check_suffix s ".dot" || Filename.check_suffix s ".gv" then begin @@ -345,10 +344,12 @@ let dump_universes_gen g s = | Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=" - in Printf.fprintf output "%s %s %s ;\n" left kind right + in + Printf.fprintf output "%s %s %s ;\n" left kind right end, (fun () -> close_out output) end in + let output_constraint k l r = output_constraint k (prl l) (prl r) in try UGraph.dump_universes output_constraint g; close (); @@ -358,6 +359,36 @@ let dump_universes_gen g s = close (); iraise reraise +let universe_subgraph ?loc g univ = + let open Univ in + let sigma = Evd.from_env (Global.env()) in + let univs_of q = + let q = Glob_term.(GType (UNamed q)) in + (* this function has a nice error message for not found univs *) + LSet.singleton (Pretyping.interp_known_glob_level ?loc sigma q) + in + let univs = List.fold_left (fun univs q -> LSet.union univs (univs_of q)) LSet.empty g in + let csts = UGraph.constraints_for ~kept:(LSet.add Level.prop (LSet.add Level.set univs)) univ in + let univ = LSet.fold UGraph.add_universe_unconstrained univs UGraph.initial_universes in + UGraph.merge_constraints csts univ + +let print_universes ?loc ~sort ~subgraph dst = + let univ = Global.universes () in + let univ = match subgraph with + | None -> univ + | Some g -> universe_subgraph ?loc g univ + in + let univ = if sort then UGraph.sort_universes univ else univ in + let pr_remaining = + if Global.is_joined_environment () then mt () + else str"There may remain asynchronous universe constraints" + in + let prl = UnivNames.pr_with_global_universes in + begin match dst with + | None -> UGraph.pr_universes prl univ ++ pr_remaining + | Some s -> dump_universes_gen (fun u -> Pp.string_of_ppcmds (prl u)) univ s + end + (*********************) (* "Locate" commands *) @@ -458,8 +489,7 @@ let start_proof_and_print k l hook = Evarutil.is_ground_term sigma concl) then raise Exit; let c, _, ctx = - Pfedit.build_by_tactic env (Evd.evar_universe_context sigma) - concl (Tacticals.New.tclCOMPLETE tac) + Pfedit.build_by_tactic env (Evd.evar_universe_context sigma) concl tac in Evd.set_universe_context sigma ctx, EConstr.of_constr c with Logic_monad.TacticFailure e when Logic.catchable_exception e -> user_err Pp.(str "The statement obligations could not be resolved \ @@ -1065,15 +1095,30 @@ let vernac_restore_state file = (* Commands *) let vernac_create_hintdb ~module_local id b = - Hints.create_hint_db module_local id full_transparent_state b - -let vernac_remove_hints ~module_local dbs ids = - Hints.remove_hints module_local dbs (List.map Smartlocate.global_with_alias ids) + Hints.create_hint_db module_local id TransparentState.full b + +let warn_implicit_core_hint_db = + CWarnings.create ~name:"implicit-core-hint-db" ~category:"deprecated" + (fun () -> strbrk "Adding and removing hints in the core database implicitly is deprecated. " + ++ strbrk"Please specify a hint database.") + +let vernac_remove_hints ~module_local dbnames ids = + let dbnames = + if List.is_empty dbnames then + (warn_implicit_core_hint_db (); ["core"]) + else dbnames + in + Hints.remove_hints module_local dbnames (List.map Smartlocate.global_with_alias ids) -let vernac_hints ~atts lb h = +let vernac_hints ~atts dbnames h = + let dbnames = + if List.is_empty dbnames then + (warn_implicit_core_hint_db (); ["core"]) + else dbnames + in let local, poly = Attributes.(parse Notations.(locality ++ polymorphic) atts) in let local = enforce_module_locality local in - Hints.add_hints ~local lb (Hints.interp_hints poly h) + Hints.add_hints ~local dbnames (Hints.interp_hints poly h) let vernac_syntactic_definition ~module_local lid x y = Dumpglob.dump_definition lid false "syndef"; @@ -1422,14 +1467,6 @@ let _ = let _ = declare_bool_option - { optdepr = true; (* remove in 8.8 *) - optname = "automatic introduction of variables"; - optkey = ["Automatic";"Introduction"]; - optread = Flags.is_auto_intros; - optwrite = Flags.make_auto_intros } - -let _ = - declare_bool_option { optdepr = false; optname = "coercion printing"; optkey = ["Printing";"Coercions"]; @@ -1827,17 +1864,7 @@ let vernac_print ~atts env sigma = | PrintCoercionPaths (cls,clt) -> Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt) | PrintCanonicalConversions -> Prettyp.print_canonical_projections env sigma - | PrintUniverses (b, dst) -> - let univ = Global.universes () in - let univ = if b then UGraph.sort_universes univ else univ in - let pr_remaining = - if Global.is_joined_environment () then mt () - else str"There may remain asynchronous universe constraints" - in - begin match dst with - | None -> UGraph.pr_universes UnivNames.pr_with_global_universes univ ++ pr_remaining - | Some s -> dump_universes_gen univ s - end + | PrintUniverses (sort, subgraph, dst) -> print_universes ~sort ~subgraph dst | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r) | PrintHintGoal -> Hints.pr_applicable_hint () | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s @@ -2268,7 +2295,7 @@ let interp ?proof ~atts ~st c = (* Extensions *) | VernacExtend (opn,args) -> (* XXX: Here we are returning the state! :) *) - let _st : Vernacstate.t = Vernacinterp.call ~atts opn args ~st in + let _st : Vernacstate.t = Vernacextend.call ~atts opn args ~st in () (** A global default timeout, controlled by option "Set Default Timeout n". @@ -2400,147 +2427,3 @@ let interp ?verbosely ?proof ~st cmd = let exn = CErrors.push exn in Vernacstate.invalidate_cache (); iraise exn - -(** VERNAC EXTEND registering *) - -open Genarg -open Extend - -type classifier = Genarg.raw_generic_argument list -> vernac_classification - -type (_, _) ty_sig = -| TyNil : (atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig -| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig -| TyNonTerminal : ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig - -type ty_ml = TyML : bool * ('r, 's) ty_sig * 'r * 's option -> ty_ml - -let type_error () = CErrors.anomaly (Pp.str "Ill-typed VERNAC EXTEND") - -let rec untype_classifier : type r s. (r, s) ty_sig -> s -> classifier = function -| TyNil -> fun f args -> - begin match args with - | [] -> f - | _ :: _ -> type_error () - end -| TyTerminal (_, ty) -> fun f args -> untype_classifier ty f args -| TyNonTerminal (tu, ty) -> fun f args -> - begin match args with - | [] -> type_error () - | Genarg.GenArg (Rawwit tag, v) :: args -> - match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with - | None -> type_error () - | Some Refl -> untype_classifier ty (f v) args - end - -(** Stupid GADTs forces us to duplicate the definition just for typing *) -let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_command = function -| TyNil -> fun f args -> - begin match args with - | [] -> f - | _ :: _ -> type_error () - end -| TyTerminal (_, ty) -> fun f args -> untype_command ty f args -| TyNonTerminal (tu, ty) -> fun f args -> - begin match args with - | [] -> type_error () - | Genarg.GenArg (Rawwit tag, v) :: args -> - match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with - | None -> type_error () - | Some Refl -> untype_command ty (f v) args - end - -let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, a) Extend.symbol = function -| TUlist1 l -> Alist1 (untype_user_symbol l) -| TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) -| TUlist0 l -> Alist0 (untype_user_symbol l) -| TUlist0sep (l, s) -> Alist0sep (untype_user_symbol l, Atoken (CLexer.terminal s)) -| TUopt o -> Aopt (untype_user_symbol o) -| TUentry a -> Aentry (Pcoq.genarg_grammar (ExtraArg a)) -| TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (ExtraArg a), string_of_int i) - -let rec untype_grammar : type r s. (r, s) ty_sig -> vernac_expr Egramml.grammar_prod_item list = function -| TyNil -> [] -| TyTerminal (tok, ty) -> Egramml.GramTerminal tok :: untype_grammar ty -| TyNonTerminal (tu, ty) -> - let t = rawwit (Egramml.proj_symbol tu) in - let symb = untype_user_symbol tu in - Egramml.GramNonTerminal (Loc.tag (t, symb)) :: untype_grammar ty - -let _ = untype_classifier, untype_command, untype_grammar, untype_user_symbol - -let classifiers : classifier array String.Map.t ref = ref String.Map.empty - -let get_vernac_classifier (name, i) args = - (String.Map.find name !classifiers).(i) args - -let declare_vernac_classifier name f = - classifiers := String.Map.add name f !classifiers - -let vernac_extend ~command ?classifier ?entry ext = - let get_classifier (TyML (_, ty, _, cl)) = match cl with - | Some cl -> untype_classifier ty cl - | None -> - match classifier with - | Some cl -> fun _ -> cl command - | None -> - let e = match entry with - | None -> "COMMAND" - | Some e -> Pcoq.Gram.Entry.name e - in - let msg = Printf.sprintf "\ - Vernac entry \"%s\" misses a classifier. \ - A classifier is a function that returns an expression \ - of type vernac_classification (see Vernacexpr). You can: \n\ - - Use '... EXTEND %s CLASSIFIED AS QUERY ...' if the \ - new vernacular command does not alter the system state;\n\ - - Use '... EXTEND %s CLASSIFIED AS SIDEFF ...' if the \ - new vernacular command alters the system state but not the \ - parser nor it starts a proof or ends one;\n\ - - Use '... EXTEND %s CLASSIFIED BY f ...' to specify \ - a global function f. The function f will be called passing\ - \"%s\" as the only argument;\n\ - - Add a specific classifier in each clause using the syntax:\n\ - '[...] => [ f ] -> [...]'.\n\ - Specific classifiers have precedence over global \ - classifiers. Only one classifier is called." - command e e e command - in - CErrors.user_err (Pp.strbrk msg) - in - let cl = Array.map_of_list get_classifier ext in - let iter i (TyML (depr, ty, f, _)) = - let f = untype_command ty f in - let r = untype_grammar ty in - let () = vinterp_add depr (command, i) f in - Egramml.extend_vernac_command_grammar (command, i) entry r - in - let () = declare_vernac_classifier command cl in - List.iteri iter ext - -(** VERNAC ARGUMENT EXTEND registering *) - -type 'a argument_rule = -| Arg_alias of 'a Pcoq.Entry.t -| Arg_rules of 'a Extend.production_rule list - -type 'a vernac_argument = { - arg_printer : 'a -> Pp.t; - arg_parsing : 'a argument_rule; -} - -let vernac_argument_extend ~name arg = - let wit = Genarg.create_arg name in - let entry = match arg.arg_parsing with - | Arg_alias e -> - let () = Pcoq.register_grammar wit e in - e - | Arg_rules rules -> - let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in - let () = Pcoq.grammar_extend e None (None, [(None, None, rules)]) in - e - in - let pr = arg.arg_printer in - let pr x = Genprint.PrinterBasic (fun () -> pr x) in - let () = Genprint.register_vernac_print0 wit pr in - (wit, entry) diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 8ccd121b8f..8d8d7cfcf0 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -36,50 +36,3 @@ val command_focus : unit Proof.focus_kind val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t - -(** {5 VERNAC EXTEND} *) - -type classifier = Genarg.raw_generic_argument list -> Vernacexpr.vernac_classification - -type (_, _) ty_sig = -| TyNil : (atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig -| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig -| TyNonTerminal : - ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> - ('a -> 'r, 'a -> 's) ty_sig - -type ty_ml = TyML : bool (** deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml - -(** Wrapper to dynamically extend vernacular commands. *) -val vernac_extend : - command:string -> - ?classifier:(string -> Vernacexpr.vernac_classification) -> - ?entry:Vernacexpr.vernac_expr Pcoq.Entry.t -> - ty_ml list -> unit - -(** {5 VERNAC ARGUMENT EXTEND} *) - -type 'a argument_rule = -| Arg_alias of 'a Pcoq.Entry.t - (** This is used because CAMLP5 parser can be dumb about rule factorization, - which sometimes requires two entries to be the same. *) -| Arg_rules of 'a Extend.production_rule list - (** There is a discrepancy here as we use directly extension rules and thus - entries instead of ty_user_symbol and thus arguments as roots. *) - -type 'a vernac_argument = { - arg_printer : 'a -> Pp.t; - arg_parsing : 'a argument_rule; -} - -val vernac_argument_extend : name:string -> 'a vernac_argument -> - ('a, unit, unit) Genarg.genarg_type * 'a Pcoq.Entry.t - -(** {5 STM classifiers} *) - -val get_vernac_classifier : - Vernacexpr.extend_name -> classifier - -(** Low-level API, not for casual user. *) -val declare_vernac_classifier : - string -> classifier array -> unit diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 594e9eca48..122005e011 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -45,7 +45,7 @@ type printable = | PrintCoercions | PrintCoercionPaths of class_rawexpr * class_rawexpr | PrintCanonicalConversions - | PrintUniverses of bool * string option + | PrintUniverses of bool * qualid list option * string option | PrintHint of qualid or_by_notation | PrintHintGoal | PrintHintDbName of string @@ -219,13 +219,6 @@ type section_subset_expr = {b ("ExtractionBlacklist", 0)} indicates {b Extraction Blacklist {i ident{_1}} ... {i ident{_n}}} command. *) -type extend_name = - (** Name of the vernac entry where the tactic is defined, typically found - after the VERNAC EXTEND statement in the source. *) - string * - (** Index of the extension in the VERNAC EXTEND statement. Each parsing branch - is given an offset, starting from zero. *) - int (* This type allows registering the inlining of constants in native compiler. It will be extended with primitive inductive types and operators *) @@ -253,6 +246,14 @@ type vernac_argument_status = { implicit_status : vernac_implicit_status; } +type extend_name = + (** Name of the vernac entry where the tactic is defined, typically found + after the VERNAC EXTEND statement in the source. *) + string * + (** Index of the extension in the VERNAC EXTEND statement. Each parsing branch + is given an offset, starting from zero. *) + int + type nonrec vernac_expr = | VernacLoad of verbose_flag * string @@ -395,71 +396,11 @@ type nonrec vernac_expr = (* For extension *) | VernacExtend of extend_name * Genarg.raw_generic_argument list -type vernac_flags = vernac_flag list -and vernac_flag = string * vernac_flag_value -and vernac_flag_value = - | VernacFlagEmpty - | VernacFlagLeaf of string - | VernacFlagList of vernac_flags - type vernac_control = - | VernacExpr of vernac_flags * vernac_expr + | VernacExpr of Attributes.vernac_flags * vernac_expr (* boolean is true when the `-time` batch-mode command line flag was set. the flag is used to print differently in `-time` vs `Time foo` *) | VernacTime of bool * vernac_control CAst.t | VernacRedirect of string * vernac_control CAst.t | VernacTimeout of int * vernac_control | VernacFail of vernac_control - -(* A vernac classifier provides information about the exectuion of a - command: - - - vernac_when: encodes if the vernac may alter the parser [thus - forcing immediate execution], or if indeed it is pure and parsing - can continue without its execution. - - - vernac_type: if it is starts, ends, continues a proof or - alters the global state or is a control command like BackTo or is - a query like Check. - - The classification works on the assumption that we have 3 states: - parsing, execution (global enviroment, etc...), and proof - state. For example, commands that only alter the proof state are - considered safe to delegate to a worker. - -*) -type vernac_type = - (* Start of a proof *) - | VtStartProof of vernac_start - (* Command altering the global state, bad for parallel - processing. *) - | VtSideff of vernac_sideff_type - (* End of a proof *) - | VtQed of vernac_qed_type - (* A proof step *) - | VtProofStep of proof_step - (* To be removed *) - | VtProofMode of string - (* Queries are commands assumed to be "pure", that is to say, they - don't modify the interpretation state. *) - | VtQuery - (* To be removed *) - | VtMeta - | VtUnknown -and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) -and vernac_start = string * opacity_guarantee * Id.t list -and vernac_sideff_type = Id.t list -and opacity_guarantee = - | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) - | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) -and proof_step = { (* TODO: inline with OCaml 4.03 *) - parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; - proof_block_detection : proof_block_name option -} -and solving_tac = bool (* a terminator *) -and anon_abstracting_tac = bool (* abstracting anonymously its result *) -and proof_block_name = string (* open type of delimiters *) -type vernac_when = - | VtNow - | VtLater -type vernac_classification = vernac_type * vernac_when diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml new file mode 100644 index 0000000000..35f26cab4d --- /dev/null +++ b/vernac/vernacextend.ml @@ -0,0 +1,250 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +open Util +open Pp +open CErrors + +type vernac_type = + (* Start of a proof *) + | VtStartProof of vernac_start + (* Command altering the global state, bad for parallel + processing. *) + | VtSideff of vernac_sideff_type + (* End of a proof *) + | VtQed of vernac_qed_type + (* A proof step *) + | VtProofStep of { + parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; + proof_block_detection : proof_block_name option + } + (* To be removed *) + | VtProofMode of string + (* Queries are commands assumed to be "pure", that is to say, they + don't modify the interpretation state. *) + | VtQuery + (* To be removed *) + | VtMeta + | VtUnknown +and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) +and vernac_start = string * opacity_guarantee * Names.Id.t list +and vernac_sideff_type = Names.Id.t list +and opacity_guarantee = + | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) + | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) +and solving_tac = bool (** a terminator *) +and anon_abstracting_tac = bool (** abstracting anonymously its result *) +and proof_block_name = string (** open type of delimiters *) + +type vernac_when = + | VtNow + | VtLater +type vernac_classification = vernac_type * vernac_when + +type 'a vernac_command = 'a -> atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t + +type plugin_args = Genarg.raw_generic_argument list + +(* Table of vernac entries *) +let vernac_tab = + (Hashtbl.create 211 : + (Vernacexpr.extend_name, bool * plugin_args vernac_command) Hashtbl.t) + +let vinterp_add depr s f = + try + Hashtbl.add vernac_tab s (depr, f) + with Failure _ -> + user_err ~hdr:"vinterp_add" + (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.") + +let vinterp_map s = + try + Hashtbl.find vernac_tab s + with Failure _ | Not_found -> + user_err ~hdr:"Vernac Interpreter" + (str"Cannot find vernac command " ++ str (fst s) ++ str".") + +let warn_deprecated_command = + let open CWarnings in + create ~name:"deprecated-command" ~category:"deprecated" + (fun pr -> str "Deprecated vernacular command: " ++ pr) + +(* Interpretation of a vernac command *) + +let call opn converted_args ~atts ~st = + let phase = ref "Looking up command" in + try + let depr, callback = vinterp_map opn in + let () = if depr then + let rules = Egramml.get_extend_vernac_rule opn in + let pr_gram = function + | Egramml.GramTerminal s -> str s + | Egramml.GramNonTerminal _ -> str "_" + in + let pr = pr_sequence pr_gram rules in + warn_deprecated_command pr; + in + phase := "Checking arguments"; + let hunk = callback converted_args in + phase := "Executing command"; + hunk ~atts ~st + with + | reraise -> + let reraise = CErrors.push reraise in + if !Flags.debug then + Feedback.msg_debug (str"Vernac Interpreter " ++ str !phase); + iraise reraise + +(** VERNAC EXTEND registering *) + +type classifier = Genarg.raw_generic_argument list -> vernac_classification + +(** Classifiers *) +let classifiers : classifier array String.Map.t ref = ref String.Map.empty + +let get_vernac_classifier (name, i) args = + (String.Map.find name !classifiers).(i) args + +let declare_vernac_classifier name f = + classifiers := String.Map.add name f !classifiers + +let classify_as_query = VtQuery, VtLater +let classify_as_sideeff = VtSideff [], VtLater +let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None}, VtLater + +type (_, _) ty_sig = +| TyNil : (atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, vernac_classification) ty_sig +| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig +| TyNonTerminal : ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig + +type ty_ml = TyML : bool * ('r, 's) ty_sig * 'r * 's option -> ty_ml + +let type_error () = CErrors.anomaly (Pp.str "Ill-typed VERNAC EXTEND") + +let rec untype_classifier : type r s. (r, s) ty_sig -> s -> classifier = function +| TyNil -> fun f args -> + begin match args with + | [] -> f + | _ :: _ -> type_error () + end +| TyTerminal (_, ty) -> fun f args -> untype_classifier ty f args +| TyNonTerminal (tu, ty) -> fun f args -> + let open Genarg in + begin match args with + | [] -> type_error () + | GenArg (Rawwit tag, v) :: args -> + match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with + | None -> type_error () + | Some Refl -> untype_classifier ty (f v) args + end + +(** Stupid GADTs forces us to duplicate the definition just for typing *) +let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_command = function +| TyNil -> fun f args -> + begin match args with + | [] -> f + | _ :: _ -> type_error () + end +| TyTerminal (_, ty) -> fun f args -> untype_command ty f args +| TyNonTerminal (tu, ty) -> fun f args -> + let open Genarg in + begin match args with + | [] -> type_error () + | GenArg (Rawwit tag, v) :: args -> + match genarg_type_eq tag (Egramml.proj_symbol tu) with + | None -> type_error () + | Some Refl -> untype_command ty (f v) args + end + +let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, a) Extend.symbol = + let open Extend in function +| TUlist1 l -> Alist1 (untype_user_symbol l) +| TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) +| TUlist0 l -> Alist0 (untype_user_symbol l) +| TUlist0sep (l, s) -> Alist0sep (untype_user_symbol l, Atoken (CLexer.terminal s)) +| TUopt o -> Aopt (untype_user_symbol o) +| TUentry a -> Aentry (Pcoq.genarg_grammar (Genarg.ExtraArg a)) +| TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (Genarg.ExtraArg a), string_of_int i) + +let rec untype_grammar : type r s. (r, s) ty_sig -> 'a Egramml.grammar_prod_item list = function +| TyNil -> [] +| TyTerminal (tok, ty) -> Egramml.GramTerminal tok :: untype_grammar ty +| TyNonTerminal (tu, ty) -> + let t = Genarg.rawwit (Egramml.proj_symbol tu) in + let symb = untype_user_symbol tu in + Egramml.GramNonTerminal (Loc.tag (t, symb)) :: untype_grammar ty + +let vernac_extend ~command ?classifier ?entry ext = + let get_classifier (TyML (_, ty, _, cl)) = match cl with + | Some cl -> untype_classifier ty cl + | None -> + match classifier with + | Some cl -> fun _ -> cl command + | None -> + let e = match entry with + | None -> "COMMAND" + | Some e -> Pcoq.Entry.name e + in + let msg = Printf.sprintf "\ + Vernac entry \"%s\" misses a classifier. \ + A classifier is a function that returns an expression \ + of type vernac_classification (see Vernacexpr). You can: \n\ + - Use '... EXTEND %s CLASSIFIED AS QUERY ...' if the \ + new vernacular command does not alter the system state;\n\ + - Use '... EXTEND %s CLASSIFIED AS SIDEFF ...' if the \ + new vernacular command alters the system state but not the \ + parser nor it starts a proof or ends one;\n\ + - Use '... EXTEND %s CLASSIFIED BY f ...' to specify \ + a global function f. The function f will be called passing\ + \"%s\" as the only argument;\n\ + - Add a specific classifier in each clause using the syntax:\n\ + '[...] => [ f ] -> [...]'.\n\ + Specific classifiers have precedence over global \ + classifiers. Only one classifier is called." + command e e e command + in + CErrors.user_err (Pp.strbrk msg) + in + let cl = Array.map_of_list get_classifier ext in + let iter i (TyML (depr, ty, f, _)) = + let f = untype_command ty f in + let r = untype_grammar ty in + let () = vinterp_add depr (command, i) f in + Egramml.extend_vernac_command_grammar (command, i) entry r + in + let () = declare_vernac_classifier command cl in + List.iteri iter ext + +(** VERNAC ARGUMENT EXTEND registering *) + +type 'a argument_rule = +| Arg_alias of 'a Pcoq.Entry.t +| Arg_rules of 'a Extend.production_rule list + +type 'a vernac_argument = { + arg_printer : 'a -> Pp.t; + arg_parsing : 'a argument_rule; +} + +let vernac_argument_extend ~name arg = + let wit = Genarg.create_arg name in + let entry = match arg.arg_parsing with + | Arg_alias e -> + let () = Pcoq.register_grammar wit e in + e + | Arg_rules rules -> + let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in + let () = Pcoq.grammar_extend e None (None, [(None, None, rules)]) in + e + in + let pr = arg.arg_printer in + let pr x = Genprint.PrinterBasic (fun () -> pr x) in + let () = Genprint.register_vernac_print0 wit pr in + (wit, entry) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli new file mode 100644 index 0000000000..7feaccd9a3 --- /dev/null +++ b/vernac/vernacextend.mli @@ -0,0 +1,118 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Vernacular Extension data *) + +(* A vernac classifier provides information about the exectuion of a + command: + + - vernac_when: encodes if the vernac may alter the parser [thus + forcing immediate execution], or if indeed it is pure and parsing + can continue without its execution. + + - vernac_type: if it is starts, ends, continues a proof or + alters the global state or is a control command like BackTo or is + a query like Check. + + The classification works on the assumption that we have 3 states: + parsing, execution (global enviroment, etc...), and proof + state. For example, commands that only alter the proof state are + considered safe to delegate to a worker. + +*) +type vernac_type = + (* Start of a proof *) + | VtStartProof of vernac_start + (* Command altering the global state, bad for parallel + processing. *) + | VtSideff of vernac_sideff_type + (* End of a proof *) + | VtQed of vernac_qed_type + (* A proof step *) + | VtProofStep of { + parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; + proof_block_detection : proof_block_name option + } + (* To be removed *) + | VtProofMode of string + (* Queries are commands assumed to be "pure", that is to say, they + don't modify the interpretation state. *) + | VtQuery + (* To be removed *) + | VtMeta + | VtUnknown +and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) +and vernac_start = string * opacity_guarantee * Names.Id.t list +and vernac_sideff_type = Names.Id.t list +and opacity_guarantee = + | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) + | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) +and solving_tac = bool (** a terminator *) +and anon_abstracting_tac = bool (** abstracting anonymously its result *) +and proof_block_name = string (** open type of delimiters *) + +type vernac_when = + | VtNow + | VtLater +type vernac_classification = vernac_type * vernac_when + +(** Interpretation of extended vernac phrases. *) + +type 'a vernac_command = 'a -> atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t + +type plugin_args = Genarg.raw_generic_argument list + +val call : Vernacexpr.extend_name -> plugin_args -> atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t + +(** {5 VERNAC EXTEND} *) + +type classifier = Genarg.raw_generic_argument list -> vernac_classification + +type (_, _) ty_sig = +| TyNil : (atts:Attributes.vernac_flags -> st:Vernacstate.t -> Vernacstate.t, vernac_classification) ty_sig +| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig +| TyNonTerminal : + ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> + ('a -> 'r, 'a -> 's) ty_sig + +type ty_ml = TyML : bool (** deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml + +(** Wrapper to dynamically extend vernacular commands. *) +val vernac_extend : + command:string -> + ?classifier:(string -> vernac_classification) -> + ?entry:Vernacexpr.vernac_expr Pcoq.Entry.t -> + ty_ml list -> unit + +(** {5 VERNAC ARGUMENT EXTEND} *) + +type 'a argument_rule = +| Arg_alias of 'a Pcoq.Entry.t + (** This is used because CAMLP5 parser can be dumb about rule factorization, + which sometimes requires two entries to be the same. *) +| Arg_rules of 'a Extend.production_rule list + (** There is a discrepancy here as we use directly extension rules and thus + entries instead of ty_user_symbol and thus arguments as roots. *) + +type 'a vernac_argument = { + arg_printer : 'a -> Pp.t; + arg_parsing : 'a argument_rule; +} + +val vernac_argument_extend : name:string -> 'a vernac_argument -> + ('a, unit, unit) Genarg.genarg_type * 'a Pcoq.Entry.t + +(** {5 STM classifiers} *) +val get_vernac_classifier : Vernacexpr.extend_name -> classifier + +(** Standard constant classifiers *) +val classify_as_query : vernac_classification +val classify_as_sideeff : vernac_classification +val classify_as_proofstep : vernac_classification diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml deleted file mode 100644 index eb4282705e..0000000000 --- a/vernac/vernacinterp.ml +++ /dev/null @@ -1,77 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -open Util -open Pp -open CErrors - -type 'a vernac_command = 'a -> atts:Vernacexpr.vernac_flags -> st:Vernacstate.t -> Vernacstate.t - -type plugin_args = Genarg.raw_generic_argument list - -(* Table of vernac entries *) -let vernac_tab = - (Hashtbl.create 211 : - (Vernacexpr.extend_name, bool * plugin_args vernac_command) Hashtbl.t) - -let vinterp_add depr s f = - try - Hashtbl.add vernac_tab s (depr, f) - with Failure _ -> - user_err ~hdr:"vinterp_add" - (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.") - -let overwriting_vinterp_add s f = - begin - try - let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s - with Not_found -> () - end; - Hashtbl.add vernac_tab s (false, f) - -let vinterp_map s = - try - Hashtbl.find vernac_tab s - with Failure _ | Not_found -> - user_err ~hdr:"Vernac Interpreter" - (str"Cannot find vernac command " ++ str (fst s) ++ str".") - -let vinterp_init () = Hashtbl.clear vernac_tab - -let warn_deprecated_command = - let open CWarnings in - create ~name:"deprecated-command" ~category:"deprecated" - (fun pr -> str "Deprecated vernacular command: " ++ pr) - -(* Interpretation of a vernac command *) - -let call opn converted_args ~atts ~st = - let phase = ref "Looking up command" in - try - let depr, callback = vinterp_map opn in - let () = if depr then - let rules = Egramml.get_extend_vernac_rule opn in - let pr_gram = function - | Egramml.GramTerminal s -> str s - | Egramml.GramNonTerminal _ -> str "_" - in - let pr = pr_sequence pr_gram rules in - warn_deprecated_command pr; - in - phase := "Checking arguments"; - let hunk = callback converted_args in - phase := "Executing command"; - hunk ~atts ~st - with - | reraise -> - let reraise = CErrors.push reraise in - if !Flags.debug then - Feedback.msg_debug (str"Vernac Interpreter " ++ str !phase); - iraise reraise |