diff options
529 files changed, 11348 insertions, 4677 deletions
diff --git a/.gitattributes b/.gitattributes index a5edcdb5bf..47538be4a3 100644 --- a/.gitattributes +++ b/.gitattributes @@ -53,3 +53,6 @@ tools/CoqMakefile.in whitespace=blank-at-eol # CR is desired for these Windows files. *.bat whitespace=cr-at-eol,blank-at-eol,tab-in-indent + +# never do endline conversion +* -text diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 98fe2546b5..2a641263e3 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -37,6 +37,9 @@ *.nix @coq/nix-maintainers +azure-pipelines.yml @coq/ci-maintainers +/dev/ci/azure* @coq/ci-maintainers + ########## Documentation ########## /README.md @Zimmi48 @@ -68,6 +71,8 @@ /man/ @silene # Secondary maintainer @maximedenes +/doc/plugin_tutorial/ @ybertot + ########## Coqchk ########## /checker/ @ppedrot @@ -311,7 +316,7 @@ /test-suite/README.md @gares # Secondary maintainer @SkySkimmer -/test-suite/save-logs @SkySkimmer +/test-suite/report.sh @SkySkimmer /test-suite/complexity/ @herbelin diff --git a/.gitignore b/.gitignore index 0411247abf..dfecfec837 100644 --- a/.gitignore +++ b/.gitignore @@ -150,6 +150,7 @@ kernel/byterun/coq_jumptbl.h kernel/copcodes.ml ide/index_urls.txt .lia.cache +.nia.cache # emacs save files *~ diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 65a8a0cb88..50b86b3c5d 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-11-08-V1" + CACHEKEY: "bionic_coq-V2018-12-14-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -89,18 +89,37 @@ after_script: - set +e +# Template for building Coq + stdlib, typical use: overload the switch .dune-template: &dune-template - dependencies: [] stage: build + dependencies: [] + script: + - set -e + - make -f Makefile.dune world + - set +e + variables: + OPAM_SWITCH: edge artifacts: name: "$CI_JOB_NAME" paths: - _build/ expire_in: 1 week + +.dune-ci-template: &dune-ci-template + stage: test + dependencies: + - build:egde:dune:dev script: - set -e + - echo 'start:coq.test' - make -f Makefile.dune "$DUNE_TARGET" + - echo 'end:coq.test' - set +e + variables: &dune-ci-template-vars + OPAM_SWITCH: edge + artifacts: &dune-ci-template-artifacts + name: "$CI_JOB_NAME" + expire_in: 1 month # every non build job must set dependencies otherwise all build # artifacts are used together and we may get some random Coq. To that @@ -132,7 +151,7 @@ after_script: - BIN=$(readlink -f ../_install_ci/bin)/ - LIB=$(readlink -f ../_install_ci/lib/coq)/ - export OCAMLPATH=$(readlink -f ../_install_ci/lib/):"$OCAMLPATH" - - make -j "$NJOBS" BIN="$BIN" LIB="$LIB" all + - make -j "$NJOBS" BIN="$BIN" LIB="$LIB" COQFLAGS="${COQFLAGS}" all artifacts: name: "$CI_JOB_NAME.logs" when: on_failure @@ -155,20 +174,17 @@ after_script: script: - set -e - echo 'start:coq.test' - - make -f Makefile.ci -j "$NJOBS" ${TEST_TARGET} + - make -f Makefile.ci -j "$NJOBS" "${CI_JOB_NAME#*:}" - echo 'end:coq.test' - set +e dependencies: - build:base - variables: &ci-template-vars - TEST_TARGET: "$CI_JOB_NAME" .ci-template-flambda: &ci-template-flambda <<: *ci-template dependencies: - build:edge+flambda variables: - <<: *ci-template-vars OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" @@ -221,9 +237,13 @@ build:edge+flambda: build:egde:dune:dev: <<: *dune-template + +build:base+async: + <<: *build-template + stage: test variables: - OPAM_SWITCH: edge - DUNE_TARGET: world + COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" + COQUSERFLAGS: "-async-proofs on" windows64: <<: *windows-template @@ -237,6 +257,18 @@ windows32: except: - /^pr-.*$/ +lint: + image: docker:git + stage: test + script: + - apk add bash + - dev/lint-repository.sh + dependencies: [] + before_script: [] + variables: + # we need an unknown amount of history for per-commit linting + GIT_DEPTH: "" + pkg:opam: stage: test # OPAM will build out-of-tree so no point in importing artifacts @@ -284,15 +316,23 @@ doc:refman: dependencies: - build:base +doc:refman:dune: + <<: *dune-ci-template + variables: + <<: *dune-ci-template-vars + DUNE_TARGET: refman-html + artifacts: + <<: *dune-ci-template-artifacts + paths: + - _build/default/doc/sphinx_build/html + doc:ml-api:odoc: - stage: test - dependencies: - - build:egde:dune:dev - script: make -f Makefile.dune apidoc + <<: *dune-ci-template variables: - OPAM_SWITCH: edge + <<: *dune-ci-template-vars + DUNE_TARGET: apidoc artifacts: - name: "$CI_JOB_NAME" + <<: *dune-ci-template-artifacts paths: - _build/default/_doc/ @@ -336,6 +376,64 @@ test-suite:egde:dune:dev: paths: - _build/default/test-suite/logs +test-suite:edge+trunk+make: + stage: test + dependencies: [] + script: + - opam switch create 4.08.0 --empty + - eval $(opam env) + - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam update + - opam install ocaml-variants=4.08.0 num + - eval $(opam env) + # We avoid problems with warnings: + - ./configure -profile devel -warn-error no + - make -j "$NJOBS" world + - make -j "$NJOBS" test-suite UNIT_TESTS= + variables: + OPAM_SWITCH: edge + artifacts: + name: "$CI_JOB_NAME.logs" + when: always + paths: + - test-suite/logs + expire_in: 1 week + allow_failure: true + +test-suite:edge+trunk+dune: + stage: test + dependencies: [] + script: + - opam switch create 4.08.0 --empty + - eval $(opam env) + - opam repo add ocaml-pr https://github.com/ocaml/ocaml-pr-repository.git + - opam update + - opam install ocaml-variants=4.08.0 num + - opam pin add dune --dev # ounit lablgtk conf-gtksourceview + - opam install dune + - eval $(opam env) + # We use the release profile to avoid problems with warnings + - make -f Makefile.dune trunk + - export COQ_UNIT_TEST=noop + - dune runtest --profile=ocaml408 + variables: + OPAM_SWITCH: edge + artifacts: + name: "$CI_JOB_NAME.logs" + when: always + paths: + - _build/log + - _build/default/test-suite/logs + expire_in: 1 week + allow_failure: true + +test-suite:base+async: + <<: *test-suite-template + dependencies: + - build:base + variables: + COQFLAGS: "-async-proofs on" + validate:base: <<: *validate-template dependencies: @@ -363,93 +461,105 @@ validate:edge+flambda: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" -ci-aac_tactics: - <<: *ci-template +# Libraries are by convention the projects that depend on Coq +# but not on its ML API -ci-bedrock2: +library:ci-bedrock2: <<: *ci-template allow_failure: true -ci-bignums: - <<: *ci-template - -ci-color: +library:ci-color: <<: *ci-template-flambda -ci-compcert: +library:ci-compcert: <<: *ci-template-flambda -ci-coq_dpdgraph: +library:ci-coquelicot: <<: *ci-template -ci-coquelicot: +library:ci-cross-crypto: <<: *ci-template -ci-cross-crypto: +library:ci-fcsl-pcm: <<: *ci-template -ci-elpi: - <<: *ci-template +library:ci-fiat-crypto: + <<: *ci-template-flambda -ci-equations: - <<: *ci-template +library:ci-fiat-crypto-legacy: + <<: *ci-template-flambda -ci-fcsl-pcm: +library:ci-flocq: <<: *ci-template -ci-fiat-crypto: +library:ci-corn: <<: *ci-template-flambda -ci-fiat-crypto-legacy: +library:ci-geocoq: <<: *ci-template-flambda -ci-fiat-parsers: +library:ci-hott: <<: *ci-template -ci-flocq: +library:ci-iris-lambda-rust: + <<: *ci-template-flambda + +library:ci-math-comp: + <<: *ci-template-flambda + +library:ci-sf: <<: *ci-template -ci-formal-topology: +library:ci-unimath: <<: *ci-template-flambda -ci-geocoq: +library:ci-verdi-raft: <<: *ci-template-flambda -ci-coqhammer: - <<: *ci-template +library:ci-vst: + <<: *ci-template-flambda + +# Plugins are by definition the projects that depend on Coq's ML API -ci-hott: +plugin:ci-aac_tactics: <<: *ci-template -ci-iris-lambda-rust: - <<: *ci-template-flambda +plugin:ci-bignums: + <<: *ci-template -ci-ltac2: +plugin:ci-coq_dpdgraph: <<: *ci-template -ci-math-comp: - <<: *ci-template-flambda +plugin:ci-coqhammer: + <<: *ci-template -ci-mtac2: +plugin:ci-elpi: <<: *ci-template -ci-paramcoq: +plugin:ci-equations: <<: *ci-template -ci-plugin_tutorial: +plugin:ci-fiat-parsers: <<: *ci-template -ci-quickchick: - <<: *ci-template-flambda +plugin:ci-ltac2: + <<: *ci-template -ci-relation-algebra: +plugin:ci-mtac2: <<: *ci-template -ci-sf: +plugin:ci-paramcoq: <<: *ci-template -ci-unimath: - <<: *ci-template-flambda +plugin:plugin-tutorial: + stage: test + dependencies: [] + script: + - ./configure -local -warn-error yes + - make -j "$NJOBS" plugin-tutorial -ci-vst: +plugin:ci-quickchick: <<: *ci-template-flambda + +plugin:ci-relation-algebra: + <<: *ci-template @@ -10,6 +10,7 @@ ## either amend this file and commit it, or contact the coqdev list Abhishek Anand <abhishek.anand.iitg@gmail.com> Abhishek Anand (@brixpro-home) <abhishek.anand.iitg@gmail.com> +Léo Andrès <leo@ndrs.fr> zapashcanon <leo@ndrs.fr> Jim Apple <github.public@jbapple.com> jbapple <github.public@jbapple.com> Bruno Barras <bruno.barras@inria.fr> barras <barras@85f007b7-540e-0410-9357-904b9bb8a0f7> Bruno Barras <bruno.barras@inria.fr> barras-local <barras-local@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -19,9 +20,11 @@ Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@inria.fr> Yves Bertot <yves.bertot@inria.fr> Yves Bertot <Yves.Bertot@inria.fr> Frédéric Besson <frederic.besson@inria.fr> fbesson <fbesson@85f007b7-540e-0410-9357-904b9bb8a0f7> Siddharth Bhat <siddu.druid@gmail.com> Siddharth <siddu.druid@gmail.com> +Simon Boulier <simon.boulier@ens-rennes.fr> SimonBoulier <simon.boulier@ens-rennes.fr> Pierre Boutillier <pierre.boutillier@ens-lyon.org> pboutill <pboutill@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre <pierre.boutillier@ens-lyon.org> Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre Boutillier <pierre.boutillier@pps.univ-paris-diderot.fr> +Arthur Charguéraud <arthur@chargueraud.org> charguer <arthur@chargueraud.org> Xavier Clerc <xavier.clerc@inria.fr> xclerc <xclerc@85f007b7-540e-0410-9357-904b9bb8a0f7> Xavier Clerc <xavier.clerc@inria.fr> xclerc <xavier.clerc@inria.fr> Pierre Corbineau <Pierre.Corbineau@NOSPAM@imag.fr> corbinea <corbinea@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -32,6 +35,7 @@ Maxime Dénès <mail@maximedenes.fr> mdenes <mdenes@85f007b7-540 Maxime Dénès <mail@maximedenes.fr> Maxime Denes <maximedenes@gillespie.inria.fr> Olivier Desmettre <desmettr@gforge> desmettr <desmettr@85f007b7-540e-0410-9357-904b9bb8a0f7> Damien Doligez <doligez@gforge> doligez <doligez@85f007b7-540e-0410-9357-904b9bb8a0f7> +İsmail Dönmez <ismail-s@users.noreply.github.com> Ismail <ismail-s@users.noreply.github.com> Andres Erbsen <andreser@mit.edu> Andres Erbsen <andres@kevix.co> Jim Fehrle <jfehrle@sbcglobal.net> Jim <jfehrle@sbcglobal.net> Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> filliatr <filliatr@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -63,11 +67,14 @@ Florent Kirchner <fkirchne@gforge> kirchner <kirchner@85f007b7-5 Johannes Kloos <jkloos@mpi-sws.org> jkloos <jkloos@mpi-sws.org> Matej Košík <matej.kosik@inria.fr> Matej Kosik <m4tej.kosik@gmail.com> Matej Košík <matej.kosik@inria.fr> Matej Kosik <matej.kosik@inria.fr> +Ambroise Lafont <chaster_killer@hotmail.fr> amblaf <you@example.com> +Ambroise Lafont <chaster_killer@hotmail.fr> Ambroise <chaster_killer@hotmail.fr> Vincent Laporte <Vincent.Laporte@fondation-inria.fr> Vincent Laporte <Vincent.Laporte@gmail.com> Marc Lasson <marc.lasson@gmail.com> mlasson <marc.lasson@gmail.com> William Lawvere <mundungus.corleone@gmail.com> william-lawvere <mundungus.corleone@gmail.com> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <letouzey@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <pierre.letouzey@inria.fr> +Xia Li-yao <lysxia@gmail.com> Lysxia <lysxia@gmail.com> Assia Mahboubi <assia.mahboubi@inria.fr> amahboub <amahboub@85f007b7-540e-0410-9357-904b9bb8a0f7> Evgeny Makarov <emakarov@gforge> emakarov <emakarov@85f007b7-540e-0410-9357-904b9bb8a0f7> Gregory Malecha <gmalecha@eecs.harvard.edu> Gregory Malecha <gmalecha@cs.harvard.edu> @@ -88,6 +95,7 @@ Russell O'Connor <roconnor@blockstream.io> roconnor-blockstream <roconno Christine Paulin <cpaulin@gforge> cpaulin <cpaulin@85f007b7-540e-0410-9357-904b9bb8a0f7> Christine Paulin <cpaulin@gforge> mohring <mohring@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> ppedrot <ppedrot@85f007b7-540e-0410-9357-904b9bb8a0f7> +Frederic Peschanski <frederic.peschanski@lip6.fr> fredokun <frederic.peschanski@lip6.fr> Clément Pit-Claudel <clement.pitclaudel@live.com> Clément Pit--Claudel <clement.pitclaudel@live.com> Loïc Pottier <pottier@gforge> pottier <pottier@85f007b7-540e-0410-9357-904b9bb8a0f7> Matthias Puech <puech@gforge> puech <puech@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -98,6 +106,7 @@ Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel De Rauglaudre <ddr@g Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> regisgia <regisgia@85f007b7-540e-0410-9357-904b9bb8a0f7> Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> Regis-Gianas <yrg@pps.univ-paris-diderot.fr> Clément Renard <clrenard@gforge> clrenard <clrenard@85f007b7-540e-0410-9357-904b9bb8a0f7> +Matthew Ryan <mr_1993@hotmail.co.uk> mrmr1993 <mr_1993@hotmail.co.uk> Claudio Sacerdoti Coen <sacerdot@gforge> sacerdot <sacerdot@85f007b7-540e-0410-9357-904b9bb8a0f7> Kazuhiko Sakaguchi <pi8027@gmail.com> Kazuhiko Sakaguchi <sakaguchi@coins.tsukuba.ac.jp> Vincent Siles <vsiles@gforge> vsiles <vsiles@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -108,6 +117,7 @@ Matthieu Sozeau <mattam@mattam.org> Matthieu Sozeau <matthieu.soz Matthieu Sozeau <mattam@mattam.org> Matthieu Sozeau <mattam@eduroam-prg-sg-1-46-137.net.univ-paris-diderot.fr> Arnaud Spiwack <arnaud@spiwack.net> aspiwack <aspiwack@85f007b7-540e-0410-9357-904b9bb8a0f7> Paul Steckler <steck@stecksoft.com> Paul Steckler <psteck@mit.edu> +Frank Steffahn <fdsteffahn@gmail.com> staffehn <fdsteffahn@gmail.com> Enrico Tassi <Enrico.Tassi@inria.fr> gareuselesinge <gareuselesinge@85f007b7-540e-0410-9357-904b9bb8a0f7> Enrico Tassi <Enrico.Tassi@inria.fr> Enrico Tassi <enrico.tassi@inria.fr> Enrico Tassi <Enrico.Tassi@inria.fr> Enrico Tassi <gares@fettunta.org> @@ -123,5 +133,8 @@ Théo Zimmermann <theo.zimmermann@univ-paris-diderot.fr> Théo Zimmermann <theo. # Anonymous accounts anonymous < > coq <coq@85f007b7-540e-0410-9357-904b9bb8a0f7> -anonymous < > (no author) <(no author)@85f007b7-540e-0410-9357-904b9bb8a0f7> -anonymous < > serpyc <serpyc@85f007b7-540e-0410-9357-904b9bb8a0f7> + +# Bot accounts + +cvs2svn < > (no author) <(no author)@85f007b7-540e-0410-9357-904b9bb8a0f7> +serpyc-bot < > serpyc <serpyc@85f007b7-540e-0410-9357-904b9bb8a0f7> diff --git a/.merlin.in b/.merlin.in index 4d646842d8..fa3473765d 100644 --- a/.merlin.in +++ b/.merlin.in @@ -1,4 +1,4 @@ -FLG -rectypes -thread -safe-string -w +a-4-9-27-41-42-44-45-48-50 +FLG -rectypes -thread -safe-string -w +a-4-9-27-41-42-44-45-48 S clib B clib diff --git a/.travis.yml b/.travis.yml index 02b94f4a8e..855d36048d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,17 +28,6 @@ env: matrix: include: - - env: - - TEST_TARGET="lint" - install: [] - before_script: [] - addons: - apt: - sources: [] - packages: [] - script: - - dev/lint-repository.sh - - os: osx env: - TEST_TARGET="test-suite" diff --git a/CHANGES.md b/CHANGES.md index 75a29de8e9..ae67eb5d1b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -46,6 +46,9 @@ Notations `Bind Scope`, `Delimit Scope`, `Undelimit Scope`, or `Notation` is deprecated. +- New command `String Notation` to register string syntax for custom + inductive types. + Plugins - The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) @@ -85,6 +88,14 @@ Vernacular commands - The `Automatic Introduction` option has been removed and is now the default. +- `Arguments` now accepts names for arguments provided with `extra_scopes`. + +- The naming scheme for anonymous binders in a `Theorem` has changed to + avoid conflicts with explicitly named binders. + +- Computation of implicit arguments now properly handles local definitions in the + binders for an `Instance`. + Tools - The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: @@ -127,10 +138,30 @@ Universes for the "Private Polymorphic Universes" option (and Unset it to get the previous behaviour). +Inductives + +- An option and attributes to control the automatic decision to + declare an inductive type as template polymorphic were added. + Warning "auto-template" will trigger when an inductive is + automatically declared template polymorphic without the attribute. + +Funind + +- Inductive types declared by Funind will never be template polymorphic. + Misc - Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. +SSReflect + +- New intro patterns: + - temporary introduction: => + + - block introduction: => [^ prefix ] [^~ suffix ] + - fast introduction: => > + - tactics as views: => /ltac:mytac + See the reference manual for the actual documentation. + Changes from 8.8.2 to 8.9+beta1 =============================== diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md index 8eee2009c9..0720cf6210 100644 --- a/CODE_OF_CONDUCT.md +++ b/CODE_OF_CONDUCT.md @@ -78,7 +78,8 @@ affect a person's ability to participate within them. If you believe someone is violating the code of conduct, we ask that you report it by emailing the Coq Code of Conduct enforcement team at -<coq-conduct@inria.fr>. Confidentiality with regard to the reporter of an +<coq-conduct@inria.fr> or, at your discretion, any member of the team. +Confidentiality with regard to the reporter of an incident will be maintained while dealing with it. In particular, you should seek support from the team instead of dealing by @@ -96,6 +97,11 @@ behavior is wrong). We consider short bans to form part of the pedagogical approach, especially when they come with explanatory comments, as this can give some time to the offender to calm down and think about their actions. +The members of the team are currently: + +- Matthieu Sozeau +- Théo Zimmermann + ## Questions? ## If you have questions, feel free to write to <coq-conduct@inria.fr>. diff --git a/META.coq.in b/META.coq.in index c2d3f85b9f..159984d87a 100644 --- a/META.coq.in +++ b/META.coq.in @@ -459,28 +459,16 @@ package "plugins" ( archive(native) = "int31_syntax_plugin.cmx" ) - package "asciisyntax" ( + package "string_notation" ( - description = "Coq asciisyntax plugin" + description = "Coq string_notation plugin" version = "8.10" requires = "" directory = "syntax" - archive(byte) = "ascii_syntax_plugin.cmo" - archive(native) = "ascii_syntax_plugin.cmx" - ) - - package "stringsyntax" ( - - description = "Coq stringsyntax plugin" - version = "8.10" - - requires = "coq.plugins.asciisyntax" - directory = "syntax" - - archive(byte) = "string_syntax_plugin.cmo" - archive(native) = "string_syntax_plugin.cmx" + archive(byte) = "string_notation_plugin.cmo" + archive(native) = "string_notation_plugin.cmx" ) package "derive" ( @@ -61,7 +61,8 @@ FIND_SKIP_DIRS:='(' \ -name 'user-contrib' -o \ -name 'test-suite' -o \ -name '.opamcache' -o \ - -name '.coq-native' \ + -name '.coq-native' -o \ + -name 'plugin_tutorial' \ ')' -prune -o define find @@ -191,7 +192,7 @@ META.coq: META.coq.in # Cleaning ########################################################################### -.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide mlgclean depclean cleanconfig distclean voclean timingclean alienclean +.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean plugin-tutorialclean clean-ide mlgclean depclean cleanconfig distclean voclean timingclean alienclean clean: objclean cruftclean depclean docclean camldevfilesclean gramlibclean @@ -237,7 +238,7 @@ docclean: rm -f doc/coq.tex rm -rf doc/sphinx/_build -archclean: clean-ide optclean voclean +archclean: clean-ide optclean voclean plugin-tutorialclean rm -rf _build rm -f $(ALLSTDLIB).* @@ -278,6 +279,9 @@ timingclean: -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" \ -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -exec rm -f {} + +plugin-tutorialclean: + +$(MAKE) -C $(PLUGINTUTO) clean + # Ensure that every compiled file around has a known source file. # This should help preventing weird compilation failures caused by leftover # compiled files after deleting or moving some source files. diff --git a/Makefile.build b/Makefile.build index ec9b81dba4..34d7ce42f7 100644 --- a/Makefile.build +++ b/Makefile.build @@ -44,6 +44,9 @@ NO_RECALC_DEPS ?= # Non-empty runs the checker on all produced .vo files: VALIDATE ?= +# When non-empty, passed as extra arguments to coqtop/coqc: +COQUSERFLAGS ?= + # Output file names for timed builds TIME_OF_BUILD_FILE ?= time-of-build.log TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log @@ -191,7 +194,7 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # the output format of the unix command time. For instance: # TIME="%C (%U user, %S sys, %e total, %M maxres)" -COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) +COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) @@ -572,11 +575,11 @@ module Gramext = Gramlib__Gramext \ module Grammar = Gramlib__Grammar" > $@ gramlib/.pack/gramlib__P%: gramlib/p% | gramlib/.pack - cp -a $< $@ - sed -e "1i # 1 \"$<\"" -i $@ + printf '# 1 "%s"\n' $< > $@ + cat $< >> $@ gramlib/.pack/gramlib__G%: gramlib/g% | gramlib/.pack - cp -a $< $@ - sed -e "1i # 1 \"$<\"" -i $@ + printf '# 1 "%s"\n' $< > $@ + cat $< >> $@ # Specific rules for gramlib to pack it Dune / OCaml 4.08 style GRAMOBJS=$(addsuffix .cmo, $(GRAMFILES)) diff --git a/Makefile.ci b/Makefile.ci index 956e3ee58f..b8bff98f5f 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -27,7 +27,6 @@ CI_TARGETS= \ ci-fiat-crypto-legacy \ ci-fiat-parsers \ ci-flocq \ - ci-formal-topology \ ci-geocoq \ ci-coqhammer \ ci-hott \ @@ -37,13 +36,13 @@ CI_TARGETS= \ ci-math-comp \ ci-mtac2 \ ci-paramcoq \ - ci-plugin_tutorial \ ci-quickchick \ ci-relation-algebra \ ci-sf \ ci-simple-io \ ci-tlc \ ci-unimath \ + ci-verdi-raft \ ci-vst .PHONY: ci-all $(CI_TARGETS) @@ -60,10 +59,9 @@ ci-math-classes: ci-bignums ci-corn: ci-math-classes +ci-simple-io: ci-ext-lib ci-quickchick: ci-ext-lib ci-simple-io -ci-formal-topology: ci-corn - # Generic rule, we use make to ease CI integration $(CI_TARGETS): ci-%: +./dev/ci/ci-wrapper.sh $* diff --git a/Makefile.common b/Makefile.common index a59fbe676e..2dced04967 100644 --- a/Makefile.common +++ b/Makefile.common @@ -140,9 +140,8 @@ RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo SYNTAXCMO:=$(addprefix plugins/syntax/, \ r_syntax_plugin.cmo \ int31_syntax_plugin.cmo \ - ascii_syntax_plugin.cmo \ - string_syntax_plugin.cmo \ - numeral_notation_plugin.cmo) + numeral_notation_plugin.cmo \ + string_notation_plugin.cmo) DERIVECMO:=plugins/derive/derive_plugin.cmo LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo @@ -169,6 +168,8 @@ LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cmo=.cmx) ALLSTDLIB := test-suite/misc/universes/all_stdlib +PLUGINTUTO := doc/plugin_tutorial + # For emacs: # Local Variables: # mode: makefile diff --git a/Makefile.doc b/Makefile.doc index 9e6ec4955a..48cdcebddb 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -89,6 +89,10 @@ stdlib: \ full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf +.PHONY: plugin-tutorial +plugin-tutorial: states tools + +$(MAKE) COQBIN=$(PWD)/bin/ -C $(PLUGINTUTO) + ###################################################################### ### Implicit rules ###################################################################### diff --git a/Makefile.dune b/Makefile.dune index 2293c69c38..ee3e2d6cb7 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -1,7 +1,11 @@ # -*- mode: makefile -*- # Dune Makefile for Coq -.PHONY: help voboot states world watch check quickbyte quickopt test-suite release apidoc ocheck ireport clean +.PHONY: help voboot states world watch check # Main developer targets +.PHONY: coq coqide coqide-server # Package targets +.PHONY: quickbyte quickopt # Partial / quick developer targets +.PHONY: test-suite refman-html apidoc release # Accesory targets +.PHONY: ocheck trunk ireport clean # Maintenance targets # use DUNEOPT=--display=short for a more verbose build # DUNEOPT=--display=short @@ -10,16 +14,26 @@ BUILD_CONTEXT=_build/default help: @echo "Welcome to Coq's Dune-based build system. Targets are:" - @echo " - states: build a minimal functional coqtop" - @echo " - world: build all binaries and libraries" - @echo " - watch: build all binaries and libraries [continuous build]" - @echo " - check: build all ML files as fast as possible [requires Dune >= 1.5.0]" - @echo " - quickbyte: build main ML files [coqtop + plugins + ide + printers] using the bytecode compiler" - @echo " - quickopt: build main ML files [coqtop + plugins + ide + printers] using the optimizing compiler" - @echo " - test-suite: run Coq's test suite" - @echo " - release: build Coq in release mode" - @echo " - apidoc: build ML API documentation" + @echo "" + @echo " - states: build a minimal functional coqtop" + @echo " - world: build all binaries and libraries" + @echo " - watch: build all binaries and libraries [continuous build]" + @echo " - check: build all ML files as fast as possible" + @echo "" + @echo " - coq: build package Coq [toplevel compilers, tools, stdlib, no GTK]" + @echo " - coqide-server: build package coqide-server [XML protocol language server]" + @echo " - coqide: build package CoqIDE [gtk application]" + @echo "" + @echo " - quickbyte: build main ML files [coqtop + plugins + ide + printers] using the bytecode compiler" + @echo " - quickopt: build main ML files [coqtop + plugins + ide + printers] using the optimizing compiler" + @echo "" + @echo " - test-suite: run Coq's test suite" + @echo " - refman-html: build Coq's reference manual [HTML version]" + @echo " - apidoc: build ML API documentation" + @echo " - release: build Coq in release mode" + @echo "" @echo " - ocheck: build for all supported OCaml versions [requires OPAM]" + @echo " - trunk: build with a configuration compatible with OCaml trunk" @echo " - ireport: build with optimized flambda settings and emit an inline report" @echo " - clean: remove build directory and autogenerated files" @echo " - help: show this message" @@ -34,6 +48,15 @@ states: voboot world: voboot dune build $(DUNEOPT) @install +coq: voboot + dune build $(DUNEOPT) coq.install + +coqide: voboot + dune build $(DUNEOPT) coqide.install + +coqide-server: voboot + dune build $(DUNEOPT) coqide-server.install + watch: voboot dune build $(DUNEOPT) @install -w @@ -55,15 +78,23 @@ quickopt: voboot test-suite: voboot dune runtest $(DUNEOPT) -release: voboot - dune build $(DUNEOPT) -p coq +refman-html: voboot + dune build @refman-html apidoc: voboot dune build $(DUNEOPT) @doc +release: voboot + dune build $(DUNEOPT) -p coq + ocheck: voboot dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all +trunk: + dune build $(DUNEOPT) --profile=ocaml408 @vodeps + dune exec coq_dune $(BUILD_CONTEXT)/.vfiles.d + dune build $(DUNEOPT) --profile=ocaml408 coq.install coqide-server.install + ireport: dune clean dune build $(DUNEOPT) @vodeps --profile=ireport @@ -73,11 +104,11 @@ ireport: clean: dune clean -# Other common dev targets +# Other common dev targets: # # dune build coq.install -# dune build ide/coqide.install - +# dune build coqide.install +# # Packaging / OPAM targets: # # dune -p coq @install @@ -1,6 +1,7 @@ # Coq -[](https://gitlab.com/coq/coq/commits/master) +[](https://gitlab.com/coq/coq/commits/master) +[](https://dev.azure.com/coq/coq/_build/latest?definitionId=1?branchName=master) [](https://travis-ci.org/coq/coq/builds) [](https://ci.appveyor.com/project/coq/coq/branch/master) [](https://gitter.im/coq/coq) diff --git a/azure-pipelines.yml b/azure-pipelines.yml new file mode 100644 index 0000000000..e217601ae2 --- /dev/null +++ b/azure-pipelines.yml @@ -0,0 +1,31 @@ + +pool: + vmImage: 'vs2017-win2016' + +steps: +- checkout: self + fetchDepth: 10 + +# cygwin package list not checked for minimality +- script: | + powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" + SET CYGROOT=C:\cygwin64 + SET CYGCACHE=%CYGROOT%\var\cache\setup + setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python + + SET TARGET_ARCH=x86_64-w64-mingw32 + SET CD_MFMT=%cd:\=/% + SET RESULT_INSTALLDIR_CFMT=%CD_MFMT:C:/=/cygdrive/c/% + C:\cygwin64\bin\bash -l %cd%\dev\build\windows\configure_profile.sh + displayName: 'Install cygwin' + env: + CYGMIRROR: "http://mirror.easyname.at/cygwin" + +- script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-opam.sh + displayName: 'Install opam' + +- script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-build.sh + displayName: 'Build Coq' + +- script: C:\cygwin64\bin\bash -l %cd%\dev\ci\azure-test.sh + displayName: 'Test Coq' diff --git a/checker/analyze.ml b/checker/analyze.ml index 7047d8a149..63324bff20 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -396,7 +396,7 @@ let parse_string s = PString.parse (s, ref 0) let instantiate (p, mem) = let len = LargeArray.length mem in let ans = LargeArray.make len (Obj.repr 0) in - (** First pass: initialize the subobjects *) + (* First pass: initialize the subobjects *) for i = 0 to len - 1 do let obj = match LargeArray.get mem i with | Struct (tag, blk) -> Obj.new_block tag (Array.length blk) @@ -408,9 +408,9 @@ let instantiate (p, mem) = | Int n -> Obj.repr n | Ptr p -> LargeArray.get ans p | Atm tag -> Obj.new_block tag 0 - | Fun _ -> assert false (** We shouldn't serialize closures *) + | Fun _ -> assert false (* We shouldn't serialize closures *) in - (** Second pass: set the pointers *) + (* Second pass: set the pointers *) for i = 0 to len - 1 do match LargeArray.get mem i with | Struct (_, blk) -> diff --git a/checker/analyze.mli b/checker/analyze.mli index 9c837643fa..d7770539df 100644 --- a/checker/analyze.mli +++ b/checker/analyze.mli @@ -30,6 +30,7 @@ sig type t val input_byte : t -> int (** Input a single byte *) + val input_binary_int : t -> int (** Input a big-endian 31-bits signed integer *) end diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 4e026d6f60..c823db956d 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -8,264 +8,155 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Sorts -open Pp open Declarations open Environ open Names -open CErrors open Univ open Util -open Constr -let check_kind env ar u = - match Constr.kind (snd (Reduction.dest_prod env ar)) with - | Sort (Sorts.Type u') when Univ.Universe.equal u' (Univ.Universe.make u) -> () - | _ -> failwith "not the correct sort" +[@@@ocaml.warning "+9+27"] -let check_polymorphic_arity env params par = - let pl = par.template_param_levels in - let rec check_p env pl params = - let open Context.Rel.Declaration in - match pl, params with - Some u::pl, LocalAssum (na,ty)::params -> - check_kind env ty u; - check_p (push_rel (LocalAssum (na,ty)) env) pl params - | None::pl,d::params -> check_p (push_rel d env) pl params - | [], _ -> () - | _ -> failwith "check_poly: not the right number of params" in - check_p env pl (List.rev params) +exception InductiveMismatch of MutInd.t * string -let conv_ctxt_prefix env (ctx1:rel_context) ctx2 = - let rec chk env rctx1 rctx2 = - let open Context.Rel.Declaration in - match rctx1, rctx2 with - (LocalAssum (_,ty1) as d1)::rctx1', LocalAssum (_,ty2)::rctx2' -> - Reduction.conv env ty1 ty2; - chk (push_rel d1 env) rctx1' rctx2' - | (LocalDef (_,bd1,ty1) as d1)::rctx1', LocalDef (_,bd2,ty2)::rctx2' -> - Reduction.conv env ty1 ty2; - Reduction.conv env bd1 bd2; - chk (push_rel d1 env) rctx1' rctx2' - | [],_ -> () - | _ -> failwith "non convertible contexts" in - chk env (List.rev ctx1) (List.rev ctx2) +let check mind field b = if not b then raise (InductiveMismatch (mind,field)) -(* check information related to inductive arity *) -let typecheck_arity env params inds = - let nparamargs = Context.Rel.nhyps params in - let nparamdecls = Context.Rel.length params in - let check_arity arctxt = function - | RegularArity mar -> - let ar = mar.mind_user_arity in - let _ = Typeops.infer_type env ar in - Reduction.conv env (Term.it_mkProd_or_LetIn (Constr.mkSort mar.mind_sort) arctxt) ar; - ar - | TemplateArity par -> - check_polymorphic_arity env params par; - Term.it_mkProd_or_LetIn (Constr.mkSort(Sorts.Type par.template_level)) arctxt +let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = + let open Entries in + let nparams = List.length mb.mind_params_ctxt in (* include letins *) + let mind_entry_record = match mb.mind_record with + | NotRecord -> None | FakeRecord -> Some None + | PrimRecord data -> Some (Some (Array.map pi1 data)) in - let env_arities = - Array.fold_left - (fun env_ar ind -> - let ar_ctxt = ind.mind_arity_ctxt in - let _ = Typeops.check_context env ar_ctxt in - conv_ctxt_prefix env params ar_ctxt; - (* Arities (with params) are typed-checked here *) - let arity = check_arity ar_ctxt ind.mind_arity in - (* mind_nrealargs *) - let nrealargs = Context.Rel.nhyps ar_ctxt - nparamargs in - if ind.mind_nrealargs <> nrealargs then - failwith "bad number of real inductive arguments"; - let nrealargs_ctxt = Context.Rel.length ar_ctxt - nparamdecls in - if ind.mind_nrealdecls <> nrealargs_ctxt then - failwith "bad length of real inductive arguments signature"; - (* We do not need to generate the universe of full_arity; if - later, after the validation of the inductive definition, - full_arity is used as argument or subject to cast, an - upper universe will be generated *) - let id = ind.mind_typename in - let env_ar' = push_rel (Context.Rel.Declaration.LocalAssum (Name id, arity)) env_ar in - env_ar') - env - inds in - let env_ar_par = push_rel_context params env_arities in - env_arities, env_ar_par - -(* Check that the subtyping information inferred for inductive types in the block is correct. *) -(* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) -let check_subtyping cumi paramsctxt env arities = - let numparams = Context.Rel.nhyps paramsctxt in - (** In [env] we already have [ Var(0) ... Var(n-1) |- cst ] available. - We must produce the substitution σ : [ Var(i) -> Var (i + n) | 0 <= i < n] - and push the constraints [ Var(n) ... Var(2n - 1) |- cst{σ} ], together - with the cumulativity constraints [ cumul_cst ]. *) - let uctx = ACumulativityInfo.univ_context cumi in - let len = AUContext.size uctx in - let inst = Instance.of_array @@ Array.init len (fun i -> Level.var (i + len)) in - - let other_context = ACumulativityInfo.univ_context cumi in - let uctx_other = UContext.make (inst, AUContext.instantiate inst other_context) in - let cumul_cst = - Array.fold_left_i (fun i csts var -> - match var with - | Variance.Irrelevant -> csts - | Variance.Covariant -> Constraint.add (Level.var i,Le,Level.var (i+len)) csts - | Variance.Invariant -> Constraint.add (Level.var i,Eq,Level.var (i+len)) csts) - Constraint.empty (ACumulativityInfo.variance cumi) + let mind_entry_universes = match mb.mind_universes with + | Monomorphic_ind univs -> Monomorphic_ind_entry univs + | Polymorphic_ind auctx -> Polymorphic_ind_entry (AUContext.names auctx, AUContext.repr auctx) + | Cumulative_ind auctx -> + Cumulative_ind_entry (AUContext.names (ACumulativityInfo.univ_context auctx), + ACumulativityInfo.repr auctx) in - let env = Environ.push_context uctx_other env in - let env = Environ.add_constraints cumul_cst env in - let dosubst = Vars.subst_instance_constr inst in - (* process individual inductive types: *) - Array.iter (fun { mind_user_lc = lc; mind_arity = arity } -> - match arity with - | RegularArity { mind_user_arity = full_arity} -> - Indtypes.check_subtyping_arity_constructor env dosubst full_arity numparams true; - Array.iter (fun cnt -> Indtypes.check_subtyping_arity_constructor env dosubst cnt numparams false) lc - | TemplateArity _ -> - anomaly ~label:"check_subtyping" - Pp.(str "template polymorphism and cumulative polymorphism are not compatible") - ) arities - -(* An inductive definition is a "unit" if it has only one constructor - and that all arguments expected by this constructor are - logical, this is the case for equality, conjunction of logical properties -*) -let is_unit constrsinfos = - match constrsinfos with (* One info = One constructor *) - | [|constrinfos|] -> Univ.is_type0m_univ constrinfos - | [||] -> (* type without constructors *) true - | _ -> false - -let small_unit constrsinfos = - let issmall = Array.for_all Univ.is_small_univ constrsinfos - and isunit = is_unit constrsinfos in - issmall, isunit - -let all_sorts = [InProp;InSet;InType] -let small_sorts = [InProp;InSet] -let logical_sorts = [InProp] - -let allowed_sorts issmall isunit s = - match Sorts.family s with - (* Type: all elimination allowed *) - | InType -> all_sorts - - (* Small Set is predicative: all elimination allowed *) - | InSet when issmall -> all_sorts + let mind_entry_inds = Array.map_to_list (fun ind -> + let mind_entry_arity, mind_entry_template = match ind.mind_arity with + | RegularArity ar -> + let ctx, arity = Term.decompose_prod_n_assum nparams ar.mind_user_arity in + ignore ctx; (* we will check that the produced user_arity is equal to the input *) + arity, false + | TemplateArity ar -> + let ctx = ind.mind_arity_ctxt in + let ctx = List.firstn (List.length ctx - nparams) ctx in + Term.mkArity (ctx, Sorts.sort_of_univ ar.template_level), true + in + { + mind_entry_typename = ind.mind_typename; + mind_entry_arity; + mind_entry_template; + mind_entry_consnames = Array.to_list ind.mind_consnames; + mind_entry_lc = Array.map_to_list (fun c -> + let ctx, c = Term.decompose_prod_n_assum nparams c in + ignore ctx; (* we will check that the produced user_lc is equal to the input *) + c + ) ind.mind_user_lc; + }) + mb.mind_packets + in + { + mind_entry_record; + mind_entry_finite = mb.mind_finite; + mind_entry_params = mb.mind_params_ctxt; + mind_entry_inds; + mind_entry_universes; + mind_entry_private = mb.mind_private; + } + +let check_arity env ar1 ar2 = match ar1, ar2 with + | RegularArity ar, RegularArity {mind_user_arity;mind_sort} -> + Constr.equal ar.mind_user_arity mind_user_arity && + Sorts.equal ar.mind_sort mind_sort + | TemplateArity ar, TemplateArity {template_param_levels;template_level} -> + List.equal (Option.equal Univ.Level.equal) ar.template_param_levels template_param_levels && + UGraph.check_leq (universes env) template_level ar.template_level + (* template_level is inferred by indtypes, so functor application can produce a smaller one *) + | (RegularArity _ | TemplateArity _), _ -> false + +(* Use [eq_ind_chk] because when we rebuild the recargs we have lost + the knowledge of who is the canonical version. + Try with to see test-suite/coqchk/include.v *) +let eq_recarg a1 a2 = match a1, a2 with + | Norec, Norec -> true + | Mrec i1, Mrec i2 -> eq_ind_chk i1 i2 + | Imbr i1, Imbr i2 -> eq_ind_chk i1 i2 + | (Norec | Mrec _ | Imbr _), _ -> false + +let eq_reloc_tbl = Array.equal (fun x y -> Int.equal (fst x) (fst y) && Int.equal (snd x) (snd y)) + +let check_packet env mind ind + { mind_typename; mind_arity_ctxt; mind_arity; mind_consnames; mind_user_lc; + mind_nrealargs; mind_nrealdecls; mind_kelim; mind_nf_lc; + mind_consnrealargs; mind_consnrealdecls; mind_recargs; mind_nb_constant; + mind_nb_args; mind_reloc_tbl } = + let check = check mind in + + ignore mind_typename; (* passed through *) + check "mind_arity_ctxt" (Context.Rel.equal Constr.equal ind.mind_arity_ctxt mind_arity_ctxt); + check "mind_arity" (check_arity env ind.mind_arity mind_arity); + ignore mind_consnames; (* passed through *) + check "mind_user_lc" (Array.equal Constr.equal ind.mind_user_lc mind_user_lc); + check "mind_nrealargs" Int.(equal ind.mind_nrealargs mind_nrealargs); + check "mind_nrealdecls" Int.(equal ind.mind_nrealdecls mind_nrealdecls); + check "mind_kelim" (List.equal Sorts.family_equal ind.mind_kelim mind_kelim); + + check "mind_nf_lc" (Array.equal Constr.equal ind.mind_nf_lc mind_nf_lc); + (* NB: here syntactic equality is not just an optimisation, we also + care about the shape of the terms *) + + check "mind_consnrealargs" (Array.equal Int.equal ind.mind_consnrealargs mind_consnrealargs); + check "mind_consnrealdecls" (Array.equal Int.equal ind.mind_consnrealdecls mind_consnrealdecls); + + check "mind_recargs" (Rtree.equal eq_recarg ind.mind_recargs mind_recargs); + + check "mind_nb_args" Int.(equal ind.mind_nb_args mind_nb_args); + check "mind_nb_constant" Int.(equal ind.mind_nb_constant mind_nb_constant); + check "mind_reloc_tbl" (eq_reloc_tbl ind.mind_reloc_tbl mind_reloc_tbl); - (* Large Set is necessarily impredicative: forbids large elimination *) - | InSet -> small_sorts + () - (* Unitary/empty Prop: elimination to all sorts are realizable *) - (* unless the type is large. If it is large, forbids large elimination *) - (* which otherwise allows simulating the inconsistent system Type:Type *) - | InProp when isunit -> if issmall then all_sorts else small_sorts +let check_same_record r1 r2 = match r1, r2 with + | NotRecord, NotRecord | FakeRecord, FakeRecord -> true + | PrimRecord r1, PrimRecord r2 -> + (* The kernel doesn't care about the names, we just need to check + that the saved types are correct. *) + Array.for_all2 (fun (_,_,tys1) (_,_,tys2) -> + Array.equal Constr.equal tys1 tys2) + r1 r2 + | (NotRecord | FakeRecord | PrimRecord _), _ -> false + +let check_inductive env mind mb = + let entry = to_entry mb in + let { mind_packets; mind_record; mind_finite; mind_ntypes; mind_hyps; + mind_nparams; mind_nparams_rec; mind_params_ctxt; mind_universes; + mind_private; mind_typing_flags; } + = + (* Locally set the oracle for further typechecking *) + let env = Environ.set_oracle env mb.mind_typing_flags.conv_oracle in + Indtypes.check_inductive env mind entry + in + let check = check mind in - (* Other propositions: elimination only to Prop *) - | InProp -> logical_sorts + Array.iter2 (check_packet env mind) mb.mind_packets mind_packets; + check "mind_record" (check_same_record mb.mind_record mind_record); + check "mind_finite" (mb.mind_finite == mind_finite); + check "mind_ntypes" Int.(equal mb.mind_ntypes mind_ntypes); + check "mind_hyps" (Context.Named.equal Constr.equal mb.mind_hyps mind_hyps); + check "mind_nparams" Int.(equal mb.mind_nparams mind_nparams); -let check_predicativity env s small level = - match s, engagement env with - Type u, _ -> - (* let u' = fresh_local_univ () in *) - (* let cst = *) - (* merge_constraints (enforce_leq u u' empty_constraint) *) - (* (universes env) in *) - if not (UGraph.check_leq (universes env) level u) then - failwith "impredicative Type inductive type" - | Set, ImpredicativeSet -> () - | Set, _ -> - if not small then failwith "impredicative Set inductive type" - | Prop,_ -> () + check "mind_nparams_rec" (mb.mind_nparams_rec <= mind_nparams_rec); + (* module substitution can increase the real number of recursively + uniform parameters, so be tolerant and use [<=]. *) -let sort_of_ind = function - | RegularArity mar -> mar.mind_sort - | TemplateArity par -> Type par.template_level + check "mind_params_ctxt" (Context.Rel.equal Constr.equal mb.mind_params_ctxt mind_params_ctxt); + ignore mind_universes; (* Indtypes did the necessary checking *) + ignore mind_private; (* passed through Indtypes *) -let compute_elim_sorts env_ar params arity lc = - let inst = Context.Rel.to_extended_list Constr.mkRel 0 params in - let env_params = push_rel_context params env_ar in - let lc = Array.map - (fun c -> - Reduction.hnf_prod_applist env_params (Vars.lift (Context.Rel.length params) c) inst) - lc in - let s = sort_of_ind arity in - let infos = Array.map (Indtypes.infos_and_sort env_params) lc in - let (small,unit) = small_unit infos in - (* We accept recursive unit types... *) - (* compute the max of the sorts of the products of the constructor type *) - let min = if Array.length lc > 1 then Universe.type0 else Universe.type0m in - let level = Array.fold_left (fun max l -> Universe.sup max l) min infos in - check_predicativity env_ar s small level; - allowed_sorts small unit s + ignore mind_typing_flags; + (* TODO non oracle flags *) -let typecheck_one_inductive env params mip = - (* mind_typename and mind_consnames not checked *) - (* mind_reloc_tbl, mind_nb_constant, mind_nb_args not checked (VM) *) - (* mind_arity_ctxt, mind_arity, mind_nrealargs DONE (typecheck_arity) *) - (* mind_user_lc *) - let _ = Array.map (Typeops.infer_type env) mip.mind_user_lc in - (* mind_nf_lc *) - let _ = Array.map (Typeops.infer_type env) mip.mind_nf_lc in - Array.iter2 (Reduction.conv env) mip.mind_nf_lc mip.mind_user_lc; - (* mind_consnrealdecls *) - let check_cons_args c n = - let ctx,_ = Term.decompose_prod_assum c in - if n <> Context.Rel.length ctx - Context.Rel.length params then - failwith "bad number of real constructor arguments" in - Array.iter2 check_cons_args mip.mind_nf_lc mip.mind_consnrealdecls; - (* mind_kelim: checked by positivity criterion ? *) - let sorts = - compute_elim_sorts env params mip.mind_arity mip.mind_nf_lc in - let reject_sort s = not (List.mem_f Sorts.family_equal s sorts) in - if List.exists reject_sort mip.mind_kelim then - failwith "elimination not allowed"; - (* mind_recargs: checked by positivity criterion *) - () - -let check_inductive env kn mib = - Flags.if_verbose Feedback.msg_notice (str " checking mutind block: " ++ MutInd.print kn); - (* check mind_constraints: should be consistent with env *) - let env0 = - match mib.mind_universes with - | Monomorphic_ind _ -> env - | Polymorphic_ind auctx -> - let uctx = Univ.AUContext.repr auctx in - Environ.push_context uctx env - | Cumulative_ind cumi -> - let uctx = Univ.AUContext.repr (Univ.ACumulativityInfo.univ_context cumi) in - Environ.push_context uctx env - in - (** Locally set the oracle for further typechecking *) - let env0 = Environ.set_oracle env0 mib.mind_typing_flags.conv_oracle in - (* check mind_record : TODO ? check #constructor = 1 ? *) - (* check mind_finite : always OK *) - (* check mind_ntypes *) - if Array.length mib.mind_packets <> mib.mind_ntypes then - user_err Pp.(str "not the right number of packets"); - (* check mind_params_ctxt *) - let params = mib.mind_params_ctxt in - let _ = Typeops.check_context env0 params in - (* check mind_nparams *) - if Context.Rel.nhyps params <> mib.mind_nparams then - user_err Pp.(str "number the right number of parameters"); - (* mind_packets *) - (* - check arities *) - let env_ar, env_ar_par = typecheck_arity env0 params mib.mind_packets in - (* - check constructor types *) - Array.iter (typecheck_one_inductive env_ar params) mib.mind_packets; - (* check the inferred subtyping relation *) - let () = - match mib.mind_universes with - | Monomorphic_ind _ | Polymorphic_ind _ -> () - | Cumulative_ind acumi -> - check_subtyping acumi params env_ar mib.mind_packets - in - (* check mind_nparams_rec: positivity condition *) - let packets = Array.map (fun p -> (p.mind_typename, Array.to_list p.mind_consnames, p.mind_user_lc, (p.mind_arity_ctxt,p.mind_arity))) mib.mind_packets in - let _ = Indtypes.check_positivity ~chkpos:true kn env_ar_par mib.mind_params_ctxt mib.mind_finite packets in - (* check mind_equiv... *) - (* Now we can add the inductive *) - add_mind kn mib env + add_mind mind mb env diff --git a/checker/checkInductive.mli b/checker/checkInductive.mli index 17ca0d4583..ab54190967 100644 --- a/checker/checkInductive.mli +++ b/checker/checkInductive.mli @@ -8,10 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(*i*) open Names open Environ -(*i*) + +exception InductiveMismatch of MutInd.t * string +(** Some field of the inductive is different from what the kernel infers. *) (*s The following function does checks on inductive declarations. *) diff --git a/checker/checker.ml b/checker/checker.ml index da6a61de1c..167258f8bb 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -302,6 +302,10 @@ let explain_exn = function (* let ctx = Check.get_env() in hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error ctx e)*) + + | CheckInductive.InductiveMismatch (mind,field) -> + hov 0 (MutInd.print mind ++ str ": field " ++ str field ++ str " is incorrect.") + | Assert_failure (s,b,e) -> hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ (if s = "" then mt () diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index b83fe831bb..086dd17e39 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -10,10 +10,10 @@ open Environ let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ Constant.print kn); - (** Locally set the oracle for further typechecking *) + (* Locally set the oracle for further typechecking *) let oracle = env.env_typing_flags.conv_oracle in let env = Environ.set_oracle env cb.const_typing_flags.conv_oracle in - (** [env'] contains De Bruijn universe variables *) + (* [env'] contains De Bruijn universe variables *) let poly, env' = match cb.const_universes with | Monomorphic_const ctx -> false, push_context_set ~strict:true ctx env @@ -40,7 +40,7 @@ let check_constant_declaration env kn cb = if poly then add_constant kn cb env else add_constant kn cb env' in - (** Reset the value of the oracle *) + (* Reset the value of the oracle *) Environ.set_oracle env oracle (** {6 Checking modules } *) diff --git a/checker/values.ml b/checker/values.ml index 863f965896..1afe764ca4 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -168,8 +168,10 @@ let v_section_ctxt = v_enum "emptylist" 1 (** kernel/mod_subst *) +let v_univ_abstracted v = v_tuple "univ_abstracted" [|v;v_abs_context|] + let v_delta_hint = - v_sum "delta_hint" 0 [|[|Int; Opt (v_pair v_abs_context v_constr)|];[|v_kn|]|] + v_sum "delta_hint" 0 [|[|Int; Opt (v_univ_abstracted v_constr)|];[|v_kn|]|] let v_resolver = v_tuple "delta_resolver" diff --git a/checker/votour.ml b/checker/votour.ml index 1ea0de456e..3c088b59b5 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -366,7 +366,7 @@ let visit_vo f = |] in let repr = if Sys.word_size = 64 then (module ReprMem : S) else (module ReprObj : S) - (** On 32-bit machines, representation may exceed the max size of arrays *) + (* On 32-bit machines, representation may exceed the max size of arrays *) in let module Repr = (val repr : S) in let module Visit = Visit(Repr) in diff --git a/clib/backtrace.ml b/clib/backtrace.ml index 27ed6fbf72..64faa5fd2e 100644 --- a/clib/backtrace.ml +++ b/clib/backtrace.ml @@ -87,8 +87,8 @@ let get_backtrace e = let add_backtrace e = if !is_recording then - (** This must be the first function call, otherwise the stack may be - destroyed *) + (* This must be the first function call, otherwise the stack may be + destroyed *) let current = get_exception_backtrace () in let info = Exninfo.info e in begin match current with diff --git a/clib/bigint.mli b/clib/bigint.mli index ac66b41fb7..88297c353d 100644 --- a/clib/bigint.mli +++ b/clib/bigint.mli @@ -25,6 +25,7 @@ val one : bigint val two : bigint val div2_with_rest : bigint -> bigint * bool (** true=odd; false=even *) + val add_1 : bigint -> bigint val sub_1 : bigint -> bigint val mult_2 : bigint -> bigint diff --git a/clib/cArray.ml b/clib/cArray.ml index c3a693ff16..e0a1859184 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -451,7 +451,7 @@ struct end done; if !i < len then begin - (** The array is not the same as the original one *) + (* The array is not the same as the original one *) let ans : 'a array = Array.copy ar in let v = match !temp with None -> assert false | Some x -> x in Array.unsafe_set ans !i v; @@ -483,7 +483,7 @@ struct end done; if !i < len then begin - (** The array is not the same as the original one *) + (* The array is not the same as the original one *) let ans : 'a array = Array.copy ar in let v = match !temp with None -> assert false | Some x -> x in Array.unsafe_set ans !i v; @@ -504,7 +504,7 @@ struct let i = ref 0 in let break = ref true in let r = ref accu in - (** This variable is never accessed unset *) + (* This variable is never accessed unset *) let temp = ref None in while !break && (!i < len) do let v = Array.unsafe_get ar !i in @@ -539,7 +539,7 @@ struct let i = ref 0 in let break = ref true in let r = ref accu in - (** This variable is never accessed unset *) + (* This variable is never accessed unset *) let temp = ref None in while !break && (!i < len) do let v = Array.unsafe_get ar !i in @@ -620,7 +620,7 @@ struct end done; if !i < len then begin - (** The array is not the same as the original one *) + (* The array is not the same as the original one *) let ans : 'a array = Array.copy ar in let v = match !temp with None -> assert false | Some x -> x in Array.unsafe_set ans !i v; diff --git a/clib/cSig.mli b/clib/cSig.mli index fb36cc5b51..859018ca4b 100644 --- a/clib/cSig.mli +++ b/clib/cSig.mli @@ -83,6 +83,7 @@ sig val choose: 'a t -> (key * 'a) val split: key -> 'a t -> 'a t * 'a option * 'a t val find: key -> 'a t -> 'a + val find_opt : key -> 'a t -> 'a option val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end diff --git a/clib/cString.mli b/clib/cString.mli index a73c2729d0..364b6a34b1 100644 --- a/clib/cString.mli +++ b/clib/cString.mli @@ -31,8 +31,8 @@ sig (** [implode [s1; ...; sn]] returns [s1 ^ ... ^ sn] *) val strip : string -> string - (** Alias for [String.trim] *) [@@ocaml.deprecated "Use [trim]"] + (** Alias for [String.trim] *) val drop_simple_quotes : string -> string (** Remove the eventual first surrounding simple quotes of a string. *) @@ -53,8 +53,8 @@ sig (** Generate the ordinal number in English. *) val split : char -> string -> string list - (** [split c s] alias of [String.split_on_char] *) [@@ocaml.deprecated "Use [split_on_char]"] + (** [split c s] alias of [String.split_on_char] *) val is_sub : string -> string -> int -> bool (** [is_sub p s off] tests whether [s] contains [p] at offset [off]. *) diff --git a/clib/exninfo.ml b/clib/exninfo.ml index 2d13049882..78ebd81f7e 100644 --- a/clib/exninfo.ml +++ b/clib/exninfo.ml @@ -89,18 +89,18 @@ let find_and_remove () = let info e = let (src, data) = find_and_remove () in if src == e then - (** Slightly unsound, some exceptions may not be unique up to pointer - equality. Though, it should be quite exceptional to be in a situation - where the following holds: - - 1. An argument-free exception is raised through the enriched {!raise}; - 2. It is not captured by any enriched with-clause (which would reset - the current data); - 3. The same exception is raised through the standard raise, accessing - the wrong data. + (* Slightly unsound, some exceptions may not be unique up to pointer + equality. Though, it should be quite exceptional to be in a situation + where the following holds: + + 1. An argument-free exception is raised through the enriched {!raise}; + 2. It is not captured by any enriched with-clause (which would reset + the current data); + 3. The same exception is raised through the standard raise, accessing + the wrong data. . *) data else - (** Mismatch: the raised exception is not the one stored, either because the - previous raise was not instrumented, or because something went wrong. *) + (* Mismatch: the raised exception is not the one stored, either because the + previous raise was not instrumented, or because something went wrong. *) Store.empty diff --git a/clib/hMap.ml b/clib/hMap.ml index 9c80398e4d..5d634b7af0 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -353,6 +353,12 @@ struct let m = Int.Map.find h s in Map.find k m + let find_opt k s = + let h = M.hash k in + match Int.Map.find_opt h s with + | None -> None + | Some m -> Map.find_opt k m + let get k s = try find k s with Not_found -> assert false let split k s = assert false (** Cannot be implemented efficiently *) diff --git a/clib/hMap.mli b/clib/hMap.mli index b26d0e04e3..ab2a6bbf15 100644 --- a/clib/hMap.mli +++ b/clib/hMap.mli @@ -13,6 +13,7 @@ sig type t val compare : t -> t -> int (** Total ordering *) + val hash : t -> int (** Hashing function compatible with [compare], i.e. [compare x y = 0] implies [hash x = hash y]. *) diff --git a/clib/hashcons.mli b/clib/hashcons.mli index 223dd2a4d2..e97708cdf3 100644 --- a/clib/hashcons.mli +++ b/clib/hashcons.mli @@ -29,17 +29,21 @@ module type HashconsedType = type t (** Type of objects to hashcons. *) + type u (** Type of hashcons functions for the sub-structures contained in [t]. Usually a tuple of functions. *) + val hashcons : u -> t -> t (** The actual hashconsing function, using its fist argument to recursively hashcons substructures. It should be compatible with [eq], that is [eq x (hashcons f x) = true]. *) + val eq : t -> t -> bool (** A comparison function. It is allowed to use physical equality on the sub-terms hashconsed by the [hashcons] function, but it should be insensible to shallow copy of the compared object. *) + val hash : t -> int (** A hash function passed to the underlying hashtable structure. [hash] should be compatible with [eq], i.e. if [eq x y = true] then @@ -50,14 +54,19 @@ module type S = sig type t (** Type of objects to hashcons. *) + type u (** Type of hashcons functions for the sub-structures contained in [t]. *) + type table (** Type of hashconsing tables *) + val generate : u -> table (** This create a hashtable of the hashconsed objects. *) + val hcons : table -> t -> t (** Perform the hashconsing of the given object within the table. *) + val stats : table -> Hashset.statistics (** Recover statistics of the hashconsing table. *) end diff --git a/clib/hashset.mli b/clib/hashset.mli index 0699d4e848..6ed93d5fe7 100644 --- a/clib/hashset.mli +++ b/clib/hashset.mli @@ -31,18 +31,23 @@ type statistics = { module type S = sig type elt (** Type of hashsets elements. *) + type t (** Type of hashsets. *) + val create : int -> t (** [create n] creates a fresh hashset with initial size [n]. *) + val clear : t -> unit (** Clear the contents of a hashset. *) + val repr : int -> elt -> t -> elt (** [repr key constr set] uses [key] to look for [constr] in the hashet [set]. If [constr] is in [set], returns the specific representation that is stored in [set]. Otherwise, [constr] is stored in [set] and will be used as the canonical representation of this value in the future. *) + val stats : t -> statistics (** Recover statistics on the table. *) end diff --git a/clib/int.ml b/clib/int.ml index 3ae836aec9..3924c152d6 100644 --- a/clib/int.ml +++ b/clib/int.ml @@ -41,6 +41,13 @@ struct if i < k then find i l else if i = k then v else find i r + + let rec find_opt i s = match map_prj s with + | MEmpty -> None + | MNode (l, k, v, r, h) -> + if i < k then find_opt i l + else if i = k then Some v + else find_opt i r end module List = struct @@ -114,8 +121,8 @@ struct let () = t := DSet (i, old, res) in res else match v with - | None -> t (** Nothing to do! *) - | Some _ -> (** we must resize *) + | None -> t (* Nothing to do! *) + | Some _ -> (* we must resize *) let nlen = next len (succ i) in let nlen = min nlen Sys.max_array_length in let () = assert (i < nlen) in diff --git a/clib/int.mli b/clib/int.mli index 76aecf057b..e02ca90916 100644 --- a/clib/int.mli +++ b/clib/int.mli @@ -33,10 +33,13 @@ sig type 'a t (** Persistent, auto-resizable arrays. The [get] and [set] functions never fail whenever the index is between [0] and [Sys.max_array_length - 1]. *) + val empty : int -> 'a t (** The empty array, with a given starting size. *) + val get : 'a t -> int -> 'a option (** Get a value at the given index. Returns [None] if undefined. *) + val set : 'a t -> int -> 'a option -> 'a t (** Set/unset a value at the given index. *) end diff --git a/clib/segmenttree.ml b/clib/segmenttree.ml index 24243b7a99..c3f1b44ef4 100644 --- a/clib/segmenttree.ml +++ b/clib/segmenttree.ml @@ -34,16 +34,16 @@ type elt = int integers which are _not_ in the set of keys handled by the tree. On leaves, a domain represents the st of integers which are in the set of keys. *) -type domain = - (** On internal nodes, a domain [Interval (a, b)] represents - the interval [a + 1; b - 1]. On leaves, it represents [a; b]. - We always have [a] <= [b]. *) +type domain = | Interval of elt * elt - (** On internal node or root, a domain [Universe] represents all - the integers. When the tree is not a trivial root, - [Universe] has no interpretation on leaves. (The lookup - function should never reach the leaves.) *) + (** On internal nodes, a domain [Interval (a, b)] represents + the interval [a + 1; b - 1]. On leaves, it represents [a; b]. + We always have [a] <= [b]. *) | Universe + (** On internal node or root, a domain [Universe] represents all + the integers. When the tree is not a trivial root, + [Universe] has no interpretation on leaves. (The lookup + function should never reach the leaves.) *) (** We use an array to store the almost complete tree. This array contains at least one element. *) @@ -71,26 +71,26 @@ let make segments = let tree = create nsegments (Universe, None) in let leaves_offset = (1 lsl (log2n nsegments)) - 1 in - (** The algorithm proceeds in two steps using an intermediate tree - to store minimum and maximum of each subtree as annotation of - the node. *) + (* The algorithm proceeds in two steps using an intermediate tree + to store minimum and maximum of each subtree as annotation of + the node. *) - (** We start from leaves: the last level of the tree is initialized - with the given segments... *) - list_iteri + (* We start from leaves: the last level of the tree is initialized + with the given segments... *) + list_iteri (fun i ((start, stop), value) -> let k = leaves_offset + i in let i = Interval (start, stop) in tree.(k) <- (i, Some i)) segments; - (** ... the remaining leaves are initialized with neutral information. *) + (* ... the remaining leaves are initialized with neutral information. *) for k = leaves_offset + nsegments to Array.length tree -1 do tree.(k) <- (Universe, Some Universe) done; - (** We traverse the tree bottom-up and compute the interval and - annotation associated to each node from the annotations of its - children. *) + (* We traverse the tree bottom-up and compute the interval and + annotation associated to each node from the annotations of its + children. *) for k = leaves_offset - 1 downto 0 do let node, annotation = match value_of (left_child k) tree, value_of (right_child k) tree with @@ -104,7 +104,7 @@ let make segments = tree.(k) <- (node, Some annotation) done; - (** Finally, annotation are replaced with the image related to each leaf. *) + (* Finally, annotation are replaced with the image related to each leaf. *) let final_tree = Array.mapi (fun i (segment, value) -> (segment, None)) tree in diff --git a/clib/trie.ml b/clib/trie.ml index ea43e9e0bd..96de2b920c 100644 --- a/clib/trie.ml +++ b/clib/trie.ml @@ -51,7 +51,7 @@ let next (Node (_,m)) lbl = T_codom.find lbl m let get (Node (hereset,_)) = hereset let labels (Node (_,m)) = - (** FIXME: this is order-dependent. Try to find a more robust presentation? *) + (* FIXME: this is order-dependent. Try to find a more robust presentation? *) List.rev (T_codom.fold (fun x _ acc -> x::acc) m []) let is_empty_node (Node(a,b)) = (X.is_nil a) && (T_codom.is_empty b) diff --git a/config/dune b/config/dune index cc993b97c9..c146e7df67 100644 --- a/config/dune +++ b/config/dune @@ -7,7 +7,7 @@ ; Dune doesn't use configure's output, but it is still necessary for ; some Coq files to work; will be fixed in the future. (rule - (targets coq_config.ml Makefile) + (targets coq_config.ml coq_config.py Makefile) (mode fallback) (deps %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run (env_var COQ_CONFIGURE_PREFIX)) (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no)))) diff --git a/configure.ml b/configure.ml index 2559e0a473..33f76078cf 100644 --- a/configure.ml +++ b/configure.ml @@ -610,10 +610,9 @@ let camltag = match caml_version_list with 44: "open" shadowing already defined identifier: too common, especially when some are aliases 45: "open" shadowing a label or constructor: see 44 48: implicit elimination of optional arguments: too common - 50: unexpected documentation comment: too common and annoying to avoid 58: "no cmx file was found in path": See https://github.com/ocaml/num/issues/9 *) -let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-50-58" +let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-58" let coq_warn_error = if !prefs.warn_error then "-warn-error +a" diff --git a/coq-refman.opam b/coq-refman.opam new file mode 100644 index 0000000000..b9500243a3 --- /dev/null +++ b/coq-refman.opam @@ -0,0 +1,39 @@ +synopsis: "The Coq Proof Assistant --- Reference Manual" +description: """ +Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +This package provides the Coq Reference Manual. +""" +opam-version: "2.0" +maintainer: "The Coq development team <coqdev@inria.fr>" +authors: "The Coq development team, INRIA, CNRS, and contributors." +homepage: "https://coq.inria.fr/" +bug-reports: "https://github.com/coq/coq/issues" +dev-repo: "https://github.com/coq/coq.git" +license: "Open Publication License" + +depends: [ + "dune" { build } + "coq" { build } +] + +build-env: [ + [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] +] + +build: [ + [ "dune" "build" "@refman" "-j" jobs ] +] + +# Would be better to have a *-conf package? +depexts: [ + [ "sphinx" ] + [ "sphinx_rtd_theme" ] + [ "beautifulsoup4" ] + [ "antlr4-python3-runtime"] + [ "pexpect" ] + [ "sphinxcontrib-bibtex" ] +] diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 8d728b5b51..cc76c44651 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -26,7 +26,7 @@ let pr_loc loc = let print_code fmt c = let loc = c.loc.loc_start in - (** Print the line location as a source annotation *) + (* Print the line location as a source annotation *) let padding = String.make (loc.pos_cnum - loc.pos_bol + 1) ' ' in let code_insert = asprintf "\n# %i \"%s\"\n%s%s" loc.pos_lnum loc.pos_fname padding c.code in fprintf fmt "@[@<0>%s@]@\n" code_insert @@ -471,16 +471,16 @@ let parse_rule self r = (symbs, vars, r.tac_body) let print_rules fmt (name, rules) = - (** Rules are reversed. *) + (* Rules are reversed. *) let rules = List.rev rules in let rules = List.map (fun r -> parse_rule name r) rules in let pr fmt l = print_list fmt (fun fmt r -> fprintf fmt "(%a)" GramExt.print_extrule r) l in match rules with | [([SymbEntry (e, None)], [Some s], { code = c } )] when String.trim c = s -> - (** This is a horrible hack to work aroud limitations of camlp5 regarding - 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. *) + (* This is a horrible hack to work aroud limitations of camlp5 regarding + 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 "@[Vernacextend.Arg_alias (%s)@]" e | _ -> fprintf fmt "@[Vernacextend.Arg_rules (%a)@]" pr rules diff --git a/default.nix b/default.nix index eeab388cb4..89d69cc40f 100644 --- a/default.nix +++ b/default.nix @@ -23,8 +23,8 @@ { pkgs ? (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/69522a0acf8e840e8b6ac0a9752a034ab74eb3c0.tar.gz"; - sha256 = "12k80gd4lkw9h9y1szvmh0jmh055g3b6wnphmx4ab1qdwlfaylnx"; + url = "https://github.com/NixOS/nixpkgs/archive/958a6c6dd39b0d6628e1408e798a8f1308f2f3e1.tar.gz"; + sha256 = "0vs6k4jn0rbdfzaxmh3xh64q213326680i9g3cjgr7l9y6h6m5sy"; }) {}) , ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_06 , buildIde ? true diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 33feeed45c..8489bcfc3a 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -55,7 +55,7 @@ IF DEFINED HTTP_PROXY ( )
REM see -cygrepo in ReadMe.txt
-SET CYGWIN_REPOSITORY=http://ftp.inf.tu-dresden.de/software/windows/cygwin32
+SET CYGWIN_REPOSITORY=http://mirror.easyname.at/cygwin
REM see -cygcache in ReadMe.txt
SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 6ca3aa2981..6663fbecf8 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -10,16 +10,21 @@ 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. + tests the compilation of several external developments. 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. - 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. + macOS. - AppVeyor is used to test the compilation of Coq and run the test-suite on Windows. +- Azure Pipelines is used to test the compilation of Coq and run the + test-suite on Windows. It is expected to replace appveyor eventually. + You can anticipate the results of most of these tests prior to submitting your PR by running GitLab CI on your private branches. To do so follow these steps: diff --git a/dev/ci/appveyor.bat b/dev/ci/appveyor.bat index 85a71baf7f..341b875edc 100644 --- a/dev/ci/appveyor.bat +++ b/dev/ci/appveyor.bat @@ -1,42 +1,42 @@ -REM This script either runs the test suite with OPAM (if USEOPAM is true) or -REM builds the Coq binary packages for windows (if USEOPAM is false). - -if %ARCH% == 32 ( - SET ARCHLONG=i686 - SET CYGROOT=C:\cygwin - SET SETUP=setup-x86.exe -) - -if %ARCH% == 64 ( - SET ARCHLONG=x86_64 - SET CYGROOT=C:\cygwin64 - SET SETUP=setup-x86_64.exe -) - -SET CYGCACHE=%CYGROOT%\var\cache\setup -SET APPVEYOR_BUILD_FOLDER_MFMT=%APPVEYOR_BUILD_FOLDER:\=/% -SET APPVEYOR_BUILD_FOLDER_CFMT=%APPVEYOR_BUILD_FOLDER_MFMT:C:/=/cygdrive/c/% -SET DESTCOQ=C:\coq%ARCH%_inst -SET COQREGTESTING=Y - -if %USEOPAM% == false ( - call %APPVEYOR_BUILD_FOLDER%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^ - -arch=%ARCH% -installer=Y -coqver=%APPVEYOR_BUILD_FOLDER_CFMT% ^ - -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ - -addon=bignums -make=N ^ - -setup %CYGROOT%\%SETUP% || GOTO ErrorExit - copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit - 7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit -) - -if %USEOPAM% == true ( - %CYGROOT%\%SETUP% -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% ^ - -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time - %CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/ci/appveyor.sh || GOTO ErrorExit -) - -GOTO :EOF - -:ErrorExit - ECHO ERROR %0 failed - EXIT /b 1 +REM This script either runs the test suite with OPAM (if USEOPAM is true) or
+REM builds the Coq binary packages for windows (if USEOPAM is false).
+
+if %ARCH% == 32 (
+ SET ARCHLONG=i686
+ SET CYGROOT=C:\cygwin
+ SET SETUP=setup-x86.exe
+)
+
+if %ARCH% == 64 (
+ SET ARCHLONG=x86_64
+ SET CYGROOT=C:\cygwin64
+ SET SETUP=setup-x86_64.exe
+)
+
+SET CYGCACHE=%CYGROOT%\var\cache\setup
+SET APPVEYOR_BUILD_FOLDER_MFMT=%APPVEYOR_BUILD_FOLDER:\=/%
+SET APPVEYOR_BUILD_FOLDER_CFMT=%APPVEYOR_BUILD_FOLDER_MFMT:C:/=/cygdrive/c/%
+SET DESTCOQ=C:\coq%ARCH%_inst
+SET COQREGTESTING=Y
+
+if %USEOPAM% == false (
+ call %APPVEYOR_BUILD_FOLDER%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^
+ -arch=%ARCH% -installer=Y -coqver=%APPVEYOR_BUILD_FOLDER_CFMT% ^
+ -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^
+ -addon=bignums -make=N ^
+ -setup %CYGROOT%\%SETUP% || GOTO ErrorExit
+ copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit
+ 7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit
+)
+
+if %USEOPAM% == true (
+ %CYGROOT%\%SETUP% -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% ^
+ -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time
+ %CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/ci/appveyor.sh || GOTO ErrorExit
+)
+
+GOTO :EOF
+
+:ErrorExit
+ ECHO ERROR %0 failed
+ EXIT /b 1
diff --git a/dev/ci/appveyor.sh b/dev/ci/appveyor.sh index cda369fb1b..470d07b27d 100644 --- a/dev/ci/appveyor.sh +++ b/dev/ci/appveyor.sh @@ -13,4 +13,4 @@ eval "$(opam env)" opam install -y num ocamlfind ounit # Full regular Coq Build -cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make && make byte && make -C test-suite all INTERACTIVE= # && make validate +cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make && make byte # && make -C test-suite all INTERACTIVE= # && make validate diff --git a/dev/ci/azure-build.sh b/dev/ci/azure-build.sh new file mode 100755 index 0000000000..c0030c566f --- /dev/null +++ b/dev/ci/azure-build.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +set -e -x + +cd $(dirname $0)/../.. + +./configure -local +make -j 2 byte +make -j 2 world diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh new file mode 100755 index 0000000000..8a1e36659c --- /dev/null +++ b/dev/ci/azure-opam.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +set -e -x + +OPAM_VARIANT=ocaml-variants.4.07.1+mingw64c + +wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz +tar -xf opam64.tar.xz +bash opam64/install.sh + +opam init default -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $OPAM_VARIANT --disable-sandboxing +eval "$(opam env)" +opam install -y num ocamlfind ounit diff --git a/dev/ci/azure-test.sh b/dev/ci/azure-test.sh new file mode 100755 index 0000000000..8813245e5a --- /dev/null +++ b/dev/ci/azure-test.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +set -e -x + +#NB: if we make test-suite from the main makefile we get environment +#too large for exec error +cd $(dirname $0)/../../test-suite +make -j 2 clean +make -j 2 PRINT_LOGS=1 diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index e0f4f50fa9..8dee465cf4 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -150,11 +150,11 @@ : "${fiat_crypto_CI_ARCHIVEURL:=${fiat_crypto_CI_GITURL}/archive}" ######################################################################## -# formal-topology +# fiat_crypto_legacy ######################################################################## -: "${formal_topology_CI_REF:=ci}" -: "${formal_topology_CI_GITURL:=https://github.com/bmsherman/topology}" -: "${formal_topology_CI_ARCHIVEURL:=${formal_topology_CI_GITURL}/archive}" +: "${fiat_crypto_legacy_CI_REF:=sp2019latest}" +: "${fiat_crypto_legacy_CI_GITURL:=https://github.com/mit-plv/fiat-crypto}" +: "${fiat_crypto_legacy_CI_ARCHIVEURL:=${fiat_crypto_legacy_CI_GITURL}/archive}" ######################################################################## # coq_dpdgraph @@ -240,13 +240,6 @@ : "${quickchick_CI_ARCHIVEURL:=${quickchick_CI_GITURL}/archive}" ######################################################################## -# plugin_tutorial -######################################################################## -: "${plugin_tutorial_CI_REF:=master}" -: "${plugin_tutorial_CI_GITURL:=https://github.com/ybertot/plugin_tutorials}" -: "${plugin_tutorial_CI_ARCHIVEURL:=${plugin_tutorial_CI_GITURL}/archive}" - -######################################################################## # menhirlib ######################################################################## : "${menhirlib_CI_REF:=master}" @@ -273,3 +266,26 @@ : "${relation_algebra_CI_REF:=master}" : "${relation_algebra_CI_GITURL:=https://github.com/damien-pous/relation-algebra}" : "${relation_algebra_CI_ARCHIVEURL:=${relation_algebra_CI_GITURL}/archive}" + +######################################################################## +# StructTact + InfSeqExt + Cheerios + Verdi + Verdi Raft +######################################################################## +: "${struct_tact_CI_REF:=master}" +: "${struct_tact_CI_GITURL:=https://github.com/uwplse/StructTact}" +: "${struct_tact_CI_ARCHIVEURL:=${struct_tact_CI_GITURL}/archive}" + +: "${inf_seq_ext_CI_REF:=master}" +: "${inf_seq_ext_CI_GITURL:=https://github.com/DistributedComponents/InfSeqExt}" +: "${inf_seq_ext_CI_ARCHIVEURL:=${inf_seq_ext_CI_GITURL}/archive}" + +: "${cheerios_CI_REF:=master}" +: "${cheerios_CI_GITURL:=https://github.com/uwplse/cheerios}" +: "${cheerios_CI_ARCHIVEURL:=${cheerios_CI_GITURL}/archive}" + +: "${verdi_CI_REF:=master}" +: "${verdi_CI_GITURL:=https://github.com/uwplse/verdi}" +: "${verdi_CI_ARCHIVEURL:=${verdi_CI_GITURL}/archive}" + +: "${verdi_raft_CI_REF:=master}" +: "${verdi_raft_CI_GITURL:=https://github.com/uwplse/verdi-raft}" +: "${verdi_raft_CI_ARCHIVEURL:=${verdi_raft_CI_GITURL}/archive}" diff --git a/dev/ci/ci-fiat-crypto-legacy.sh b/dev/ci/ci-fiat-crypto-legacy.sh index 6bf3138346..2af4b58201 100755 --- a/dev/ci/ci-fiat-crypto-legacy.sh +++ b/dev/ci/ci-fiat-crypto-legacy.sh @@ -4,11 +4,11 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" FORCE_GIT=1 -git_download fiat_crypto +git_download fiat_crypto_legacy fiat_crypto_legacy_CI_TARGETS1="print-old-pipeline-lite old-pipeline-lite lite-display" fiat_crypto_legacy_CI_TARGETS2="print-old-pipeline-nobigmem old-pipeline-nobigmem nonautogenerated-specific nonautogenerated-specific-display" -( cd "${CI_BUILD_DIR}/fiat_crypto" && git submodule update --init --recursive && \ +( cd "${CI_BUILD_DIR}/fiat_crypto_legacy" && git submodule update --init --recursive && \ ./etc/ci/remove_autogenerated.sh && \ make ${fiat_crypto_legacy_CI_TARGETS1} && make -j 1 ${fiat_crypto_legacy_CI_TARGETS2} ) diff --git a/dev/ci/ci-formal-topology.sh b/dev/ci/ci-formal-topology.sh deleted file mode 100755 index 8be5a06ed2..0000000000 --- a/dev/ci/ci-formal-topology.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download formal_topology - -( cd "${CI_BUILD_DIR}/formal_topology" && make ) diff --git a/dev/ci/ci-plugin_tutorial.sh b/dev/ci/ci-plugin_tutorial.sh deleted file mode 100755 index 6c26a71a21..0000000000 --- a/dev/ci/ci-plugin_tutorial.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download plugin_tutorial - -( cd "${CI_BUILD_DIR}/plugin_tutorial" && \ - pushd tuto0 && make && popd && \ - pushd tuto1 && make && popd && \ - pushd tuto2 && make && popd && \ - pushd tuto3 && make && popd ) diff --git a/dev/ci/ci-verdi-raft.sh b/dev/ci/ci-verdi-raft.sh new file mode 100755 index 0000000000..3bcd52c464 --- /dev/null +++ b/dev/ci/ci-verdi-raft.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download struct_tact + +( cd "${CI_BUILD_DIR}/struct_tact" && ./configure && make && make install ) + +git_download inf_seq_ext + +( cd "${CI_BUILD_DIR}/inf_seq_ext" && ./configure && make && make install ) + +git_download cheerios + +( cd "${CI_BUILD_DIR}/cheerios" && ./configure && make && make install ) + +git_download verdi + +( cd "${CI_BUILD_DIR}/verdi" && ./configure && make && make install ) + +git_download verdi_raft + +( cd "${CI_BUILD_DIR}/verdi_raft" && ./configure && make ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 3fc6dce4e5..baf470e021 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2018-11-08-V1" +# CACHEKEY: "bionic_coq-V2018-12-14-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -37,7 +37,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.4.0 ounit.2.0.8 odoc.1.3.0" \ +ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.3.0" \ CI_OPAM="menhir.20180530 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. diff --git a/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh b/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh deleted file mode 100644 index b05d02c5be..0000000000 --- a/dev/ci/user-overlays/07925-ppedrot-clean-transp-state.sh +++ /dev/null @@ -1,14 +0,0 @@ -_OVERLAY_BRANCH=clean-transp-state - -if [ "$CI_PULL_REQUEST" = "7925" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then - - unicoq_CI_REF="$_OVERLAY_BRANCH" - unicoq_CI_GITURL=https://github.com/ppedrot/unicoq - - equations_CI_REF="$_OVERLAY_BRANCH" - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - mtac2_CI_REF="$_OVERLAY_BRANCH" - mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 - -fi diff --git a/dev/ci/user-overlays/08705-ejgallego-vernac+remove_empty_hooks.sh b/dev/ci/user-overlays/08705-ejgallego-vernac+remove_empty_hooks.sh deleted file mode 100644 index 3600f1cd3e..0000000000 --- a/dev/ci/user-overlays/08705-ejgallego-vernac+remove_empty_hooks.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8705" ] || [ "$CI_BRANCH" = "vernac+remove_empty_hooks" ]; then - - elpi_CI_REF=vernac+remove_empty_hooks - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - equations_CI_REF=vernac+remove_empty_hooks - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - paramcoq_CI_REF=vernac+remove_empty_hooks - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - - plugin_tutorial_CI_REF=vernac+remove_empty_hooks - plugin_tutorial_CI_GITURL=https://github.com/ejgallego/plugin_tutorials - - mtac2_CI_REF=vernac+remove_empty_hooks - mtac2_CI_GITURL=https://github.com/ejgallego/mtac2 - -fi diff --git a/dev/ci/user-overlays/08850-poly-local-univs.sh b/dev/ci/user-overlays/08850-poly-local-univs.sh deleted file mode 100644 index 482792d7cd..0000000000 --- a/dev/ci/user-overlays/08850-poly-local-univs.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8850" ] || [ "$CI_BRANCH" = "poly-local-univs" ]; then - formal_topology_CI_REF=poly-local-univs - formal_topology_CI_GITURL=https://github.com/SkySkimmer/topology - - paramcoq_CI_REF=poly-local-univs - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq -fi diff --git a/dev/ci/user-overlays/08889-mattam-program-obl-subst.sh b/dev/ci/user-overlays/08889-mattam-program-obl-subst.sh deleted file mode 100644 index 17eb5fffae..0000000000 --- a/dev/ci/user-overlays/08889-mattam-program-obl-subst.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8889" ] || [ "$CI_BRANCH" = "program-hook-obligation-subst" ]; then - - Equations_CI_REF=program-hook-obligation-subst - Equations_CI_GITURL=https://github.com/mattam82/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh b/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh deleted file mode 100644 index 08112d3054..0000000000 --- a/dev/ci/user-overlays/08902-ejgallego-ltac+use_atts_in_ast.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8902" ] || [ "$CI_BRANCH" = "ltac+use_atts_in_ast" ]; then - - aactactics_CI_REF=ltac+use_atts_in_ast - aactactics_CI_GITURL=https://github.com/ejgallego/aac-tactics - - coqhammer_CI_REF=ltac+use_atts_in_ast - coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer - - Equations_CI_REF=ltac+use_atts_in_ast - Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - mtac2_CI_REF=ltac+use_atts_in_ast - mtac2_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh b/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh deleted file mode 100644 index 1c5157ba12..0000000000 --- a/dev/ci/user-overlays/08914-ejgallego-lib+better_boot_coqproject.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8914" ] || [ "$CI_BRANCH" = "lib+better_boot_coqproject" ]; then - - quickchick_CI_REF=lib+better_boot_coqproject - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh b/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh deleted file mode 100644 index e74e53fa40..0000000000 --- a/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh - -if [ "$CI_PULL_REQUEST" = "8933" ] || [ "$CI_BRANCH" = "solve-remaining-evars-initial-arg" ]; then - plugin_tutorial_CI_REF=solve-remaining-evars-initial-arg - plugin_tutorial_CI_GITURL=https://github.com/SkySkimmer/plugin_tutorials -fi diff --git a/dev/ci/user-overlays/08985-ejgallego-build+pack_gramlib.sh b/dev/ci/user-overlays/08985-ejgallego-build+pack_gramlib.sh deleted file mode 100644 index d7130cc67a..0000000000 --- a/dev/ci/user-overlays/08985-ejgallego-build+pack_gramlib.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8985" ] || [ "$CI_BRANCH" = "build+pack_gramlib" ]; then - - elpi_CI_REF=use_coq_gramlib - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -fi diff --git a/dev/ci/user-overlays/08998-ejgallego-legacy_proof_eng_clean.sh b/dev/ci/user-overlays/08998-ejgallego-legacy_proof_eng_clean.sh deleted file mode 100644 index c8bea0c868..0000000000 --- a/dev/ci/user-overlays/08998-ejgallego-legacy_proof_eng_clean.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8998" ] || [ "$CI_BRANCH" = "legacy_proof_eng_clean" ]; then - - equations_CI_REF=legacy_proof_eng_clean - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh b/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh deleted file mode 100644 index 61ffa4a197..0000000000 --- a/dev/ci/user-overlays/09003-ejgallego-vernac+move_extend_ast.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9003" ] || [ "$CI_BRANCH" = "vernac+move_extend_ast" ]; then - - ltac2_CI_REF=vernac+move_extend_ast - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - -fi diff --git a/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh b/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh deleted file mode 100644 index 14e7c0d7f0..0000000000 --- a/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9051" ] || [ "$CI_BRANCH" = "camlp5-safe-api-strikes-back" ]; then - - equations_CI_REF=camlp5-safe-api-strikes-back - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - ltac2_CI_REF=camlp5-safe-api-strikes-back - ltac2_CI_GITURL=https://github.com/ppedrot/ltac2 - -fi diff --git a/dev/ci/user-overlays/09065-ejgallego-gramlib+no_ploc.sh b/dev/ci/user-overlays/09065-ejgallego-gramlib+no_ploc.sh deleted file mode 100644 index e9daa7a44e..0000000000 --- a/dev/ci/user-overlays/09065-ejgallego-gramlib+no_ploc.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9065" ] || [ "$CI_BRANCH" = "gramlib+no_ploc" ]; then - - elpi_CI_REF=gramlib+no_ploc - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -fi diff --git a/dev/ci/user-overlays/09150-ejgallego-build+warn_50.sh b/dev/ci/user-overlays/09150-ejgallego-build+warn_50.sh new file mode 100644 index 0000000000..f2a113b118 --- /dev/null +++ b/dev/ci/user-overlays/09150-ejgallego-build+warn_50.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9150" ] || [ "$CI_BRANCH" = "build+warn_50" ]; then + + mtac2_CI_REF=build+warn_50 + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + +fi diff --git a/dev/ci/user-overlays/09172-ejgallego-proof_rework.sh b/dev/ci/user-overlays/09172-ejgallego-proof_rework.sh new file mode 100644 index 0000000000..f532fdfc52 --- /dev/null +++ b/dev/ci/user-overlays/09172-ejgallego-proof_rework.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9172" ] || [ "$CI_BRANCH" = "proof_rework" ]; then + + ltac2_CI_REF=proof_rework + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + mtac2_CI_REF=proof_rework + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + +fi diff --git a/dev/ci/user-overlays/09220-maximedenes-stm-shallow-logic.sh b/dev/ci/user-overlays/09220-maximedenes-stm-shallow-logic.sh new file mode 100644 index 0000000000..efcdd2e97f --- /dev/null +++ b/dev/ci/user-overlays/09220-maximedenes-stm-shallow-logic.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9220" ] || [ "$CI_BRANCH" = "stm-shallow-logic" ]; then + + paramcoq_CI_REF=stm-shallow-logic + paramcoq_CI_GITURL=https://github.com/maximedenes/paramcoq + +fi diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 3609171b82..01c32041d2 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -10,9 +10,9 @@ Coq can now be built using [Dune](https://github.com/ocaml/dune). ## Quick Start -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. +Usually, using the latest version of Dune 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, so please be sure your tree is clean from objects files generated by @@ -63,11 +63,16 @@ ml files in quick mode. Dune also provides targets for documentation, testing, and release builds, please see below. -## Documentation and test targets +## Documentation and testing targets Coq's test-suite can be run with `dune runtest`. -The documentation target is not implemented in Dune yet. +There is preliminary support to build the API documentation and +reference manual in HTML format, use `dune build {@doc,@refman-html}` +to generate them. + +So far these targets will build the documentation artifacts, however +no install rules are generated yet. ## Developer shell diff --git a/dev/doc/changes.md b/dev/doc/changes.md index c0f15f02a5..e7d4b605c7 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -52,6 +52,26 @@ Macros: where `atts : Vernacexpr.vernac_flags` was bound in the expression and had to be manually parsed. +Libobject + +- A Higher-level API for objects with fixed scope was introduced. It supports the following kinds of objects: + + * Local objects, meaning that objects cannot be imported from outside. + * Global objects, meaning that they can be imported (by importing the module that contains the object). + * Superglobal objects, meaning that objects survive to closing a module, and + are imported when the file which contains them is Required (even without + Import). + * Objects that survive section closing or don't (see `nodischarge` variants, + however we discourage defining such objects) + + This API is made of the following functions: + * `Libobject.local_object` + * `Libobject.local_object_nodischarge` + * `Libobject.global_object` + * `Libobject.global_object_nodischarge` + * `Libobject.superglobal_object` + * `Libobject.superglobal_object_nodischarge` + ## Changes between Coq 8.8 and Coq 8.9 ### ML API diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index cd09b6d305..f588c20d02 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -4,33 +4,25 @@ # lint-commits.sh seeks to prevent the worsening of already present # problems, such as tab indentation in ml files. lint-repository.sh -# seeks to prevent the (re-)introduction of solved problems, such as -# newlines at the end of .v files. +# also seeks to prevent the (re-)introduction of solved problems, such +# as newlines at the end of .v files. CODE=0 -if [ -n "${TRAVIS_PULL_REQUEST}" ] && [ "${TRAVIS_PULL_REQUEST}" != false ]; -then - # skip PRs from before the linter existed - if [ -z "$(git ls-tree --name-only "${TRAVIS_PULL_REQUEST_SHA}" dev/lint-commits.sh)" ]; - then - 1>&2 echo "Linting skipped: pull request older than the linter." - exit 0 - fi - - # Some problems are too widespread to fix in one commit, but we - # can still check that they don't worsen. - CUR_HEAD=${TRAVIS_COMMIT_RANGE%%...*} - PR_HEAD=${TRAVIS_COMMIT_RANGE##*...} - MERGE_BASE=$(git merge-base "$CUR_HEAD" "$PR_HEAD") - dev/lint-commits.sh "$MERGE_BASE" "$PR_HEAD" || CODE=1 -fi +# We assume that all merge commits are from the main branch +# For Coq it is extremely rare for this assumption to be broken +read -r base < <(git log -n 1 --merges --pretty='format:%H') +head=$(git rev-parse HEAD) + +dev/lint-commits.sh "$base" "$head" || CODE=1 # Check that the files with 'whitespace' gitattribute end in a newline. # xargs exit status is 123 if any file failed the test +echo Checking end of file newlines find . "(" -path ./.git -prune ")" -o -type f -print0 | xargs -0 dev/tools/check-eof-newline.sh || CODE=1 +echo Checking overlays dev/tools/check-overlays.sh || CODE=1 exit $CODE diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index 5fd8a3b7d9..ca6d9e0d83 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -198,8 +198,25 @@ if [ -z "$(git config user.signingkey)" ]; then warning "gpg will guess a key out of your git config user.* data" fi +# Generate commit message + +info "Fetching review data" +reviews=$(curl -s "$API/pulls/$PR/reviews") +msg="Merge PR #$PR: $TITLE" + +select_state() { + jq -rc 'map(select(.state == "'"$1"'") | .user.login) | join(" ")' <<< "$reviews" +} + +for reviewer in $(select_state APPROVED); do + msg=$(printf '%s\n' "$msg" | git interpret-trailers --trailer Reviewed-by="$reviewer") +done +for reviewer in $(select_state COMMENTED); do + msg=$(printf '%s\n' "$msg" | git interpret-trailers --trailer Ack-by="$reviewer") +done + info "merging" -git merge -v -S --no-ff FETCH_HEAD -m "Merge PR #$PR: $TITLE" -e +git merge -v -S --no-ff FETCH_HEAD -m "$msg" -e # TODO: improve this check if ! git diff --quiet --diff-filter=A "$REMOTE/$CURRENT_LOCAL_BRANCH" -- dev/ci/user-overlays; then diff --git a/dev/top_printers.ml b/dev/top_printers.ml index b90a53220d..8f207d1e0a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -476,7 +476,7 @@ let pp_generic_argument arg = let prgenarginfo arg = let Geninterp.Val.Dyn (tag, _) = arg in let tpe = Geninterp.Val.pr tag in - (** FIXME *) + (* FIXME *) (* try *) (* let data = Pptactic.pr_top_generic (Global.env ()) arg in *) (* str "<genarg:" ++ tpe ++ str " := [ " ++ data ++ str " ] >" *) diff --git a/doc/README.md b/doc/README.md index 3db1261656..c41d269437 100644 --- a/doc/README.md +++ b/doc/README.md @@ -101,18 +101,21 @@ Alternatively, you can use some specific targets: Also note the `-with-doc yes` option of `./configure` to enable the build of the documentation as part of the default make target. -If you're editing Sphinx documentation, set SPHINXWARNERROR to 0 -to avoid treating Sphinx warnings as errors. Otherwise, Sphinx quits -upon detecting the first warning. You can set this on the Sphinx `make` -command line or as an environment variable: - -- `make refman SPHINXWARNERROR=0` - -- ~~~ - export SPHINXWARNERROR=0 - ⋮ - make refman - ~~~ +To build the Sphinx documentation without stopping at the first +warning with the legacy Makefile, set `SPHINXWARNERROR` to 0 as such: + +``` +SPHINXWARNERROR=0 make refman-html +``` + +To do the same with the Dune build system, change the value of the +`SPHINXWARNOPT` variable (default is `-W`). The following will build +the Sphinx documentation without stopping at the first warning, and +store all the warnings in the file `/tmp/warn.log`: + +``` +SPHINXWARNOPT="-w/tmp/warn.log" dune build @refman-html +``` Installation ------------ diff --git a/doc/dune b/doc/dune new file mode 100644 index 0000000000..6372fe4a91 --- /dev/null +++ b/doc/dune @@ -0,0 +1,26 @@ +(rule + (targets sphinx_build) + (deps + ; We could use finer dependencies here so the build is faster: + ; + ; - vo files: generated by sphinx after parsing the doc, promoted, + ; - Static files: + ; + %{bin:coqdoc} etc... + ; + config/coq_config.py + ; + tools/coqdoc/coqdoc.css + (package coq) + (source_tree sphinx) + (source_tree tools) + (env_var SPHINXWARNOPT)) + (action + (run sphinx-build -j4 %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) + +(alias + (name refman-html) + (deps sphinx_build)) + +; The install target still needs more work. +; (install +; (section doc) +; (package coq-refman) +; (files sphinx_build)) diff --git a/doc/plugin_tutorial/.gitignore b/doc/plugin_tutorial/.gitignore new file mode 100644 index 0000000000..3e4978fac4 --- /dev/null +++ b/doc/plugin_tutorial/.gitignore @@ -0,0 +1,13 @@ +*.ml*.d +*.cm[ixt]* +Makefile.coq* +*~ +*.[ao] +.coqdeps.d +*.vo +*.glob +*.aux +*/*/.merlin + +# by convention g_foo.ml is generated +g_*.ml diff --git a/doc/plugin_tutorial/.travis.yml b/doc/plugin_tutorial/.travis.yml new file mode 100644 index 0000000000..556e0ac45a --- /dev/null +++ b/doc/plugin_tutorial/.travis.yml @@ -0,0 +1,38 @@ +dist: trusty +sudo: required +language: generic + +services: + - docker + +env: + global: + - NJOBS="2" + - CONTRIB_NAME="plugin_tutorials" + matrix: + - COQ_IMAGE="coqorg/coq:dev" + +install: | + # Prepare the COQ container + docker run -d -i --init --name=COQ -v ${TRAVIS_BUILD_DIR}:/home/coq/$CONTRIB_NAME -w /home/coq/$CONTRIB_NAME ${COQ_IMAGE} + docker exec COQ /bin/bash --login -c " + # This bash script is double-quoted to interpolate Travis CI env vars: + echo \"Build triggered by ${TRAVIS_EVENT_TYPE}\" + export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' + set -ex # -e = exit on failure; -x = trace for debug + opam list + " +script: +- echo -e "${ANSI_YELLOW}Building $CONTRIB_NAME...${ANSI_RESET}" && echo -en 'travis_fold:start:testbuild\\r' +- | + docker exec COQ /bin/bash --login -c " + export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' + set -ex + sudo chown -R coq:coq /home/coq/$CONTRIB_NAME + ( cd tuto0 && make ) + ( cd tuto1 && make ) + ( cd tuto2 && make ) + ( cd tuto3 && make ) + " +- docker stop COQ # optional +- echo -en 'travis_fold:end:testbuild\\r' diff --git a/doc/plugin_tutorial/LICENSE b/doc/plugin_tutorial/LICENSE new file mode 100644 index 0000000000..cf1ab25da0 --- /dev/null +++ b/doc/plugin_tutorial/LICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to <http://unlicense.org> diff --git a/doc/plugin_tutorial/Makefile b/doc/plugin_tutorial/Makefile new file mode 100644 index 0000000000..7f1833fadd --- /dev/null +++ b/doc/plugin_tutorial/Makefile @@ -0,0 +1,21 @@ + +TUTOS:= \ + tuto0 \ + tuto1 \ + tuto2 \ + tuto3 + +all: $(TUTOS) + +.PHONY: $(TUTOS) all + +$(TUTOS): %: + +$(MAKE) -C $@ + +CLEANS:=$(addsuffix -clean, $(TUTOS)) +.PHONY: clean $(CLEANS) + +clean: $(CLEANS) + +%-clean: + +$(MAKE) -C $* clean diff --git a/doc/plugin_tutorial/README.md b/doc/plugin_tutorial/README.md new file mode 100644 index 0000000000..f82edb2352 --- /dev/null +++ b/doc/plugin_tutorial/README.md @@ -0,0 +1,86 @@ +How to write plugins in Coq +=========================== + # Working environment : merlin, tuareg (open question) + + ## OCaml & related tools + + These instructions use [OPAM](http://opam.ocaml.org/doc/Install.html) + +```shell +opam init --root=$PWD/CIW2018 --compiler=4.06.0 -j2 +eval `opam config env --root=$PWD/CIW2018` +opam install camlp5 ocamlfind num # Coq's dependencies +opam install lablgtk # Coqide's dependencies (optional) +opam install merlin # prints instructions for vim and emacs +``` + + ## Coq + +```shell +git clone git@github.com:coq/coq.git +cd coq +./configure -profile devel +make -j2 +cd .. +export PATH=$PWD/coq/bin:$PATH +``` + + ## This tutorial + +```shell +git clone git@github.com:ybertot/plugin_tutorials.git +cd plugin_tutorials/tuto0 +make .merlin # run before opening .ml files in your editor +make # build +``` + + + + # tuto0 : basics of project organization + package a ml4 file in a plugin, organize a `Makefile`, `_CoqProject` + - Example of syntax to add a new toplevel command + - Example of function call to print a simple message + - Example of syntax to add a simple tactic + (that does nothing and prints a message) + - To use it: + +```bash + cd tuto0; make + coqtop -I src -R theories Tuto0 +``` + + In the Coq session type: +```coq + Require Import Tuto0.Loader. HelloWorld. +``` + + # tuto1 : Ocaml to Coq communication + Explore the memory of Coq, modify it + - Commands that take arguments: strings, symbols, expressions of the calculus of constructions + - Commands that interact with type-checking in Coq + - A command that adds a new definition or theorem + - A command that uses a name and exploits the existing definitions + or theorems + - A command that exploits an existing ongoing proof + - A command that defines a new tactic + + Compilation and loading must be performed as for `tuto0`. + + # tuto2 : Ocaml to Coq communication + A more step by step introduction to writing commands + - Explanation of the syntax of entries + - Adding a new type to and parsing to the available choices + - Handling commands that store information in user-chosen registers and tables + + Compilation and loading must be performed as for `tuto1`. + + # tuto3 : manipulating terms of the calculus of constructions + Manipulating terms, inside commands and tactics. + - Obtaining existing values from memory + - Composing values + - Verifying types + - Using these terms in commands + - Using these terms in tactics + - Automatic proofs without tactics using type classes and canonical structures + + compilation and loading must be performed as for `tuto0`. diff --git a/doc/plugin_tutorial/tuto0/Makefile b/doc/plugin_tutorial/tuto0/Makefile new file mode 100644 index 0000000000..e0e197650d --- /dev/null +++ b/doc/plugin_tutorial/tuto0/Makefile @@ -0,0 +1,14 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + +%: Makefile.coq + +Makefile.coq: _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/doc/plugin_tutorial/tuto0/_CoqProject b/doc/plugin_tutorial/tuto0/_CoqProject new file mode 100644 index 0000000000..76368e3ac7 --- /dev/null +++ b/doc/plugin_tutorial/tuto0/_CoqProject @@ -0,0 +1,10 @@ +-R theories/ Tuto0 +-I src + +theories/Loader.v +theories/Demo.v + +src/tuto0_main.ml +src/tuto0_main.mli +src/g_tuto0.mlg +src/tuto0_plugin.mlpack diff --git a/doc/plugin_tutorial/tuto0/src/dune b/doc/plugin_tutorial/tuto0/src/dune new file mode 100644 index 0000000000..79d561061d --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/dune @@ -0,0 +1,9 @@ +(library + (name tuto0_plugin) + (public_name coq.plugins.tutorial.p0) + (libraries coq.plugins.ltac)) + +(rule + (targets g_tuto0.ml) + (deps (:pp-file g_tuto0.mlg) ) + (action (run coqpp %{pp-file}))) diff --git a/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg b/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg new file mode 100644 index 0000000000..5c633fe862 --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg @@ -0,0 +1,18 @@ +DECLARE PLUGIN "tuto0_plugin" + +{ + +open Pp +open Ltac_plugin + +} + +VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY +| [ "HelloWorld" ] -> { Feedback.msg_notice (strbrk Tuto0_main.message) } +END + +TACTIC EXTEND hello_world_tactic +| [ "hello_world" ] -> + { let _ = Feedback.msg_notice (str Tuto0_main.message) in + Tacticals.New.tclIDTAC } +END diff --git a/doc/plugin_tutorial/tuto0/src/tuto0_main.ml b/doc/plugin_tutorial/tuto0/src/tuto0_main.ml new file mode 100644 index 0000000000..93a807a800 --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/tuto0_main.ml @@ -0,0 +1 @@ +let message = "Hello world!" diff --git a/doc/plugin_tutorial/tuto0/src/tuto0_main.mli b/doc/plugin_tutorial/tuto0/src/tuto0_main.mli new file mode 100644 index 0000000000..846af3ed8c --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/tuto0_main.mli @@ -0,0 +1 @@ +val message : string diff --git a/doc/plugin_tutorial/tuto0/src/tuto0_plugin.mlpack b/doc/plugin_tutorial/tuto0/src/tuto0_plugin.mlpack new file mode 100644 index 0000000000..73be1bb561 --- /dev/null +++ b/doc/plugin_tutorial/tuto0/src/tuto0_plugin.mlpack @@ -0,0 +1,2 @@ +Tuto0_main +G_tuto0 diff --git a/doc/plugin_tutorial/tuto0/theories/Demo.v b/doc/plugin_tutorial/tuto0/theories/Demo.v new file mode 100644 index 0000000000..bdc61986af --- /dev/null +++ b/doc/plugin_tutorial/tuto0/theories/Demo.v @@ -0,0 +1,8 @@ +From Tuto0 Require Import Loader. + +HelloWorld. + +Lemma test : True. +Proof. +hello_world. +Abort. diff --git a/doc/plugin_tutorial/tuto0/theories/Loader.v b/doc/plugin_tutorial/tuto0/theories/Loader.v new file mode 100644 index 0000000000..7bce38382b --- /dev/null +++ b/doc/plugin_tutorial/tuto0/theories/Loader.v @@ -0,0 +1 @@ +Declare ML Module "tuto0_plugin". diff --git a/doc/plugin_tutorial/tuto1/Makefile b/doc/plugin_tutorial/tuto1/Makefile new file mode 100644 index 0000000000..e0e197650d --- /dev/null +++ b/doc/plugin_tutorial/tuto1/Makefile @@ -0,0 +1,14 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + +%: Makefile.coq + +Makefile.coq: _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/doc/plugin_tutorial/tuto1/_CoqProject b/doc/plugin_tutorial/tuto1/_CoqProject new file mode 100644 index 0000000000..585d1360be --- /dev/null +++ b/doc/plugin_tutorial/tuto1/_CoqProject @@ -0,0 +1,13 @@ +-R theories Tuto1 +-I src + +theories/Loader.v + +src/simple_check.mli +src/simple_check.ml +src/simple_declare.mli +src/simple_declare.ml +src/simple_print.ml +src/simple_print.mli +src/g_tuto1.mlg +src/tuto1_plugin.mlpack diff --git a/doc/plugin_tutorial/tuto1/src/dune b/doc/plugin_tutorial/tuto1/src/dune new file mode 100644 index 0000000000..cf9c674b14 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/dune @@ -0,0 +1,9 @@ +(library + (name tuto1_plugin) + (public_name coq.plugins.tutorial.p1) + (libraries coq.plugins.ltac)) + +(rule + (targets g_tuto1.ml) + (deps (:pp-file g_tuto1.mlg) ) + (action (run coqpp %{pp-file}))) diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg new file mode 100644 index 0000000000..4df284d2d9 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -0,0 +1,154 @@ +DECLARE PLUGIN "tuto1_plugin" + +{ + +(* If we forget this line and include our own tactic definition using + TACTIC EXTEND, as below, then we get the strange error message + no implementation available for Tacentries, only when compiling + theories/Loader.v +*) +open Ltac_plugin +open Attributes +open Pp +(* This module defines the types of arguments to be used in the + EXTEND directives below, for example the string one. *) +open Stdarg + +} + +VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY +| [ "Hello" string(s) ] -> + { Feedback.msg_notice (strbrk "Hello " ++ str s) } +END + +(* reference is allowed as a syntactic entry, but so are all the entries + found the signature of module Prim in file coq/parsing/pcoq.mli *) + +VERNAC COMMAND EXTEND HelloAgain CLASSIFIED AS QUERY +| [ "HelloAgain" reference(r)] -> +(* The function Ppconstr.pr_qualid was found by searching all mli files + for a function of type qualid -> Pp.t *) + { Feedback.msg_notice + (strbrk "Hello again " ++ Ppconstr.pr_qualid r)} +END + +(* According to parsing/pcoq.mli, e has type constr_expr *) +(* this type is defined in pretyping/constrexpr.ml *) +(* Question for the developers: why is the file constrexpr.ml and not + constrexpr.mli --> Easier for packing the software in components. *) +VERNAC COMMAND EXTEND TakingConstr CLASSIFIED AS QUERY +| [ "Cmd1" constr(e) ] -> + { let _ = e in Feedback.msg_notice (strbrk "Cmd1 parsed something") } +END + +(* The next step is to make something of parsed expression. + Interesting information in interp/constrintern.mli *) + +(* There are several phases of transforming a parsed expression into + the final internal data-type (constr). There exists a collection of + functions that combine all the phases *) + +VERNAC COMMAND EXTEND TakingConstr2 CLASSIFIED AS QUERY +| [ "Cmd2" constr(e) ] -> + { let _ = Constrintern.interp_constr + (Global.env()) + (* Make sure you don't use Evd.empty here, as this does not + check consistency with existing universe constraints. *) + (Evd.from_env (Global.env())) e in + Feedback.msg_notice (strbrk "Cmd2 parsed something legitimate") } +END + +(* This is to show what happens when typing in an empty environment + with an empty evd. + Question for the developers: why does "Cmd3 (fun x : nat => x)." + raise an anomaly, not the same error as "Cmd3 (fun x : a => x)." *) + +VERNAC COMMAND EXTEND TakingConstr3 CLASSIFIED AS QUERY +| [ "Cmd3" constr(e) ] -> + { let _ = Constrintern.interp_constr Environ.empty_env + Evd.empty e in + Feedback.msg_notice + (strbrk "Cmd3 accepted something in the empty context")} +END + +(* When adding a definition, we have to be careful that just + the operation of constructing a well-typed term may already change + the environment, at the level of universe constraints (which + are recorded in the evd component). The function + Constrintern.interp_constr ignores this side-effect, so it should + not be used here. *) + +(* Looking at the interface file interp/constrintern.ml4, I lost + some time because I did not see that the "constr" type appearing + there was "EConstr.constr" and not "Constr.constr". *) + +VERNAC COMMAND EXTEND Define1 CLASSIFIED AS SIDEFF +| #[ poly = polymorphic ] [ "Cmd4" ident(i) constr(e) ] -> + { let v = Constrintern.interp_constr (Global.env()) + (Evd.from_env (Global.env())) e in + Simple_declare.packed_declare_definition ~poly i v } +END + +VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY +| [ "Cmd5" constr(e) ] -> + { let v = Constrintern.interp_constr (Global.env()) + (Evd.from_env (Global.env())) e in + let (_, ctx) = v in + let evd = Evd.from_ctx ctx in + Feedback.msg_notice + (Printer.pr_econstr_env (Global.env()) evd + (Simple_check.simple_check1 v)) } +END + +VERNAC COMMAND EXTEND Check2 CLASSIFIED AS QUERY +| [ "Cmd6" constr(e) ] -> + { let v = Constrintern.interp_constr (Global.env()) + (Evd.from_env (Global.env())) e in + let evd, ty = Simple_check.simple_check2 v in + Feedback.msg_notice + (Printer.pr_econstr_env (Global.env()) evd ty) } +END + +VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY +| [ "Cmd7" constr(e) ] -> + { let v = Constrintern.interp_constr (Global.env()) + (Evd.from_env (Global.env())) e in + let (a, ctx) = v in + let evd = Evd.from_ctx ctx in + Feedback.msg_notice + (Printer.pr_econstr_env (Global.env()) evd + (Simple_check.simple_check3 v)) } +END + +(* This command takes a name and return its value. It does less + than Print, because it fails on constructors, axioms, and inductive types. + This should be improved, because the error message is an anomaly. + Anomalies should never appear even when using a command outside of its + intended use. *) +VERNAC COMMAND EXTEND ExamplePrint CLASSIFIED AS QUERY +| [ "Cmd8" reference(r) ] -> + { let env = Global.env() in + let evd = Evd.from_env env in + Feedback.msg_notice + (Printer.pr_econstr_env env evd + (EConstr.of_constr + (Simple_print.simple_body_access (Nametab.global r)))) } +END + +TACTIC EXTEND my_intro +| [ "my_intro" ident(i) ] -> + { Tactics.introduction i } +END + +(* if one write this: + VERNAC COMMAND EXTEND exploreproof CLASSIFIED AS QUERY + it gives an error message that is basically impossible to understand. *) + +VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY +| [ "Cmd9" ] -> + { let p = Proof_global.give_me_the_proof () in + let sigma, env = Pfedit.get_current_context () in + let pprf = Proof.partial_proof p in + Feedback.msg_notice + (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } +END diff --git a/doc/plugin_tutorial/tuto1/src/simple_check.ml b/doc/plugin_tutorial/tuto1/src/simple_check.ml new file mode 100644 index 0000000000..1f636c531a --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_check.ml @@ -0,0 +1,32 @@ +let simple_check1 value_with_constraints = + begin + let evalue, st = value_with_constraints in + let evd = Evd.from_ctx st in +(* This is reverse engineered from vernacentries.ml *) +(* The point of renaming is to make sure the bound names printed by Check + can be re-used in `apply with` tactics that use bound names to + refer to arguments. *) + let j = Termops.on_judgment EConstr.of_constr + (Arguments_renaming.rename_typing (Global.env()) + (EConstr.to_constr evd evalue)) in + let {Environ.uj_type=x}=j in x + end + +let simple_check2 value_with_constraints = + let evalue, st = value_with_constraints in + let evd = Evd.from_ctx st in +(* This version should be preferred if bound variable names are not so + important, you want to really verify that the input is well-typed, + and if you want to obtain the type. *) +(* Note that the output value is a pair containing a new evar_map: + typing will fill out blanks in the term by add evar bindings. *) + Typing.type_of (Global.env()) evd evalue + +let simple_check3 value_with_constraints = + let evalue, st = value_with_constraints in + let evd = Evd.from_ctx st in +(* This version should be preferred if bound variable names are not so + important and you already expect the input to have been type-checked + before. Set ~lax to false if you want an anomaly to be raised in + case of a type error. Otherwise a ReTypeError exception is raised. *) + Retyping.get_type_of ~lax:true (Global.env()) evd evalue diff --git a/doc/plugin_tutorial/tuto1/src/simple_check.mli b/doc/plugin_tutorial/tuto1/src/simple_check.mli new file mode 100644 index 0000000000..bcf1bf56cf --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_check.mli @@ -0,0 +1,8 @@ +val simple_check1 : + EConstr.constr Evd.in_evar_universe_context -> EConstr.constr + +val simple_check2 : + EConstr.constr Evd.in_evar_universe_context -> Evd.evar_map * EConstr.constr + +val simple_check3 : + EConstr.constr Evd.in_evar_universe_context -> EConstr.constr diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml new file mode 100644 index 0000000000..9d10a8ba72 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -0,0 +1,24 @@ +(* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *) +let edeclare ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps hook = + let sigma = Evd.minimize_universes sigma in + let body = EConstr.to_constr sigma body in + let tyopt = Option.map (EConstr.to_constr sigma) tyopt in + let uvars_fold uvars c = + Univ.LSet.union uvars (Vars.universes_of_constr c) in + let uvars = List.fold_left uvars_fold Univ.LSet.empty + (Option.List.cons tyopt [body]) in + let sigma = Evd.restrict_universe_context sigma uvars in + let univs = Evd.check_univ_decl ~poly sigma udecl in + let ubinders = Evd.universe_binders sigma in + let ce = Declare.definition_entry ?types:tyopt ~univs body in + DeclareDef.declare_definition ident k ce ubinders imps ~hook + +let packed_declare_definition ~poly ident value_with_constraints = + let body, ctx = value_with_constraints in + let sigma = Evd.from_ctx ctx in + let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in + let udecl = UState.default_univ_decl in + let nohook = Lemmas.mk_hook (fun _ x -> ()) in + ignore (edeclare ident k ~opaque:false sigma udecl body None [] nohook) + +(* But this definition cannot be undone by Reset ident *) diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.mli b/doc/plugin_tutorial/tuto1/src/simple_declare.mli new file mode 100644 index 0000000000..fd74e81526 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.mli @@ -0,0 +1,5 @@ +open Names +open EConstr + +val packed_declare_definition : + poly:bool -> Id.t -> constr Evd.in_evar_universe_context -> unit diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.ml b/doc/plugin_tutorial/tuto1/src/simple_print.ml new file mode 100644 index 0000000000..cfc38ff9c9 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_print.ml @@ -0,0 +1,17 @@ +(* A more advanced example of how to explore the structure of terms of + type constr is given in the coq-dpdgraph plugin. *) + +let simple_body_access gref = + match gref with + | Globnames.VarRef _ -> + failwith "variables are not covered in this example" + | Globnames.IndRef _ -> + failwith "inductive types are not covered in this example" + | Globnames.ConstructRef _ -> + failwith "constructors are not covered in this example" + | Globnames.ConstRef cst -> + let cb = Environ.lookup_constant cst (Global.env()) in + match Global.body_of_constant_body cb with + | Some(e, _) -> e + | None -> failwith "This term has no value" + diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.mli b/doc/plugin_tutorial/tuto1/src/simple_print.mli new file mode 100644 index 0000000000..254b56ff79 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/simple_print.mli @@ -0,0 +1 @@ +val simple_body_access : Names.GlobRef.t -> Constr.constr diff --git a/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack b/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack new file mode 100644 index 0000000000..a797a509e0 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack @@ -0,0 +1,4 @@ +Simple_check +Simple_declare +Simple_print +G_tuto1 diff --git a/doc/plugin_tutorial/tuto1/theories/Loader.v b/doc/plugin_tutorial/tuto1/theories/Loader.v new file mode 100644 index 0000000000..6e8e308b3f --- /dev/null +++ b/doc/plugin_tutorial/tuto1/theories/Loader.v @@ -0,0 +1 @@ +Declare ML Module "tuto1_plugin". diff --git a/doc/plugin_tutorial/tuto2/Makefile b/doc/plugin_tutorial/tuto2/Makefile new file mode 100644 index 0000000000..e0e197650d --- /dev/null +++ b/doc/plugin_tutorial/tuto2/Makefile @@ -0,0 +1,14 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + +%: Makefile.coq + +Makefile.coq: _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/doc/plugin_tutorial/tuto2/_CoqProject b/doc/plugin_tutorial/tuto2/_CoqProject new file mode 100644 index 0000000000..cf9cb5cc26 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/_CoqProject @@ -0,0 +1,6 @@ +-R theories/ Tuto +-I src + +theories/Test.v +src/demo.mlg +src/demo_plugin.mlpack diff --git a/doc/plugin_tutorial/tuto2/src/.gitignore b/doc/plugin_tutorial/tuto2/src/.gitignore new file mode 100644 index 0000000000..5b1b6a902e --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/.gitignore @@ -0,0 +1 @@ +/demo.ml diff --git a/doc/plugin_tutorial/tuto2/src/demo.mlg b/doc/plugin_tutorial/tuto2/src/demo.mlg new file mode 100644 index 0000000000..966c05acdc --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/demo.mlg @@ -0,0 +1,375 @@ +(* -------------------------------------------------------------------------- *) +(* *) +(* Initial ritual dance *) +(* *) +(* -------------------------------------------------------------------------- *) + +DECLARE PLUGIN "demo_plugin" + +(* + Use this macro before any of the other OCaml macros. + + Each plugin has a unique name. + We have decided to name this plugin as "demo_plugin". + That means that: + + (1) If we want to load this particular plugin to Coq toplevel, + we must use the following command. + + Declare ML Module "demo_plugin". + + (2) The above command will succeed only if there is "demo_plugin.cmxs" + in some of the directories that Coq is supposed to look + (i.e. the ones we specified via "-I ..." command line options). + + (3) The file "demo_plugin.mlpack" lists the OCaml modules to be linked in + "demo_plugin.cmxs". + + (4) The file "demo_plugin.mlpack" as well as all .ml, .mli and .mlg files + are listed in the "_CoqProject" file. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command? *) +(* *) +(* -------------------------------------------------------------------------- *) + +VERNAC COMMAND EXTEND Cmd1 CLASSIFIED AS QUERY +| [ "Cmd1" ] -> { () } +END + +(* + These: + + VERNAC COMMAND EXTEND + + and + + END + + mark the beginning and the end of the definition of a new Vernacular command. + + Cmd1 is a unique identifier (which must start with an upper-case letter) + associated with the new Vernacular command we are defining. + + CLASSIFIED AS QUERY tells Coq that the new Vernacular command: + - changes neither the global environment + - nor does it modify the plugin's state. + + If the new command could: + - change the global environment + - or modify a plugin's state + then one would have to use CLASSIFIED AS SIDEFF instead. + + This: + + [ "Cmd1" ] -> { () } + + defines: + - the parsing rule + - the interpretation rule + + The parsing rule and the interpretation rule are separated by -> token. + + The parsing rule, in this case, is: + + [ "Cmd1" ] + + By convention, all vernacular command start with an upper-case letter. + + The [ and ] characters mark the beginning and the end of the parsing rule. + The parsing rule itself says that the syntax of the newly defined command + is composed from a single terminal Cmd1. + + The interpretation rule, in this case, is: + + { () } + + Similarly to the case of the parsing rule, + { and } characters mark the beginning and the end of the interpretation rule. + In this case, the following Ocaml expression: + + () + + defines the effect of the Vernacular command we have just defined. + That is, it behaves is no-op. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command with some terminal parameters? *) +(* *) +(* -------------------------------------------------------------------------- *) + +VERNAC COMMAND EXTEND Cmd2 CLASSIFIED AS QUERY +| [ "Cmd2" "With" "Some" "Terminal" "Parameters" ] -> { () } +END + +(* + As shown above, the Vernacular command can be composed from + any number of terminals. + + By convention, each of these terminals starts with an upper-case letter. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command with some non-terminal parameter? *) +(* *) +(* -------------------------------------------------------------------------- *) + +{ + +open Stdarg + +} + +VERNAC COMMAND EXTEND Cmd3 CLASSIFIED AS QUERY +| [ "Cmd3" int(i) ] -> { () } +END + +(* + This: + + open Stdarg + + is needed as some identifiers in the Ocaml code generated by the + + VERNAC COMMAND EXTEND ... END + + macros are not fully qualified. + + This: + + int(i) + + means that the new command is expected to be followed by an integer. + The integer is bound in the parsing rule to variable i. + This variable i then can be used in the interpretation rule. + + To see value of which Ocaml types can be bound this way, + look at the wit_* function declared in interp/stdarg.mli + (in the Coq's codebase). + + If we drop the wit_ prefix, we will get the token + that we can use in the parsing rule. + That is, since there exists wit_int, we know that + we can write: + + int(i) + + By looking at the signature of the wit_int function: + + val wit_int : int uniform_genarg_type + + we also know that variable i will have the type int. + + The types of wit_* functions are either: + + 'c uniform_genarg_type + + or + + ('a,'b,'c) genarg_type + + In both cases, the bound variable will have type 'c. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command with variable number of arguments? *) +(* *) +(* -------------------------------------------------------------------------- *) + +VERNAC COMMAND EXTEND Cmd4 CLASSIFIED AS QUERY +| [ "Cmd4" int_list(l) ] -> { () } +END + +(* + This: + + int_list(l) + + means that the new Vernacular command is expected to be followed + by a (whitespace separated) list of integers. + This list of integers is bound to the indicated l. + + In this case, as well as in the cases we point out below, instead of int + in int_list we could use any other supported type, e.g. ident, bool, ... + + To see which other Ocaml type constructors (in addition to list) + are supported, have a look at the parse_user_entry function defined + in grammar/q_util.mlp file. + + E.g.: + - ne_int_list(x) would represent a non-empty list of integers, + - int_list(x) would represent a list of integers, + - int_opt(x) would represent a value of type int option, + - ··· +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to define a new Vernacular command that takes values of a custom type? *) +(* *) +(* -------------------------------------------------------------------------- *) + +{ + +open Ltac_plugin + +} + +(* + If we want to avoid a compilation failure + + "no implementation available for Tacenv" + + then we have to open the Ltac_plugin module. +*) + +(* + Pp module must be opened because some of the macros that are part of the API + do not expand to fully qualified names. +*) + +{ + +type type_5 = Foo_5 | Bar_5 + +} + +(* + We define a type of values that we want to pass to our Vernacular command. +*) + +(* + By default, we are able to define new Vernacular commands that can take + parameters of some of the supported types. Which types are supported, + that was discussed earlier. + + If we want to be able to define Vernacular command that takes parameters + of a type that is not supported by default, we must use the following macro: +*) + +{ + +open Pp + +} + +VERNAC ARGUMENT EXTEND custom5 +| [ "Foo_5" ] -> { Foo_5 } +| [ "Bar_5" ] -> { Bar_5 } +END + +(* + where: + + custom5 + + indicates that, from now on, in our parsing rules we can write: + + custom5(some_variable) + + in those places where we expect user to provide an input + that can be parsed by the parsing rules above + (and interpreted by the interpretations rules above). +*) + +(* Here: *) + +VERNAC COMMAND EXTEND Cmd5 CLASSIFIED AS QUERY +| [ "Cmd5" custom5(x) ] -> { () } +END + +(* + we define a new Vernacular command whose parameters, provided by the user, + can be mapped to values of type_5. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to give a feedback to the user? *) +(* *) +(* -------------------------------------------------------------------------- *) + +VERNAC COMMAND EXTEND Cmd6 CLASSIFIED AS QUERY +| [ "Cmd6" ] -> { Feedback.msg_notice (Pp.str "Everything is awesome!") } +END + +(* + The following functions: + + - Feedback.msg_info : Pp.t -> unit + - Feedback.msg_notice : Pp.t -> unit + - Feedback.msg_warning : Pp.t -> unit + - Feedback.msg_error : Pp.t -> unit + - Feedback.msg_debug : Pp.t -> unit + + enable us to give user a textual feedback. + + Pp module enable us to represent and construct pretty-printing instructions. + The concepts defined and the services provided by the Pp module are in + various respects related to the concepts and services provided + by the Format module that is part of the Ocaml standard library. +*) + +(* -------------------------------------------------------------------------- *) +(* *) +(* How to implement a Vernacular command with (undoable) side-effects? *) +(* *) +(* -------------------------------------------------------------------------- *) + +{ + +open Summary.Local + +} + +(* + By opening Summary.Local module we shadow the original functions + that we traditionally use for implementing stateful behavior. + + ref + ! + := + + are now shadowed by their counterparts in Summary.Local. *) + +{ + +let counter = ref ~name:"counter" 0 + +} + +VERNAC COMMAND EXTEND Cmd7 CLASSIFIED AS SIDEFF +| [ "Cmd7" ] -> { counter := succ !counter; + Feedback.msg_notice (Pp.str "counter = " ++ Pp.str (string_of_int (!counter))) } +END + +TACTIC EXTEND tactic1 +| [ "tactic1" ] -> { Proofview.tclUNIT () } +END + +(* ---- *) + +{ + +type custom = Foo_2 | Bar_2 + +let pr_custom _ _ _ = function + | Foo_2 -> Pp.str "Foo_2" + | Bar_2 -> Pp.str "Bar_2" + +} + +ARGUMENT EXTEND custom2 PRINTED BY { pr_custom } +| [ "Foo_2" ] -> { Foo_2 } +| [ "Bar_2" ] -> { Bar_2 } +END + +TACTIC EXTEND tactic2 +| [ "tactic2" custom2(x) ] -> { Proofview.tclUNIT () } +END diff --git a/doc/plugin_tutorial/tuto2/src/demo_plugin.mlpack b/doc/plugin_tutorial/tuto2/src/demo_plugin.mlpack new file mode 100644 index 0000000000..4f0b8480b5 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/demo_plugin.mlpack @@ -0,0 +1 @@ +Demo diff --git a/doc/plugin_tutorial/tuto2/src/dune b/doc/plugin_tutorial/tuto2/src/dune new file mode 100644 index 0000000000..f2bc405455 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/src/dune @@ -0,0 +1,9 @@ +(library + (name tuto2_plugin) + (public_name coq.plugins.tutorial.p2) + (libraries coq.plugins.ltac)) + +(rule + (targets demo.ml) + (deps (:pp-file demo.mlg) ) + (action (run coqpp %{pp-file}))) diff --git a/doc/plugin_tutorial/tuto2/theories/Test.v b/doc/plugin_tutorial/tuto2/theories/Test.v new file mode 100644 index 0000000000..38e83bfff1 --- /dev/null +++ b/doc/plugin_tutorial/tuto2/theories/Test.v @@ -0,0 +1,19 @@ +Declare ML Module "demo_plugin". + +Cmd1. +Cmd2 With Some Terminal Parameters. +Cmd3 42. +Cmd4 100 200 300 400. +Cmd5 Foo_5. +Cmd5 Bar_5. +Cmd6. +Cmd7. +Cmd7. +Cmd7. + +Goal True. +Proof. + tactic1. + tactic2 Foo_2. + tactic2 Bar_2. +Abort. diff --git a/doc/plugin_tutorial/tuto3/Makefile b/doc/plugin_tutorial/tuto3/Makefile new file mode 100644 index 0000000000..e0e197650d --- /dev/null +++ b/doc/plugin_tutorial/tuto3/Makefile @@ -0,0 +1,14 @@ +ifeq "$(COQBIN)" "" + COQBIN=$(dir $(shell which coqtop))/ +endif + +%: Makefile.coq + +Makefile.coq: _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq + +tests: all + @$(MAKE) -C tests -s clean + @$(MAKE) -C tests -s all + +-include Makefile.coq diff --git a/doc/plugin_tutorial/tuto3/_CoqProject b/doc/plugin_tutorial/tuto3/_CoqProject new file mode 100644 index 0000000000..e2a60a430f --- /dev/null +++ b/doc/plugin_tutorial/tuto3/_CoqProject @@ -0,0 +1,12 @@ +-R theories Tuto3 +-I src + +theories/Data.v +theories/Loader.v + +src/tuto_tactic.ml +src/tuto_tactic.mli +src/construction_game.ml +src/construction_game.mli +src/g_tuto3.mlg +src/tuto3_plugin.mlpack diff --git a/doc/plugin_tutorial/tuto3/src/construction_game.ml b/doc/plugin_tutorial/tuto3/src/construction_game.ml new file mode 100644 index 0000000000..9d9f894e18 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/construction_game.ml @@ -0,0 +1,186 @@ +open Pp + +let find_reference = Coqlib.find_reference [@ocaml.warning "-3"] + +let example_sort evd = +(* creating a new sort requires that universes should be recorded + in the evd datastructure, so this datastructure also needs to be + passed around. *) + let evd, s = Evd.new_sort_variable Evd.univ_rigid evd in + let new_type = EConstr.mkSort s in + evd, new_type + +let c_one evd = +(* In the general case, global references may refer to universe polymorphic + objects, and their universe has to be made afresh when creating an instance. *) + let gr_S = + find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "S" in +(* the long name of "S" was found with the command "About S." *) + let gr_O = + find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "O" in + let evd, c_O = Evarutil.new_global evd gr_O in + let evd, c_S = Evarutil.new_global evd gr_S in +(* Here is the construction of a new term by applying functions to argument. *) + evd, EConstr.mkApp (c_S, [| c_O |]) + +let dangling_identity env evd = +(* I call this a dangling identity, because it is not polymorph, but + the type on which it applies is left unspecified, as it is + represented by an existential variable. The declaration for this + existential variable needs to be added in the evd datastructure. *) + let evd, type_type = example_sort evd in + let evd, arg_type = Evarutil.new_evar env evd type_type in +(* Notice the use of a De Bruijn index for the inner occurrence of the + bound variable. *) + evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, + EConstr.mkRel 1) + +let dangling_identity2 env evd = +(* This example uses directly a function that produces an evar that + is meant to be a type. *) + let evd, (arg_type, type_type) = + Evarutil.new_type_evar env evd Evd.univ_rigid in + evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, + EConstr.mkRel 1) + +let example_sort_app_lambda () = + let env = Global.env () in + let evd = Evd.from_env env in + let evd, c_v = c_one evd in +(* dangling_identity and dangling_identity2 can be used interchangeably here *) + let evd, c_f = dangling_identity2 env evd in + let c_1 = EConstr.mkApp (c_f, [| c_v |]) in + let _ = Feedback.msg_notice + (Printer.pr_econstr_env env evd c_1) in + (* type verification happens here. Type verification will update + existential variable information in the evd part. *) + let evd, the_type = Typing.type_of env evd c_1 in +(* At display time, you will notice that the system knows about the + existential variable being instantiated to the "nat" type, even + though c_1 still contains the meta-variable. *) + Feedback.msg_notice + ((Printer.pr_econstr_env env evd c_1) ++ + str " has type " ++ + (Printer.pr_econstr_env env evd the_type)) + + +let c_S evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "S" in + Evarutil.new_global evd gr + +let c_O evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "O" in + Evarutil.new_global evd gr + +let c_E evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "EvenNat" in + Evarutil.new_global evd gr + +let c_D evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "tuto_div2" in + Evarutil.new_global evd gr + +let c_Q evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Logic"] "eq" in + Evarutil.new_global evd gr + +let c_R evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Logic"] "eq_refl" in + Evarutil.new_global evd gr + +let c_N evd = + let gr = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "nat" in + Evarutil.new_global evd gr + +let c_C evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "C" in + Evarutil.new_global evd gr + +let c_F evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "S_ev" in + Evarutil.new_global evd gr + +let c_P evd = + let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "s_half_proof" in + Evarutil.new_global evd gr + +(* If c_S was universe polymorphic, we should have created a new constant + at each iteration of buildup. *) +let mk_nat evd n = + let evd, c_S = c_S evd in + let evd, c_O = c_O evd in + let rec buildup = function + | 0 -> c_O + | n -> EConstr.mkApp (c_S, [| buildup (n - 1) |]) in + if n <= 0 then evd, c_O else evd, buildup n + +let example_classes n = + let env = Global.env () in + let evd = Evd.from_env env in + let evd, c_n = mk_nat evd n in + let evd, n_half = mk_nat evd (n / 2) in + let evd, c_N = c_N evd in + let evd, c_div = c_D evd in + let evd, c_even = c_E evd in + let evd, c_Q = c_Q evd in + let evd, c_R = c_R evd in + let arg_type = EConstr.mkApp (c_even, [| c_n |]) in + let evd0 = evd in + let evd, instance = Evarutil.new_evar env evd arg_type in + let c_half = EConstr.mkApp (c_div, [|c_n; instance|]) in + let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd c_half) in + let evd, the_type = Typing.type_of env evd c_half in + let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd c_half) in + let proved_equality = + EConstr.mkCast(EConstr.mkApp (c_R, [| c_N; c_half |]), Constr.DEFAULTcast, + EConstr.mkApp (c_Q, [| c_N; c_half; n_half|])) in +(* This is where we force the system to compute with type classes. *) +(* Question to coq developers: why do we pass two evd arguments to + solve_remaining_evars? Is the choice of evd0 relevant here? *) + let evd = Pretyping.solve_remaining_evars + (Pretyping.default_inference_flags true) env evd ~initial:evd0 in + let evd, final_type = Typing.type_of env evd proved_equality in + Feedback.msg_notice (Printer.pr_econstr_env env evd proved_equality) + +(* This function, together with definitions in Data.v, shows how to + trigger automatic proofs at the time of typechecking, based on + canonical structures. + + n is a number for which we want to find the half (and a proof that + this half is indeed the half) +*) +let example_canonical n = + let env = Global.env () in + let evd = Evd.from_env env in +(* Construct a natural representation of this integer. *) + let evd, c_n = mk_nat evd n in +(* terms for "nat", "eq", "S_ev", "eq_refl", "C" *) + let evd, c_N = c_N evd in + let evd, c_F = c_F evd in + let evd, c_R = c_R evd in + let evd, c_C = c_C evd in + let evd, c_P = c_P evd in +(* the last argument of C *) + let refl_term = EConstr.mkApp (c_R, [|c_N; c_n |]) in +(* Now we build two existential variables, for the value of the half and for + the "S_ev" structure that triggers the proof search. *) + let evd, ev1 = Evarutil.new_evar env evd c_N in +(* This is the type for the second existential variable *) + let csev = EConstr.mkApp (c_F, [| ev1 |]) in + let evd, ev2 = Evarutil.new_evar env evd csev in +(* Now we build the C structure. *) + let test_term = EConstr.mkApp (c_C, [| c_n; ev1; ev2; refl_term |]) in +(* Type-checking this term will compute values for the existential variables *) + let evd, final_type = Typing.type_of env evd test_term in +(* The computed type has two parameters, the second one is the proof. *) + let value = match EConstr.kind evd final_type with + | Constr.App(_, [| _; the_half |]) -> the_half + | _ -> failwith "expecting the whole type to be \"cmp _ the_half\"" in + let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd value) in +(* I wish for a nicer way to get the value of ev2 in the evar_map *) + let prf_struct = EConstr.of_constr (EConstr.to_constr evd ev2) in + let the_prf = EConstr.mkApp (c_P, [| ev1; prf_struct |]) in + let evd, the_statement = Typing.type_of env evd the_prf in + Feedback.msg_notice + (Printer.pr_econstr_env env evd the_prf ++ str " has type " ++ + Printer.pr_econstr_env env evd the_statement) diff --git a/doc/plugin_tutorial/tuto3/src/construction_game.mli b/doc/plugin_tutorial/tuto3/src/construction_game.mli new file mode 100644 index 0000000000..1832ed6630 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/construction_game.mli @@ -0,0 +1,4 @@ +val dangling_identity : Environ.env -> Evd.evar_map -> Evd.evar_map * EConstr.t +val example_sort_app_lambda : unit -> unit +val example_classes : int -> unit +val example_canonical : int -> unit diff --git a/doc/plugin_tutorial/tuto3/src/dune b/doc/plugin_tutorial/tuto3/src/dune new file mode 100644 index 0000000000..ba6d8b288f --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/dune @@ -0,0 +1,10 @@ +(library + (name tuto3_plugin) + (public_name coq.plugins.tutorial.p3) + (flags :standard -warn-error -3) + (libraries coq.plugins.ltac)) + +(rule + (targets g_tuto3.ml) + (deps (:pp-file g_tuto3.mlg)) + (action (run coqpp %{pp-file}))) diff --git a/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg b/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg new file mode 100644 index 0000000000..82ba45726e --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg @@ -0,0 +1,46 @@ +DECLARE PLUGIN "tuto3_plugin" + +{ + +open Ltac_plugin + +open Construction_game + +(* This one is necessary, to avoid message about missing wit_string *) +open Stdarg + +} + +VERNAC COMMAND EXTEND ShowTypeConstruction CLASSIFIED AS QUERY +| [ "Tuto3_1" ] -> + { let env = Global.env () in + let evd = Evd.from_env env in + let evd, s = Evd.new_sort_variable Evd.univ_rigid evd in + let new_type_2 = EConstr.mkSort s in + let evd, _ = + Typing.type_of (Global.env()) (Evd.from_env (Global.env())) new_type_2 in + Feedback.msg_notice + (Printer.pr_econstr_env env evd new_type_2) } +END + +VERNAC COMMAND EXTEND ShowOneConstruction CLASSIFIED AS QUERY +| [ "Tuto3_2" ] -> { example_sort_app_lambda () } +END + +TACTIC EXTEND collapse_hyps +| [ "pack" "hypothesis" ident(i) ] -> + { Tuto_tactic.pack_tactic i } +END + +(* More advanced examples, where automatic proof happens but + no tactic is being called explicitely. The first one uses + type classes. *) +VERNAC COMMAND EXTEND TriggerClasses CLASSIFIED AS QUERY +| [ "Tuto3_3" int(n) ] -> { example_classes n } +END + +(* The second one uses canonical structures. *) +VERNAC COMMAND EXTEND TriggerCanonical CLASSIFIED AS QUERY +| [ "Tuto3_4" int(n) ] -> { example_canonical n } +END + diff --git a/doc/plugin_tutorial/tuto3/src/tuto3_plugin.mlpack b/doc/plugin_tutorial/tuto3/src/tuto3_plugin.mlpack new file mode 100644 index 0000000000..f4645ad7ed --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/tuto3_plugin.mlpack @@ -0,0 +1,3 @@ +Construction_game +Tuto_tactic +G_tuto3 diff --git a/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml new file mode 100644 index 0000000000..8f2c387d09 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml @@ -0,0 +1,143 @@ +open Proofview + +let constants = ref ([] : EConstr.t list) + +(* This is a pattern to collect terms from the Coq memory of valid terms + and proofs. This pattern extends all the way to the definition of function + c_U *) +let collect_constants () = + if (!constants = []) then + let open EConstr in + let open UnivGen in + let find_reference = Coqlib.find_reference [@ocaml.warning "-3"] in + let gr_H = find_reference "Tuto3" ["Tuto3"; "Data"] "pack" in + let gr_M = find_reference "Tuto3" ["Tuto3"; "Data"] "packer" in + let gr_R = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "pair" in + let gr_P = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "prod" in + let gr_U = find_reference "Tuto3" ["Tuto3"; "Data"] "uncover" in + constants := List.map (fun x -> of_constr (constr_of_monomorphic_global x)) + [gr_H; gr_M; gr_R; gr_P; gr_U]; + !constants + else + !constants + +let c_H () = + match collect_constants () with + it :: _ -> it + | _ -> failwith "could not obtain an internal representation of pack" + +let c_M () = + match collect_constants () with + _ :: it :: _ -> it + | _ -> failwith "could not obtain an internal representation of pack_marker" + +let c_R () = + match collect_constants () with + _ :: _ :: it :: _ -> it + | _ -> failwith "could not obtain an internal representation of pair" + +let c_P () = + match collect_constants () with + _ :: _ :: _ :: it :: _ -> it + | _ -> failwith "could not obtain an internal representation of prod" + +let c_U () = + match collect_constants () with + _ :: _ :: _ :: _ :: it :: _ -> it + | _ -> failwith "could not obtain an internal representation of prod" + +(* The following tactic is meant to pack an hypothesis when no other + data is already packed. + + The main difficulty in defining this tactic is to understand how to + construct the input expected by apply_in. *) +let package i = Goal.enter begin fun gl -> + Tactics.apply_in true false i + [(* this means that the applied theorem is not to be cleared. *) + None, (CAst.make (c_M (), + (* we don't specialize the theorem with extra values. *) + Tactypes.NoBindings))] + (* we don't destruct the result according to any intro_pattern *) + None + end + +(* This function is meant to observe a type of shape (f a) + and return the value a. *) + +(* Remark by Maxime: look for destApp combinator. *) +let unpack_type evd term = + let report () = + CErrors.user_err (Pp.str "expecting a packed type") in + match EConstr.kind evd term with + | Constr.App (_, [| ty |]) -> ty + | _ -> report () + +(* This function is meant to observe a type of shape + A -> pack B -> C and return A, B, C + but it is not used in the current version of our tactic. + It is kept as an example. *) +let two_lambda_pattern evd term = + let report () = + CErrors.user_err (Pp.str "expecting two nested implications") in +(* Note that pattern-matching is always done through the EConstr.kind function, + which only provides one-level deep patterns. *) + match EConstr.kind evd term with + (* Here we recognize the outer implication *) + | Constr.Prod (_, ty1, l1) -> + (* Here we recognize the inner implication *) + (match EConstr.kind evd l1 with + | Constr.Prod (n2, packed_ty2, deep_conclusion) -> + (* Here we recognized that the second type is an application *) + ty1, unpack_type evd packed_ty2, deep_conclusion + | _ -> report ()) + | _ -> report () + +(* In the environment of the goal, we can get the type of an assumption + directly by a lookup. The other solution is to call a low-cost retyping + function like *) +let get_type_of_hyp env id = + match EConstr.lookup_named id env with + | Context.Named.Declaration.LocalAssum (_, ty) -> ty + | _ -> CErrors.user_err (let open Pp in + str (Names.Id.to_string id) ++ + str " is not a plain hypothesis") + +let repackage i h_hyps_id = Goal.enter begin fun gl -> + let env = Goal.env gl in + let evd = Tacmach.New.project gl in + let concl = Tacmach.New.pf_concl gl in + let (ty1 : EConstr.t) = get_type_of_hyp env i in + let (packed_ty2 : EConstr.t) = get_type_of_hyp env h_hyps_id in + let ty2 = unpack_type evd packed_ty2 in + let new_packed_type = EConstr.mkApp (c_P (), [| ty1; ty2 |]) in + let open EConstr in + let new_packed_value = + mkApp (c_R (), [| ty1; ty2; mkVar i; + mkApp (c_U (), [| ty2; mkVar h_hyps_id|]) |]) in + Refine.refine ~typecheck:true begin fun evd -> + let evd, new_goal = Evarutil.new_evar env evd + (mkProd (Names.Name.Anonymous, + mkApp(c_H (), [| new_packed_type |]), + Vars.lift 1 concl)) in + evd, mkApp (new_goal, + [|mkApp(c_M (), [|new_packed_type; new_packed_value |]) |]) + end + end + +let pack_tactic i = + let h_hyps_id = (Names.Id.of_string "packed_hyps") in + Proofview.Goal.enter begin fun gl -> + let hyps = Environ.named_context_val (Proofview.Goal.env gl) in + if not (Termops.mem_named_context_val i hyps) then + (CErrors.user_err + (Pp.str ("no hypothesis named" ^ (Names.Id.to_string i)))) + else + if Termops.mem_named_context_val h_hyps_id hyps then + tclTHEN (repackage i h_hyps_id) + (tclTHEN (Tactics.clear [h_hyps_id; i]) + (Tactics.introduction h_hyps_id)) + else + tclTHEN (package i) + (tclTHEN (Tactics.rename_hyp [i, h_hyps_id]) + (Tactics.move_hyp h_hyps_id Logic.MoveLast)) + end diff --git a/doc/plugin_tutorial/tuto3/src/tuto_tactic.mli b/doc/plugin_tutorial/tuto3/src/tuto_tactic.mli new file mode 100644 index 0000000000..dbf6cf48e2 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/src/tuto_tactic.mli @@ -0,0 +1,3 @@ +val two_lambda_pattern : + Evd.evar_map -> EConstr.t -> EConstr.t * EConstr.t * EConstr.t +val pack_tactic : Names.Id.t -> unit Proofview.tactic diff --git a/doc/plugin_tutorial/tuto3/theories/Data.v b/doc/plugin_tutorial/tuto3/theories/Data.v new file mode 100644 index 0000000000..f7395d686b --- /dev/null +++ b/doc/plugin_tutorial/tuto3/theories/Data.v @@ -0,0 +1,73 @@ + + +Inductive pack (A: Type) : Type := + packer : A -> pack A. + +Arguments packer {A}. + +Definition uncover (A : Type) (packed : pack A) : A := + match packed with packer v => v end. + +Notation "!!!" := (pack _) (at level 0, only printing). + +(* The following data is used as material for automatic proofs + based on type classes. *) + +Class EvenNat the_even := {half : nat; half_prop : 2 * half = the_even}. + +Instance EvenNat0 : EvenNat 0 := {half := 0; half_prop := eq_refl}. + +Lemma even_rec n h : 2 * h = n -> 2 * S h = S (S n). +Proof. + intros []. + simpl. rewrite <-plus_n_O, <-plus_n_Sm. + reflexivity. +Qed. + +Instance EvenNat_rec n (p : EvenNat n) : EvenNat (S (S n)) := + {half := S (@half _ p); half_prop := even_rec n (@half _ p) (@half_prop _ p)}. + +Definition tuto_div2 n (p : EvenNat n) := @half _ p. + +(* to be used in the following examples +Compute (@half 8 _). + +Check (@half_prop 8 _). + +Check (@half_prop 7 _). + +and in command Tuto3_3 8. *) + +(* The following data is used as material for automatic proofs + based on canonical structures. *) + +Record S_ev n := Build_S_ev {double_of : nat; _ : 2 * n = double_of}. + +Definition s_half_proof n (r : S_ev n) : 2 * n = double_of n r := + match r with Build_S_ev _ _ h => h end. + +Canonical Structure can_ev_default n d (Pd : 2 * n = d) : S_ev n := + Build_S_ev n d Pd. + +Canonical Structure can_ev0 : S_ev 0 := + Build_S_ev 0 0 (@eq_refl _ 0). + +Lemma can_ev_rec n : forall (s : S_ev n), S_ev (S n). +Proof. +intros s; exists (S (S (double_of _ s))). +destruct s as [a P]. +exact (even_rec _ _ P). +Defined. + +Canonical Structure can_ev_rec. + +Record cmp (n : nat) (k : nat) := + C {h : S_ev k; _ : double_of k h = n}. + +(* To be used in, e.g., + +Check (C _ _ _ eq_refl : cmp 6 _). + +Check (C _ _ _ eq_refl : cmp 7 _). + +*) diff --git a/doc/plugin_tutorial/tuto3/theories/Loader.v b/doc/plugin_tutorial/tuto3/theories/Loader.v new file mode 100644 index 0000000000..1351cff63b --- /dev/null +++ b/doc/plugin_tutorial/tuto3/theories/Loader.v @@ -0,0 +1,3 @@ +From Tuto3 Require Export Data. + +Declare ML Module "tuto3_plugin". diff --git a/doc/plugin_tutorial/tuto3/theories/test.v b/doc/plugin_tutorial/tuto3/theories/test.v new file mode 100644 index 0000000000..43204ddf34 --- /dev/null +++ b/doc/plugin_tutorial/tuto3/theories/test.v @@ -0,0 +1,23 @@ +(* to be used e.g. in : coqtop -I src -R theories Tuto3 < theories/test.v *) + +Require Import Tuto3.Loader. + +(* This should print Type. *) +Tuto3_1. + +(* This should print a term that contains an existential variable. *) +(* And then print the same term, where the variable has been correctly + instantiated. *) +Tuto3_2. + +Lemma tutu x y (A : 0 < x) (B : 10 < y) : True. +Proof. +pack hypothesis A. +(* Hypothesis A should have disappeared and a "packed_hyps" hypothesis + should have appeared, with unreadable content. *) +pack hypothesis B. +(* Hypothesis B should have disappeared *) +destruct packed_hyps as [unpacked_hyps]. +(* Hypothesis unpacked_hyps should contain the previous contents of A and B. *) +exact I. +Qed. diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index e681d0f3ff..39047f4f23 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -61,7 +61,7 @@ extensions = [ # Change this to "info" or "warning" to get notifications about undocumented Coq # objects (objects with no contents). -report_undocumented_coq_objects = None +report_undocumented_coq_objects = "warning" # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] diff --git a/doc/sphinx/dune b/doc/sphinx/dune new file mode 100644 index 0000000000..fff025c919 --- /dev/null +++ b/doc/sphinx/dune @@ -0,0 +1 @@ +(dirs :standard _static) diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 1a33a9a46e..8fa631174f 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -230,7 +230,7 @@ There are three sorts :g:`Set`, :g:`Prop` and :g:`Type`. themselves are typing the proofs. We denote propositions by :production:`form`. This constitutes a semantic subclass of the syntactic class :token:`term`. -- :g:`Set` is is the universe of *program types* or *specifications*. The +- :g:`Set` is the universe of *program types* or *specifications*. The specifications themselves are typing the programs. We denote specifications by :production:`specif`. This constitutes a semantic subclass of the syntactic class :token:`term`. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 9fbac95f0c..92bd4dbd1d 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -418,30 +418,29 @@ each point of use, e.g., the above definition can be written: Prenex Implicits null. Definition all_null (s : list T) := all null s. -Better yet, it can be omitted entirely, since ``all_null s`` isn’t much of -an improvement over ``all null s``. +Better yet, it can be omitted entirely, since :g:`all_null s` isn’t much of +an improvement over :g:`all null s`. The syntax of the new declaration is -.. cmd:: Prenex Implicits {+ @ident} +.. cmd:: Prenex Implicits {+ @ident__i} -Let us denote :math:`c_1` … :math:`c_n` the list of identifiers given to a -``Prenex Implicits`` command. The command checks that each ci is the name of -a functional constant, whose implicit arguments are prenex, i.e., the first -:math:`n_i > 0` arguments of :math:`c_i` are implicit; then it assigns -``Maximal Implicit`` status to these arguments. + This command checks that each :n:`@ident__i` is the name of a functional + constant, whose implicit arguments are prenex, i.e., the first + :math:`n_i > 0` arguments of :n:`@ident__i` are implicit; then it assigns + ``Maximal Implicit`` status to these arguments. -As these prenex implicit arguments are ubiquitous and have often large -display strings, it is strongly recommended to change the default -display settings of |Coq| so that they are not printed (except after -a ``Set Printing All`` command). All |SSR| library files thus start -with the incantation + As these prenex implicit arguments are ubiquitous and have often large + display strings, it is strongly recommended to change the default + display settings of |Coq| so that they are not printed (except after + a ``Set Printing All`` command). All |SSR| library files thus start + with the incantation -.. coqtop:: all undo + .. coqtop:: all undo - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. Anonymous arguments @@ -601,25 +600,21 @@ resemble ML-like definitions of polymorphic functions. Abbreviations ~~~~~~~~~~~~~ -The |SSR| set tactic performs abbreviations: it introduces a -defined constant for a subterm appearing in the goal and/or in the -context. - -|SSR| extends the set tactic by supplying: - +.. tacn:: set @ident {? : @term } := {? @occ_switch } @term + :name: set (ssreflect) -+ an open syntax, similarly to the pose tactic; -+ a more aggressive matching algorithm; -+ an improved interpretation of wildcards, taking advantage of the - matching algorithm; -+ an improved occurrence selection mechanism allowing to abstract only - selected occurrences of a term. + The |SSR| ``set`` tactic performs abbreviations: it introduces a + defined constant for a subterm appearing in the goal and/or in the + context. + |SSR| extends the :tacn:`set` tactic by supplying: -The general syntax of this tactic is - -.. tacn:: set @ident {? : @term } := {? @occ_switch } @term - :name: set (ssreflect) + + an open syntax, similarly to the :tacn:`pose (ssreflect)` tactic; + + a more aggressive matching algorithm; + + an improved interpretation of wildcards, taking advantage of the + matching algorithm; + + an improved occurrence selection mechanism allowing to abstract only + selected occurrences of a term. .. prodn:: occ_switch ::= { {? + %| - } {* @num } } @@ -903,23 +898,15 @@ Basic localization ~~~~~~~~~~~~~~~~~~ It is possible to define an abbreviation for a term appearing in the -context of a goal thanks to the in tactical. - -A tactic of the form: +context of a goal thanks to the ``in`` tactical. .. tacv:: set @ident := @term in {+ @ident} -introduces a defined constant called ``x`` in the context, and folds it in -the context entries mentioned on the right hand side of ``in``. -The body of ``x`` is the first subterm matching these context entries -(taken in the given order). - -A tactic of the form: - -.. tacv:: set @ident := @term in {+ @ident} * - -matches term and then folds ``x`` similarly in all the given context entries -but also folds ``x`` in the goal. + This variant of :tacn:`set (ssreflect)` introduces a defined constant + called :token:`ident` in the context, and folds it in + the context entries mentioned on the right hand side of ``in``. + The body of :token:`ident` is the first subterm matching these context + entries (taken in the given order). .. example:: @@ -932,7 +919,10 @@ but also folds ``x`` in the goal. Lemma test x t (Hx : x = 3) : x + t = 4. set z := 3 in Hx. -If the localization also mentions the goal, then the result is the following one: +.. tacv:: set @ident := @term in {+ @ident} * + + This variant matches :token:`term` and then folds :token:`ident` similarly + in all the given context entries but also folds :token:`ident` in the goal. .. example:: @@ -945,7 +935,7 @@ If the localization also mentions the goal, then the result is the following one Lemma test x t (Hx : x = 3) : x + t = 4. set z := 3 in Hx * . -Indeed, remember that 4 is just a notation for (S 3). + Indeed, remember that 4 is just a notation for (S 3). The use of the ``in`` tactical is not limited to the localization of abbreviations: for a complete description of the in tactical, see @@ -1202,77 +1192,82 @@ context manipulations and the main backward chaining tool. The move tactic. ```````````````` -The move tactic, in its defective form, behaves like the primitive ``hnf`` -|Coq| tactic. For example, such a defective: - .. tacn:: move :name: move -exposes the first assumption in the goal, i.e. its changes the -goal ``not False`` into ``False -> False``. + This tactic, in its defective form, behaves like the :tacn:`hnf` tactic. -More precisely, the ``move`` tactic inspects the goal and does nothing -(``idtac``) if an introduction step is possible, i.e. if the goal is a -product or a ``let…in``, and performs ``hnf`` otherwise. + .. example:: -Of course this tactic is most often used in combination with the -bookkeeping tacticals (see section :ref:`introduction_ssr` and :ref:`discharge_ssr`). These -combinations mostly subsume the :tacn:`intros`, :tacn:`generalize`, :tacn:`revert`, :tacn:`rename`, -:tacn:`clear` and :tacn:`pattern` tactics. + .. coqtop:: reset all + + Require Import ssreflect. + Goal not False. + move. + + More precisely, the :tacn:`move` tactic inspects the goal and does nothing + (:tacn:`idtac`) if an introduction step is possible, i.e. if the goal is a + product or a ``let … in``, and performs :tacn:`hnf` otherwise. + + Of course this tactic is most often used in combination with the bookkeeping + tacticals (see section :ref:`introduction_ssr` and :ref:`discharge_ssr`). + These combinations mostly subsume the :tacn:`intros`, :tacn:`generalize`, + :tacn:`revert`, :tacn:`rename`, :tacn:`clear` and :tacn:`pattern` tactics. The case tactic ``````````````` -The ``case`` tactic performs *primitive case analysis* on (co)inductive -types; specifically, it destructs the top variable or assumption of -the goal, exposing its constructor(s) and its arguments, as well as -setting the value of its type family indices if it belongs to a type -family (see section :ref:`type_families_ssr`). +.. tacn:: case + :name: case (ssreflect) + + This tactic performs *primitive case analysis* on (co)inductive + types; specifically, it destructs the top variable or assumption of + the goal, exposing its constructor(s) and its arguments, as well as + setting the value of its type family indices if it belongs to a type + family (see section :ref:`type_families_ssr`). -The |SSR| case tactic has a special behavior on equalities. If the -top assumption of the goal is an equality, the case tactic “destructs” -it as a set of equalities between the constructor arguments of its -left and right hand sides, as per the tactic injection. For example, -``case`` changes the goal:: + The |SSR| case tactic has a special behavior on equalities. If the + top assumption of the goal is an equality, the case tactic “destructs” + it as a set of equalities between the constructor arguments of its + left and right hand sides, as per the tactic injection. For example, + ``case`` changes the goal:: - (x, y) = (1, 2) -> G. + (x, y) = (1, 2) -> G. -into:: + into:: - x = 1 -> y = 2 -> G. + x = 1 -> y = 2 -> G. -Note also that the case of |SSR| performs ``False`` elimination, even -if no branch is generated by this case operation. Hence the command: -``case.`` on a goal of the form ``False -> G`` will succeed and -prove the goal. + Note also that the case of |SSR| performs :g:`False` elimination, even + if no branch is generated by this case operation. Hence the tactic + :tacn:`case` on a goal of the form :g:`False -> G` will succeed and + prove the goal. The elim tactic ``````````````` -The ``elim`` tactic performs inductive elimination on inductive types. The -defective: - .. tacn:: elim :name: elim (ssreflect) -tactic performs inductive elimination on a goal whose top assumption -has an inductive type. + This tactic performs inductive elimination on inductive types. In its + defective form, the tactic performs inductive elimination on a goal whose + top assumption has an inductive type. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. - .. coqtop:: all + .. coqtop:: all - Lemma test m : forall n : nat, m <= n. - elim. + Lemma test m : forall n : nat, m <= n. + elim. .. _apply_ssr: @@ -1280,27 +1275,25 @@ has an inductive type. The apply tactic ```````````````` -The ``apply`` tactic is the main backward chaining tactic of the proof -system. It takes as argument any :token:`term` and applies it to the goal. -Assumptions in the type of :token:`term` that don’t directly match the goal -may generate one or more subgoals. - -In fact the |SSR| tactic: - -.. tacn:: apply +.. tacn:: apply {? @term } :name: apply (ssreflect) -is a synonym for:: + This is the main backward chaining tactic of the proof system. + It takes as argument any :token:`term` and applies it to the goal. + Assumptions in the type of :token:`term` that don’t directly match the goal + may generate one or more subgoals. + + In its defective form, this tactic is a synonym for:: - intro top; first [refine top | refine (top _) | refine (top _ _) | …]; clear top. + intro top; first [refine top | refine (top _) | refine (top _ _) | …]; clear top. -where ``top`` is a fresh name, and the sequence of refine tactics tries to -catch the appropriate number of wildcards to be inserted. Note that -this use of the refine tactic implies that the tactic tries to match -the goal up to expansion of constants and evaluation of subterms. + where :g:`top` is a fresh name, and the sequence of :tacn:`refine` tactics + tries to catch the appropriate number of wildcards to be inserted. Note that + this use of the :tacn:`refine` tactic implies that the tactic tries to match + the goal up to expansion of constants and evaluation of subterms. -|SSR|’s apply has a special behavior on goals containing -existential metavariables of sort Prop. +:tacn:`apply (ssreflect)` has a special behavior on goals containing +existential metavariables of sort :g:`Prop`. .. example:: @@ -1348,6 +1341,7 @@ The general syntax of the discharging tactical ``:`` is: .. tacn:: @tactic {? @ident } : {+ @d_item } {? @clear_switch } :name: ... : ... (ssreflect) + :undocumented: .. prodn:: d_item ::= {? @occ_switch %| @clear_switch } @term @@ -1502,8 +1496,8 @@ The abstract tactic .. tacn:: abstract: {+ d_item} :name: abstract (ssreflect) -This tactic assigns an abstract constant previously introduced with the ``[: -name ]`` intro pattern (see section :ref:`introduction_ssr`). + This tactic assigns an abstract constant previously introduced with the + :n:`[: @ident ]` intro pattern (see section :ref:`introduction_ssr`). In a goal like the following:: @@ -1553,22 +1547,29 @@ whose general syntax is .. tacn:: @tactic => {+ @i_item } :name: => + :undocumented: .. prodn:: - i_item ::= @i_pattern %| @s_item %| @clear_switch %| {? %{%} } /@term + i_item ::= @i_pattern %| @s_item %| @clear_switch %| @i_view %| @i_block .. prodn:: s_item ::= /= %| // %| //= .. prodn:: - i_pattern ::= @ident %| _ %| ? %| * %| {? @occ_switch } -> %| {? @occ_switch }<- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] + i_view ::= {? %{%} } /@term %| /ltac:( @tactic ) -The ``=>`` tactical first executes tactic, then the :token:`i_item` s, +.. prodn:: + i_pattern ::= @ident %| > %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch }<- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] + +.. prodn:: + i_block ::= [^ @ident ] %| [^~ @ident ] %| [^~ @num ] + +The ``=>`` tactical first executes :token:`tactic`, then the :token:`i_item`\s, left to right. An :token:`s_item` specifies a simplification operation; a :token:`clear_switch` -h specifies context pruning as in :ref:`discharge_ssr`. -The :token:`i_pattern` s can be seen as a variant of *intro patterns* -:ref:`tactics`: each performs an introduction operation, i.e., pops some +specifies context pruning as in :ref:`discharge_ssr`. +The :token:`i_pattern`\s can be seen as a variant of *intro patterns* +(see :tacn:`intros`:) each performs an introduction operation, i.e., pops some variables or assumptions from the goal. An :token:`s_item` can simplify the set of subgoals or the subgoals themselves: @@ -1577,7 +1578,7 @@ An :token:`s_item` can simplify the set of subgoals or the subgoals themselves: |SSR| tactic :tacn:`done` described in :ref:`terminators_ssr`, i.e., it executes ``try done``. + ``/=`` simplifies the goal by performing partial evaluation, as per the - tactic ``simpl`` [#5]_. + tactic :tacn:`simpl` [#5]_. + ``//=`` combines both kinds of simplification; it is equivalent to ``/= //``, i.e., ``simpl; try done``. @@ -1588,21 +1589,43 @@ When an :token:`s_item` bears a :token:`clear_switch`, then the possibly using the fact ``IHn``, and will erase ``IHn`` from the context of the remaining subgoals. -The last entry in the :token:`i_item` grammar rule, ``/``:token:`term`, +The first entry in the :token:`i_view` grammar rule, :n:`/@term`, represents a view (see section :ref:`views_and_reflection_ssr`). +It interprets the top of the stack with the view :token:`term`. +It is equivalent to ``move/term``. The optional flag ``{}`` can +be used to signal that the :token:`term`, when it is a context entry, +has to be cleared. If the next :token:`i_item` is a view, then the view is applied to the assumption in top position once all the previous :token:`i_item` have been performed. -The view is applied to the top assumption. +The second entry in the :token:`i_view` grammar rule, +``/ltac:(`` :token:`tactic` ``)``, executes :token:`tactic`. +Notations can be used to name tactics, for example:: + + Notation myop := (ltac:(some ltac code)) : ssripat_scope. -|SSR| supports the following :token:`i_pattern` s: +lets one write just ``/myop`` in the intro pattern. Note the scope +annotation: views are interpreted opening the ``ssripat`` scope. + +|SSR| supports the following :token:`i_pattern`\s: :token:`ident` pops the top variable, assumption, or local definition into a new constant, fact, or defined constant :token:`ident`, respectively. Note that defined constants cannot be introduced when δ-expansion is required to expose the top variable or assumption. +``>`` + pops every variable occurring in the rest of the stack. + Type class instances are popped even if they don't occur + in the rest of the stack. + The tactic ``move=> >`` is equivalent to + ``move=> ? ?`` on a goal such as:: + + forall x y, x < y -> G + + A typical use if ``move=>> H`` to name ``H`` the first assumption, + in the example above ``x < y``. ``?`` pops the top variable into an anonymous constant or fact, whose name is picked by the tactic interpreter. |SSR| only generates names that cannot @@ -1625,7 +1648,17 @@ The view is applied to the top assumption. a first ``move=> *`` adds only ``_a_ : bool`` and ``_b_ : bool`` to the context; it takes a second ``move=> *`` to add ``_Hyp_ : _a_ = _b_``. -:token:`occ_switch` ``->`` +``+`` + temporarily introduces the top variable. It is discharged at the end + of the intro pattern. For example ``move=> + y`` on a goal:: + + forall x y, P + + is equivalent to ``move=> _x_ y; move: _x_`` that results in the goal:: + + forall x, P + +:n:`{? occ_switch } ->` (resp. :token:`occ_switch` ``<-``) pops the top assumption (which should be a rewritable proposition) into an anonymous fact, rewrites (resp. rewrites right to left) the goal with this @@ -1650,18 +1683,13 @@ The view is applied to the top assumption. variable, using the |SSR| ``case`` tactic described in :ref:`the_defective_tactics_ssr`. It then behaves as the corresponding branching :token:`i_pattern`, executing the - sequence:token:`i_item`:math:`_i` in the i-th subgoal generated by the + sequence :n:`@i_item__i` in the i-th subgoal generated by the case analysis; unless we have the trivial destructing :token:`i_pattern` ``[]``, the latter should generate exactly m subgoals, i.e., the top variable should have an inductive type with exactly m constructors [#7]_. While it is good style to use the :token:`i_item` i * to pop the variables and assumptions corresponding to each constructor, this is not enforced by |SSR|. -``/`` :token:`term` - Interprets the top of the stack with the view :token:`term`. - It is equivalent to ``move/term``. The optional flag ``{}`` can - be used to signal that the :token:`term`, when it is a context entry, - has to be cleared. ``-`` does nothing, but counts as an intro pattern. It can also be used to force the interpretation of ``[`` :token:`i_item` * ``| … |`` @@ -1726,6 +1754,40 @@ interpretation, e.g.: are all equivalent. +|SSR| supports the following :token:`i_block`\s: + +:n:`[^ @ident ]` + *block destructing* :token:`i_pattern`. It performs a case analysis + on the top variable and introduces, in one go, all the variables coming + from the case analysis. The names of these variables are obtained by + taking the names used in the inductive type declaration and prefixing them + with :token:`ident`. If the intro pattern immediately follows a call + to ``elim`` with a custom eliminator (see :ref:`custom_elim_ssr`) then + the names are taken from the ones used in the type of the eliminator. + + .. example:: + + .. coqtop:: reset + + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + + .. coqtop:: all + + Record r := { a : nat; b := (a, 3); _ : bool; }. + + Lemma test : r -> True. + Proof. move => [^ x ]. + +:n:`[^~ @ident ]` + *block destructing* using :token:`ident` as a suffix. +:n:`[^~ @num ]` + *block destructing* using :token:`num` as a suffix. + + Only a :token:`s_item` is allowed between the elimination tactic and + the block destructing. .. _generation_of_equations_ssr: @@ -1803,136 +1865,132 @@ Type families ~~~~~~~~~~~~~ When the top assumption of a goal has an inductive type, two specific -operations are possible: the case analysis performed by the ``case`` +operations are possible: the case analysis performed by the :tacn:`case` tactic, and the application of an induction principle, performed by -the ``elim`` tactic. When this top assumption has an inductive type, which +the :tacn:`elim` tactic. When this top assumption has an inductive type, which is moreover an instance of a type family, |Coq| may need help from the user to specify which occurrences of the parameters of the type should be substituted. -A specific ``/`` switch indicates the type family parameters of the type -of a :token:`d_item` immediately following this ``/`` switch, -using the syntax: - .. tacv:: case: {+ @d_item } / {+ @d_item } - :name: case (ssreflect) + elim: {+ @d_item } / {+ @d_item } + + A specific ``/`` switch indicates the type family parameters of the type + of a :token:`d_item` immediately following this ``/`` switch. + The :token:`d_item` on the right side of the ``/`` switch are discharged as + described in section :ref:`discharge_ssr`. The case analysis or elimination + will be done on the type of the top assumption after these discharge + operations. + + Every :token:`d_item` preceding the ``/`` is interpreted as arguments of this + type, which should be an instance of an inductive type family. These terms + are not actually generalized, but rather selected for substitution. + Occurrence switches can be used to restrict the substitution. If a term is + left completely implicit (e.g. writing just ``_``), then a pattern is + inferred looking at the type of the top assumption. This allows for the + compact syntax: -.. tacv:: elim: {+ @d_item } / {+ @d_item } + .. coqtop:: in -The :token:`d_item` on the right side of the ``/`` switch are discharged as -described in section :ref:`discharge_ssr`. The case analysis or elimination -will be done on the type of the top assumption after these discharge -operations. + case: {2}_ / eqP. -Every :token:`d_item` preceding the ``/`` is interpreted as arguments of this -type, which should be an instance of an inductive type family. These terms -are not actually generalized, but rather selected for substitution. -Occurrence switches can be used to restrict the substitution. If a term is -left completely implicit (e.g. writing just ``_``), then a pattern is -inferred looking at the type of the top assumption. This allows for the -compact syntax: + where ``_`` is interpreted as ``(_ == _)`` since + ``eqP T a b : reflect (a = b) (a == b)`` and reflect is a type family with + one index. -.. coqtop:: in + Moreover if the :token:`d_item` list is too short, it is padded with an + initial sequence of ``_`` of the right length. - case: {2}_ / eqP. + .. example:: -where ``_`` is interpreted as ``(_ == _)`` since -``eqP T a b : reflect (a = b) (a == b)`` and reflect is a type family with -one index. + Here is a small example on lists. We define first a function which + adds an element at the end of a given list. -Moreover if the :token:`d_item` list is too short, it is padded with an -initial sequence of ``_`` of the right length. + .. coqtop:: reset -.. example:: + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. - Here is a small example on lists. We define first a function which - adds an element at the end of a given list. + .. coqtop:: all - .. coqtop:: reset + Require Import List. + Section LastCases. + Variable A : Type. + Implicit Type l : list A. + Fixpoint add_last a l : list A := + match l with + | nil => a :: nil + | hd :: tl => hd :: (add_last a tl) end. - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. + Then we define an inductive predicate for case analysis on lists + according to their last element: - .. coqtop:: all + .. coqtop:: all - Require Import List. - Section LastCases. - Variable A : Type. - Implicit Type l : list A. - Fixpoint add_last a l : list A := - match l with - | nil => a :: nil - | hd :: tl => hd :: (add_last a tl) end. + Inductive last_spec : list A -> Type := + | LastSeq0 : last_spec nil + | LastAdd s x : last_spec (add_last x s). - Then we define an inductive predicate for case analysis on lists - according to their last element: + Theorem lastP : forall l : list A, last_spec l. + Admitted. - .. coqtop:: all + We are now ready to use ``lastP`` in conjunction with ``case``. - Inductive last_spec : list A -> Type := - | LastSeq0 : last_spec nil - | LastAdd s x : last_spec (add_last x s). + .. coqtop:: all - Theorem lastP : forall l : list A, last_spec l. - Admitted. + Lemma test l : (length l) * 2 = length (l ++ l). + case: (lastP l). - We are now ready to use ``lastP`` in conjunction with ``case``. + Applied to the same goal, the command: + ``case: l / (lastP l).`` + generates the same subgoals but ``l`` has been cleared from both contexts. - .. coqtop:: all + Again applied to the same goal, the command. - Lemma test l : (length l) * 2 = length (l ++ l). - case: (lastP l). + .. coqtop:: none - Applied to the same goal, the command: - ``case: l / (lastP l).`` - generates the same subgoals but ``l`` has been cleared from both contexts. + Abort. - Again applied to the same goal, the command. + .. coqtop:: all - .. coqtop:: none + Lemma test l : (length l) * 2 = length (l ++ l). + case: {1 3}l / (lastP l). - Abort. + Note that selected occurrences on the left of the ``/`` + switch have been substituted with l instead of being affected by + the case analysis. - .. coqtop:: all + The equation name generation feature combined with a type family ``/`` + switch generates an equation for the *first* dependent :token:`d_item` + specified by the user. Again starting with the above goal, the + command: - Lemma test l : (length l) * 2 = length (l ++ l). - case: {1 3}l / (lastP l). + .. example:: - Note that selected occurrences on the left of the ``/`` - switch have been substituted with l instead of being affected by - the case analysis. + .. coqtop:: none -The equation name generation feature combined with a type family / -switch generates an equation for the *first* dependent :token:`d_item` -specified by the user. Again starting with the above goal, the -command: + Abort. -.. example:: + .. coqtop:: all - .. coqtop:: none + Lemma test l : (length l) * 2 = length (l ++ l). + case E: {1 3}l / (lastP l) => [|s x]. + Show 2. - Abort. - .. coqtop:: all + There must be at least one :token:`d_item` to the left of the ``/`` switch; this + prevents any confusion with the view feature. However, the :token:`d_item` + to the right of the ``/`` are optional, and if they are omitted the first + assumption provides the instance of the type family. - Lemma test l : (length l) * 2 = length (l ++ l). - case E: {1 3}l / (lastP l) => [|s x]. - Show 2. - - -There must be at least one :token:`d_item` to the left of the / switch; this -prevents any confusion with the view feature. However, the :token:`d_item` -to the right of the ``/`` are optional, and if they are omitted the first -assumption provides the instance of the type family. - -The equation always refers to the first :token:`d_item` in the actual tactic -call, before any padding with initial ``_``. Thus, if an inductive type -has two family parameters, it is possible to have|SSR| generate an -equation for the second one by omitting the pattern for the first; -note however that this will fail if the type of the second parameter -depends on the value of the first parameter. + The equation always refers to the first :token:`d_item` in the actual tactic + call, before any padding with initial ``_``. Thus, if an inductive type + has two family parameters, it is possible to have|SSR| generate an + equation for the second one by omitting the pattern for the first; + note however that this will fail if the type of the second parameter + depends on the value of the first parameter. Control flow @@ -1991,13 +2049,14 @@ closed tactic fails to prove its subgoal. It is hence recommended practice that the proof of any subgoal should end with a tactic which *fails if it does not solve the current goal*, -like discriminate, contradiction or assumption. +like :tacn:`discriminate`, :tacn:`contradiction` or :tacn:`assumption`. In fact, |SSR| provides a generic tactical which turns any tactic -into a closing one (similar to now). Its general syntax is: +into a closing one (similar to :tacn:`now`). Its general syntax is: .. tacn:: by @tactic :name: by + :undocumented: The Ltac expression :n:`by [@tactic | [@tactic | …]` is equivalent to :n:`[by @tactic | by @tactic | ...]` and this form should be preferred @@ -2014,39 +2073,29 @@ with a ``by``, like in: .. tacn:: done :name: done -The :tacn:`by` tactical is implemented using the user-defined, and extensible -:tacn:`done` tactic. This :tacn:`done` tactic tries to solve the current goal by some -trivial means and fails if it doesn’t succeed. Indeed, the tactic -expression :n:`by @tactic` is equivalent to :n:`@tactic; done`. - -Conversely, the tactic - -.. coqtop:: - - by [ ]. - -is equivalent to: + The :tacn:`by` tactical is implemented using the user-defined, and extensible + :tacn:`done` tactic. This :tacn:`done` tactic tries to solve the current goal by some + trivial means and fails if it doesn’t succeed. Indeed, the tactic + expression :n:`by @tactic` is equivalent to :n:`@tactic; done`. -.. coqtop:: + Conversely, the tactic ``by [ ]`` is equivalent to :tacn:`done`. - done. + The default implementation of the done tactic, in the ``ssreflect.v`` + file, is: -The default implementation of the done tactic, in the ``ssreflect.v`` -file, is: + .. coqdoc:: -.. coqtop:: in + Ltac done := + trivial; hnf; intros; solve + [ do ![solve [trivial | apply: sym_equal; trivial] + | discriminate | contradiction | split] + | case not_locked_false_eq_true; assumption + | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. - Ltac done := - trivial; hnf; intros; solve - [ do ![solve [trivial | apply: sym_equal; trivial] - | discriminate | contradiction | split] - | case not_locked_false_eq_true; assumption - | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. - -The lemma ``not_locked_false_eq_true`` is needed to discriminate -*locked* boolean predicates (see section :ref:`locking_ssr`). The iterator -tactical do is presented in section :ref:`iteration_ssr`. This tactic can be -customized by the user, for instance to include an ``auto`` tactic. + The lemma :g:`not_locked_false_eq_true` is needed to discriminate + *locked* boolean predicates (see section :ref:`locking_ssr`). The iterator + tactical do is presented in section :ref:`iteration_ssr`. This tactic can be + customized by the user, for instance to include an :tacn:`auto` tactic. A natural and common way of closing a goal is to apply a lemma which is the exact one needed for the goal to be solved. The defective form @@ -2063,7 +2112,7 @@ is equivalent to: do [done | by move=> top; apply top]. where ``top`` is a fresh name assigned to the top assumption of the goal. -This applied form is supported by the : discharge tactical, and the +This applied form is supported by the ``:`` discharge tactical, and the tactic: .. coqtop:: in @@ -2106,57 +2155,47 @@ is equivalent to: Selectors ~~~~~~~~~ -When composing tactics, the two tacticals ``first`` and ``last`` let the user -restrict the application of a tactic to only one of the subgoals -generated by the previous tactic. This covers the frequent cases where -a tactic generates two subgoals one of which can be easily disposed -of. - -This is another powerful way of linearization of scripts, since it -happens very often that a trivial subgoal can be solved in a less than -one line tactic. For instance, the tactic: - -.. tacn:: @tactic ; last by @tactic - :name: last - -tries to solve the last subgoal generated by the first -tactic using the given second tactic, and fails if it does not succeed. -Its analogue - -.. tacn:: @tactic ; first by @tactic - :name: first (ssreflect) - -tries to solve the first subgoal generated by the first tactic using the -second given tactic, and fails if it does not succeed. +.. tacn:: last + first + :name: last; first (ssreflect) + + When composing tactics, the two tacticals ``first`` and ``last`` let the user + restrict the application of a tactic to only one of the subgoals + generated by the previous tactic. This covers the frequent cases where + a tactic generates two subgoals one of which can be easily disposed + of. + + This is another powerful way of linearization of scripts, since it + happens very often that a trivial subgoal can be solved in a less than + one line tactic. For instance, :n:`@tactic ; last by @tactic` + tries to solve the last subgoal generated by the first + tactic using the given second tactic, and fails if it does not succeed. + Its analogue :n:`@tactic ; first by @tactic` + tries to solve the first subgoal generated by the first tactic using the + second given tactic, and fails if it does not succeed. |SSR| also offers an extension of this facility, by supplying -tactics to *permute* the subgoals generated by a tactic. The tactic: +tactics to *permute* the subgoals generated by a tactic. -.. tacv:: @tactic; last first +.. tacv:: last first + first last + :name: last first; first last -inverts the order of the subgoals generated by tactic. It is -equivalent to: + These two equivalent tactics invert the order of the subgoals in focus. -.. tacv:: @tactic; first last + .. tacv:: last @num first -More generally, the tactic: + If :token:`num`\'s value is :math:`k`, + this tactic rotates the :math:`n` subgoals :math:`G_1` , …, :math:`G_n` + in focus. The first subgoal becomes :math:`G_{n + 1 − k}` and the + circular order of subgoals remains unchanged. -.. tacn:: @tactic; last @num first - :name: last first + .. tacn:: first @num last -where :token:`num` is a |Coq| numeral, or an Ltac variable -denoting a |Coq| -numeral, having the value k. It rotates the n subgoals G1 , …, Gn -generated by tactic. The first subgoal becomes Gn + 1 − k and the -circular order of subgoals remains unchanged. - -Conversely, the tactic: - -.. tacn:: @tactic; first @num last - :name: first last - -rotates the n subgoals G1 , …, Gn generated by tactic in order that -the first subgoal becomes Gk . + If :token:`num`\'s value is :math:`k`, + this tactic rotates the :math:`n` subgoals :math:`G_1` , …, :math:`G_n` + in focus. The first subgoal becomes :math:`G_k` and the circular order + of subgoals remains unchanged. Finally, the tactics ``last`` and ``first`` combine with the branching syntax of Ltac: if the tactic generates n subgoals on a given goal, @@ -2200,16 +2239,14 @@ to the others. Iteration ~~~~~~~~~ -|SSR| offers an accurate control on the repetition of tactics, -thanks to the do tactical, whose general syntax is: - -.. tacn:: do {? @mult } ( @tactic | [ {+| @tactic } ] ) +.. tacn:: do {? @num } ( @tactic | [ {+| @tactic } ] ) :name: do (ssreflect) -where :token:`mult` is a *multiplier*. + This tactical offers an accurate control on the repetition of tactics. + :token:`mult` is a *multiplier*. -Brackets can only be omitted if a single tactic is given *and* a -multiplier is present. + Brackets can only be omitted if a single tactic is given *and* a + multiplier is present. A tactic of the form: @@ -2274,6 +2311,7 @@ already presented the *localization* tactical in, whose general syntax is: .. tacn:: @tactic in {+ @ident} {? * } :name: in + :undocumented: where :token:`ident` is a name in the context. On the left side of ``in``, @@ -2318,17 +2356,15 @@ of a local definition during the generalization phase, the name of the local definition must be written between parentheses, like in ``rewrite H in H1 (def_n) H2.`` -From |SSR| 1.5 the grammar for the in tactical has been extended -to the following one: - .. tacv:: @tactic in {+ @clear_switch | {? @ } @ident | ( @ident ) | ( {? @ } @ident := @c_pattern ) } {? * } -In its simplest form the last option lets one rename hypotheses that -can’t be cleared (like section variables). For example, ``(y := x)`` -generalizes over ``x`` and reintroduces the generalized variable under the -name ``y`` (and does not clear ``x``). -For a more precise description of this form of localization refer -to :ref:`advanced_generalization_ssr`. + This is the most general form of the ``in`` tactical. + In its simplest form the last option lets one rename hypotheses that + can’t be cleared (like section variables). For example, ``(y := x)`` + generalizes over ``x`` and reintroduces the generalized variable under the + name ``y`` (and does not clear ``x``). + For a more precise description of this form of localization refer + to :ref:`advanced_generalization_ssr`. .. _structure_ssr: @@ -2352,25 +2388,23 @@ intermediate statement. The have tactic. ```````````````` -The main |SSR| forward reasoning tactic is the ``have`` tactic. It can -be use in two modes: one starts a new (sub)proof for an intermediate -result in the main proof, and the other provides explicitly a proof -term for this intermediate step. - -In the first mode, the syntax of have in its defective form is: - .. tacn:: have : @term :name: have -This tactic supports open syntax for :token:`term`. Applied to a goal ``G``, it -generates a first subgoal requiring a proof of ``term`` in the context of -``G``. The second generated subgoal is of the form ``term -> G``, where term -becomes the new top assumption, instead of being introduced with a -fresh name. At the proof-term level, the have tactic creates a β -redex, and introduces the lemma under a fresh name, automatically -chosen. + This is the main |SSR| forward reasoning tactic. It can + be used in two modes: one starts a new (sub)proof for an intermediate + result in the main proof, and the other provides explicitly a proof + term for this intermediate step. + + This tactic supports open syntax for :token:`term`. Applied to a goal ``G``, it + generates a first subgoal requiring a proof of :token:`term` in the context of + ``G``. The second generated subgoal is of the form :n:`term -> G`, where term + becomes the new top assumption, instead of being introduced with a + fresh name. At the proof-term level, the have tactic creates a β + redex, and introduces the lemma under a fresh name, automatically + chosen. -Like in the case of the ``pose`` tactic (see section :ref:`definitions_ssr`), the types of +Like in the case of the :n:`pose (ssreflect)` tactic (see section :ref:`definitions_ssr`), the types of the holes are abstracted in term. .. example:: @@ -2425,6 +2459,7 @@ The behavior of the defective have tactic makes it possible to generalize it in the following general construction: .. tacn:: have {* @i_item } {? @i_pattern } {? @s_item | {+ @ssr_binder } } {? : @term } {? := @term | by @tactic } + :undocumented: Open syntax is supported for both :token:`term`. For the description of :token:`i_item` and :token:`s_item` see section @@ -2433,6 +2468,7 @@ have tactic, which opens a sub-proof for an intermediate result, uses tactics of the form: .. tacv:: have @clear_switch @i_item : @term by @tactic + :undocumented: which behave like: @@ -2446,7 +2482,7 @@ allows to reuse a name of the context, possibly used by the proof of the assumption, to introduce the new assumption itself. -The``by`` feature is especially convenient when the proof script of the +The ``by`` feature is especially convenient when the proof script of the statement is very short, basically when it fits in one line like in: .. coqtop:: in @@ -2503,13 +2539,13 @@ term for the intermediate lemma, using tactics of the form: .. tacv:: have {? @ident } := term -This tactic creates a new assumption of type the type of :token:`term`. -If the -optional :token:`ident` is present, this assumption is introduced under the -name :token:`ident`. Note that the body of the constant is lost for the user. + This tactic creates a new assumption of type the type of :token:`term`. + If the + optional :token:`ident` is present, this assumption is introduced under the + name :token:`ident`. Note that the body of the constant is lost for the user. -Again, non inferred implicit arguments and explicit holes are -abstracted. + Again, non inferred implicit arguments and explicit holes are + abstracted. .. example:: @@ -2781,9 +2817,9 @@ hypothesis and by pointing at the elements of the initial goals which should be generalized. The general syntax of without loss is: .. tacn:: wlog {? suff } {? @clear_switch } {? @i_item } : {* @ident } / @term - :name: wlog -.. tacv:: without loss {? suff } {? @clear_switch } {? @i_item } : {* @ident } / @term - :name: without loss + without loss {? suff } {? @clear_switch } {? @i_item } : {* @ident } / @term + :name: wlog; without loss + :undocumented: where each :token:`ident` is a constant in the context of the goal. Open syntax is supported for :token:`term`. @@ -2791,8 +2827,8 @@ of the goal. Open syntax is supported for :token:`term`. In its defective form: .. tacv:: wlog: / @term -.. tacv:: without loss: / @term - + without loss: / @term + :undocumented: on a goal G, it creates two subgoals: a first one to prove the formula (term -> G) -> G and a second one to prove the formula @@ -2873,6 +2909,7 @@ The complete syntax for the items on the left hand side of the ``/`` separator is the following one: .. tacv:: wlog … : {? @clear_switch | {? @ } @ident | ( {? @ } @ident := @c_pattern) } / @term + :undocumented: Clear operations are intertwined with generalization operations. This helps in particular avoiding dependency issues while generalizing some @@ -2957,8 +2994,9 @@ The general form of an |SSR| rewrite tactic is: .. tacn:: rewrite {+ @rstep } :name: rewrite (ssreflect) + :undocumented: -The combination of a rewrite tactic with the in tactical (see section +The combination of a rewrite tactic with the ``in`` tactical (see section :ref:`localization_ssr`) performs rewriting in both the context and the goal. A rewrite step :token:`rstep` has the general form: @@ -3692,14 +3730,12 @@ definition. rewrite /=. unlock lid. -We provide a special tactic unlock for unfolding such definitions -while removing “locks”, e.g., the tactic: - .. tacn:: unlock {? @occ_switch } @ident :name: unlock -replaces the occurrence(s) of :token:`ident` coded by the -:token:`occ_switch` with the corresponding body. + This tactic unfolds such definitions while removing “locks”, i.e. it + replaces the occurrence(s) of :token:`ident` coded by the + :token:`occ_switch` with the corresponding body. We found that it was usually preferable to prevent the expansion of some functions by the partial evaluation switch ``/=``, unless this @@ -3775,103 +3811,102 @@ which the function is supplied: .. tacn:: congr {? @num } @term :name: congr -This tactic: - + This tactic: + checks that the goal is a Leibniz equality; + matches both sides of this equality with “term applied to some arguments”, inferring the right number of arguments from the goal and the type of term. This may expand some definitions or fixpoints; + generates the subgoals corresponding to pairwise equalities of the arguments present in the goal. -The goal can be a non dependent product ``P -> Q``. In that case, the -system asserts the equation ``P = Q``, uses it to solve the goal, and -calls the ``congr`` tactic on the remaining goal ``P = Q``. This can be useful -for instance to perform a transitivity step, like in the following -situation. + The goal can be a non dependent product ``P -> Q``. In that case, the + system asserts the equation ``P = Q``, uses it to solve the goal, and + calls the ``congr`` tactic on the remaining goal ``P = Q``. This can be useful + for instance to perform a transitivity step, like in the following + situation. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. - Section Test. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + Section Test. - .. coqtop:: all + .. coqtop:: all - Lemma test (x y z : nat) (H : x = y) : x = z. - congr (_ = _) : H. - Abort. + Lemma test (x y z : nat) (H : x = y) : x = z. + congr (_ = _) : H. + Abort. - Lemma test (x y z : nat) : x = y -> x = z. - congr (_ = _). + Lemma test (x y z : nat) : x = y -> x = z. + congr (_ = _). -The optional :token:`num` forces the number of arguments for which the -tactic should generate equality proof obligations. + The optional :token:`num` forces the number of arguments for which the + tactic should generate equality proof obligations. -This tactic supports equalities between applications with dependent -arguments. Yet dependent arguments should have exactly the same -parameters on both sides, and these parameters should appear as first -arguments. + This tactic supports equalities between applications with dependent + arguments. Yet dependent arguments should have exactly the same + parameters on both sides, and these parameters should appear as first + arguments. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. - Section Test. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + Section Test. - .. coqtop:: all + .. coqtop:: all - Definition f n := - if n is 0 then plus else mult. - Definition g (n m : nat) := plus. + Definition f n := + if n is 0 then plus else mult. + Definition g (n m : nat) := plus. - Lemma test x y : f 0 x y = g 1 1 x y. - congr plus. + Lemma test x y : f 0 x y = g 1 1 x y. + congr plus. - This script shows that the ``congr`` tactic matches ``plus`` - with ``f 0`` on the left hand side and ``g 1 1`` on the right hand - side, and solves the goal. + This script shows that the ``congr`` tactic matches ``plus`` + with ``f 0`` on the left hand side and ``g 1 1`` on the right hand + side, and solves the goal. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. - Section Test. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + Section Test. - .. coqtop:: all + .. coqtop:: all - Lemma test n m (Hnm : m <= n) : S m + (S n - S m) = S n. - congr S; rewrite -/plus. + Lemma test n m (Hnm : m <= n) : S m + (S n - S m) = S n. + congr S; rewrite -/plus. - The tactic ``rewrite -/plus`` folds back the expansion of plus - which was necessary for matching both sides of the equality with - an application of ``S``. + The tactic ``rewrite -/plus`` folds back the expansion of plus + which was necessary for matching both sides of the equality with + an application of ``S``. -Like most |SSR| arguments, term can contain wildcards. + Like most |SSR| arguments, :token:`term` can contain wildcards. -.. example:: + .. example:: - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. - Section Test. + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + Section Test. - .. coqtop:: all + .. coqtop:: all - Lemma test x y : x + (y * (y + x - x)) = x * 1 + (y + 0) * y. - congr ( _ + (_ * _)). + Lemma test x y : x + (y * (y + x - x)) = x * 1 + (y + 0) * y. + congr ( _ + (_ * _)). .. _contextual_patterns_ssr: @@ -4192,6 +4227,7 @@ interpretation operations with the proof stack operations. This *view mechanism* relies on the combination of the ``/`` view switch with bookkeeping tactics and tacticals. +.. _custom_elim_ssr: Interpreting eliminations ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -4883,6 +4919,7 @@ Interpreting assumptions The general form of an assumption view tactic is: .. tacv:: [move | case] / @term + :undocumented: The term , called the *view lemma* can be: @@ -4997,6 +5034,7 @@ Interpreting goals A goal interpretation view tactic of the form: .. tacv:: apply/@term + :undocumented: applied to a goal ``top`` is interpreted in the following way: @@ -5027,6 +5065,7 @@ both sides. The syntax of double views is: .. tacv:: apply/@term/@term + :undocumented: The first term is the view lemma applied to the left hand side of the equality, while the second term is the one applied to the right hand side. @@ -5074,31 +5113,30 @@ In this context, the identity view can be used when no view has to be applied: Declaring new Hint Views ~~~~~~~~~~~~~~~~~~~~~~~~ -The database of hints for the view mechanism is extensible via a -dedicated vernacular command. As library ``ssrbool.v`` already declares a -corpus of hints, this feature is probably useful only for users who -define their own logical connectives. Users can declare their own -hints following the syntax used in ``ssrbool.v``: - .. cmd:: Hint View for move / @ident {? | @num } -.. cmd:: Hint View for apply / @ident {? | @num } + Hint View for apply / @ident {? | @num } -The :token:`ident` is the name of the lemma to be -declared as a hint. If `move` is used as -tactic, the hint is declared for assumption interpretation tactics, -`apply` declares hints for goal interpretations. Goal interpretation -view hints are declared for both simple views and left hand side -views. The optional natural number is the number of implicit -arguments to be considered for the declared hint view lemma. + This command can be used to extend the database of hints for the view + mechanism. -The command: + As library ``ssrbool.v`` already declares a + corpus of hints, this feature is probably useful only for users who + define their own logical connectives. -.. cmd:: Hint View for apply//@ident {? | @num } + The :token:`ident` is the name of the lemma to be + declared as a hint. If ``move`` is used as + tactic, the hint is declared for assumption interpretation tactics, + ``apply`` declares hints for goal interpretations. Goal interpretation + view hints are declared for both simple views and left hand side + views. The optional natural number is the number of implicit + arguments to be considered for the declared hint view lemma. -with a double slash ``//``, declares hint views for right hand sides of -double views. + .. cmdv:: Hint View for apply//@ident {? | @num } -See the files ``ssreflect.v`` and ``ssrbool.v`` for examples. + This variant with a double slash ``//``, declares hint views for right + hand sides of double views. + + See the files ``ssreflect.v`` and ``ssrbool.v`` for examples. Multiple views @@ -5157,73 +5195,66 @@ equivalences are indeed taken into account, otherwise only single |SSR| searching tool -------------------- -|SSR| proposes an extension of the Search command. Its syntax is: - .. cmd:: Search {? @pattern } {* {? - } %( @string %| @pattern %) {? % @ident} } {? in {+ {? - } @qualid } } :name: Search (ssreflect) -where :token:`qualid` is the name of an open module. This command returns -the list of lemmas: - - -+ whose *conclusion* contains a subterm matching the optional first - pattern. A - reverses the test, producing the list of lemmas whose - conclusion does not contain any subterm matching the pattern; -+ whose name contains the given string. A ``-`` prefix reverses the test, - producing the list of lemmas whose name does not contain the string. A - string that contains symbols or is followed by a scope key, is - interpreted as the constant whose notation involves that string (e.g., - `+` for `addn`), if this is unambiguous; otherwise the diagnostic - includes the output of the ``Locate`` vernacular command. -+ whose statement, including assumptions and types, contains a subterm - matching the next patterns. If a pattern is prefixed by ``-``, the test is - reversed; -+ contained in the given list of modules, except the ones in the - modules prefixed by a ``-``. - + This is the |SSR| extension of the Search command. :token:`qualid` is the + name of an open module. This command returns the list of lemmas: + + + whose *conclusion* contains a subterm matching the optional first + pattern. A - reverses the test, producing the list of lemmas whose + conclusion does not contain any subterm matching the pattern; + + whose name contains the given string. A ``-`` prefix reverses the test, + producing the list of lemmas whose name does not contain the string. A + string that contains symbols or is followed by a scope key, is + interpreted as the constant whose notation involves that string (e.g., + :g:`+` for :g:`addn`), if this is unambiguous; otherwise the diagnostic + includes the output of the :cmd:`Locate` vernacular command. + + whose statement, including assumptions and types, contains a subterm + matching the next patterns. If a pattern is prefixed by ``-``, the test is + reversed; + + contained in the given list of modules, except the ones in the + modules prefixed by a ``-``. + +.. note:: + + + As for regular terms, patterns can feature scope indications. For + instance, the command: ``Search _ (_ + _)%N.`` lists all the lemmas whose + statement (conclusion or hypotheses) involves an application of the + binary operation denoted by the infix ``+`` symbol in the ``N`` scope (which is + |SSR| scope for natural numbers). + + Patterns with holes should be surrounded by parentheses. + + Search always volunteers the expansion of the notation, avoiding the + need to execute Locate independently. Moreover, a string fragment + looks for any notation that contains fragment as a substring. If the + ``ssrbool.v`` library is imported, the command: ``Search "~~".`` answers : -Note that: - - -+ As for regular terms, patterns can feature scope indications. For - instance, the command: ``Search _ (_ + _)%N.`` lists all the lemmas whose - statement (conclusion or hypotheses) involves an application of the - binary operation denoted by the infix ``+`` symbol in the ``N`` scope (which is - |SSR| scope for natural numbers). -+ Patterns with holes should be surrounded by parentheses. -+ Search always volunteers the expansion of the notation, avoiding the - need to execute Locate independently. Moreover, a string fragment - looks for any notation that contains fragment as a substring. If the - ``ssrbool.v`` library is imported, the command: ``Search "~~".`` answers : - - .. example:: - - .. coqtop:: reset + .. coqtop:: reset - From Coq Require Import ssreflect ssrbool. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. + From Coq Require Import ssreflect ssrbool. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. - .. coqtop:: all + .. coqtop:: all - Search "~~". + Search "~~". -+ A diagnostic is issued if there are different matching notations; it - is an error if all matches are partial. -+ Similarly, a diagnostic warns about multiple interpretations, and - signals an error if there is no default one. -+ The command ``Search in M.`` is a way of obtaining the complete - signature of the module ``M``. -+ Strings and pattern indications can be interleaved, but the first - indication has a special status if it is a pattern, and only filters - the conclusion of lemmas: + + A diagnostic is issued if there are different matching notations; it + is an error if all matches are partial. + + Similarly, a diagnostic warns about multiple interpretations, and + signals an error if there is no default one. + + The command ``Search in M.`` is a way of obtaining the complete + signature of the module ``M``. + + Strings and pattern indications can be interleaved, but the first + indication has a special status if it is a pattern, and only filters + the conclusion of lemmas: - + The command : ``Search (_ =1 _) "bij".`` lists all the lemmas whose - conclusion features a ``=1`` and whose name contains the string ``bij``. - + The command : ``Search "bij" (_ =1 _).`` lists all the lemmas whose - statement, including hypotheses, features a ``=1`` and whose name - contains the string ``bij``. + + The command : ``Search (_ =1 _) "bij".`` lists all the lemmas whose + conclusion features a ``=1`` and whose name contains the string ``bij``. + + The command : ``Search "bij" (_ =1 _).`` lists all the lemmas whose + statement, including hypotheses, features a ``=1`` and whose name + contains the string ``bij``. Synopsis and Index ------------------ @@ -5275,11 +5306,21 @@ discharge item see :ref:`discharge_ssr` generalization item see :ref:`structure_ssr` -.. prodn:: i_pattern ::= @ident %| _ %| ? %| * %| {? @occ_switch } -> %| {? @occ_switch } <- %| [ {*| {* @i_item } } %| - %| [: {+ @ident } ] +.. prodn:: i_pattern ::= @ident %| > %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch } <- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] intro pattern :ref:`introduction_ssr` -.. prodn:: i_item ::= @clear_switch %| @s_item %| @i_pattern %| {? %{%} } / @term +.. prodn:: i_item ::= @clear_switch %| @s_item %| @i_pattern %| @i_view %| @i_block + +view :ref:`introduction_ssr` + +.. prodn:: + i_view ::= {? %{%} } /@term %| /ltac:( @tactic ) + +intro block :ref:`introduction_ssr` + +.. prodn:: + i_block ::= [^ @ident ] %| [^~ @ident ] %| [^~ @num ] intro item see :ref:`introduction_ssr` @@ -5327,80 +5368,78 @@ respectively. .. tacn:: move -idtac or hnf see :ref:`bookkeeping_ssr` + :tacn:`idtac` or :tacn:`hnf` (see :ref:`bookkeeping_ssr`) .. tacn:: apply -.. tacn:: exact + exact -application see :ref:`the_defective_tactics_ssr` + application (see :ref:`the_defective_tactics_ssr`) .. tacn:: abstract - see :ref:`abstract_ssr` and :ref:`generating_let_ssr` + see :ref:`abstract_ssr` and :ref:`generating_let_ssr` .. tacn:: elim -induction see :ref:`the_defective_tactics_ssr` + induction (see :ref:`the_defective_tactics_ssr`) .. tacn:: case -case analysis see :ref:`the_defective_tactics_ssr` + case analysis (see :ref:`the_defective_tactics_ssr`) .. tacn:: rewrite {+ @r_step } -rewrite see :ref:`rewriting_ssr` + rewrite (see :ref:`rewriting_ssr`) .. tacn:: have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } {? : @term } := @term -.. tacv:: have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } : @term {? by @tactic } -.. tacn:: have suff {? @clear_switch } {? @i_pattern } {? : @term } := @term -.. tacv:: have suff {? @clear_switch } {? @i_pattern } : @term {? by @tactic } -.. tacv:: gen have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } -.. tacv:: generally have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } - :name: generally have - -forward chaining see :ref:`structure_ssr` + have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } : @term {? by @tactic } + have suff {? @clear_switch } {? @i_pattern } {? : @term } := @term + have suff {? @clear_switch } {? @i_pattern } : @term {? by @tactic } + gen have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } + generally have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } + :name: _; _; _; _; _; generally have + forward chaining (see :ref:`structure_ssr`) .. tacn:: wlog {? suff } {? @i_item } : {* @gen_item %| @clear_switch } / @term -specializing see :ref:`structure_ssr` + specializing (see :ref:`structure_ssr`) .. tacn:: suff {* @i_item } {? @i_pattern } {+ @ssr_binder } : @term {? by @tactic } - :name: suff -.. tacv:: suffices {* @i_item } {? @i_pattern } {+ @ssr_binder } : @term {? by @tactic } - :name: suffices -.. tacv:: suff {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } -.. tacv:: suffices {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } + suffices {* @i_item } {? @i_pattern } {+ @ssr_binder } : @term {? by @tactic } + suff {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } + suffices {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } + :name: suff; suffices; _; _ -backchaining see :ref:`structure_ssr` + backchaining (see :ref:`structure_ssr`) .. tacn:: pose @ident := @term -local definition :ref:`definitions_ssr` + local definition (see :ref:`definitions_ssr`) .. tacv:: pose @ident {+ @ssr_binder } := @term -local function definition + local function definition .. tacv:: pose fix @fix_body -local fix definition + local fix definition .. tacv:: pose cofix @fix_body -local cofix definition + local cofix definition .. tacn:: set @ident {? : @term } := {? @occ_switch } %( @term %| ( @c_pattern) %) -abbreviation see :ref:`abbreviations_ssr` + abbreviation (see :ref:`abbreviations_ssr`) .. tacn:: unlock {* {? @r_prefix } @ident } -unlock see :ref:`locking_ssr` + unlock (see :ref:`locking_ssr`) .. tacn:: congr {? @num } @term -congruence :ref:`congruence_ssr` + congruence (see :ref:`congruence_ssr`) Tacticals @@ -5439,15 +5478,15 @@ Commands .. cmd:: Hint View for %( move %| apply %) / @ident {? | @num } -view hint declaration see :ref:`declaring_new_hints_ssr` + view hint declaration (see :ref:`declaring_new_hints_ssr`) .. cmd:: Hint View for apply // @ident {? @num } -right hand side double , view hint declaration see :ref:`declaring_new_hints_ssr` + right hand side double , view hint declaration (see :ref:`declaring_new_hints_ssr`) .. cmd:: Prenex Implicits {+ @ident } -prenex implicits declaration see :ref:`parametric_polymorphism_ssr` + prenex implicits declaration (see :ref:`parametric_polymorphism_ssr`) Settings ~~~~~~~~ diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index ad80cb62e1..59602581c7 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3425,7 +3425,9 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. cmdv:: Hint @hint_definition - No database name is given: the hint is registered in the core database. + No database name is given: the hint is registered in the ``core`` database. + + .. deprecated:: 8.10 .. cmdv:: Local Hint @hint_definition : {+ @ident} diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index a5869055fa..47afa5ba0c 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -70,7 +70,7 @@ associativity rules have to be given. The right-hand side of a notation is interpreted at the time the notation is given. In particular, disambiguation of constants, :ref:`implicit arguments - <ImplicitArguments>`, :ref:`coercions <Coercions>`, etc. are resolved at the + <ImplicitArguments>` and other notations are resolved at the time of the declaration of the notation. Precedences and associativity @@ -1583,6 +1583,104 @@ Numeral notations As noted above, the :n:`(abstract after @num)` directive has no effect when :n:`@ident__2` lands in an :g:`option` type. +String notations +----------------- + +.. cmd:: String Notation @ident__1 @ident__2 @ident__3 : @scope. + :name: String Notation + + This command allows the user to customize the way strings are parsed + and printed. + + The token :n:`@ident__1` should be the name of an inductive type, + while :n:`@ident__2` and :n:`@ident__3` should be the names of the + parsing and printing functions, respectively. The parsing function + :n:`@ident__2` should have one of the following types: + + * :n:`Byte.byte -> @ident__1` + * :n:`Byte.byte -> option @ident__1` + * :n:`list Byte.byte -> @ident__1` + * :n:`list Byte.byte -> option @ident__1` + + And the printing function :n:`@ident__3` should have one of the + following types: + + * :n:`@ident__1 -> Byte.byte` + * :n:`@ident__1 -> option Byte.byte` + * :n:`@ident__1 -> list Byte.byte` + * :n:`@ident__1 -> option (list Byte.byte)` + + When parsing, the application of the parsing function + :n:`@ident__2` to the string will be fully reduced, and universes + of the resulting term will be refreshed. + + .. exn:: Cannot interpret this string as a value of type @type + + The string notation registered for :token:`type` does not support + the given string. This error is given when the interpretation + function returns :g:`None`. + + .. exn:: @ident should go from Byte.byte or (list Byte.byte) to @type or (option @type). + + The parsing function given to the :cmd:`String Notation` + vernacular is not of the right type. + + .. exn:: @ident should go from @type to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)). + + The printing function given to the :cmd:`String Notation` + vernacular is not of the right type. + + .. exn:: @type is not an inductive type. + + String notations can only be declared for inductive types with no + arguments. + + .. exn:: Unexpected term @term while parsing a string notation. + + Parsing functions must always return ground terms, made up of + applications of constructors and inductive types. Parsing + functions may not return terms containing axioms, bare + (co)fixpoints, lambdas, etc. + + .. exn:: Unexpected non-option term @term while parsing a string notation. + + Parsing functions expected to return an :g:`option` must always + return a concrete :g:`Some` or :g:`None` when applied to a + concrete string expressed as a decimal. They may not return + opaque constants. + + .. exn:: Cannot interpret in @scope because @ident could not be found in the current environment. + + The inductive type used to register the string notation is no + longer available in the environment. Most likely, this is because + the string notation was declared inside a functor for an + inductive type inside the functor. This use case is not currently + supported. + + Alternatively, you might be trying to use a primitive token + notation from a plugin which forgot to specify which module you + must :g:`Require` for access to that notation. + + .. exn:: Syntax error: [prim:reference] expected after 'Notation' (in [vernac:command]). + + The type passed to :cmd:`String Notation` must be a single + identifier. + + .. exn:: Syntax error: [prim:reference] expected after [prim:reference] (in [vernac:command]). + + Both functions passed to :cmd:`String Notation` must be single + identifiers. + + .. exn:: The reference @ident was not found in the current environment. + + Identifiers passed to :cmd:`String Notation` must exist in the + global environment. + + .. exn:: @ident is bound to a notation that does not denote a reference. + + Identifiers passed to :cmd:`String Notation` must be global + references, or notations which denote to single identifiers. + .. _TacticNotation: Tactic Notations diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 4fc9bf9e19..51f94d7e5a 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -17,6 +17,7 @@ through the <tt>Require Import</tt> command.</p> theories/Init/Datatypes.v theories/Init/Logic.v theories/Init/Logic_Type.v + theories/Init/Byte.v theories/Init/Nat.v theories/Init/Decimal.v theories/Init/Peano.v @@ -497,6 +498,7 @@ through the <tt>Require Import</tt> command.</p> Implementation of string as list of ascii characters </dt> <dd> + theories/Strings/Byte.v theories/Strings/Ascii.v theories/Strings/String.v theories/Strings/BinaryString.v diff --git a/doc/tools/coqrst/coqdoc/main.py b/doc/tools/coqrst/coqdoc/main.py index 57adcb287c..1de9890992 100644 --- a/doc/tools/coqrst/coqdoc/main.py +++ b/doc/tools/coqrst/coqdoc/main.py @@ -35,7 +35,7 @@ COQDOC_HEADER = "".join("(** remove printing {} *)".format(s) for s in COQDOC_SY def coqdoc(coq_code, coqdoc_bin=None): """Get the output of coqdoc on coq_code.""" - coqdoc_bin = coqdoc_bin or os.path.join(os.getenv("COQBIN"), "coqdoc") + coqdoc_bin = coqdoc_bin or os.path.join(os.getenv("COQBIN", ""), "coqdoc") fd, filename = mkstemp(prefix="coqdoc-", suffix=".v") if platform.system().startswith("CYGWIN"): # coqdoc currently doesn't accept cygwin style paths in the form "/cygdrive/c/..." diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 2c69dcfe08..067af954ad 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -198,6 +198,25 @@ class CoqObject(ObjectDescription): self._add_index_entry(name, target) return target + def _prepare_names(self): + sigs = self.get_signatures() + names = self.options.get("name") + if names is None: + self._names = {} + else: + names = [n.strip() for n in names.split(";")] + if len(names) != len(sigs): + ERR = ("Expected {} semicolon-separated names, got {}. " + + "Please provide one name per signature line.") + raise self.error(ERR.format(len(names), len(sigs))) + self._names = dict(zip(sigs, names)) + + def run(self): + self._prepare_names() + return super().run() + +class DocumentableObject(CoqObject): + def _warn_if_undocumented(self): document = self.state.document config = document.settings.env.config @@ -212,30 +231,16 @@ class CoqObject(ObjectDescription): if report == "warning": raise self.warning(msg) - def _prepare_names(self): - sigs = self.get_signatures() - names = self.options.get("name") - if names is None: - self._names = {} - else: - names = [n.strip() for n in names.split(";")] - if len(names) != len(sigs): - ERR = ("Expected {} semicolon-separated names, got {}. " + - "Please provide one name per signature line.") - raise self.error(ERR.format(len(names), len(sigs))) - self._names = dict(zip(sigs, names)) - def run(self): self._warn_if_undocumented() - self._prepare_names() return super().run() -class PlainObject(CoqObject): +class PlainObject(DocumentableObject): """A base class for objects whose signatures should be rendered literally.""" def _render_signature(self, signature, signode): signode += addnodes.desc_name(signature, signature) -class NotationObject(CoqObject): +class NotationObject(DocumentableObject): """A base class for objects whose signatures should be rendered as nested boxes. Objects that inherit from this class can use the notation grammar (“{+ …}”, @@ -1184,7 +1189,6 @@ def setup(app): app.connect('doctree-resolved', CoqtopBlocksTransform.merge_consecutive_coqtop_blocks) # Add extra styles - app.add_stylesheet("fonts.css") app.add_stylesheet("ansi.css") app.add_stylesheet("coqdoc.css") app.add_javascript("notations.js") @@ -1,10 +1,12 @@ ; Default flags for all Coq libraries. (env - (dev (flags :standard -rectypes -w -9-27-50+40+60)) + (dev (flags :standard -rectypes -w -9-27+40+60)) (release (flags :standard -rectypes) (ocamlopt_flags -O3 -unbox-closures)) - (ireport (flags :standard -rectypes -w -9-27-50+40+60) - (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report))) + (ireport (flags :standard -rectypes -w -9-27-40+60) + (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report)) + (ocaml408 + (flags :standard -strict-sequence -strict-formats -short-paths -keep-locs -rectypes -w -9-27+40+60 -warn-error -5 -alert --deprecated))) ; The _ profile could help factoring the above, however it doesn't ; seem to work like we'd expect/like: diff --git a/dune-project b/dune-project index 85238c70c5..f0ac11ba61 100644 --- a/dune-project +++ b/dune-project @@ -1,3 +1,2 @@ -(lang dune 1.4) - +(lang dune 1.6) (name coq) diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 96f1ce5e60..24d161d00a 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -606,6 +606,7 @@ let subst_var subst c = of_constr (Vars.subst_var subst (to_constr c)) let subst_univs_level_constr subst c = of_constr (Vars.subst_univs_level_constr subst (to_constr c)) + (** Operations that dot NOT commute with evar-normalization *) let noccurn sigma n term = let rec occur_rec n c = match kind sigma c with diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 69ee5223c4..db56d0628f 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -155,7 +155,7 @@ let is_ground_env = memo is_ground_env exception NoHeadEvar let head_evar sigma c = - (** FIXME: this breaks if using evar-insensitive code *) + (* FIXME: this breaks if using evar-insensitive code *) let c = EConstr.Unsafe.to_constr c in let rec hrec c = match kind c with | Evar (evk,_) -> evk @@ -288,7 +288,7 @@ let empty_csubst = { } let csubst_subst { csubst_len = k; csubst_var = v; csubst_rel = s } c = - (** Safe because this is a substitution *) + (* Safe because this is a substitution *) let c = EConstr.Unsafe.to_constr c in let rec subst n c = match Constr.kind c with | Rel m -> @@ -318,7 +318,7 @@ let update_var src tgt subst = in match cur with | None -> - (** Missing keys stand for identity substitution [src ↦ src] *) + (* Missing keys stand for identity substitution [src ↦ src] *) let csubst_var = Id.Map.add src (Constr.mkVar tgt) subst.csubst_var in let csubst_rev = Id.Map.add tgt (SVar src) subst.csubst_rev in { subst with csubst_var; csubst_rev } @@ -366,8 +366,8 @@ let push_rel_decl_to_named_context about this whole name generation problem. *) if Flags.is_program_mode () then next_name_away na avoid else - (** id_of_name_using_hdchar only depends on the rel context which is empty - here *) + (* id_of_name_using_hdchar only depends on the rel context which is empty + here *) next_ident_away (id_of_name_using_hdchar empty_env sigma (RelDecl.get_type decl) na) avoid in match extract_if_neq id na with @@ -540,8 +540,8 @@ let restrict_evar evd evk filter ?src candidates = | Some [] -> raise (ClearDependencyError (*FIXME*)(Id.of_string "blah", (NoCandidatesLeft evk), None)) | _ -> let evd, evk' = Evd.restrict evk filter ?candidates ?src evd in - (** Mark new evar as future goal, removing previous one, - circumventing Proofview.advance but making Proof.run_tactic catch these. *) + (* Mark new evar as future goal, removing previous one, + circumventing Proofview.advance but making Proof.run_tactic catch these. *) let future_goals = Evd.save_future_goals evd in let future_goals = Evd.filter_future_goals (fun evk' -> not (Evar.equal evk evk')) future_goals in let evd = Evd.restore_future_goals evd future_goals in @@ -779,7 +779,7 @@ let cached_evar_of_hyp cache sigma decl accu = match cache with let r = try Id.Map.find id cache.cache with Not_found -> - (** Dummy value *) + (* Dummy value *) let r = ref (NamedDecl.LocalAssum (id, EConstr.mkProp), Evar.Set.empty) in let () = cache.cache <- Id.Map.add id r cache.cache in r diff --git a/engine/evd.ml b/engine/evd.ml index 6345046431..31c326df6a 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -89,8 +89,8 @@ struct | Some f2 -> normalize (CList.filter_with f1 f2) let apply_subfilter_array filter subfilter = - (** In both cases we statically know that the argument will contain at - least one [false] *) + (* In both cases we statically know that the argument will contain at + least one [false] *) match filter with | None -> Some (Array.to_list subfilter) | Some f -> @@ -395,7 +395,7 @@ let rename evk id (evtoid, idtoev) = let reassign_name_defined evk evk' (evtoid, idtoev as names) = let id = try Some (EvMap.find evk evtoid) with Not_found -> None in match id with - | None -> names (** evk' must not be defined *) + | None -> names (* evk' must not be defined *) | Some id -> (EvMap.add evk' id (EvMap.remove evk evtoid), Id.Map.add id evk' (Id.Map.remove id idtoev)) @@ -416,7 +416,7 @@ type evar_flags = typeclass_evars : Evar.Set.t } type evar_map = { - (** Existential variables *) + (* Existential variables *) defn_evars : evar_info EvMap.t; undf_evars : evar_info EvMap.t; evar_names : EvNames.t; @@ -520,7 +520,7 @@ let inherit_evar_flags evar_flags evk evk' = let remove_evar_flags evk evar_flags = { typeclass_evars = Evar.Set.remove evk evar_flags.typeclass_evars; obligation_evars = Evar.Set.remove evk evar_flags.obligation_evars; - (** Restriction information is kept. *) + (* Restriction information is kept. *) restricted_evars = evar_flags.restricted_evars } (** New evars *) @@ -601,19 +601,19 @@ let is_defined d e = EvMap.mem e d.defn_evars let is_undefined d e = EvMap.mem e d.undf_evars -let existential_value d (n, args) = - let info = find d n in - match evar_body info with - | Evar_defined c -> - instantiate_evar_array info c args - | Evar_empty -> - raise NotInstantiatedEvar +let existential_opt_value d (n, args) = + match EvMap.find_opt n d.defn_evars with + | None -> None + | Some info -> + match evar_body info with + | Evar_defined c -> Some (instantiate_evar_array info c args) + | Evar_empty -> None (* impossible but w/e *) -let existential_value0 = existential_value +let existential_value d ev = match existential_opt_value d ev with + | None -> raise NotInstantiatedEvar + | Some v -> v -let existential_opt_value d ev = - try Some (existential_value d ev) - with NotInstantiatedEvar -> None +let existential_value0 = existential_value let existential_opt_value0 = existential_opt_value @@ -1341,14 +1341,14 @@ module MiniEConstr = struct | None -> c end | App (f, args) when isEvar f -> - (** Enforce smart constructor invariant on applications *) + (* Enforce smart constructor invariant on applications *) let ev = destEvar f in begin match safe_evar_value sigma ev with | None -> c | Some f -> whd_evar sigma (mkApp (f, args)) end | Cast (c0, k, t) when isEvar c0 -> - (** Enforce smart constructor invariant on casts. *) + (* Enforce smart constructor invariant on casts. *) let ev = destEvar c0 in begin match safe_evar_value sigma ev with | None -> c diff --git a/engine/evd.mli b/engine/evd.mli index 0a8d1f3287..7560d68805 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -86,7 +86,7 @@ type evar_body = type evar_info = { evar_concl : econstr; (** Type of the evar. *) - evar_hyps : named_context_val; (** TODO econstr? *) + evar_hyps : named_context_val; (* TODO econstr? *) (** Context of the evar. *) evar_body : evar_body; (** Optional content of the evar. *) @@ -546,6 +546,7 @@ val univ_flexible_alg : rigid type 'a in_evar_universe_context = 'a * UState.t val restrict_universe_context : evar_map -> Univ.LSet.t -> evar_map + (** Raises Not_found if not a name for a universe in this map. *) val universe_of_name : evar_map -> Id.t -> Univ.Level.t @@ -567,6 +568,7 @@ val make_nonalgebraic_variable : evar_map -> Univ.Level.t -> evar_map 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] *) + val is_flexible_level : evar_map -> Univ.Level.t -> bool (* val normalize_universe_level : evar_map -> Univ.Level.t -> Univ.Level.t *) diff --git a/engine/ftactic.ml b/engine/ftactic.ml index b371884ba4..ac0344148a 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -29,8 +29,8 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function | Depends l -> let f arg = f arg >>= function | Uniform x -> - (** We dispatch the uniform result on each goal under focus, as we know - that the [m] argument was actually dependent. *) + (* We dispatch the uniform result on each goal under focus, as we know + that the [m] argument was actually dependent. *) Proofview.Goal.goals >>= fun goals -> let ans = List.map (fun g -> (g,x)) goals in Proofview.tclUNIT ans diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 4afa817b27..e0c24f049f 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -28,8 +28,10 @@ from the IO monad ([Proofview] catches errors in its compatibility layer, and when lifting goal-level expressions). *) exception Exception of exn + (** This exception is used to signal abortion in [timeout] functions. *) exception Timeout + (** This exception is used by the tactics to signal failure by lack of successes, rather than some other exceptions (like system interrupts). *) diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 545334ce9a..3e57baab26 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -28,8 +28,10 @@ from the IO monad ([Proofview] catches errors in its compatibility layer, and when lifting goal-level expressions). *) exception Exception of exn + (** This exception is used to signal abortion in [timeout] functions. *) exception Timeout + (** This exception is used by the tactics to signal failure by lack of successes, rather than some other exceptions (like system interrupts). *) @@ -51,8 +53,10 @@ module NonLogical : sig val ref : 'a -> 'a ref t (** [Pervasives.(:=)] *) + val (:=) : 'a ref -> 'a -> unit t (** [Pervasives.(!)] *) + val (!) : 'a ref -> 'a t val read_line : string t @@ -67,6 +71,7 @@ module NonLogical : sig (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) val raise : ?info:Exninfo.info -> exn -> 'a t + (** [try ... with ...] but restricted to {!Exception}. *) val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t val timeout : int -> 'a t -> 'a t diff --git a/engine/namegen.ml b/engine/namegen.ml index a67ff6965b..018eca1ba2 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -358,7 +358,7 @@ let next_name_away_with_default_using_types default na avoid t = let next_name_away = next_name_away_with_default default_non_dependent_string let make_all_name_different env sigma = - (** FIXME: this is inefficient, but only used in printing *) + (* FIXME: this is inefficient, but only used in printing *) let avoid = ref (ids_of_named_context_val (named_context_val env)) in let sign = named_context_val env in let rels = rel_context env in diff --git a/engine/nameops.mli b/engine/nameops.mli index 8a93fad8cc..a5308904f5 100644 --- a/engine/nameops.mli +++ b/engine/nameops.mli @@ -16,6 +16,7 @@ val make_ident : string -> int option -> Id.t val repr_ident : Id.t -> string * int option val atompart_of_id : Id.t -> string (** remove trailing digits *) + val root_of_id : Id.t -> Id.t (** remove trailing digits, ' and _ *) val add_suffix : Id.t -> string -> Id.t diff --git a/engine/proofview.ml b/engine/proofview.ml index 304b2dff84..cf4224bbdb 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -636,7 +636,7 @@ let shelve = let open Proof in Comb.get >>= fun initial -> Comb.set [] >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve")) >> Shelf.modify (fun gls -> gls @ CList.map drop_state initial) let shelve_goals l = @@ -644,7 +644,7 @@ let shelve_goals l = Comb.get >>= fun initial -> let comb = CList.filter (fun g -> not (CList.mem (drop_state g) l)) initial in Comb.set comb >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_goals")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve_goals")) >> Shelf.modify (fun gls -> gls @ l) (** [depends_on sigma src tgt] checks whether the goal [src] appears @@ -660,9 +660,9 @@ let unifiable_delayed g l = let free_evars sigma l = let cache = Evarutil.create_undefined_evars_cache () in let map ev = - (** Computes the set of evars appearing in the hypotheses, the conclusion or - the body of the evar_info [evi]. Note: since we want to use it on goals, - the body is actually supposed to be empty. *) + (* Computes the set of evars appearing in the hypotheses, the conclusion or + the body of the evar_info [evi]. Note: since we want to use it on goals, + the body is actually supposed to be empty. *) let evi = Evd.find sigma ev in let fevs = lazy (Evarutil.filtered_undefined_evars_of_evar_info ~cache sigma evi) in (ev, fevs) @@ -672,9 +672,9 @@ let free_evars sigma l = let free_evars_with_state sigma l = let cache = Evarutil.create_undefined_evars_cache () in let map ev = - (** Computes the set of evars appearing in the hypotheses, the conclusion or - the body of the evar_info [evi]. Note: since we want to use it on goals, - the body is actually supposed to be empty. *) + (* Computes the set of evars appearing in the hypotheses, the conclusion or + the body of the evar_info [evi]. Note: since we want to use it on goals, + the body is actually supposed to be empty. *) let ev = drop_state ev in let evi = Evd.find sigma ev in let fevs = lazy (Evarutil.filtered_undefined_evars_of_evar_info ~cache sigma evi) in @@ -710,7 +710,7 @@ let shelve_unifiable_informative = Pv.get >>= fun initial -> let (u,n) = partition_unifiable initial.solution initial.comb in Comb.set n >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve_unifiable")) >> let u = CList.map drop_state u in Shelf.modify (fun gls -> gls @ u) >> tclUNIT u @@ -794,7 +794,7 @@ let goodmod p m = let cycle n = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.(str"cycle "++int n))) >> Comb.modify begin fun initial -> let l = CList.length initial in let n' = goodmod n l in @@ -804,7 +804,7 @@ let cycle n = let swap i j = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> Comb.modify begin fun initial -> let l = CList.length initial in let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in @@ -819,7 +819,7 @@ let swap i j = let revgoals = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"revgoals")) >> Comb.modify CList.rev let numgoals = @@ -858,7 +858,7 @@ let give_up = Comb.get >>= fun initial -> Comb.set [] >> mark_as_unsafe >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"give_up")) >> Giveup.put (CList.map drop_state initial) @@ -1157,7 +1157,7 @@ module Goal = struct let sigma = step.solution in let map goal = match cleared_alias sigma goal with - | None -> None (** ppedrot: Is this check really necessary? *) + | None -> None (* ppedrot: Is this check really necessary? *) | Some goal -> let gl = Env.get >>= fun env -> @@ -1188,9 +1188,9 @@ module Trace = struct let log m = InfoL.leaf (Info.Msg m) let name_tactic m t = InfoL.tag (Info.Tactic m) t - let pr_info ?(lvl=0) info = + let pr_info env sigma ?(lvl=0) info = assert (lvl >= 0); - Info.(print (collapse lvl info)) + Info.(print env sigma (collapse lvl info)) end @@ -1234,7 +1234,7 @@ module V82 = struct let (goalss,evd) = Evd.Monad.List.map tac initgoals_w_state initevd in let sgs = CList.flatten goalss in let sgs = undefined evd sgs in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"<unknown>")) >> + InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"<unknown>")) >> Pv.set { ps with solution = evd; comb = sgs; } with e when catchable_exception e -> let (e, info) = CErrors.push e in diff --git a/engine/proofview.mli b/engine/proofview.mli index cda4808a23..286703c0dc 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -398,6 +398,7 @@ val tclPROGRESS : 'a tactic -> 'a tactic val tclCHECKINTERRUPT : unit tactic exception Timeout + (** [tclTIMEOUT n t] can have only one success. In case of timeout if fails with [tclZERO Timeout]. *) val tclTIMEOUT : int -> 'a tactic -> 'a tactic @@ -517,8 +518,8 @@ module Goal : sig (** Like {!nf_enter}, but does not normalize the goal beforehand. *) val enter : (t -> unit tactic) -> unit tactic - (** Like {!enter}, but assumes exactly one goal under focus, raising *) - (** a fatal error otherwise. *) + (** Like {!enter}, but assumes exactly one goal under focus, raising + a fatal error otherwise. *) val enter_one : ?__LOC__:string -> (t -> 'a tactic) -> 'a tactic (** Recover the list of current goals under focus, without evar-normalization. @@ -547,7 +548,7 @@ module Trace : sig val log : Proofview_monad.lazy_msg -> unit tactic val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic - val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.t + val pr_info : Environ.env -> Evd.evar_map -> ?lvl:int -> Proofview_monad.Info.tree -> Pp.t end @@ -612,8 +613,10 @@ module Notations : sig (** {!tclBIND} *) val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + (** {!tclTHEN} *) val (<*>) : unit tactic -> 'a tactic -> 'a tactic + (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 52bcabf958..69341d97df 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -64,8 +64,7 @@ end (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) -type lazy_msg = unit -> Pp.t -let pr_lazy_msg msg = msg () +type lazy_msg = Environ.env -> Evd.evar_map -> Pp.t (** Info trace. *) module Info = struct @@ -80,9 +79,7 @@ module Info = struct type state = tag Trace.incr type tree = tag Trace.forest - - - let pr_in_comments m = Pp.(str"(* "++pr_lazy_msg m++str" *)") + let pr_in_comments env sigma m = Pp.(str"(* "++ m env sigma ++str" *)") let unbranch = function | Trace.Seq (DBranch,brs) -> brs @@ -112,31 +109,31 @@ module Info = struct (** [with_sep] is [true] when [Tactic m] must be printed with a trailing semi-colon. *) - let rec pr_tree with_sep = let open Trace in function - | Seq (Msg m,[]) -> pr_in_comments m + let rec pr_tree env sigma with_sep = let open Trace in function + | Seq (Msg m,[]) -> pr_in_comments env sigma m | Seq (Tactic m,_) -> let tail = if with_sep then Pp.str";" else Pp.mt () in - Pp.(pr_lazy_msg m ++ tail) + Pp.(m env sigma ++ tail) | Seq (Dispatch,brs) -> let tail = if with_sep then Pp.str";" else Pp.mt () in - Pp.(pr_dispatch brs++tail) + Pp.(pr_dispatch env sigma brs++tail) | Seq (Msg _,_::_) | Seq (DBranch,_) -> assert false - and pr_dispatch brs = + and pr_dispatch env sigma brs = let open Pp in let brs = List.map unbranch brs in match brs with - | [br] -> pr_forest br + | [br] -> pr_forest env sigma br | _ -> let sep () = spc()++str"|"++spc() in - let branches = prlist_with_sep sep pr_forest brs in + let branches = prlist_with_sep sep (pr_forest env sigma) brs in str"[>"++spc()++branches++spc()++str"]" - and pr_forest = function + and pr_forest env sigma = function | [] -> Pp.mt () - | [tr] -> pr_tree false tr - | tr::l -> Pp.(pr_tree true tr ++ pr_forest l) + | [tr] -> pr_tree env sigma false tr + | tr::l -> Pp.(pr_tree env sigma true tr ++ pr_forest env sigma l) - let print f = - pr_forest (compress f) + let print env sigma f = + pr_forest env sigma (compress f) let rec collapse_tree n t = let open Trace in diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index 9d75242175..a08cab3bf6 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -45,7 +45,7 @@ end (** We typically label nodes of [Trace.tree] with messages to print. But we don't want to compute the result. *) -type lazy_msg = unit -> Pp.t +type lazy_msg = Environ.env -> Evd.evar_map -> Pp.t (** Info trace. *) module Info : sig @@ -60,7 +60,7 @@ module Info : sig type state = tag Trace.incr type tree = tag Trace.forest - val print : tree -> Pp.t + val print : Environ.env -> Evd.evar_map -> tree -> Pp.t (** [collapse n t] flattens the first [n] levels of [Tactic] in an info trace, effectively forgetting about the [n] top level of diff --git a/engine/termops.ml b/engine/termops.ml index 98300764df..137770d8f0 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -197,8 +197,8 @@ let compute_evar_dependency_graph sigma = let evar_dependency_closure n sigma = let open Evd in - (** Create the DAG of depth [n] representing the recursive dependencies of - undefined evars. *) + (* Create the DAG of depth [n] representing the recursive dependencies of + undefined evars. *) let graph = compute_evar_dependency_graph sigma in let rec aux n curr accu = if Int.equal n 0 then Evar.Set.union curr accu @@ -209,9 +209,9 @@ let evar_dependency_closure n sigma = Evar.Set.union deps accu with Not_found -> accu in - (** Consider only the newly added evars *) + (* Consider only the newly added evars *) let ncurr = Evar.Set.fold fold curr Evar.Set.empty in - (** Merge the others *) + (* Merge the others *) let accu = Evar.Set.union curr accu in aux (n - 1) ncurr accu in @@ -261,13 +261,13 @@ let print_env_short env sigma = let pr_evar_constraints sigma pbs = let pr_evconstr (pbty, env, t1, t2) = let env = - (** We currently allow evar instances to refer to anonymous de - Bruijn indices, so we protect the error printing code in this - case by giving names to every de Bruijn variable in the - rel_context of the conversion problem. MS: we should rather - stop depending on anonymous variables, they can be used to - indicate independency. Also, this depends on a strategy for - naming/renaming. *) + (* We currently allow evar instances to refer to anonymous de + Bruijn indices, so we protect the error printing code in this + case by giving names to every de Bruijn variable in the + rel_context of the conversion problem. MS: we should rather + stop depending on anonymous variables, they can be used to + indicate independency. Also, this depends on a strategy for + naming/renaming. *) Namegen.make_all_name_different env sigma in print_env_short env sigma ++ spc () ++ str "|-" ++ spc () ++ diff --git a/engine/uState.ml b/engine/uState.ml index 185283225c..6969d2ba44 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -197,7 +197,7 @@ let process_universe_constraints ctx cstrs = | Some l -> Inr l in let equalize_variables fo l l' r r' local = - (** Assumes l = [l',0] and r = [r',0] *) + (* Assumes l = [l',0] and r = [r',0] *) let () = if is_local l' then instantiate_variable l' r vars @@ -235,8 +235,8 @@ let process_universe_constraints ctx cstrs = match cst with | ULe (l, r) -> if UGraph.check_leq univs l r then - (** Keep Prop/Set <= var around if var might be instantiated by prop or set - later. *) + (* Keep Prop/Set <= var around if var might be instantiated by prop or set + later. *) match Univ.Universe.level l, Univ.Universe.level r with | Some l, Some r -> Univ.Constraint.add (l, Univ.Le, r) local diff --git a/engine/univMinim.ml b/engine/univMinim.ml index e20055b133..1619ac3d34 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -32,15 +32,15 @@ let add_list_map u t map = let choose_canonical ctx flexible algs s = let global = LSet.diff s ctx in let flexible, rigid = LSet.partition flexible (LSet.inter s ctx) in - (** If there is a global universe in the set, choose it *) + (* If there is a global universe in the set, choose it *) if not (LSet.is_empty global) then let canon = LSet.choose global in canon, (LSet.remove canon global, rigid, flexible) - else (** No global in the equivalence class, choose a rigid one *) + else (* No global in the equivalence class, choose a rigid one *) if not (LSet.is_empty rigid) then let canon = LSet.choose rigid in canon, (global, LSet.remove canon rigid, flexible) - else (** There are only flexible universes in the equivalence + else (* There are only flexible universes in the equivalence class, choose a non-algebraic. *) let algs, nonalgs = LSet.partition (fun x -> LSet.mem x algs) flexible in if not (LSet.is_empty nonalgs) then @@ -94,8 +94,8 @@ let find_inst insts v = with Found (f,l) -> (f,l) let compute_lbound left = - (** The universe variable was not fixed yet. - Compute its level using its lower bound. *) + (* The universe variable was not fixed yet. + Compute its level using its lower bound. *) let sup l lbound = match lbound with | None -> Some l @@ -154,9 +154,10 @@ let not_lower lower (d,l) = * constraints we must keep it. *) compare_constraint_type d d' > 0 with Not_found -> - (** No constraint existing on l *) true) l + (* No constraint existing on l *) true) l exception UpperBoundedAlg + (** [enforce_uppers upper lbound cstrs] interprets [upper] as upper constraints to [lbound], adding them to [cstrs]. @@ -269,7 +270,7 @@ module UPairSet = Set.Make (UPairs) let normalize_context_set g ctx us algs weak = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in - (** Keep the Prop/Set <= i constraints separate for minimization *) + (* Keep the Prop/Set <= i constraints separate for minimization *) let smallles, csts = Constraint.partition (fun (l,d,r) -> d == Le && Level.is_small l) csts in diff --git a/engine/univNames.ml b/engine/univNames.ml index 19705f9d36..7e6ed5e4c0 100644 --- a/engine/univNames.ml +++ b/engine/univNames.ml @@ -35,8 +35,8 @@ type universe_binders = Univ.Level.t Names.Id.Map.t let empty_binders = Id.Map.empty 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. *) + (* 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 compute_instance_binders inst ubinders = diff --git a/gramlib/ploc.mli b/gramlib/ploc.mli index 766e96fdfc..100fbc7271 100644 --- a/gramlib/ploc.mli +++ b/gramlib/ploc.mli @@ -10,6 +10,7 @@ exception Exc of Loc.t * exn for an error. This exception must not be raised by [raise] but rather by [Ploc.raise] (see below), to prevent the risk of several encapsulations of [Ploc.Exc]. *) + val raise : Loc.t -> exn -> 'a (** [Ploc.raise loc e], if [e] is already the exception [Ploc.Exc], re-raise it (ignoring the new location [loc]), else raise the @@ -29,9 +30,11 @@ val sub : Loc.t -> int -> int -> Loc.t (** [Ploc.sub loc sh len] is the location [loc] shifted with [sh] characters and with length [len]. The previous ending position of the location is lost. *) + val after : Loc.t -> int -> int -> Loc.t (** [Ploc.after loc sh len] is the location just after loc (starting at the end position of [loc]) shifted with [sh] characters and of length [len]. *) + val with_comment : Loc.t -> string -> Loc.t (** Change the comment part of the given location *) diff --git a/ide/configwin_ihm.ml b/ide/configwin_ihm.ml index 91695e944e..8420d930d5 100644 --- a/ide/configwin_ihm.ml +++ b/ide/configwin_ihm.ml @@ -209,7 +209,8 @@ class ['a] list_selection_box () initializer - (** create the functions called when the buttons are clicked *) + + (* create the functions called when the buttons are clicked *) let f_add () = (* get the files to add with the function provided *) let l = add_function () in @@ -300,8 +301,10 @@ class string_param_box param (tt:GData.tooltips) = let _ = we#set_text (param.string_to_string param.string_value) in object (self) + (** This method returns the main box ready to be packed. *) method box = hbox#coerce + (** This method applies the new value of the parameter. *) method apply = let new_value = param.string_of_string we#text in @@ -347,9 +350,11 @@ class combo_param_box param (tt:GData.tooltips) = fun () -> wc#entry#text in object (self) + (** This method returns the main box ready to be packed. *) method box = hbox#coerce - (** This method applies the new value of the parameter. *) + + (** This method applies the new value of the parameter. *) method apply = let new_value = get_value () in if new_value <> param.combo_value then @@ -404,8 +409,10 @@ class text_param_box param (tt:GData.tooltips) = let _ = dbg "text_param_box: object(self)" in object (self) val wview = wview + (** This method returns the main box ready to be packed. *) method box = wf#coerce + (** This method applies the new value of the parameter. *) method apply = let v = param.string_of_string (buffer#get_text ()) in @@ -435,8 +442,10 @@ class bool_param_box param (tt:GData.tooltips) = let _ = wchk#misc#set_sensitive param.bool_editable in object (self) + (** This method returns the check button ready to be packed. *) method box = wchk#coerce + (** This method applies the new value of the parameter. *) method apply = let new_value = wchk#active in @@ -471,8 +480,10 @@ class modifiers_param_box param = tooltips#set_tip wev#coerce ~text: help ~privat: help in object (self) + (** This method returns the main box ready to be packed. *) method box = hbox#coerce + (** This method applies the new value of the parameter. *) method apply = let new_value = !value in @@ -500,8 +511,10 @@ class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = in object (self) + (** This method returns the main box ready to be packed. *) method box = frame_selection#box#coerce + (** This method applies the new value of the parameter. *) method apply = param.list_f_apply !listref ; diff --git a/ide/coq.ml b/ide/coq.ml index 88ffb4f0b7..91cd448eda 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -334,8 +334,8 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all = (* Parsing error at the end of s : we have only received a part of an xml answer. We store the current fragment for later *) let l_end = Lexing.lexeme_end lex in - (** Heuristic hack not to reimplement the lexer: if ever the lexer dies - twice at the same place, then this is a non-recoverable error *) + (* Heuristic hack not to reimplement the lexer: if ever the lexer dies + twice at the same place, then this is a non-recoverable error *) if state.lexerror = Some l_end then raise e; state.lexerror <- Some l_end @@ -496,7 +496,7 @@ let init_coqtop coqtop task = type 'a query = 'a Interface.value task let eval_call call handle k = - (** Send messages to coqtop and prepare the decoding of the answer *) + (* Send messages to coqtop and prepare the decoding of the answer *) Minilib.log ("Start eval_call " ^ Xmlprotocol.pr_call call); assert (handle.alive && handle.waiting_for = None); handle.waiting_for <- Some (mk_ccb (call,k)); diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 6c3438a4b0..8da9900724 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -255,8 +255,8 @@ object(self) let sentence = Doc.find document find in let mark = sentence.start in let iter = script#buffer#get_iter_at_mark mark in - (** Sentence starts tend to be at the end of a line, so we rather choose - the first non-line-ending position. *) + (* Sentence starts tend to be at the end of a line, so we rather choose + the first non-line-ending position. *) let rec sentence_start iter = if iter#ends_line then sentence_start iter#forward_line else iter diff --git a/ide/coqide.ml b/ide/coqide.ml index 40b8d2f484..48c08899e0 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -566,7 +566,7 @@ let update_status sn = Coq.bind (Coq.status false) next let find_next_occurrence ~backward sn = - (** go to the next occurrence of the current word, forward or backward *) + (* go to the next occurrence of the current word, forward or backward *) let b = sn.buffer in let start = find_word_start (b#get_iter_at_mark `INSERT) in let stop = find_word_end start in @@ -613,11 +613,11 @@ let printopts_callback opts v = (** Templates menu *) let get_current_word term = - (** First look to find if autocompleting *) + (* First look to find if autocompleting *) match term.script#complete_popup#proposal with | Some p -> p | None -> - (** Then look at the current selected word *) + (* Then look at the current selected word *) let buf1 = term.script#buffer in let buf2 = term.proof#buffer in if buf1#has_selection then @@ -628,7 +628,7 @@ let get_current_word term = buf2#get_text ~slice:true ~start ~stop () else if term.messages#has_selection then term.messages#get_selected_text - (** Otherwise try to find the word around the cursor *) + (* Otherwise try to find the word around the cursor *) else let it = term.script#buffer#get_iter_at_mark `INSERT in let start = find_word_start it in @@ -772,11 +772,11 @@ let uncomment = cb_on_current_term (fun t -> t.script#uncomment ()) let coqtop_arguments sn = let dialog = GWindow.dialog ~title:"Coqtop arguments" () in let coqtop = sn.coqtop in - (** Text entry *) + (* Text entry *) let args = Coq.get_arguments coqtop in let text = String.concat " " args in let entry = GEdit.entry ~text ~packing:dialog#vbox#add () in - (** Buttons *) + (* Buttons *) let box = dialog#action_area in let ok = GButton.button ~stock:`OK ~packing:box#add () in let ok_cb () = diff --git a/ide/fake_ide.ml b/ide/fake_ide.ml index 521aff6bf6..8b0c736f50 100644 --- a/ide/fake_ide.ml +++ b/ide/fake_ide.ml @@ -11,7 +11,7 @@ (** Fake_ide : Simulate a [coqide] talking to a [coqidetop] *) let error s = - prerr_endline ("fake_id: error: "^s); + prerr_endline ("fake_ide: error: "^s); exit 1 let pperr_endline pp = Format.eprintf "@[%a@]\n%!" Pp.pp_with pp @@ -22,7 +22,7 @@ type coqtop = { } let print_error msg = - Format.eprintf "fake_id: error: @[%a@]\n%!" Pp.pp_with msg + Format.eprintf "fake_ide: error: @[%a@]\n%!" Pp.pp_with msg let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); @@ -257,10 +257,15 @@ let eval_print l coq = eval_call (wait ()) coq | [ Tok(_,"JOIN") ] -> eval_call (status true) coq + | [ Tok(_,"FAILJOIN") ] -> + after_fail coq (base_eval_call ~fail:false (status true) coq) | [ Tok(_,"ASSERT"); Tok(_,"TIP"); Tok(_,id) ] -> let to_id, _ = get_id id in if not(Stateid.equal (Document.tip doc) to_id) then error "Wrong tip" else prerr_endline "Good tip" + | [ Tok(_,"ABORT") ] -> + prerr_endline "Quitting fake_ide"; + exit 0 | Tok("#[^\n]*",_) :: _ -> () | _ -> error "syntax error" @@ -276,6 +281,8 @@ let grammar = ; Seq [Item (eat_rex "JOIN")] ; Seq [Item (eat_rex "GOALS")] ; Seq [Item (eat_rex "FAILGOALS")] + ; Seq [Item (eat_rex "FAILJOIN")] + ; Seq [Item (eat_rex "ABORT")] ; Seq [Item (eat_rex "ASSERT"); Item (eat_rex "TIP"); Item eat_id ] ; Item (eat_rex "#[^\n]*") ] @@ -305,6 +312,8 @@ let main = Array.of_list (def_args @ ct), f | _ -> usage () in let inc = if input_file = "-" then stdin else open_in input_file in + prerr_endline ("Running: "^idetop_name^" "^ + (String.concat " " (Array.to_list coqtop_args))); let coq = let _p, cin, cout = Coqide.spawn idetop_name coqtop_args in let ip = Xml_parser.make (Xml_parser.SChannel cin) in diff --git a/ide/idetop.ml b/ide/idetop.ml index a2b85041e8..716a942d5c 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -196,12 +196,24 @@ let process_goal sigma g = (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } -let export_pre_goals pgs = - { - Interface.fg_goals = pgs.Proof.fg_goals; - Interface.bg_goals = pgs.Proof.bg_goals; - Interface.shelved_goals = pgs.Proof.shelved_goals; - Interface.given_up_goals = pgs.Proof.given_up_goals +let process_goal_diffs diff_goal_map oldp nsigma ng = + let open Evd in + let og_s = match oldp with + | Some oldp -> + let Proof.{ sigma=osigma } = Proof.data oldp in + (try Some { it = Evar.Map.find ng diff_goal_map; sigma = osigma } + with Not_found -> None) + | 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 } + +let export_pre_goals Proof.{ sigma; goals; stack; shelf; given_up } process = + let process = List.map (process sigma) in + { Interface.fg_goals = process goals + ; Interface.bg_goals = List.(map (fun (lg,rg) -> process lg, process rg)) stack + ; Interface.shelved_goals = process shelf + ; Interface.given_up_goals = process given_up } let goals () = @@ -212,22 +224,9 @@ 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 process_goal_diffs nsigma ng = - let open Evd in - let og_s = match oldp with - | Some oldp -> - let (_,_,_,_,osigma) = Proof.proof oldp in - (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 - Some (export_pre_goals (Proof.map_structured_proof newp process_goal_diffs)) + Some (export_pre_goals Proof.(data newp) (process_goal_diffs diff_goal_map oldp)) end else - Some (export_pre_goals (Proof.map_structured_proof newp process_goal)) + Some (export_pre_goals Proof.(data newp) process_goal) with Proof_global.NoCurrentProof -> None;; let evars () = @@ -235,7 +234,7 @@ let evars () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; let pfts = Proof_global.give_me_the_proof () in - let all_goals, _, _, _, sigma = Proof.proof pfts in + let Proof.{ sigma } = Proof.data pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in @@ -245,8 +244,8 @@ let evars () = let hints () = try let pfts = Proof_global.give_me_the_proof () in - let all_goals, _, _, _, sigma = Proof.proof pfts in - match all_goals with + let Proof.{ goals; sigma } = Proof.data pfts in + match goals with | [] -> None | g :: _ -> let env = Goal.V82.env sigma g in @@ -263,9 +262,9 @@ let wait () = set_doc (Stm.wait ~doc) let status force = - (** We remove the initial part of the current [DirPath.t] - (usually Top in an interactive session, cf "coqtop -top"), - and display the other parts (opened sections and modules) *) + (* We remove the initial part of the current [DirPath.t] + (usually Top in an interactive session, cf "coqtop -top"), + and display the other parts (opened sections and modules) *) set_doc (Stm.finish ~doc:(get_doc ())); if force then set_doc (Stm.join ~doc:(get_doc ())); @@ -408,14 +407,12 @@ let interp ((_raw, verbose), s) = (** When receiving the Quit call, we don't directly do an [exit 0], but rather set this reference, in order to send a final answer before exiting. *) - let quit = ref false (** Disabled *) let print_ast id = Xml_datatype.PCData "ERROR" (** Grouping all call handlers together + error handling *) - let eval_call c = let interruptible f x = catch_break := true; diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 7044263b94..c14af7d21d 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -43,10 +43,10 @@ color on Windows. A clean fix, if ever needed, would be to combine the attribut of the tags into a single composite tag before applying. This is left as an exercise for the reader. *) let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text = - (** FIXME: LablGTK2 does not export the C insert_with_tags function, so that - it has to reimplement its own helper function. Unluckily, it relies on - a slow algorithm, so that we have to have our own quicker version here. - Alas, it is still much slower than the native version... *) + (* FIXME: LablGTK2 does not export the C insert_with_tags function, so that + it has to reimplement its own helper function. Unluckily, it relies on + a slow algorithm, so that we have to have our own quicker version here. + Alas, it is still much slower than the native version... *) if CList.is_empty tags then buf#insert ~iter:(buf#get_iter_at_mark mark) text else let it = buf#get_iter_at_mark mark in diff --git a/ide/preferences.ml b/ide/preferences.ml index 045d650c1c..4aa8c92f73 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -815,33 +815,20 @@ let configure ?(apply=(fun () -> ())) parent = custom ~label box callback true in -(* - let show_toolbar = - bool - ~f:(fun s -> - current.show_toolbar <- s; - !show_toolbar s) - "Show toolbar" current.show_toolbar - in let window_height = string - ~f:(fun s -> current.window_height <- (try int_of_string s with _ -> 600); - !resize_window (); - ) - "Window height" - (string_of_int current.window_height) + ~f:(fun s -> try window_height#set (int_of_string s) with _ -> ()) + "Default window height at starting time" + (string_of_int window_height#get) in + let window_width = string - ~f:(fun s -> current.window_width <- - (try int_of_string s with _ -> 800)) - "Window width" - (string_of_int current.window_width) + ~f:(fun s -> try window_width#set (int_of_string s) with _ -> ()) + "Default window width at starting time" + (string_of_int window_width#get) in -*) -(* - let config_appearance = [show_toolbar; window_width; window_height] in -*) + let global_auto_revert = pbool "Enable global auto revert" global_auto_revert in let global_auto_revert_delay = string @@ -1049,10 +1036,7 @@ let configure ?(apply=(fun () -> ())) parent = Section("Project", Some (`STOCK "gtk-page-setup"), [project_file_name;read_project; ]); -(* - Section("Appearance", - config_appearance); -*) + Section("Appearance", Some `PREFERENCES, [window_width; window_height]); Section("Externals", None, [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;cmd_editor;cmd_browse;doc_url;library_url]); diff --git a/ide/protocol/interface.ml b/ide/protocol/interface.ml index debbc8301e..ccb6bedaf6 100644 --- a/ide/protocol/interface.ml +++ b/ide/protocol/interface.ml @@ -78,16 +78,20 @@ type option_state = { } type search_constraint = -(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) | Name_Pattern of string -(** Whether the object type satisfies a pattern *) +(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) + | Type_Pattern of string -(** Whether some subtype of object type satisfies a pattern *) +(** Whether the object type satisfies a pattern *) + | SubType_Pattern of string -(** Whether the object pertains to a module *) +(** Whether some subtype of object type satisfies a pattern *) + | In_Module of string list -(** Bypass the Search blacklist *) +(** Whether the object pertains to a module *) + | Include_Blacklist +(** Bypass the Search blacklist *) (** A list of search constraints; the boolean flag is set to [false] whenever the flag should be negated. *) diff --git a/ide/protocol/richpp.ml b/ide/protocol/richpp.ml index 19e9799c19..b2ce55e89a 100644 --- a/ide/protocol/richpp.ml +++ b/ide/protocol/richpp.ml @@ -46,7 +46,7 @@ let rich_pp width ppcmds = let pp_buffer = Buffer.create 180 in let push_pcdata () = - (** Push the optional PCData on the above node *) + (* Push the optional PCData on the above node *) let len = Buffer.length pp_buffer in if len = 0 then () else match context.stack with @@ -77,7 +77,7 @@ let rich_pp width ppcmds = let xml = Element (node, annotation, List.rev child) in match ctx with | Leaf -> - (** Final node: we keep the result in a dummy context *) + (* Final node: we keep the result in a dummy context *) context.stack <- Node ("", [xml], 0, Leaf) | Node (node, child, pos, ctx) -> context.stack <- Node (node, xml :: child, pos, ctx) @@ -104,15 +104,15 @@ let rich_pp width ppcmds = pp_set_max_boxes ft 50 ; pp_set_ellipsis_text ft "..."; - (** The whole output must be a valid document. To that - end, we nest the document inside <pp> tags. *) + (* The whole output must be a valid document. To that + end, we nest the document inside <pp> tags. *) pp_open_box ft 0; pp_open_tag ft "pp"; Pp.(pp_with ft ppcmds); pp_close_tag ft (); pp_close_box ft (); - (** Get the resulting XML tree. *) + (* Get the resulting XML tree. *) let () = pp_print_flush ft () in let () = assert (Buffer.length pp_buffer = 0) in match context.stack with diff --git a/ide/sentence.ml b/ide/sentence.ml index 2f7820a77c..2e508969aa 100644 --- a/ide/sentence.ml +++ b/ide/sentence.ml @@ -91,8 +91,8 @@ let tag_on_insert buffer = in try let start = grab_sentence_start prev soi in - (** The status of "{" "}" as sentence delimiters is too fragile. - We retag up to the next "." instead. *) + (* The status of "{" "}" as sentence delimiters is too fragile. + We retag up to the next "." instead. *) let stop = grab_ending_dot insert in try split_slice_lax buffer start#backward_char stop with Coq_lex.Unterminated -> diff --git a/ide/session.ml b/ide/session.ml index be2bfe060c..805e1d38a7 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -217,7 +217,7 @@ let set_buffer_handlers | Some s -> Minilib.log (s^" moved") | None -> () in - (** Pluging callbacks *) + (* Pluging callbacks *) let _ = buffer#connect#insert_text ~callback:insert_cb in let _ = buffer#connect#delete_range ~callback:delete_cb in let _ = buffer#connect#begin_user_action ~callback:begin_action_cb in @@ -427,7 +427,7 @@ let build_layout (sn:session) = GPack.vbox ~packing:(session_paned#pack1 ~shrink:false ~resize:true) () in - (** Right part of the window. *) + (* Right part of the window. *) let eval_paned = GPack.paned `HORIZONTAL ~border_width:5 ~packing:(session_box#pack ~expand:true) () in @@ -438,7 +438,7 @@ let build_layout (sn:session) = let state_paned = GPack.paned `VERTICAL ~packing:eval_paned#add2 () in - (** Proof buffer. *) + (* Proof buffer. *) let title = Printf.sprintf "Proof (%s)" sn.tab_label#text in let proof_detachable = Wg_Detachable.detachable ~title () in @@ -454,7 +454,7 @@ let build_layout (sn:session) = let proof_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_detachable#pack () in - (** Message buffer. *) + (* Message buffer. *) let message_frame = GPack.notebook ~packing:state_paned#add () in let add_msg_page pos name text (w : GObj.widget) = @@ -514,14 +514,14 @@ let build_layout (sn:session) = let detach, _ = add_msg_page 0 sn.tab_label#text "Messages" sn.messages#default_route#coerce in let _, label = add_msg_page 1 sn.tab_label#text "Errors" sn.errpage#coerce in let _, _ = add_msg_page 2 sn.tab_label#text "Jobs" sn.jobpage#coerce in - (** When a message is received, focus on the message pane *) + (* When a message is received, focus on the message pane *) let _ = sn.messages#default_route#connect#pushed ~callback:(fun _ _ -> let num = message_frame#page_num detach#coerce in if 0 <= num then message_frame#goto_page num ) in - (** When an error occurs, paint the error label in red *) + (* When an error occurs, paint the error label in red *) let txt = label#text in let red s = "<span foreground=\"#FF0000\">" ^ s ^ "</span>" in sn.errpage#on_update ~callback:(fun l -> diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml index 6a9317bc2f..c39d6d0563 100644 --- a/ide/wg_Completion.ml +++ b/ide/wg_Completion.ml @@ -40,7 +40,7 @@ let get_syntactic_completion (buffer : GText.buffer) pattern accu = (** Retrieve completion proposals in Coq libraries *) let get_semantic_completion pattern accu = let flags = [Interface.Name_Pattern ("^" ^ pattern), true] in - (** Only get the last part of the qualified name *) + (* Only get the last part of the qualified name *) let rec last accu = function | [] -> accu | [basename] -> Proposals.add basename accu @@ -199,15 +199,15 @@ object (self) let () = self#init_proposals w props in update_completion_signal#call (start_offset, w, props) in - (** If not in the cache, we recompute it: first syntactic *) + (* If not in the cache, we recompute it: first syntactic *) let synt = get_syntactic_completion buffer w Proposals.empty in - (** Then semantic *) + (* Then semantic *) let next prop = let () = update prop in Coq.lift k in let query = Coq.bind (get_semantic_completion w synt) next in - (** If coqtop is computing, do the syntactic completion altogether *) + (* If coqtop is computing, do the syntactic completion altogether *) let occupied () = let () = update synt in k () @@ -264,20 +264,20 @@ object (self) renderer#set_properties [`FONT_DESC font; `XPAD 10] method private coordinates pos = - (** Toplevel position w.r.t. screen *) + (* Toplevel position w.r.t. screen *) let (x, y) = Gdk.Window.get_position view#misc#toplevel#misc#window in - (** Position of view w.r.t. window *) + (* Position of view w.r.t. window *) let (ux, uy) = Gdk.Window.get_position view#misc#window in - (** Relative buffer position to view *) + (* Relative buffer position to view *) let (dx, dy) = view#window_to_buffer_coords ~tag:`WIDGET ~x:0 ~y:0 in - (** Iter position *) + (* Iter position *) let iter = view#buffer#get_iter pos in let coords = view#get_iter_location iter in let lx = Gdk.Rectangle.x coords in let ly = Gdk.Rectangle.y coords in let w = Gdk.Rectangle.width coords in let h = Gdk.Rectangle.height coords in - (** Absolute position *) + (* Absolute position *) (x + lx + ux - dx, y + ly + uy - dy, w, h) method private select_any f = @@ -374,9 +374,9 @@ object (self) else None method private manage_scrollbar () = - (** HACK: we don't have access to the treeview size because of the lack of - LablGTK binding for certain functions, so we bypass it by approximating - it through the size of the proposals *) + (* HACK: we don't have access to the treeview size because of the lack of + LablGTK binding for certain functions, so we bypass it by approximating + it through the size of the proposals *) let height = match model#store#get_iter_first with | None -> -1 | Some iter -> @@ -434,18 +434,18 @@ object (self) else false else false in - (** Style handling *) + (* Style handling *) let _ = view#misc#connect#style_set ~callback:self#refresh_style in let _ = self#refresh_style () in let _ = data#set_resize_mode `PARENT in let _ = frame#set_resize_mode `PARENT in - (** Callback to model *) + (* Callback to model *) let _ = model#connect#start_completion ~callback:self#start_callback in let _ = model#connect#update_completion ~callback:self#update_callback in let _ = model#connect#end_completion ~callback:self#end_callback in - (** Popup interaction *) + (* Popup interaction *) let _ = view#event#connect#key_press ~callback:key_cb in - (** Hiding the popup when necessary*) + (* Hiding the popup when necessary*) let _ = view#misc#connect#hide ~callback:obj#misc#hide in let _ = view#event#connect#button_press ~callback:(fun _ -> self#hide (); false) in let _ = view#connect#move_cursor ~callback:move_cb in diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index 296a942321..7d2d7da570 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -212,13 +212,13 @@ class finder name (view : GText.view) = initializer let _ = self#hide () in - (** Widget button interaction *) + (* Widget button interaction *) let _ = next_button#connect#clicked ~callback:self#find_forward in let _ = previous_button#connect#clicked ~callback:self#find_backward in let _ = replace_button#connect#clicked ~callback:self#replace in let _ = replace_all_button#connect#clicked ~callback:self#replace_all in - (** Keypress interaction *) + (* Keypress interaction *) let generic_cb esc_cb ret_cb ev = let ev_key = GdkEvent.Key.keyval ev in let (return, _) = GtkData.AccelGroup.parse "Return" in @@ -232,7 +232,7 @@ class finder name (view : GText.view) = let _ = find_entry#event#connect#key_press ~callback:find_cb in let _ = replace_entry#event#connect#key_press ~callback:replace_cb in - (** TextView interaction *) + (* TextView interaction *) let view_cb ev = if widget#visible then let ev_key = GdkEvent.Key.keyval ev in diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index a79a093e32..6b09b344b5 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -36,6 +36,7 @@ class type message_view = method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) + method has_selection : bool method get_selected_text : string end diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 472aaf5ed4..613f1b4190 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -26,6 +26,7 @@ class type message_view = method refresh : bool -> unit method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) + method has_selection : bool method get_selected_text : string end diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 74bc0b8d53..5e26c50797 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -152,11 +152,11 @@ object(self) if self#process_delete_action del then (`OK, `WRITE) else (`FAIL, `NOOP) | Action lst -> let fold accu action = match accu with - | (`FAIL, _) -> accu (** we stop now! *) + | (`FAIL, _) -> accu (* we stop now! *) | (`OK, status) -> let (res, nstatus) = self#process_action action in let merge op1 op2 = match op1, op2 with - | `NOOP, `NOOP -> `NOOP (** only a noop when both are *) + | `NOOP, `NOOP -> `NOOP (* only a noop when both are *) | _ -> `WRITE in (res, merge status nstatus) @@ -172,8 +172,8 @@ object(self) | (`OK, _) -> history <- rem; redo <- (negate_action action) :: redo - | (`FAIL, `NOOP) -> () (** we do nothing *) - | (`FAIL, `WRITE) -> self#clear_undo () (** we don't know how we failed, so start off *) + | (`FAIL, `NOOP) -> () (* we do nothing *) + | (`FAIL, `WRITE) -> self#clear_undo () (* we don't know how we failed, so start off *) end method perform_redo () = match redo with @@ -184,8 +184,8 @@ object(self) | (`OK, _) -> redo <- rem; history <- (negate_action action) :: history; - | (`FAIL, `NOOP) -> () (** we do nothing *) - | (`FAIL, `WRITE) -> self#clear_undo () (** we don't know how we failed *) + | (`FAIL, `NOOP) -> () (* we do nothing *) + | (`FAIL, `WRITE) -> self#clear_undo () (* we don't know how we failed *) end method undo () = @@ -212,9 +212,9 @@ object(self) self#with_lock_undo self#process_begin_user_action () method process_end_user_action () = - (** Search for the pending action *) + (* Search for the pending action *) let rec split accu = function - | [] -> raise Not_found (** no pending begin action! *) + | [] -> raise Not_found (* no pending begin action! *) | EndGrp :: rem -> let grp = List.rev accu in let rec flatten = function @@ -240,7 +240,7 @@ object(self) (* Save the insert action *) let len = Glib.Utf8.length s in let mergeable = - (** heuristic: split at newline and atomic pastes *) + (* heuristic: split at newline and atomic pastes *) len = 1 && (s <> "\n") in let ins = { @@ -460,7 +460,7 @@ object (self) if not proceed then GtkSignal.stop_emit () in let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in - (** Plug on preferences *) + (* Plug on preferences *) let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 0f5ed8d896..3b2572f9d2 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -70,7 +70,7 @@ object (self) let cb rect = let w = rect.Gtk.width in let h = rect.Gtk.height in - (** Only refresh when size actually changed, otherwise loops *) + (* Only refresh when size actually changed, otherwise loops *) if self#misc#visible && (width <> w || height <> h) then begin width <- w; height <- h; @@ -91,7 +91,7 @@ object (self) let _ = eventbox#event#connect#button_press ~callback:clicked_cb in let cb show = if show then self#misc#show () else self#misc#hide () in stick show_progress_bar self cb; - (** Initial pixmap *) + (* Initial pixmap *) draw#set_pixmap pixmap; refresh_timer.Ideutils.run ~ms:300 ~callback:(fun () -> if need_refresh then self#refresh (); true) diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 77d612cfd9..757d186c8b 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -80,8 +80,8 @@ type cases_pattern_expr_r = and cases_pattern_expr = cases_pattern_expr_r CAst.t and cases_pattern_notation_substitution = - cases_pattern_expr list * (** for constr subterms *) - cases_pattern_expr list list (** for recursive notations *) + cases_pattern_expr list * (* for constr subterms *) + cases_pattern_expr list list (* for recursive notations *) and constr_expr_r = | CRef of qualid * instance_expr option @@ -142,10 +142,10 @@ and local_binder_expr = | CLocalPattern of (cases_pattern_expr * constr_expr option) CAst.t and constr_notation_substitution = - constr_expr list * (** for constr subterms *) - constr_expr list list * (** for recursive notations *) - cases_pattern_expr list * (** for binders *) - local_binder_expr list list (** for binder lists (recursive notations) *) + constr_expr list * (* for constr subterms *) + constr_expr list list * (* for recursive notations *) + cases_pattern_expr list * (* for binders *) + local_binder_expr list list (* for binder lists (recursive notations) *) type constr_pattern_expr = constr_expr diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 3a4969a3ee..95a0039b0a 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -140,7 +140,7 @@ let rec constr_expr_eq e1 e2 = in List.equal field_eq l1 l2 | CCases(_,r1,a1,brl1), CCases(_,r2,a2,brl2) -> - (** Don't care about the case_style *) + (* Don't care about the case_style *) Option.equal constr_expr_eq r1 r2 && List.equal case_expr_eq a1 a2 && List.equal branch_expr_eq brl1 brl2 @@ -220,7 +220,7 @@ and local_binder_eq l1 l2 = match l1, l2 with | CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> eq_ast Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 | CLocalAssum (n1, _, e1), CLocalAssum (n2, _, e2) -> - (** Don't care about the [binder_kind] *) + (* Don't care about the [binder_kind] *) List.equal (eq_ast Name.equal) n1 n2 && constr_expr_eq e1 e2 | _ -> false @@ -258,7 +258,6 @@ let local_binders_loc bll = match bll with | h :: l -> Loc.merge_opt (local_binder_loc h) (local_binder_loc (List.last bll)) (** Folds and maps *) - let is_constructor id = try Globnames.isConstructRef (Smartlocate.global_of_extended_global @@ -294,9 +293,6 @@ let ids_of_pattern_list = (List.fold_left (cases_pattern_fold_names Id.Set.add)) Id.Set.empty -let ids_of_cases_indtype p = - cases_pattern_fold_names Id.Set.add Id.Set.empty p - let ids_of_cases_tomatch tms = List.fold_right (fun (_, ona, indnal) l -> @@ -367,6 +363,14 @@ let free_vars_of_constr_expr c = | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c in aux [] Id.Set.empty c +let names_of_constr_expr c = + let vars = ref Id.Set.empty in + let rec aux () () = function + | { CAst.v = CRef (qid, _) } when qualid_is_ident qid -> + let id = qualid_basename qid in vars := Id.Set.add id !vars + | c -> fold_constr_expr_with_binders (fun a () -> vars := Id.Set.add a !vars) aux () () c + in aux () () c; !vars + let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) (* Used in correctness and interface *) diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 7f14eb4583..f1a8ed202f 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -113,12 +113,12 @@ val map_constr_expr_with_binders : val replace_vars_constr_expr : Id.t Id.Map.t -> constr_expr -> constr_expr -(** Specific function for interning "in indtype" syntax of "match" *) -val ids_of_cases_indtype : cases_pattern_expr -> Id.Set.t - val free_vars_of_constr_expr : constr_expr -> Id.Set.t val occur_var_constr_expr : Id.t -> constr_expr -> bool +(** Return all (non-qualified) names treating binders as names *) +val names_of_constr_expr : constr_expr -> Id.Set.t + val split_at_annot : local_binder_expr list -> lident option -> local_binder_expr list * local_binder_expr list val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> notation -> (int * int) list diff --git a/interp/constrextern.ml b/interp/constrextern.ml index fba03b9de9..444ac5ab6d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -67,10 +67,7 @@ let print_no_symbol = ref false (**********************************************************************) (* Turning notations and scopes on and off for printing *) -module IRuleSet = Set.Make(struct - type t = interp_rule - let compare x y = Pervasives.compare x y - end) +module IRuleSet = InterpRuleSet let inactive_notations_table = Summary.ref ~name:"inactive_notations_table" (IRuleSet.empty) @@ -960,7 +957,7 @@ let rec extern inctx (custom,scopes as allscopes) vars r = | GSort s -> CSort (extern_glob_sort s) - | GHole (e,naming,_) -> CHole (Some e, naming, None) (** TODO: extern tactics. *) + | GHole (e,naming,_) -> CHole (Some e, naming, None) (* TODO: extern tactics. *) | GCast (c, c') -> CCast (sub_extern true scopes vars c, diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 6313f2d7ba..c8c38ffe05 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -573,12 +573,17 @@ let find_fresh_name renaming (terms,termlists,binders,binderlists) avoid id = (* TODO binders *) next_ident_away_from id (fun id -> Id.Set.mem id fvs3) -let is_var store pat = +let is_patvar c = + match DAst.get c with + | PatVar _ -> true + | _ -> false + +let is_patvar_store store pat = match DAst.get pat with | PatVar na -> ignore(store na); true | _ -> false -let out_var pat = +let out_patvar pat = match pat.v with | CPatAtom (Some qid) when qualid_is_ident qid -> Name (qualid_basename qid) @@ -600,7 +605,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam let pat = coerce_to_cases_pattern_expr (fst (Id.Map.find id terms)) in let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in let pat, na = match disjpat with - | [pat] when is_var store pat -> let na = get () in None, na + | [pat] when is_patvar_store store pat -> let na = get () in None, na | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na.v in (renaming,env), pat, na with Not_found -> @@ -610,7 +615,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam let env = set_env_scopes env scopes in if onlyident then (* Do not try to interpret a variable as a constructor *) - let na = out_var pat in + let na = out_patvar pat in let env = push_name_env ntnvars (Variable,[],[],[]) env (make ?loc:pat.loc na) in (renaming,env), None, na else @@ -618,7 +623,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in let pat, na = match disjpat with - | [pat] when is_var store pat -> let na = get () in None, na + | [pat] when is_patvar_store store pat -> let na = get () in None, na | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na.v in (renaming,env), pat, na with Not_found -> @@ -743,7 +748,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = let mk_env' (c, (onlyident,(tmp_scope,subscopes))) = let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in if onlyident then - let na = out_var c in term_of_name na, None + let na = out_patvar c in term_of_name na, None else let _,((disjpat,_),_),_ = intern_pat ntnvars nenv c in match disjpat with @@ -805,7 +810,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = (* and since we are only interested in the pattern as a term *) let env = reset_hidden_inductive_implicit_test env in if onlyident then - term_of_name (out_var pat) + term_of_name (out_patvar pat) else let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in match disjpat with @@ -1507,7 +1512,7 @@ let drop_notations_pattern looked_for genv = let test_kind top = if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found in - (** [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) + (* [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) let rec rcp_of_glob scopes x = DAst.(map (function | GVar id -> RCPatAtom (Some (CAst.make ?loc:x.loc id,scopes)) | GHole (_,_,_) -> RCPatAtom (None) @@ -1527,8 +1532,8 @@ let drop_notations_pattern looked_for genv = try match Nametab.locate_extended qid with | SynDef sp -> - let (vars,a) = Syntax_def.search_syntactic_definition sp in - (match a with + let filter (vars,a) = + try match a with | NRef g -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_kind top g; @@ -1549,7 +1554,9 @@ let drop_notations_pattern looked_for genv = let idspl1 = List.map (in_not false qid.loc scopes (subst, Id.Map.empty) []) args in let (_,argscs) = find_remaining_scopes pats1 pats2 g in Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) - | _ -> raise Not_found) + | _ -> raise Not_found + with Not_found -> None in + Syntax_def.search_filtered_syntactic_definition filter sp | TrueGlobal g -> test_kind top g; Dumpglob.add_glob ?loc:qid.loc g; @@ -1739,7 +1746,7 @@ let intern_ind_pattern genv ntnvars scopes pat = let idslpl = List.map (intern_pat genv ntnvars empty_alias) (expl_pl@pl2) in (with_letin, match product_of_cases_patterns empty_alias idslpl with - | _,[_,pl] -> (c,chop_params_pattern loc c pl with_letin) + | ids,[asubst,pl] -> (c,ids,asubst,chop_params_pattern loc c pl with_letin) | _ -> error_bad_inductive_type ?loc) | x -> error_bad_inductive_type ?loc @@ -1977,30 +1984,30 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = end | CCases (sty, rtnpo, tms, eqns) -> let as_in_vars = List.fold_left (fun acc (_,na,inb) -> - Option.fold_left (fun acc tt -> Id.Set.union (ids_of_cases_indtype tt) acc) - (Option.fold_left (fun acc { CAst.v = y } -> Name.fold_right Id.Set.add y acc) acc na) - inb) Id.Set.empty tms in + (Option.fold_left (fun acc { CAst.v = y } -> Name.fold_right Id.Set.add y acc) acc na)) + Id.Set.empty tms in (* as, in & return vars *) let forbidden_vars = Option.cata free_vars_of_constr_expr as_in_vars rtnpo in - let tms,ex_ids,match_from_in = List.fold_right - (fun citm (inds,ex_ids,matchs) -> - let ((tm,ind),extra_id,match_td) = intern_case_item env forbidden_vars citm in - (tm,ind)::inds, Option.fold_right Id.Set.add extra_id ex_ids, List.rev_append match_td matchs) - tms ([],Id.Set.empty,[]) in + let tms,ex_ids,aliases,match_from_in = List.fold_right + (fun citm (inds,ex_ids,asubst,matchs) -> + let ((tm,ind),extra_id,(ind_ids,alias_subst,match_td)) = + intern_case_item env forbidden_vars citm in + (tm,ind)::inds, + Id.Set.union ind_ids (Option.fold_right Id.Set.add extra_id ex_ids), + merge_subst alias_subst asubst, + List.rev_append match_td matchs) + tms ([],Id.Set.empty,Id.Map.empty,[]) in let env' = Id.Set.fold (fun var bli -> push_name_env ntnvars (Variable,[],[],[]) bli (CAst.make @@ Name var)) (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = - let is_patvar c = match DAst.get c with - | PatVar _ -> true - | _ -> false - in let rec aux = function | [] -> [] | (_, c) :: q when is_patvar c -> aux q | l -> l in aux match_from_in in + let rtnpo = Option.map (replace_vars_constr_expr aliases) rtnpo in let rtnpo = match stripped_match_from_in with | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) | l -> @@ -2148,7 +2155,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* the "in" part *) let match_td,typ = match t with | Some t -> - let with_letin,(ind,l) = intern_ind_pattern globalenv ntnvars (None,env.scopes) t in + let with_letin,(ind,ind_ids,alias_subst,l) = + intern_ind_pattern globalenv ntnvars (None,env.scopes) t in let (mib,mip) = Inductive.lookup_mind_specif globalenv ind in let nparams = (List.length (mib.Declarations.mind_params_ctxt)) in (* for "in Vect n", we answer (["n","n"],[(loc,"n")]) @@ -2184,9 +2192,10 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let _,args_rel = List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in canonize_args args_rel l forbidden_names_for_gen [] [] in - match_to_do, Some (CAst.make ?loc:(cases_pattern_expr_loc t) (ind,List.rev_map (fun x -> x.v) nal)) + (Id.Set.of_list (List.map (fun id -> id.CAst.v) ind_ids),alias_subst,match_to_do), + Some (CAst.make ?loc:(cases_pattern_expr_loc t) (ind,List.rev_map (fun x -> x.v) nal)) | None -> - [], None in + (Id.Set.empty,Id.Map.empty,[]), None in (tm',(na.CAst.v, typ)), extra_id, match_td and intern_impargs c env l subscopes args = diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 035e4bc644..61acd09d65 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -45,13 +45,15 @@ type var_internalization_type = type var_internalization_data = var_internalization_type * - (** type of the "free" variable, for coqdoc, e.g. while typing the - constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) + (* type of the "free" variable, for coqdoc, e.g. while typing the + constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) + Id.t list * - (** impargs to automatically add to the variable, e.g. for "JMeq A a B b" - in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) - Impargs.implicit_status list * (** signature of impargs of the variable *) - Notation_term.scope_name option list (** subscopes of the args of the variable *) + (* impargs to automatically add to the variable, e.g. for "JMeq A a B b" + in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) + + Impargs.implicit_status list * (* signature of impargs of the variable *) + Notation_term.scope_name option list (* subscopes of the args of the variable *) (** A map of free variables to their implicit arguments and scopes *) type internalization_env = var_internalization_data Id.Map.t diff --git a/interp/declare.ml b/interp/declare.ml index a809a856b9..6778fa1e7a 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -56,7 +56,7 @@ let load_constant i ((sp,kn), obj) = (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn), obj) = - (** Never open a local definition *) + (* Never open a local definition *) if obj.cst_locl then () else let con = Global.constant_of_delta_kn kn in @@ -166,9 +166,9 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e export_seff || not de.const_entry_opaque || is_poly de -> - (** This globally defines the side-effects in the environment. We mark - exported constants as being side-effect not to redeclare them at - caching time. *) + (* This globally defines the side-effects in the environment. We mark + exported constants as being side-effect not to redeclare them at + caching time. *) let de, export = Global.export_private_constants ~in_section de in export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) @@ -191,7 +191,6 @@ let declare_definition ?(internal=UserIndividualRequest) (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind) (** Declaration of section variables and local definitions *) - type section_variable_entry = | SectionLocalDef of Safe_typing.private_constants definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) @@ -214,16 +213,16 @@ let cache_variable ((sp,_),o) = | SectionLocalDef (de) -> let (de, eff) = Global.export_private_constants ~in_section:true de in let () = List.iter register_side_effect eff in - (** The body should already have been forced upstream because it is a - section-local definition, but it's not enforced by typing *) + (* The body should already have been forced upstream because it is a + section-local definition, but it's not enforced by typing *) let (body, uctx), () = 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 in let univs = Univ.ContextSet.union uctx univs in - (** We must declare the universe constraints before type-checking the - term. *) + (* We must declare the universe constraints before type-checking the + term. *) let () = Global.push_context_set (not poly) univs in let se = { secdef_body = body; @@ -262,7 +261,6 @@ let declare_variable id obj = oname (** Declaration of inductive blocks *) - let declare_inductive_argument_scopes kn mie = List.iteri (fun i {mind_entry_consnames=lc} -> Notation.declare_ref_arguments_scope Evd.empty (IndRef (kn,i)); @@ -360,7 +358,7 @@ let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (ter let id = Label.to_id label in let univs = match univs with | Monomorphic_ind_entry _ -> - (** Global constraints already defined through the inductive *) + (* Global constraints already defined through the inductive *) Monomorphic_const_entry Univ.ContextSet.empty | Polymorphic_ind_entry (nas, ctx) -> Polymorphic_const_entry (nas, ctx) @@ -447,11 +445,9 @@ let assumption_message id = (** Monomorphic universes need to survive sections. *) let input_universe_context : Univ.ContextSet.t -> Libobject.obj = - declare_object - { (default_object "Monomorphic section universes") with - cache_function = (fun (na, uctx) -> Global.push_context_set false uctx); - discharge_function = (fun (_, x) -> Some x); - classify_function = (fun a -> Dispose) } + declare_object @@ local_object "Monomorphic section universes" + ~cache:(fun (na, uctx) -> Global.push_context_set false uctx) + ~discharge:(fun (_, x) -> Some x) let declare_universe_context poly ctx = if poly then @@ -511,7 +507,7 @@ let input_univ_names : universe_name_decl -> Libobject.obj = load_function = load_univ_names; open_function = open_univ_names; discharge_function = discharge_univ_names; - subst_function = (fun (subst, a) -> (** Actually the name is generated once and for all. *) a); + subst_function = (fun (subst, a) -> (* Actually the name is generated once and for all. *) a); classify_function = (fun a -> Substitute a) } let declare_univ_binders gr pl = diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 931d05a975..554da7603f 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -18,6 +18,7 @@ val dump : unit -> bool val noglob : unit -> unit val dump_into_file : string -> unit (** special handling of "stdout" *) + val dump_to_dotglob : unit -> unit val feedback_glob : unit -> unit diff --git a/interp/impargs.ml b/interp/impargs.ml index d024a9e808..8a89bcdf26 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -448,7 +448,7 @@ let compute_mib_implicits flags kn = Array.to_list (Array.mapi (* No need to lift, arities contain no de Bruijn *) (fun i mip -> - (** No need to care about constraints here *) + (* No need to care about constraints here *) let ty, _ = Typeops.type_of_global_in_context env (IndRef (kn,i)) in Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, ty)) mib.mind_packets) in diff --git a/interp/impargs.mli b/interp/impargs.mli index ea5aa90f68..4afc2af5e9 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -65,6 +65,7 @@ type implicit_explanation = operational only if [conclusion_matters] is true. *) type maximal_insertion = bool (** true = maximal contextual insertion *) + type force_inference = bool (** true = always infer, never turn into evar/subgoal *) type implicit_status = (Id.t * implicit_explanation * diff --git a/interp/interp.mllib b/interp/interp.mllib index aa20bda705..147eaf20dc 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,6 +1,4 @@ Constrexpr -Genredexpr -Redops Tactypes Stdarg Notation_term diff --git a/interp/notation.ml b/interp/notation.ml index 0af75b5bfa..ca27d439fb 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -50,15 +50,25 @@ let notation_entry_level_eq s1 s2 = match (s1,s2) with | InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> String.equal s1 s2 && n1 = n2 | (InConstrEntrySomeLevel | InCustomEntryLevel _), _ -> false +let notation_entry_level_compare s1 s2 = match (s1,s2) with +| InConstrEntrySomeLevel, InConstrEntrySomeLevel -> 0 +| InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> + pair_compare String.compare Int.compare (s1,n1) (s2,n2) +| InConstrEntrySomeLevel, _ -> -1 +| InCustomEntryLevel _, _ -> 1 + let notation_eq (from1,ntn1) (from2,ntn2) = notation_entry_level_eq from1 from2 && String.equal ntn1 ntn2 let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntrySomeLevel -> mt () | InCustomEntryLevel (s,n) -> str " in custom " ++ str s +let notation_compare = + pair_compare notation_entry_level_compare String.compare + module NotationOrd = struct type t = notation - let compare = Pervasives.compare + let compare = notation_compare end module NotationSet = Set.Make(NotationOrd) @@ -178,6 +188,17 @@ type scoped_notation_rule_core = scope_name * notation * interpretation * int op type notation_rule_core = interp_rule * interpretation * int option type notation_rule = notation_rule_core * delimiters option * bool +let interp_rule_compare r1 r2 = match r1, r2 with + | NotationRule (sc1,ntn1), NotationRule (sc2,ntn2) -> + pair_compare (Option.compare String.compare) notation_compare (sc1,ntn1) (sc2,ntn2) + | SynDefRule kn1, SynDefRule kn2 -> KerName.compare kn1 kn2 + | (NotationRule _ | SynDefRule _), _ -> -1 + +module InterpRuleSet = Set.Make(struct + type t = interp_rule + let compare = interp_rule_compare + end) + (* Scopes for uninterpretation: includes abbreviations (i.e. syntactic definitions) and *) type uninterp_scope_elem = @@ -308,7 +329,7 @@ let declare_delimiters scope key = | None -> scope_map := String.Map.add scope newsc !scope_map | Some oldkey when String.equal oldkey key -> () | Some oldkey -> - (** FIXME: implement multikey scopes? *) + (* FIXME: implement multikey scopes? *) Flags.if_verbose Feedback.msg_info (str "Overwriting previous delimiting key " ++ str oldkey ++ str " in scope " ++ str scope); scope_map := String.Map.add scope newsc !scope_map @@ -530,11 +551,11 @@ let prim_token_uninterpreters = (*******************************************************) (* Numeral notation interpretation *) -type numeral_notation_error = +type prim_token_notation_error = | UnexpectedTerm of Constr.t | UnexpectedNonOptionTerm of Constr.t -exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error +exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_token_notation_error type numnot_option = | Nop @@ -554,20 +575,26 @@ type target_kind = | UInt of Names.inductive (* Coq.Init.Decimal.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) +type string_target_kind = + | ListByte + | Byte + type option_kind = Option | Direct -type conversion_kind = target_kind * option_kind +type 'target conversion_kind = 'target * option_kind -type numeral_notation_obj = - { to_kind : conversion_kind; +type ('target, 'warning) prim_token_notation_obj = + { to_kind : 'target conversion_kind; to_ty : GlobRef.t; - of_kind : conversion_kind; + of_kind : 'target conversion_kind; of_ty : GlobRef.t; - num_ty : Libnames.qualid; (* for warnings / error messages *) - warning : numnot_option } + ty_name : Libnames.qualid; (* for warnings / error messages *) + warning : 'warning } -module Numeral = struct -(** * Numeral notation *) +type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj +module PrimTokenNotation = struct +(** * Code shared between Numeral notation and String notation *) (** Reduction The constr [c] below isn't necessarily well-typed, since we @@ -596,7 +623,69 @@ let eval_constr env sigma (c : Constr.t) = let eval_constr_app env sigma c1 c2 = eval_constr env sigma (mkApp (c1,[| c2 |])) -exception NotANumber +exception NotAValidPrimToken + +(** The uninterp function below work at the level of [glob_constr] + which is too low for us here. So here's a crude conversion back + to [constr] for the subset that concerns us. *) + +let rec constr_of_glob env sigma g = match DAst.get g with + | Glob_term.GRef (ConstructRef c, _) -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma,mkConstructU c + | Glob_term.GApp (gc, gcl) -> + let sigma,c = constr_of_glob env sigma gc in + let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in + sigma,mkApp (c, Array.of_list cl) + | _ -> + raise NotAValidPrimToken + +let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with + | App (c, ca) -> + let c = glob_of_constr token_kind ?loc env sigma c in + let cel = List.map (glob_of_constr token_kind ?loc env sigma) (Array.to_list ca) in + DAst.make ?loc (Glob_term.GApp (c, cel)) + | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) + | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) + | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) + | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) + | _ -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedTerm c)) + +let no_such_prim_token uninterpreted_token_kind ?loc ty = + CErrors.user_err ?loc + (str ("Cannot interpret this "^uninterpreted_token_kind^" as a value of type ") ++ + pr_qualid ty) + +let interp_option uninterpreted_token_kind token_kind ty ?loc env sigma c = + match Constr.kind c with + | App (_Some, [| _; c |]) -> glob_of_constr token_kind ?loc env sigma c + | App (_None, [| _ |]) -> no_such_prim_token uninterpreted_token_kind ?loc ty + | x -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedNonOptionTerm c)) + +let uninterp_option c = + match Constr.kind c with + | App (_Some, [| _; x |]) -> x + | _ -> raise NotAValidPrimToken + +let uninterp to_raw o (Glob_term.AnyGlobConstr n) = + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in + let of_ty = EConstr.Unsafe.to_constr of_ty in + try + let sigma,n = constr_of_glob env sigma n in + let c = eval_constr_app env sigma of_ty n in + let c = if snd o.of_kind == Direct then c else uninterp_option c in + Some (to_raw (fst o.of_kind, c)) + with + | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) + | NotAValidPrimToken -> None (* all other functions except big2raw *) + +end + +module Numeral = struct +(** * Numeral notation *) +open PrimTokenNotation let warn_large_num = CWarnings.create ~name:"large-number" ~category:"numbers" @@ -670,15 +759,15 @@ let rawnum_of_coquint c = | Construct ((_,n), _) (* D0 to D9 *) -> let () = Buffer.add_char buf (char_of_digit n) in of_uint_loop a buf - | _ -> raise NotANumber) - | _ -> raise NotANumber + | _ -> raise NotAValidPrimToken) + | _ -> raise NotAValidPrimToken in let buf = Buffer.create 64 in let () = of_uint_loop c buf in if Int.equal (Buffer.length buf) 0 then (* To avoid ambiguities between Nil and (D0 Nil), we choose to not display Nil alone as "0" *) - raise NotANumber + raise NotAValidPrimToken else Buffer.contents buf let rawnum_of_coqint c = @@ -687,8 +776,8 @@ let rawnum_of_coqint c = (match Constr.kind c with | Construct ((_,1), _) (* Pos *) -> (rawnum_of_coquint c', true) | Construct ((_,2), _) (* Neg *) -> (rawnum_of_coquint c', false) - | _ -> raise NotANumber) - | _ -> raise NotANumber + | _ -> raise NotAValidPrimToken) + | _ -> raise NotAValidPrimToken (***********************************************************************) @@ -718,9 +807,9 @@ let rec bigint_of_pos c = match Constr.kind c with | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) | n -> assert false (* no other constructor of type positive *) end - | x -> raise NotANumber + | x -> raise NotAValidPrimToken end - | x -> raise NotANumber + | x -> raise NotAValidPrimToken (** Now, [Z] from/to bigint *) @@ -745,51 +834,9 @@ let bigint_of_z z = match Constr.kind z with | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) | n -> assert false (* no other constructor of type Z *) end - | _ -> raise NotANumber + | _ -> raise NotAValidPrimToken end - | _ -> raise NotANumber - -(** The uninterp function below work at the level of [glob_constr] - which is too low for us here. So here's a crude conversion back - to [constr] for the subset that concerns us. *) - -let rec constr_of_glob env sigma g = match DAst.get g with - | Glob_term.GRef (ConstructRef c, _) -> - let sigma,c = Evd.fresh_constructor_instance env sigma c in - sigma,mkConstructU c - | Glob_term.GApp (gc, gcl) -> - let sigma,c = constr_of_glob env sigma gc in - let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in - sigma,mkApp (c, Array.of_list cl) - | _ -> - raise NotANumber - -let rec glob_of_constr ?loc env sigma c = match Constr.kind c with - | App (c, ca) -> - let c = glob_of_constr ?loc env sigma c in - let cel = List.map (glob_of_constr ?loc env sigma) (Array.to_list ca) in - DAst.make ?loc (Glob_term.GApp (c, cel)) - | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) - | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) - | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) - | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) - | _ -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedTerm c)) - -let no_such_number ?loc ty = - CErrors.user_err ?loc - (str "Cannot interpret this number as a value of type " ++ - pr_qualid ty) - -let interp_option ty ?loc env sigma c = - match Constr.kind c with - | App (_Some, [| _; c |]) -> glob_of_constr ?loc env sigma c - | App (_None, [| _ |]) -> no_such_number ?loc ty - | x -> Loc.raise ?loc (NumeralNotationError(env,sigma,UnexpectedNonOptionTerm c)) - -let uninterp_option c = - match Constr.kind c with - | App (_Some, [| _; x |]) -> x - | _ -> raise NotANumber + | _ -> raise NotAValidPrimToken let big2raw n = if Bigint.is_pos_or_zero n then (Bigint.to_string n, true) @@ -801,13 +848,13 @@ let raw2big (n,s) = let interp o ?loc n = begin match o.warning with | Warning threshold when snd n && rawnum_compare (fst n) threshold >= 0 -> - warn_large_num o.num_ty + warn_large_num o.ty_name | _ -> () end; let c = match fst o.to_kind with | Int int_ty -> coqint_of_rawnum int_ty n | UInt uint_ty when snd n -> coquint_of_rawnum uint_ty (fst n) - | UInt _ (* n <= 0 *) -> no_such_number ?loc o.num_ty + | UInt _ (* n <= 0 *) -> no_such_prim_token "number" ?loc o.ty_name | Z z_pos_ty -> z_of_bigint z_pos_ty (raw2big n) in let env = Global.env () in @@ -816,30 +863,120 @@ let interp o ?loc n = let to_ty = EConstr.Unsafe.to_constr to_ty in match o.warning, snd o.to_kind with | Abstract threshold, Direct when rawnum_compare (fst n) threshold >= 0 -> - warn_abstract_large_num (o.num_ty,o.to_ty); - glob_of_constr ?loc env sigma (mkApp (to_ty,[|c|])) + warn_abstract_large_num (o.ty_name,o.to_ty); + glob_of_constr "numeral" ?loc env sigma (mkApp (to_ty,[|c|])) | _ -> let res = eval_constr_app env sigma to_ty c in match snd o.to_kind with - | Direct -> glob_of_constr ?loc env sigma res - | Option -> interp_option o.num_ty ?loc env sigma res + | Direct -> glob_of_constr "numeral" ?loc env sigma res + | Option -> interp_option "number" "numeral" o.ty_name ?loc env sigma res + +let uninterp o n = + PrimTokenNotation.uninterp + begin function + | (Int _, c) -> rawnum_of_coqint c + | (UInt _, c) -> (rawnum_of_coquint c, true) + | (Z _, c) -> big2raw (bigint_of_z c) + end o n +end + +module Strings = struct +(** * String notation *) +open PrimTokenNotation + +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_list () = qualid_of_ref "core.list.type" +let q_byte () = qualid_of_ref "core.byte.type" + +let unsafe_locate_ind q = + match Nametab.locate q with + | IndRef i -> i + | _ -> raise Not_found + +let locate_list () = unsafe_locate_ind (q_list ()) +let locate_byte () = unsafe_locate_ind (q_byte ()) + +(***********************************************************************) + +(** ** Conversion between Coq [list Byte.byte] and internal raw string *) + +let coqbyte_of_char_code byte c = + mkConstruct (byte, 1 + c) -let uninterp o (Glob_term.AnyGlobConstr n) = +let coqbyte_of_string ?loc byte s = + let p = + if Int.equal (String.length s) 1 then int_of_char s.[0] + else + if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] + then int_of_string s + else + user_err ?loc ~hdr:"coqbyte_of_string" + (str "Expects a single character or a three-digits ascii code.") in + coqbyte_of_char_code byte p + +let coqbyte_of_char byte c = coqbyte_of_char_code byte (Char.code c) + +let make_ascii_string n = + if n>=32 && n<=126 then String.make 1 (char_of_int n) + else Printf.sprintf "%03d" n + +let char_code_of_coqbyte c = + match Constr.kind c with + | Construct ((_,c), _) -> c - 1 + | _ -> raise NotAValidPrimToken + +let string_of_coqbyte c = make_ascii_string (char_code_of_coqbyte c) + +let coqlist_byte_of_string byte_ty list_ty str = + let cbyte = mkInd byte_ty in + let nil = mkApp (mkConstruct (list_ty, 1), [|cbyte|]) in + let cons x xs = mkApp (mkConstruct (list_ty, 2), [|cbyte; x; xs|]) in + let rec do_chars s i acc = + if i < 0 then acc + else + let b = coqbyte_of_char byte_ty s.[i] in + do_chars s (i-1) (cons b acc) + in + do_chars str (String.length str - 1) nil + +(* N.B. We rely on the fact that [nil] is the first constructor and [cons] is the second constructor, for [list] *) +let string_of_coqlist_byte c = + let rec of_coqlist_byte_loop c buf = + match Constr.kind c with + | App (_nil, [|_ty|]) -> () + | App (_cons, [|_ty;b;c|]) -> + let () = Buffer.add_char buf (Char.chr (char_code_of_coqbyte b)) in + of_coqlist_byte_loop c buf + | _ -> raise NotAValidPrimToken + in + let buf = Buffer.create 64 in + let () = of_coqlist_byte_loop c buf in + Buffer.contents buf + +let interp o ?loc n = + let byte_ty = locate_byte () in + let list_ty = locate_list () in + let c = match fst o.to_kind with + | ListByte -> coqlist_byte_of_string byte_ty list_ty n + | Byte -> coqbyte_of_string ?loc byte_ty n + in let env = Global.env () in let sigma = Evd.from_env env in - let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in - let of_ty = EConstr.Unsafe.to_constr of_ty in - try - let sigma,n = constr_of_glob env sigma n in - let c = eval_constr_app env sigma of_ty n in - let c = if snd o.of_kind == Direct then c else uninterp_option c in - match fst o.of_kind with - | Int _ -> Some (rawnum_of_coqint c) - | UInt _ -> Some (rawnum_of_coquint c, true) - | Z _ -> Some (big2raw (bigint_of_z c)) - with - | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) - | NotANumber -> None (* all other functions except big2raw *) + let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in + let to_ty = EConstr.Unsafe.to_constr to_ty in + let res = eval_constr_app env sigma to_ty c in + match snd o.to_kind with + | Direct -> glob_of_constr "string" ?loc env sigma res + | Option -> interp_option "string" "string" o.ty_name ?loc env sigma res + +let uninterp o n = + PrimTokenNotation.uninterp + begin function + | (ListByte, c) -> string_of_coqlist_byte c + | (Byte, c) -> string_of_coqbyte c + end o n end (* A [prim_token_infos], which is synchronized with the document @@ -853,6 +990,7 @@ end type prim_token_interp_info = Uid of prim_token_uid | NumeralNotation of numeral_notation_obj + | StringNotation of string_notation_obj type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) @@ -1081,6 +1219,7 @@ let find_prim_token check_allowed ?loc p sc = let interp = match info with | Uid uid -> Hashtbl.find prim_token_interpreters uid | NumeralNotation o -> InnerPrimToken.RawNumInterp (Numeral.interp o) + | StringNotation o -> InnerPrimToken.StringInterp (Strings.interp o) in let pat = InnerPrimToken.do_interp ?loc interp p in check_allowed pat; @@ -1270,6 +1409,7 @@ let uninterp_prim_token c = let uninterp = match info with | Uid uid -> Hashtbl.find prim_token_uninterpreters uid | NumeralNotation o -> InnerPrimToken.RawNumUninterp (Numeral.uninterp o) + | StringNotation o -> InnerPrimToken.StringUninterp (Strings.uninterp o) in match InnerPrimToken.do_uninterp uninterp (AnyGlobConstr c) with | None -> raise Notation_ops.No_match @@ -1289,6 +1429,8 @@ let availability_of_prim_token n printer_scope local_scopes = match n, uid with | Numeral _, NumeralNotation _ -> true | _, NumeralNotation _ -> false + | String _, StringNotation _ -> true + | _, StringNotation _ -> false | _, Uid uid -> let interp = Hashtbl.find prim_token_interpreters uid in match n, interp with @@ -1781,7 +1923,7 @@ let pr_visibility prglob = function (**********************************************************************) (* Synchronisation with reset *) -let freeze _ = +let freeze ~marshallable = (!scope_map, !scope_stack, !uninterp_scope_stack, !arguments_scope, !delimiters_map, !notations_key_table, !scope_class_map, !prim_token_interp_infos, !prim_token_uninterp_infos, @@ -1818,7 +1960,7 @@ let _ = Summary.init_function = init } let with_notation_protection f x = - let fs = freeze false in + let fs = freeze ~marshallable:false in try let a = f x in unfreeze fs; a with reraise -> let reraise = CErrors.push reraise in diff --git a/interp/notation.mli b/interp/notation.mli index 3480d1c8f2..a482e00e81 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -54,7 +54,7 @@ val scope_is_open : scope_name -> bool (** Open scope *) val open_close_scope : - (** locality *) bool * (* open *) bool * scope_name -> unit + (* locality *) bool * (* open *) bool * scope_name -> unit (** Extend a list of scopes *) val empty_scope_stack : scopes @@ -104,11 +104,11 @@ val register_string_interpretation : (** * Numeral notation *) -type numeral_notation_error = +type prim_token_notation_error = | UnexpectedTerm of Constr.t | UnexpectedNonOptionTerm of Constr.t -exception NumeralNotationError of Environ.env * Evd.evar_map * numeral_notation_error +exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_token_notation_error type numnot_option = | Nop @@ -128,20 +128,28 @@ type target_kind = | UInt of Names.inductive (* Coq.Init.Decimal.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) +type string_target_kind = + | ListByte + | Byte + type option_kind = Option | Direct -type conversion_kind = target_kind * option_kind +type 'target conversion_kind = 'target * option_kind -type numeral_notation_obj = - { to_kind : conversion_kind; +type ('target, 'warning) prim_token_notation_obj = + { to_kind : 'target conversion_kind; to_ty : GlobRef.t; - of_kind : conversion_kind; + of_kind : 'target conversion_kind; of_ty : GlobRef.t; - num_ty : Libnames.qualid; (* for warnings / error messages *) - warning : numnot_option } + ty_name : Libnames.qualid; (* for warnings / error messages *) + warning : 'warning } + +type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj type prim_token_interp_info = Uid of prim_token_uid | NumeralNotation of numeral_notation_obj + | StringNotation of string_notation_obj type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) @@ -202,6 +210,8 @@ type interp_rule = | NotationRule of scope_name option * notation | SynDefRule of KerName.t +module InterpRuleSet : Set.S with type elt = interp_rule + val declare_notation_interpretation : notation -> scope_name option -> interpretation -> notation_location -> onlyprint:bool -> unit diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 7a525f84a5..8d225fe683 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -37,7 +37,7 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with | _ -> false) | NApp (t1, a1), NApp (t2, a2) -> (eq_notation_constr vars) t1 t2 && List.equal (eq_notation_constr vars) a1 a2 -| NHole (_, _, _), NHole (_, _, _) -> true (** FIXME? *) +| NHole (_, _, _), NHole (_, _, _) -> true (* FIXME? *) | NList (i1, j1, t1, u1, b1), NList (i2, j2, t2, u2, b2) -> Id.equal i1 i2 && Id.equal j1 j2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 && b1 == b2 @@ -51,7 +51,7 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with | NLetIn (na1, b1, t1, u1), NLetIn (na2, b2, t2, u2) -> Name.equal na1 na2 && eq_notation_constr vars b1 b2 && Option.equal (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 -| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (** FIXME? *) +| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (* FIXME? *) let eqpat (p1, t1) (p2, t2) = List.equal cases_pattern_eq p1 p2 && (eq_notation_constr vars) t1 t2 @@ -75,7 +75,7 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with Option.equal (eq_notation_constr vars) o1 o2 && (eq_notation_constr vars) u1 u2 && (eq_notation_constr vars) r1 r2 -| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (** FIXME? *) +| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (* FIXME? *) let eq (na1, o1, t1) (na2, o2, t2) = Name.equal na1 na2 && Option.equal (eq_notation_constr vars) o1 o2 && @@ -530,8 +530,10 @@ let rec subst_notation_constr subst bound raw = match raw with | NRef ref -> let ref',t = subst_global subst ref in - if ref' == ref then raw else - fst (notation_constr_of_constr bound t) + if ref' == ref then raw else (match t with + | None -> NRef ref' + | Some t -> + fst (notation_constr_of_constr bound t.Univ.univ_abstracted_value)) | NVar _ -> raw diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 5fb0ca1b43..0ef1f267f6 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -20,13 +20,13 @@ open Glob_term as well as non global expressions such as existential variables. *) type notation_constr = - (** Part common to [glob_constr] and [cases_pattern] *) + (* Part common to [glob_constr] and [cases_pattern] *) | NRef of GlobRef.t | NVar of Id.t | NApp of notation_constr * notation_constr list | NHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option | NList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool - (** Part only in [glob_constr] *) + (* Part only in [glob_constr] *) | NLambda of Name.t * notation_constr * notation_constr | NProd of Name.t * notation_constr * notation_constr | NBinderList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 7b01b6dc1c..bf3a8fe215 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -11,8 +11,6 @@ open Genarg open Geninterp -type 'a and_short_name = 'a * Names.lident option - let make0 ?dyn name = let wit = Genarg.make0 name in let () = register_val0 wit dyn in @@ -53,8 +51,6 @@ let wit_uconstr = make0 "uconstr" let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" -let wit_red_expr = make0 "redexpr" - let wit_clause_dft_concl = make0 "clause_dft_concl" @@ -65,4 +61,3 @@ let wit_preident = wit_pre_ident let wit_reference = wit_ref let wit_global = wit_ref let wit_clause = wit_clause_dft_concl -let wit_redexpr = wit_red_expr diff --git a/interp/stdarg.mli b/interp/stdarg.mli index 5e5e43ed38..c974a4403c 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -14,15 +14,11 @@ open Loc open Names open EConstr open Libnames -open Genredexpr -open Pattern open Constrexpr open Genarg open Genintern open Locus -type 'a and_short_name = 'a * lident option - val wit_unit : unit uniform_genarg_type val wit_bool : bool uniform_genarg_type @@ -52,11 +48,6 @@ val wit_uconstr : (constr_expr , glob_constr_and_expr, Ltac_pretype.closed_glob_ val wit_open_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type -val wit_red_expr : - ((constr_expr,qualid or_by_notation,constr_expr) red_expr_gen, - (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, - (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type - val wit_clause_dft_concl : (lident Locus.clause_expr, lident Locus.clause_expr, Names.Id.t Locus.clause_expr) genarg_type (** Aliases for compatibility *) @@ -66,7 +57,3 @@ val wit_preident : string uniform_genarg_type val wit_reference : (qualid, GlobRef.t located or_var, GlobRef.t) genarg_type val wit_global : (qualid, GlobRef.t located or_var, GlobRef.t) genarg_type val wit_clause : (lident Locus.clause_expr, lident Locus.clause_expr, Names.Id.t Locus.clause_expr) genarg_type -val wit_redexpr : - ((constr_expr,qualid or_by_notation,constr_expr) red_expr_gen, - (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, - (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index b73d238c22..49273c4146 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -105,3 +105,10 @@ let search_syntactic_definition ?loc kn = let def = out_pat pat in verbose_compat ?loc kn def v; def + +let search_filtered_syntactic_definition ?loc filter kn = + let pat,v = KNmap.find kn !syntax_table in + let def = out_pat pat in + let res = filter def in + (match res with Some _ -> verbose_compat ?loc kn def v | None -> ()); + res diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index c5b6655ff8..77873f8f67 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -19,3 +19,6 @@ val declare_syntactic_definition : bool -> Id.t -> Flags.compat_version option -> syndef_interpretation -> unit val search_syntactic_definition : ?loc:Loc.t -> KerName.t -> syndef_interpretation + +val search_filtered_syntactic_definition : ?loc:Loc.t -> + (syndef_interpretation -> 'a option) -> KerName.t -> 'a option diff --git a/kernel/.merlin.in b/kernel/.merlin.in index 912ff61496..29da7d2cf6 100644 --- a/kernel/.merlin.in +++ b/kernel/.merlin.in @@ -1,4 +1,4 @@ -FLG -rectypes -thread -safe-string -w +a-4-44-50 +FLG -rectypes -thread -safe-string -w +a-4-44 S ../clib B ../clib diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 1f61bcae2e..196bb16f32 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -374,46 +374,6 @@ let rec stack_args_size = function | Zupdate(_)::s -> stack_args_size s | (ZcaseT _ | Zproj _ | Zfix _) :: _ | [] -> 0 -(* When used as an argument stack (only Zapp can appear) *) -let rec decomp_stack = function - | Zapp v :: s -> - (match Array.length v with - 0 -> decomp_stack s - | 1 -> Some (v.(0), s) - | _ -> - Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s))) - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> None -let array_of_stack s = - let rec stackrec = function - | [] -> [] - | Zapp args :: s -> args :: (stackrec s) - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ -> assert false - in Array.concat (stackrec s) -let rec stack_assign s p c = match s with - | Zapp args :: s -> - let q = Array.length args in - if p >= q then - Zapp args :: stack_assign s (p-q) c - else - (let nargs = Array.copy args in - nargs.(p) <- c; - Zapp nargs :: s) - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> s -let rec stack_tail p s = - if Int.equal p 0 then s else - match s with - | Zapp args :: s -> - let q = Array.length args in - if p >= q then stack_tail (p-q) s - else Zapp (Array.sub args p (q-p)) :: s - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> failwith "stack_tail" -let rec stack_nth s p = match s with - | Zapp args :: s -> - let q = Array.length args in - if p >= q then stack_nth s (p-q) - else args.(p) - | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _) :: _ | [] -> raise Not_found - (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index c2d53eed47..46be1bb279 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -123,8 +123,7 @@ type fterm = (*********************************************************************** s A [stack] is a context of arguments, arguments are pushed by - [append_stack] one array at a time but popped with [decomp_stack] - one by one *) + [append_stack] one array at a time *) type stack_member = | Zapp of fconstr array @@ -139,13 +138,7 @@ and stack = stack_member list val empty_stack : stack val append_stack : fconstr array -> stack -> stack -val decomp_stack : stack -> (fconstr * stack) option -val array_of_stack : stack -> fconstr array -val stack_assign : stack -> int -> fconstr -> stack val stack_args_size : stack -> int -val stack_tail : int -> stack -> stack -val stack_nth : stack -> int -> fconstr -val zip_term : (fconstr -> constr) -> constr -> stack -> constr val eta_expand_stack : stack -> stack (** To lazy reduce a constr, create a [clos_infos] with diff --git a/kernel/constr.ml b/kernel/constr.ml index 8e5d15dd2d..d67d15b23b 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -1361,7 +1361,7 @@ type rel_context = rel_declaration list type named_context = named_declaration list type compacted_context = compacted_declaration list -(* Sorts and sort family *) +(** Minimalistic constr printer, typically for debugging *) let debug_print_fix pr_constr ((t,i),(lna,tl,bl)) = let open Pp in @@ -1377,8 +1377,6 @@ let pr_puniverses p u = if Univ.Instance.is_empty u then p else Pp.(p ++ str"(*" ++ Univ.Instance.pr Univ.Level.pr u ++ str"*)") -(* Minimalistic constr printer, typically for debugging *) - let rec debug_print c = let open Pp in match kind c with diff --git a/kernel/dune b/kernel/dune index 4f2e0e4e28..01abdb8f67 100644 --- a/kernel/dune +++ b/kernel/dune @@ -18,3 +18,4 @@ ; warnings. (env (dev (flags :standard -w +a-4-44-50))) + ; (ocaml408 (flags :standard -w +a-3-4-44-50))) diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 2a91c7dab0..52fb39e1d0 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -24,7 +24,7 @@ open Constr is the term into which we should inline. *) type delta_hint = - | Inline of int * (Univ.AUContext.t * constr) option + | Inline of int * constr Univ.univ_abstracted option | Equiv of KerName.t (* NB: earlier constructor Prefix_equiv of ModPath.t @@ -164,7 +164,7 @@ let find_prefix resolve mp = (** Applying a resolver to a kernel name *) -exception Change_equiv_to_inline of (int * (Univ.AUContext.t * constr)) +exception Change_equiv_to_inline of (int * constr Univ.univ_abstracted) let solve_delta_kn resolve kn = try @@ -294,43 +294,34 @@ let subst_ind sub (ind,i as indi) = let subst_pind sub (ind,u) = (subst_ind sub ind, u) -let subst_con0 sub (cst,u) = +let subst_con0 sub cst = let mpu,l = Constant.repr2 cst in let mpc = KerName.modpath (Constant.canonical cst) in let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in let knu = KerName.make mpu l in let knc = if mpu == mpc then knu else KerName.make mpc l in match search_delta_inline resolve knu knc with - | Some (ctx, t) -> + | Some t -> (* In case of inlining, discard the canonical part (cf #2608) *) - let () = assert (Int.equal (Univ.AUContext.size ctx) (Univ.Instance.length u)) in - Constant.make1 knu, Vars.subst_instance_constr u t + Constant.make1 knu, Some t | None -> let knc' = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc in let cst' = Constant.make knu knc' in - cst', mkConstU (cst',u) + cst', None let subst_con sub cst = try subst_con0 sub cst - with No_subst -> fst cst, mkConstU cst + with No_subst -> cst, None -let subst_con_kn sub con = - subst_con sub (con,Univ.Instance.empty) - -let subst_pcon sub (_con,u as pcon) = - try let con', _can = subst_con0 sub pcon in +let subst_pcon sub (con,u as pcon) = + try let con', _can = subst_con0 sub con in con',u with No_subst -> pcon -let subst_pcon_term sub (_con,u as pcon) = - try let con', can = subst_con0 sub pcon in - (con',u), can - with No_subst -> pcon, mkConstU pcon - let subst_constant sub con = - try fst (subst_con0 sub (con,Univ.Instance.empty)) + try fst (subst_con0 sub con) with No_subst -> con let subst_proj_repr sub p = @@ -351,7 +342,7 @@ let subst_evaluable_reference subst = function let rec map_kn f f' c = let func = map_kn f f' in match kind c with - | Const kn -> (try snd (f' kn) with No_subst -> c) + | Const kn -> (try f' kn with No_subst -> c) | Proj (p,t) -> let p' = Projection.map f p in let t' = func t in @@ -420,8 +411,14 @@ let rec map_kn f f' c = | _ -> c let subst_mps sub c = + let subst_pcon_term sub (con,u) = + let con', can = subst_con0 sub con in + match can with + | None -> mkConstU (con',u) + | Some t -> Vars.univ_instantiate_constr u t + in if is_empty_subst sub then c - else map_kn (subst_mind sub) (subst_con0 sub) c + else map_kn (subst_mind sub) (subst_pcon_term sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with @@ -486,7 +483,7 @@ let gen_subst_delta_resolver dom subst resolver = | Equiv kequ -> (try Equiv (subst_kn_delta subst kequ) with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c)) - | Inline (lev,Some (ctx, t)) -> Inline (lev,Some (ctx, subst_mps subst t)) + | Inline (lev,Some t) -> Inline (lev,Some (Univ.map_univ_abstracted (subst_mps subst) t)) | Inline (_,None) -> hint in Deltamap.add_kn kkey' hint' rslv diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 8416094063..ea391b3de7 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -28,7 +28,7 @@ val add_kn_delta_resolver : KerName.t -> KerName.t -> delta_resolver -> delta_resolver val add_inline_delta_resolver : - KerName.t -> (int * (Univ.AUContext.t * constr) option) -> delta_resolver -> delta_resolver + KerName.t -> (int * constr Univ.univ_abstracted option) -> delta_resolver -> delta_resolver val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver @@ -133,17 +133,11 @@ val subst_kn : substitution -> KerName.t -> KerName.t val subst_con : - substitution -> pconstant -> Constant.t * constr + substitution -> Constant.t -> Constant.t * constr Univ.univ_abstracted option val subst_pcon : substitution -> pconstant -> pconstant -val subst_pcon_term : - substitution -> pconstant -> pconstant * constr - -val subst_con_kn : - substitution -> Constant.t -> Constant.t * constr - val subst_constant : substitution -> Constant.t -> Constant.t diff --git a/kernel/modops.ml b/kernel/modops.ml index f43dbd88f9..97ac3cdebb 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -403,7 +403,8 @@ let inline_delta_resolver env inl mp mbid mtb delta = | Def body -> let constr = Mod_subst.force_constr body in let ctx = Declareops.constant_polymorphic_context constant in - add_inline_delta_resolver kn (lev, Some (ctx, constr)) l + let constr = Univ.{univ_abstracted_value=constr; univ_abstracted_binder=ctx} in + add_inline_delta_resolver kn (lev, Some constr) l with Not_found -> error_no_such_label_sub (Constant.label con) (ModPath.to_string (Constant.modpath con)) diff --git a/kernel/names.ml b/kernel/names.ml index b2d6a489a6..9f27212967 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -391,6 +391,8 @@ module KerName = struct let print kn = str (to_string kn) + let debug_print kn = str (debug_to_string kn) + let compare (kn1 : kernel_name) (kn2 : kernel_name) = if kn1 == kn2 then 0 else diff --git a/kernel/names.mli b/kernel/names.mli index 350db871d5..61df3bad0e 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -149,15 +149,15 @@ sig val is_empty : t -> bool (** Test whether a directory path is empty. *) - val to_string : t -> string - (** Print directory paths as ["coq_root.module.submodule"] *) - val initial : t (** Initial "seed" of the unique identifier generator *) val hcons : t -> t (** Hashconsing of directory paths. *) + val to_string : t -> string + (** Print non-empty directory paths as ["coq_root.module.submodule"] *) + val print : t -> Pp.t end @@ -180,15 +180,15 @@ sig val make : string -> t (** Create a label out of a string. *) - val to_string : t -> string - (** Conversion to string. *) - val of_id : Id.t -> t (** Conversion from an identifier. *) val to_id : t -> Id.t (** Conversion to an identifier. *) + val to_string : t -> string + (** Conversion to string. *) + val print : t -> Pp.t (** Pretty-printer. *) @@ -227,10 +227,10 @@ sig (** Return the identifier contained in the argument. *) val to_string : t -> string - (** Conversion to a string. *) + (** Encode as a string (not to be used for user-facing messages). *) val debug_to_string : t -> string - (** Same as [to_string], but outputs information related to debug. *) + (** Same as [to_string], but outputs extra information related to debug. *) end @@ -252,16 +252,17 @@ sig val is_bound : t -> bool - val to_string : t -> string - - val debug_to_string : t -> string - (** Same as [to_string], but outputs information related to debug. *) - val initial : t (** Name of the toplevel structure ([= MPfile initial_dir]) *) val dp : t -> DirPath.t + val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + + val debug_to_string : t -> string + (** Same as [to_string], but outputs extra information related to debug. *) + end module MPset : Set.S with type elt = ModPath.t @@ -284,13 +285,17 @@ sig val modpath : t -> ModPath.t val label : t -> Label.t - (** Display *) val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) val debug_to_string : t -> string - (** Same as [to_string], but outputs information related to debug. *) + (** Same as [to_string], but outputs extra information related to debug. *) - val print : t -> Pp.t + val debug_print : t -> Pp.t + (** Same as [print], but outputs extra information related to debug. *) (** Comparisons *) val compare : t -> t -> int @@ -365,9 +370,16 @@ sig (** Displaying *) val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) + val debug_to_string : t -> string + (** Same as [to_string], but outputs extra information related to debug. *) + val debug_print : t -> Pp.t + (** Same as [print], but outputs extra information related to debug. *) end @@ -444,9 +456,16 @@ sig (** Displaying *) val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) + val debug_to_string : t -> string + (** Same as [to_string], but outputs extra information related to debug. *) + val debug_print : t -> Pp.t + (** Same as [print], but outputs extra information related to debug. *) end @@ -567,8 +586,12 @@ module Projection : sig val map : (MutInd.t -> MutInd.t) -> t -> t val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t - val print : t -> Pp.t val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) + end type t (* = Repr.t * bool *) @@ -609,7 +632,10 @@ module Projection : sig val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) end diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 5fc8d0297f..8187dea41b 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -8,749 +8,80 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Pp -open Util open Univ -(* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *) -(* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *) -(* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *) -(* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) -(* Support for universe polymorphism by MS [2014] *) +module G = AcyclicGraph.Make(struct + type t = Level.t + module Set = LSet + module Map = LMap + module Constraint = Constraint -(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu - Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) + let equal = Level.equal + let compare = Level.compare -let error_inconsistency o u v p = - raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) + type explanation = Univ.explanation + let error_inconsistency d u v p = + raise (UniverseInconsistency (d,Universe.make u, Universe.make v, p)) -(* Universes are stratified by a partial ordering $\le$. - Let $\~{}$ be the associated equivalence. We also have a strict ordering - $<$ between equivalence classes, and we maintain that $<$ is acyclic, - and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$. + let pr = Level.pr + end) [@@inlined] (* without inline, +1% ish on HoTT, compcert. See jenkins 594 vs 596 *) +(* Do not include G to make it easier to control universe specific + code (eg add_universe with a constraint vs G.add with no + constraint) *) - At every moment, we have a finite number of universes, and we - maintain the ordering in the presence of assertions $U<V$ and $U\le V$. - - The equivalence $\~{}$ is represented by a tree structure, as in the - union-find algorithm. The assertions $<$ and $\le$ are represented by - adjacency lists. - - We use the algorithm described in the paper: - - Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A - new approach to incremental cycle detection and related - problems. arXiv preprint arXiv:1112.0784. - - *) - -open Universe - -module UMap = LMap - -type status = NoMark | Visited | WeakVisited | ToMerge - -(* Comparison on this type is pointer equality *) -type canonical_node = - { univ: Level.t; - ltle: bool UMap.t; (* true: strict (lt) constraint. - false: weak (le) constraint. *) - gtge: LSet.t; - rank : int; - klvl: int; - ilvl: int; - mutable status: status - } - -let big_rank = 1000000 - -(* A Level.t is either an alias for another one, or a canonical one, - for which we know the universes that are above *) - -type univ_entry = - Canonical of canonical_node - | Equiv of Level.t - -type universes = - { entries : univ_entry UMap.t; - index : int; - n_nodes : int; n_edges : int } - -type t = universes - -(** Used to cleanup universes if a traversal function is interrupted before it - has the opportunity to do it itself. *) -let unsafe_cleanup_universes g = - let iter _ n = match n with - | Equiv _ -> () - | Canonical n -> n.status <- NoMark - in - UMap.iter iter g.entries - -let rec cleanup_universes g = - try unsafe_cleanup_universes g - with e -> - (** The only way unsafe_cleanup_universes may raise an exception is when - a serious error (stack overflow, out of memory) occurs, or a signal is - sent. In this unlikely event, we relaunch the cleanup until we finally - succeed. *) - cleanup_universes g; raise e - -(* Every Level.t has a unique canonical arc representative *) - -(* Low-level function : makes u an alias for v. - Does not removes edges from n_edges, but decrements n_nodes. - u should be entered as canonical before. *) -let enter_equiv g u v = - { entries = - UMap.modify u (fun _ a -> - match a with - | Canonical n -> - n.status <- NoMark; - Equiv v - | _ -> assert false) g.entries; - index = g.index; - n_nodes = g.n_nodes - 1; - n_edges = g.n_edges } - -(* Low-level function : changes data associated with a canonical node. - Resets the mutable fields in the old record, in order to avoid breaking - invariants for other users of this record. - n.univ should already been inserted as a canonical node. *) -let change_node g n = - { g with entries = - UMap.modify n.univ - (fun _ a -> - match a with - | Canonical n' -> - n'.status <- NoMark; - Canonical n - | _ -> assert false) - g.entries } - -(* repr : universes -> Level.t -> canonical_node *) -(* canonical representative : we follow the Equiv links *) -let rec repr g u = - let a = - try UMap.find u g.entries - with Not_found -> CErrors.anomaly ~label:"Univ.repr" - (str"Universe " ++ Level.pr u ++ str" undefined.") - in - match a with - | Equiv v -> repr g v - | Canonical arc -> arc - -let get_set_arc g = repr g Level.set -let is_set_arc u = Level.is_set u.univ -let is_prop_arc u = Level.is_prop u.univ - -exception AlreadyDeclared - -(* Reindexes the given universe, using the next available index. *) -let use_index g u = - let u = repr g u in - let g = change_node g { u with ilvl = g.index } in - assert (g.index > min_int); - { g with index = g.index - 1 } - -(* [safe_repr] is like [repr] but if the graph doesn't contain the - searched universe, we add it. *) -let safe_repr g u = - let rec safe_repr_rec entries u = - match UMap.find u entries with - | Equiv v -> safe_repr_rec entries v - | Canonical arc -> arc - in - try g, safe_repr_rec g.entries u - with Not_found -> - let can = - { univ = u; - ltle = UMap.empty; gtge = LSet.empty; - rank = if Level.is_small u then big_rank else 0; - klvl = 0; ilvl = 0; - status = NoMark } - in - let g = { g with - entries = UMap.add u (Canonical can) g.entries; - n_nodes = g.n_nodes + 1 } - in - let g = use_index g u in - g, repr g u - -(* Returns 1 if u is higher than v in topological order. - -1 lower - 0 if u = v *) -let topo_compare u v = - if u.klvl > v.klvl then 1 - else if u.klvl < v.klvl then -1 - else if u.ilvl > v.ilvl then 1 - else if u.ilvl < v.ilvl then -1 - else (assert (u==v); 0) - -(* Checks most of the invariants of the graph. For debugging purposes. *) -let check_universes_invariants g = - let n_edges = ref 0 in - let n_nodes = ref 0 in - UMap.iter (fun l u -> - match u with - | Canonical u -> - UMap.iter (fun v _strict -> - incr n_edges; - let v = repr g v in - assert (topo_compare u v = -1); - if u.klvl = v.klvl then - assert (LSet.mem u.univ v.gtge || - LSet.exists (fun l -> u == repr g l) v.gtge)) - u.ltle; - LSet.iter (fun v -> - let v = repr g v in - assert (v.klvl = u.klvl && - (UMap.mem u.univ v.ltle || - UMap.exists (fun l _ -> u == repr g l) v.ltle)) - ) u.gtge; - assert (u.status = NoMark); - assert (Level.equal l u.univ); - assert (u.ilvl > g.index); - assert (not (UMap.mem u.univ u.ltle)); - incr n_nodes - | Equiv _ -> assert (not (Level.is_small l))) - g.entries; - assert (!n_edges = g.n_edges); - assert (!n_nodes = g.n_nodes) - -let clean_ltle g ltle = - UMap.fold (fun u strict acc -> - let uu = (repr g u).univ in - if Level.equal uu u then acc - else ( - let acc = UMap.remove u (fst acc) in - if not strict && UMap.mem uu acc then (acc, true) - else (UMap.add uu strict acc, true))) - ltle (ltle, false) - -let clean_gtge g gtge = - LSet.fold (fun u acc -> - let uu = (repr g u).univ in - if Level.equal uu u then acc - else LSet.add uu (LSet.remove u (fst acc)), true) - gtge (gtge, false) - -(* [get_ltle] and [get_gtge] return ltle and gtge arcs. - Moreover, if one of these lists is dirty (e.g. points to a - non-canonical node), these functions clean this node in the - graph by removing some duplicate edges *) -let get_ltle g u = - let ltle, chgt_ltle = clean_ltle g u.ltle in - if not chgt_ltle then u.ltle, u, g - else - let sz = UMap.cardinal u.ltle in - let sz2 = UMap.cardinal ltle in - let u = { u with ltle } in - let g = change_node g u in - let g = { g with n_edges = g.n_edges + sz2 - sz } in - u.ltle, u, g - -let get_gtge g u = - let gtge, chgt_gtge = clean_gtge g u.gtge in - if not chgt_gtge then u.gtge, u, g - else - let u = { u with gtge } in - let g = change_node g u in - u.gtge, u, g - -(* [revert_graph] rollbacks the changes made to mutable fields in - nodes in the graph. - [to_revert] contains the touched nodes. *) -let revert_graph to_revert g = - List.iter (fun t -> - match UMap.find t g.entries with - | Equiv _ -> () - | Canonical t -> - t.status <- NoMark) to_revert - -exception AbortBackward of universes -exception CycleDetected - -(* Implementation of the algorithm described in § 5.1 of the following paper: - - Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A - new approach to incremental cycle detection and related - problems. arXiv preprint arXiv:1112.0784. - - The "STEP X" comments contained in this file refers to the - corresponding step numbers of the algorithm described in Section - 5.1 of this paper. *) - -(* [delta] is the timeout for backward search. It might be - useful to tune a multiplicative constant. *) -let get_delta g = - int_of_float - (min (float_of_int g.n_edges ** 0.5) - (float_of_int g.n_nodes ** (2./.3.))) - -let rec backward_traverse to_revert b_traversed count g x = - let x = repr g x in - let count = count - 1 in - if count < 0 then begin - revert_graph to_revert g; - raise (AbortBackward g) - end; - if x.status = NoMark then begin - x.status <- Visited; - let to_revert = x.univ::to_revert in - let gtge, x, g = get_gtge g x in - let to_revert, b_traversed, count, g = - LSet.fold (fun y (to_revert, b_traversed, count, g) -> - backward_traverse to_revert b_traversed count g y) - gtge (to_revert, b_traversed, count, g) - in - to_revert, x.univ::b_traversed, count, g - end - else to_revert, b_traversed, count, g - -let rec forward_traverse f_traversed g v_klvl x y = - let y = repr g y in - if y.klvl < v_klvl then begin - let y = { y with klvl = v_klvl; - gtge = if x == y then LSet.empty - else LSet.singleton x.univ } - in - let g = change_node g y in - let ltle, y, g = get_ltle g y in - let f_traversed, g = - UMap.fold (fun z _ (f_traversed, g) -> - forward_traverse f_traversed g v_klvl y z) - ltle (f_traversed, g) - in - y.univ::f_traversed, g - end else if y.klvl = v_klvl && x != y then - let g = change_node g - { y with gtge = LSet.add x.univ y.gtge } in - f_traversed, g - else f_traversed, g - -let rec find_to_merge to_revert g x v = - let x = repr g x in - match x.status with - | Visited -> false, to_revert | ToMerge -> true, to_revert - | NoMark -> - let to_revert = x::to_revert in - if Level.equal x.univ v then - begin x.status <- ToMerge; true, to_revert end - else - begin - let merge, to_revert = LSet.fold - (fun y (merge, to_revert) -> - let merge', to_revert = find_to_merge to_revert g y v in - merge' || merge, to_revert) x.gtge (false, to_revert) - in - x.status <- if merge then ToMerge else Visited; - merge, to_revert - end - | _ -> assert false - -let get_new_edges g to_merge = - (* Computing edge sets. *) - let to_merge_lvl = - List.fold_left (fun acc u -> UMap.add u.univ u acc) - UMap.empty to_merge - in - let ltle = - let fold _ n acc = - let fold u strict acc = - if strict then UMap.add u strict acc - else if UMap.mem u acc then acc - else UMap.add u false acc - in - UMap.fold fold n.ltle acc - in - UMap.fold fold to_merge_lvl UMap.empty - in - let ltle, _ = clean_ltle g ltle in - let ltle = - UMap.merge (fun _ a strict -> - match a, strict with - | Some _, Some true -> - (* There is a lt edge inside the new component. This is a - "bad cycle". *) - raise CycleDetected - | Some _, Some false -> None - | _, _ -> strict - ) to_merge_lvl ltle - in - let gtge = - UMap.fold (fun _ n acc -> LSet.union acc n.gtge) - to_merge_lvl LSet.empty - in - let gtge, _ = clean_gtge g gtge in - let gtge = LSet.diff gtge (UMap.domain to_merge_lvl) in - (ltle, gtge) - - -let reorder g u v = - (* STEP 2: backward search in the k-level of u. *) - let delta = get_delta g in - - (* [v_klvl] is the chosen future level for u, v and all - traversed nodes. *) - let b_traversed, v_klvl, g = - try - let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in - revert_graph to_revert g; - let v_klvl = (repr g u).klvl in - b_traversed, v_klvl, g - with AbortBackward g -> - (* Backward search was too long, use the next k-level. *) - let v_klvl = (repr g u).klvl + 1 in - [], v_klvl, g - in - let f_traversed, g = - (* STEP 3: forward search. Contrary to what is described in - the paper, we do not test whether v_klvl = u.klvl nor we assign - v_klvl to v.klvl. Indeed, the first call to forward_traverse - will do all that. *) - forward_traverse [] g v_klvl (repr g v) v - in - - (* STEP 4: merge nodes if needed. *) - let to_merge, b_reindex, f_reindex = - if (repr g u).klvl = v_klvl then - begin - let merge, to_revert = find_to_merge [] g u v in - let r = - if merge then - List.filter (fun u -> u.status = ToMerge) to_revert, - List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, - List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed - else [], b_traversed, f_traversed - in - List.iter (fun u -> u.status <- NoMark) to_revert; - r - end - else [], b_traversed, f_traversed - in - let to_reindex, g = - match to_merge with - | [] -> List.rev_append f_reindex b_reindex, g - | n0::q0 -> - (* Computing new root. *) - let root, rank_rest = - List.fold_left (fun ((best, _rank_rest) as acc) n -> - if n.rank >= best.rank then n, best.rank else acc) - (n0, min_int) q0 - in - let ltle, gtge = get_new_edges g to_merge in - (* Inserting the new root. *) - let g = change_node g - { root with ltle; gtge; - rank = max root.rank (rank_rest + 1); } - in - - (* Inserting shortcuts for old nodes. *) - let g = List.fold_left (fun g n -> - if Level.equal n.univ root.univ then g else enter_equiv g n.univ root.univ) - g to_merge - in - - (* Updating g.n_edges *) - let oldsz = - List.fold_left (fun sz u -> sz+UMap.cardinal u.ltle) - 0 to_merge - in - let sz = UMap.cardinal ltle in - let g = { g with n_edges = g.n_edges + sz - oldsz } in - - (* Not clear in the paper: we have to put the newly - created component just between B and F. *) - List.rev_append f_reindex (root.univ::b_reindex), g - - in - - (* STEP 5: reindex traversed nodes. *) - List.fold_left use_index g to_reindex - -(* Assumes [u] and [v] are already in the graph. *) -(* Does NOT assume that ucan != vcan. *) -let insert_edge strict ucan vcan g = - try - let u = ucan.univ and v = vcan.univ in - (* STEP 1: do we need to reorder nodes ? *) - let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in - - (* STEP 6: insert the new edge in the graph. *) - let u = repr g u in - let v = repr g v in - if u == v then - if strict then raise CycleDetected else g - else - let g = - try let oldstrict = UMap.find v.univ u.ltle in - if strict && not oldstrict then - change_node g { u with ltle = UMap.add v.univ true u.ltle } - else g - with Not_found -> - { (change_node g { u with ltle = UMap.add v.univ strict u.ltle }) - with n_edges = g.n_edges + 1 } - in - if u.klvl <> v.klvl || LSet.mem u.univ v.gtge then g - else - let v = { v with gtge = LSet.add u.univ v.gtge } in - change_node g v - with - | CycleDetected as e -> raise e - | e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -let add_universe_gen vlev g = - try - let _arcv = UMap.find vlev g.entries in - raise AlreadyDeclared - with Not_found -> - assert (g.index > min_int); - let v = { - univ = vlev; - ltle = LMap.empty; - gtge = LSet.empty; - rank = 0; - klvl = 0; - ilvl = g.index; - status = NoMark; - } - in - let entries = UMap.add vlev (Canonical v) g.entries in - { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges }, v - -let add_universe vlev strict g = - let g, v = add_universe_gen vlev g in - insert_edge strict (get_set_arc g) v g - -let add_universe_unconstrained vlev g = - fst (add_universe_gen vlev g) - -exception UndeclaredLevel of Univ.Level.t -let check_declared_universes g us = - let check l = if not (UMap.mem l g.entries) then raise (UndeclaredLevel l) in - Univ.LSet.iter check us - -exception Found_explanation of explanation - -let get_explanation strict u v g = - let v = repr g v in - let visited_strict = ref UMap.empty in - let rec traverse strict u = - if u == v then - if strict then None else Some [] - else if topo_compare u v = 1 then None - else - let visited = - try not (UMap.find u.univ !visited_strict) || strict - with Not_found -> false - in - if visited then None - else begin - visited_strict := UMap.add u.univ strict !visited_strict; - try - UMap.iter (fun u' strictu' -> - match traverse (strict && not strictu') (repr g u') with - | None -> () - | Some exp -> - let typ = if strictu' then Lt else Le in - raise (Found_explanation ((typ, make u') :: exp))) - u.ltle; - None - with Found_explanation exp -> Some exp - end - in - let u = repr g u in - if u == v then [(Eq, make v.univ)] - else match traverse strict u with Some exp -> exp | None -> assert false - -let get_explanation strict u v g = - Some (lazy (get_explanation strict u v g)) - -(* To compare two nodes, we simply do a forward search. - We implement two improvements: - - we ignore nodes that are higher than the destination; - - we do a BFS rather than a DFS because we expect to have a short - path (typically, the shortest path has length 1) -*) -exception Found of canonical_node list -let search_path strict u v g = - let rec loop to_revert todo next_todo = - match todo, next_todo with - | [], [] -> to_revert (* No path found *) - | [], _ -> loop to_revert next_todo [] - | (u, strict)::todo, _ -> - if u.status = Visited || (u.status = WeakVisited && strict) - then loop to_revert todo next_todo - else - let to_revert = - if u.status = NoMark then u::to_revert else to_revert - in - u.status <- if strict then WeakVisited else Visited; - if try UMap.find v.univ u.ltle || not strict - with Not_found -> false - then raise (Found to_revert) - else - begin - let next_todo = - UMap.fold (fun u strictu next_todo -> - let strict = not strictu && strict in - let u = repr g u in - if u == v && not strict then raise (Found to_revert) - else if topo_compare u v = 1 then next_todo - else (u, strict)::next_todo) - u.ltle next_todo - in - loop to_revert todo next_todo - end - in - if u == v then not strict - else - try - let res, to_revert = - try false, loop [] [u, strict] [] - with Found to_revert -> true, to_revert - in - List.iter (fun u -> u.status <- NoMark) to_revert; - res - with e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -(** Uncomment to debug the cycle detection algorithm. *) -(*let insert_edge strict ucan vcan g = - check_universes_invariants g; - let g = insert_edge strict ucan vcan g in - check_universes_invariants g; - let ucan = repr g ucan.univ in - let vcan = repr g vcan.univ in - assert (search_path strict ucan vcan g); - g*) - -(** First, checks on universe levels *) - -let check_equal g u v = - let arcu = repr g u and arcv = repr g v in - arcu == arcv - -let check_eq_level g u v = u == v || check_equal g u v - -let check_smaller g strict u v = - let arcu = repr g u and arcv = repr g v in - if strict then - search_path true arcu arcv g - else - is_prop_arc arcu - || (is_set_arc arcu && not (is_prop_arc arcv)) - || search_path false arcu arcv g - -(** Then, checks on universes *) - -type 'a check_function = universes -> 'a -> 'a -> bool +type t = G.t +type 'a check_function = 'a G.check_function let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with - | 0 -> check_smaller g false u v - | 1 -> check_smaller g true u v - | x when x < 0 -> check_smaller g false u v + | 0 -> G.check_leq g u v + | 1 -> G.check_lt g u v + | x when x < 0 -> G.check_leq g u v | _ -> false let exists_bigger g ul l = - Universe.exists (fun ul' -> + Universe.exists (fun ul' -> check_smaller_expr g ul ul') l let real_check_leq g u v = Universe.for_all (fun ul -> exists_bigger g ul v) u - + let check_leq g u v = Universe.equal u v || is_type0m_univ u || real_check_leq g u v -let check_eq_univs g l1 l2 = - real_check_leq g l1 l2 && real_check_leq g l2 l1 - let check_eq g u v = - Universe.equal u v || check_eq_univs g u v - -(* enforce_univ_eq g u v will force u=v if possible, will fail otherwise *) - -let rec enforce_univ_eq u v g = - let ucan = repr g u in - let vcan = repr g v in - if topo_compare ucan vcan = 1 then enforce_univ_eq v u g - else - let g = insert_edge false ucan vcan g in (* Cannot fail *) - try insert_edge false vcan ucan g - with CycleDetected -> - error_inconsistency Eq v u (get_explanation true u v g) - -(* enforce_univ_leq g u v will force u<=v if possible, will fail otherwise *) -let enforce_univ_leq u v g = - let ucan = repr g u in - let vcan = repr g v in - try insert_edge false ucan vcan g - with CycleDetected -> - error_inconsistency Le u v (get_explanation true v u g) - -(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *) -let enforce_univ_lt u v g = - let ucan = repr g u in - let vcan = repr g v in - try insert_edge true ucan vcan g - with CycleDetected -> - error_inconsistency Lt u v (get_explanation false v u g) - -let empty_universes = - { entries = UMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + Universe.equal u v || + (real_check_leq g u v && real_check_leq g v u) + +let check_eq_level = G.check_eq + +let empty_universes = G.empty let initial_universes = - let set_arc = Canonical { - univ = Level.set; - ltle = LMap.empty; - gtge = LSet.empty; - rank = big_rank; - klvl = 0; - ilvl = (-1); - status = NoMark; - } in - let prop_arc = Canonical { - univ = Level.prop; - ltle = LMap.empty; - gtge = LSet.empty; - rank = big_rank; - klvl = 0; - ilvl = 0; - status = NoMark; - } in - let entries = UMap.add Level.set set_arc (UMap.singleton Level.prop prop_arc) in - let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in - enforce_univ_lt Level.prop Level.set empty - -let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries - -let enforce_constraint cst g = - match cst with - | (u,Lt,v) -> enforce_univ_lt u v g - | (u,Le,v) -> enforce_univ_leq u v g - | (u,Eq,v) -> enforce_univ_eq u v g - -let merge_constraints c g = - Constraint.fold enforce_constraint c g - -let check_constraint g (l,d,r) = + let big_rank = 1000000 in + let g = G.empty in + let g = G.add ~rank:big_rank Level.prop g in + let g = G.add ~rank:big_rank Level.set g in + G.enforce_lt Level.prop Level.set g + +let enforce_constraint (u,d,v) g = + match d with + | Le -> G.enforce_leq u v g + | Lt -> G.enforce_lt u v g + | Eq -> G.enforce_eq u v g + +let merge_constraints csts g = Constraint.fold enforce_constraint csts g + +let check_constraint g (u,d,v) = match d with - | Eq -> check_equal g l r - | Le -> check_smaller g false l r - | Lt -> check_smaller g true l r + | Le -> G.check_leq g u v + | Lt -> G.check_lt g u v + | Eq -> G.check_eq g u v -let check_constraints c g = - Constraint.for_all (check_constraint g) c +let check_constraints csts g = Constraint.for_all (check_constraint g) csts let leq_expr (u,m) (v,n) = let d = match m - n with @@ -760,6 +91,7 @@ let leq_expr (u,m) (v,n) = (u,d,v) let enforce_leq_alg u v g = + let open Util in let enforce_one (u,v) = function | Inr _ as orig -> orig | Inl (cstrs,g) as orig -> @@ -791,148 +123,19 @@ let enforce_leq_alg u v g = assert (check_leq g u v); cg -(* Normalization *) - -(** [normalize_universes g] returns a graph where all edges point - directly to the canonical representent of their target. The output - graph should be equivalent to the input graph from a logical point - of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges. *) -let normalize_universes g = - let g = - { g with - entries = UMap.map (fun entry -> - match entry with - | Equiv u -> Equiv ((repr g u).univ) - | Canonical ucan -> Canonical { ucan with rank = 1 }) - g.entries } - in - UMap.fold (fun _ u g -> - match u with - | Equiv _u -> g - | Canonical u -> - let _, u, g = get_ltle g u in - let _, _, g = get_gtge g u in - g) - g.entries g - -let constraints_of_universes g = - let module UF = Unionfind.Make (LSet) (LMap) in - let uf = UF.create () in - let constraints_of u v acc = - match v with - | Canonical {univ=u; ltle; _} -> - UMap.fold (fun v strict acc-> - let typ = if strict then Lt else Le in - Constraint.add (u,typ,v) acc) ltle acc - | Equiv v -> UF.union u v uf; acc - in - let csts = UMap.fold constraints_of g.entries Constraint.empty in - csts, UF.partition uf - -(* domain g.entries = kept + removed *) -let constraints_for ~kept g = - (* rmap: partial map from canonical universes to kept universes *) - let rmap, csts = LSet.fold (fun u (rmap,csts) -> - let arcu = repr g u in - if LSet.mem arcu.univ kept then - LMap.add arcu.univ arcu.univ rmap, enforce_eq_level u arcu.univ csts - else - match LMap.find arcu.univ rmap with - | v -> rmap, enforce_eq_level u v csts - | exception Not_found -> LMap.add arcu.univ u rmap, csts) - kept (LMap.empty,Constraint.empty) - in - let rec add_from u csts todo = match todo with - | [] -> csts - | (v,strict)::todo -> - let v = repr g v in - (match LMap.find v.univ rmap with - | v -> - let d = if strict then Lt else Le in - let csts = Constraint.add (u,d,v) csts in - add_from u csts todo - | exception Not_found -> - (* v is not equal to any kept universe *) - let todo = LMap.fold (fun v' strict' todo -> - (v',strict || strict') :: todo) - v.ltle todo - in - add_from u csts todo) - in - LSet.fold (fun u csts -> - let arc = repr g u in - LMap.fold (fun v strict csts -> add_from u csts [v,strict]) - arc.ltle csts) - kept csts - -let domain g = LMap.domain g.entries - -let choose p g u = - let exception Found of Level.t in - let ru = (repr g u).univ in - if p ru then Some ru - else - try LMap.iter (fun v -> function - | Canonical _ -> () (* we already tried [p ru] *) - | Equiv v' -> - let rv = (repr g v').univ in - if rv == ru && p v then raise (Found v) - (* NB: we could also try [p v'] but it will come up in the - rest of the iteration regardless. *) - ) g.entries; None - with Found v -> Some v - -(** [sort_universes g] builds a totally ordered universe graph. The - output graph should imply the input graph (and the implication - will be strict most of the time), but is not necessarily minimal. - Moreover, it adds levels [Type.n] to identify universes at level - n. An artificial constraint Set < Type.2 is added to ensure that - Type.n and small universes are not merged. Note: the result is - unspecified if the input graph already contains [Type.n] nodes - (calling a module Type is probably a bad idea anyway). *) -let sort_universes g = - let cans = - UMap.fold (fun _ u l -> - match u with - | Equiv _ -> l - | Canonical can -> can :: l - ) g.entries [] - in - let cans = List.sort topo_compare cans in - let lowest_levels = - UMap.mapi (fun u _ -> if Level.is_small u then 0 else 2) - (UMap.filter - (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) - g.entries) - in - let lowest_levels = - List.fold_left (fun lowest_levels can -> - let lvl = UMap.find can.univ lowest_levels in - UMap.fold (fun u' strict lowest_levels -> - let cost = if strict then 1 else 0 in - let u' = (repr g u').univ in - UMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest_levels) - can.ltle lowest_levels) - lowest_levels cans - in - let max_lvl = UMap.fold (fun _ a b -> max a b) lowest_levels 0 in - let mp = Names.DirPath.make [Names.Id.of_string "Type"] in - let types = Array.init (max_lvl + 1) (function - | 0 -> Level.prop - | 1 -> Level.set - | n -> Level.make (Level.UGlobal.make mp (n-2))) - in - let g = Array.fold_left (fun g u -> - let g, u = safe_repr g u in - change_node g { u with rank = big_rank }) g types - in - let g = if max_lvl >= 2 then enforce_univ_lt Level.set types.(2) g else g in - let g = - UMap.fold (fun u lvl g -> enforce_univ_eq u (types.(lvl)) g) - lowest_levels g - in - normalize_universes g +exception AlreadyDeclared = G.AlreadyDeclared +let add_universe u strict g = + let g = G.add u g in + let d = if strict then Lt else Le in + enforce_constraint (Level.set,d,u) g + +let add_universe_unconstrained u g = G.add u g + +exception UndeclaredLevel = G.Undeclared +let check_declared_universes = G.check_declared + +let constraints_of_universes = G.constraints_of +let constraints_for = G.constraints_for (** Subtyping of polymorphic contexts *) @@ -957,45 +160,23 @@ let check_eq_instances g t1 t2 = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) -(** Pretty-printing *) - -let pr_umap sep pr map = - let cmp (u,_) (v,_) = Level.compare u v in - Pp.prlist_with_sep sep pr (List.sort cmp (UMap.bindings map)) - -let pr_arc prl = function - | _, Canonical {univ=u; ltle; _} -> - if UMap.is_empty ltle then mt () - else - prl u ++ str " " ++ - v 0 - (pr_umap Pp.spc (fun (v, strict) -> - (if strict then str "< " else str "<= ") ++ prl v) - ltle) ++ - fnl () - | u, Equiv v -> - prl u ++ str " = " ++ prl v ++ fnl () - -let pr_universes prl g = - pr_umap mt (pr_arc prl) g.entries - -(* Dumping constraints to a file *) - -let dump_universes output g = - let dump_arc u = function - | Canonical {univ=u; ltle; _} -> - UMap.iter (fun v strict -> - let typ = if strict then Lt else Le in - output typ u v) ltle; - | Equiv v -> - output Eq u v - in - UMap.iter dump_arc g.entries +let domain = G.domain +let choose = G.choose + +let dump_universes = G.dump + +let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g + +let pr_universes = G.pr + +let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] +let make_dummy i = Level.(make (UGlobal.make dummy_mp i)) +let sort_universes g = G.sort make_dummy [Level.prop;Level.set] g (** Profiling *) -let merge_constraints = - if Flags.profile then +let merge_constraints = + if Flags.profile then let key = CProfile.declare_profile "merge_constraints" in CProfile.profile2 key merge_constraints else merge_constraints @@ -1005,15 +186,14 @@ let check_constraints = CProfile.profile2 key check_constraints else check_constraints -let check_eq = +let check_eq = if Flags.profile then let check_eq_key = CProfile.declare_profile "check_eq" in CProfile.profile3 check_eq_key check_eq else check_eq -let check_leq = - if Flags.profile then +let check_leq = + if Flags.profile then let check_leq_key = CProfile.declare_profile "check_leq" in CProfile.profile3 check_leq_key check_leq else check_leq - diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 4dbfac5c73..e1a5d50425 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -22,9 +22,6 @@ val check_eq_level : Level.t check_function (** The initial graph of universes: Prop < Set *) val initial_universes : t -(** Check if we are in the initial case *) -val is_initial_universes : t -> bool - (** Check equality of instances w.r.t. a universe graph *) val check_eq_instances : Instance.t check_function diff --git a/kernel/univ.ml b/kernel/univ.ml index 7b5ed05bda..8940c0337e 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -533,9 +533,9 @@ open Universe let universe_level = Universe.level -type constraint_type = Lt | Le | Eq +type constraint_type = AcyclicGraph.constraint_type = Lt | Le | Eq -type explanation = (constraint_type * universe) list +type explanation = (constraint_type * Level.t) list let constraint_type_ord c1 c2 = match c1, c2 with | Lt, Lt -> 0 @@ -978,6 +978,15 @@ struct end +type 'a univ_abstracted = { + univ_abstracted_value : 'a; + univ_abstracted_binder : AUContext.t; +} + +let map_univ_abstracted f {univ_abstracted_value;univ_abstracted_binder} = + let univ_abstracted_value = f univ_abstracted_value in + {univ_abstracted_value;univ_abstracted_binder} + let hcons_abstract_universe_context = AUContext.hcons (** Universe info for cumulative inductive types: A context of @@ -1025,6 +1034,8 @@ module ACumulativityInfo = struct type t = AUContext.t * Variance.t array + let repr (auctx,var) = AUContext.repr auctx, var + let pr prl (univs, variance) = AUContext.pr prl ~variance univs @@ -1258,7 +1269,7 @@ let hcons_universe_context_set (v, c) = let hcons_univ x = Universe.hcons x -let explain_universe_inconsistency prl (o,u,v,p) = +let explain_universe_inconsistency prl (o,u,v,p : univ_inconsistency) = let pr_uni = Universe.pr_with prl in let pr_rel = function | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" @@ -1270,9 +1281,9 @@ let explain_universe_inconsistency prl (o,u,v,p) = if p = [] then mt () else str " because" ++ spc() ++ pr_uni v ++ - prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) + prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ prl v) p ++ - (if Universe.equal (snd (List.last p)) u then mt() else + (if Universe.equal (Universe.make (snd (List.last p))) u then mt() else (spc() ++ str "= " ++ pr_uni u)) in str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ diff --git a/kernel/univ.mli b/kernel/univ.mli index 512f38cedd..b83251e983 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -166,7 +166,7 @@ val univ_level_rem : Level.t -> Universe.t -> Universe.t -> Universe.t (** {6 Constraints. } *) -type constraint_type = Lt | Le | Eq +type constraint_type = AcyclicGraph.constraint_type = Lt | Le | Eq type univ_constraint = Level.t * constraint_type * Level.t module Constraint : sig @@ -203,7 +203,7 @@ val enforce_leq_level : Level.t constraint_function system stores the graph and may result from combination of several Constraint.t... *) -type explanation = (constraint_type * Universe.t) list +type explanation = (constraint_type * Level.t) list type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation Lazy.t option exception UniverseInconsistency of univ_inconsistency @@ -360,6 +360,14 @@ sig end +type 'a univ_abstracted = { + univ_abstracted_value : 'a; + univ_abstracted_binder : AUContext.t; +} +(** A value with bound universe levels. *) + +val map_univ_abstracted : ('a -> 'b) -> 'a univ_abstracted -> 'b univ_abstracted + (** Universe info for cumulative inductive types: A context of universe levels with universe constraints, representing local universe variables and constraints, together with an array of @@ -392,6 +400,7 @@ module ACumulativityInfo : sig type t + val repr : t -> CumulativityInfo.t val univ_context : t -> AUContext.t val variance : t -> Variance.t array val leq_constraints : t -> Instance.t constraint_function diff --git a/kernel/vars.ml b/kernel/vars.ml index f9c576ca4a..bd56d60053 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -295,6 +295,11 @@ let subst_instance_constr subst c = in aux c +let univ_instantiate_constr u c = + let open Univ in + assert (Int.equal (Instance.length u) (AUContext.size c.univ_abstracted_binder)); + subst_instance_constr u c.univ_abstracted_value + (* let substkey = CProfile.declare_profile "subst_instance_constr";; *) (* let subst_instance_constr inst c = CProfile.profile2 substkey subst_instance_constr inst c;; *) diff --git a/kernel/vars.mli b/kernel/vars.mli index 7c928e2694..f2c32b3625 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -140,4 +140,7 @@ val subst_univs_level_context : Univ.universe_level_subst -> Constr.rel_context val subst_instance_constr : Instance.t -> constr -> constr val subst_instance_context : Instance.t -> Constr.rel_context -> Constr.rel_context +val univ_instantiate_constr : Instance.t -> constr univ_abstracted -> constr +(** Ignores the constraints carried by [univ_abstracted]. *) + val universes_of_constr : constr -> Univ.LSet.t diff --git a/lib/acyclicGraph.ml b/lib/acyclicGraph.ml new file mode 100644 index 0000000000..7d04c8f5a1 --- /dev/null +++ b/lib/acyclicGraph.ml @@ -0,0 +1,852 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type constraint_type = Lt | Le | Eq + +module type Point = sig + type t + + module Set : CSig.SetS with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + + module Constraint : CSet.S with type elt = (t * constraint_type * t) + + val equal : t -> t -> bool + val compare : t -> t -> int + + type explanation = (constraint_type * t) list + val error_inconsistency : constraint_type -> t -> t -> explanation lazy_t option -> 'a + + val pr : t -> Pp.t +end + +module Make (Point:Point) = struct + + (* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *) + (* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *) + (* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *) + (* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) + (* Support for universe polymorphism by MS [2014] *) + + (* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu + Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) + + (* Points are stratified by a partial ordering $\le$. + Let $\~{}$ be the associated equivalence. We also have a strict ordering + $<$ between equivalence classes, and we maintain that $<$ is acyclic, + and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$. + + At every moment, we have a finite number of points, and we + maintain the ordering in the presence of assertions $U<V$ and $U\le V$. + + The equivalence $\~{}$ is represented by a tree structure, as in the + union-find algorithm. The assertions $<$ and $\le$ are represented by + adjacency lists. + + We use the algorithm described in the paper: + + Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A + new approach to incremental cycle detection and related + problems. arXiv preprint arXiv:1112.0784. + + *) + + module PMap = Point.Map + module PSet = Point.Set + module Constraint = Point.Constraint + + type status = NoMark | Visited | WeakVisited | ToMerge + + (* Comparison on this type is pointer equality *) + type canonical_node = + { canon: Point.t; + ltle: bool PMap.t; (* true: strict (lt) constraint. + false: weak (le) constraint. *) + gtge: PSet.t; + rank : int; + klvl: int; + ilvl: int; + mutable status: status + } + + let big_rank = 1000000 + + (* A Point.t is either an alias for another one, or a canonical one, + for which we know the points that are above *) + + type entry = + | Canonical of canonical_node + | Equiv of Point.t + + type t = + { entries : entry PMap.t; + index : int; + n_nodes : int; n_edges : int } + + (** Used to cleanup mutable marks if a traversal function is + interrupted before it has the opportunity to do it itself. *) + let unsafe_cleanup_marks g = + let iter _ n = match n with + | Equiv _ -> () + | Canonical n -> n.status <- NoMark + in + PMap.iter iter g.entries + + let rec cleanup_marks g = + try unsafe_cleanup_marks g + with e -> + (* The only way unsafe_cleanup_marks may raise an exception is when + a serious error (stack overflow, out of memory) occurs, or a signal is + sent. In this unlikely event, we relaunch the cleanup until we finally + succeed. *) + cleanup_marks g; raise e + + (* Every Point.t has a unique canonical arc representative *) + + (* Low-level function : makes u an alias for v. + Does not removes edges from n_edges, but decrements n_nodes. + u should be entered as canonical before. *) + let enter_equiv g u v = + { entries = + PMap.modify u (fun _ a -> + match a with + | Canonical n -> + n.status <- NoMark; + Equiv v + | _ -> assert false) g.entries; + index = g.index; + n_nodes = g.n_nodes - 1; + n_edges = g.n_edges } + + (* Low-level function : changes data associated with a canonical node. + Resets the mutable fields in the old record, in order to avoid breaking + invariants for other users of this record. + n.canon should already been inserted as a canonical node. *) + let change_node g n = + { g with entries = + PMap.modify n.canon + (fun _ a -> + match a with + | Canonical n' -> + n'.status <- NoMark; + Canonical n + | _ -> assert false) + g.entries } + + (* canonical representative : we follow the Equiv links *) + let rec repr g u = + match PMap.find u g.entries with + | Equiv v -> repr g v + | Canonical arc -> arc + | exception Not_found -> + CErrors.anomaly ~label:"Univ.repr" + Pp.(str"Universe " ++ Point.pr u ++ str" undefined.") + + exception AlreadyDeclared + + (* Reindexes the given point, using the next available index. *) + let use_index g u = + let u = repr g u in + let g = change_node g { u with ilvl = g.index } in + assert (g.index > min_int); + { g with index = g.index - 1 } + + (* [safe_repr] is like [repr] but if the graph doesn't contain the + searched point, we add it. *) + let safe_repr g u = + let rec safe_repr_rec entries u = + match PMap.find u entries with + | Equiv v -> safe_repr_rec entries v + | Canonical arc -> arc + in + try g, safe_repr_rec g.entries u + with Not_found -> + let can = + { canon = u; + ltle = PMap.empty; gtge = PSet.empty; + rank = 0; + klvl = 0; ilvl = 0; + status = NoMark } + in + let g = { g with + entries = PMap.add u (Canonical can) g.entries; + n_nodes = g.n_nodes + 1 } + in + let g = use_index g u in + g, repr g u + + (* Returns 1 if u is higher than v in topological order. + -1 lower + 0 if u = v *) + let topo_compare u v = + if u.klvl > v.klvl then 1 + else if u.klvl < v.klvl then -1 + else if u.ilvl > v.ilvl then 1 + else if u.ilvl < v.ilvl then -1 + else (assert (u==v); 0) + + (* Checks most of the invariants of the graph. For debugging purposes. *) + let check_invariants ~required_canonical g = + let n_edges = ref 0 in + let n_nodes = ref 0 in + PMap.iter (fun l u -> + match u with + | Canonical u -> + PMap.iter (fun v _strict -> + incr n_edges; + let v = repr g v in + assert (topo_compare u v = -1); + if u.klvl = v.klvl then + assert (PSet.mem u.canon v.gtge || + PSet.exists (fun l -> u == repr g l) v.gtge)) + u.ltle; + PSet.iter (fun v -> + let v = repr g v in + assert (v.klvl = u.klvl && + (PMap.mem u.canon v.ltle || + PMap.exists (fun l _ -> u == repr g l) v.ltle)) + ) u.gtge; + assert (u.status = NoMark); + assert (Point.equal l u.canon); + assert (u.ilvl > g.index); + assert (not (PMap.mem u.canon u.ltle)); + incr n_nodes + | Equiv _ -> assert (not (required_canonical l))) + g.entries; + assert (!n_edges = g.n_edges); + assert (!n_nodes = g.n_nodes) + + let clean_ltle g ltle = + PMap.fold (fun u strict acc -> + let uu = (repr g u).canon in + if Point.equal uu u then acc + else ( + let acc = PMap.remove u (fst acc) in + if not strict && PMap.mem uu acc then (acc, true) + else (PMap.add uu strict acc, true))) + ltle (ltle, false) + + let clean_gtge g gtge = + PSet.fold (fun u acc -> + let uu = (repr g u).canon in + if Point.equal uu u then acc + else PSet.add uu (PSet.remove u (fst acc)), true) + gtge (gtge, false) + + (* [get_ltle] and [get_gtge] return ltle and gtge arcs. + Moreover, if one of these lists is dirty (e.g. points to a + non-canonical node), these functions clean this node in the + graph by removing some duplicate edges *) + let get_ltle g u = + let ltle, chgt_ltle = clean_ltle g u.ltle in + if not chgt_ltle then u.ltle, u, g + else + let sz = PMap.cardinal u.ltle in + let sz2 = PMap.cardinal ltle in + let u = { u with ltle } in + let g = change_node g u in + let g = { g with n_edges = g.n_edges + sz2 - sz } in + u.ltle, u, g + + let get_gtge g u = + let gtge, chgt_gtge = clean_gtge g u.gtge in + if not chgt_gtge then u.gtge, u, g + else + let u = { u with gtge } in + let g = change_node g u in + u.gtge, u, g + + (* [revert_graph] rollbacks the changes made to mutable fields in + nodes in the graph. + [to_revert] contains the touched nodes. *) + let revert_graph to_revert g = + List.iter (fun t -> + match PMap.find t g.entries with + | Equiv _ -> () + | Canonical t -> + t.status <- NoMark) to_revert + + exception AbortBackward of t + exception CycleDetected + + (* Implementation of the algorithm described in § 5.1 of the following paper: + + Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A + new approach to incremental cycle detection and related + problems. arXiv preprint arXiv:1112.0784. + + The "STEP X" comments contained in this file refers to the + corresponding step numbers of the algorithm described in Section + 5.1 of this paper. *) + + (* [delta] is the timeout for backward search. It might be + useful to tune a multiplicative constant. *) + let get_delta g = + int_of_float + (min (float_of_int g.n_edges ** 0.5) + (float_of_int g.n_nodes ** (2./.3.))) + + let rec backward_traverse to_revert b_traversed count g x = + let x = repr g x in + let count = count - 1 in + if count < 0 then begin + revert_graph to_revert g; + raise (AbortBackward g) + end; + if x.status = NoMark then begin + x.status <- Visited; + let to_revert = x.canon::to_revert in + let gtge, x, g = get_gtge g x in + let to_revert, b_traversed, count, g = + PSet.fold (fun y (to_revert, b_traversed, count, g) -> + backward_traverse to_revert b_traversed count g y) + gtge (to_revert, b_traversed, count, g) + in + to_revert, x.canon::b_traversed, count, g + end + else to_revert, b_traversed, count, g + + let rec forward_traverse f_traversed g v_klvl x y = + let y = repr g y in + if y.klvl < v_klvl then begin + let y = { y with klvl = v_klvl; + gtge = if x == y then PSet.empty + else PSet.singleton x.canon } + in + let g = change_node g y in + let ltle, y, g = get_ltle g y in + let f_traversed, g = + PMap.fold (fun z _ (f_traversed, g) -> + forward_traverse f_traversed g v_klvl y z) + ltle (f_traversed, g) + in + y.canon::f_traversed, g + end else if y.klvl = v_klvl && x != y then + let g = change_node g + { y with gtge = PSet.add x.canon y.gtge } in + f_traversed, g + else f_traversed, g + + let rec find_to_merge to_revert g x v = + let x = repr g x in + match x.status with + | Visited -> false, to_revert | ToMerge -> true, to_revert + | NoMark -> + let to_revert = x::to_revert in + if Point.equal x.canon v then + begin x.status <- ToMerge; true, to_revert end + else + begin + let merge, to_revert = PSet.fold + (fun y (merge, to_revert) -> + let merge', to_revert = find_to_merge to_revert g y v in + merge' || merge, to_revert) x.gtge (false, to_revert) + in + x.status <- if merge then ToMerge else Visited; + merge, to_revert + end + | _ -> assert false + + let get_new_edges g to_merge = + (* Computing edge sets. *) + let to_merge_lvl = + List.fold_left (fun acc u -> PMap.add u.canon u acc) + PMap.empty to_merge + in + let ltle = + let fold _ n acc = + let fold u strict acc = + if strict then PMap.add u strict acc + else if PMap.mem u acc then acc + else PMap.add u false acc + in + PMap.fold fold n.ltle acc + in + PMap.fold fold to_merge_lvl PMap.empty + in + let ltle, _ = clean_ltle g ltle in + let ltle = + PMap.merge (fun _ a strict -> + match a, strict with + | Some _, Some true -> + (* There is a lt edge inside the new component. This is a + "bad cycle". *) + raise CycleDetected + | Some _, Some false -> None + | _, _ -> strict + ) to_merge_lvl ltle + in + let gtge = + PMap.fold (fun _ n acc -> PSet.union acc n.gtge) + to_merge_lvl PSet.empty + in + let gtge, _ = clean_gtge g gtge in + let gtge = PSet.diff gtge (PMap.domain to_merge_lvl) in + (ltle, gtge) + + + let reorder g u v = + (* STEP 2: backward search in the k-level of u. *) + let delta = get_delta g in + + (* [v_klvl] is the chosen future level for u, v and all + traversed nodes. *) + let b_traversed, v_klvl, g = + try + let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in + revert_graph to_revert g; + let v_klvl = (repr g u).klvl in + b_traversed, v_klvl, g + with AbortBackward g -> + (* Backward search was too long, use the next k-level. *) + let v_klvl = (repr g u).klvl + 1 in + [], v_klvl, g + in + let f_traversed, g = + (* STEP 3: forward search. Contrary to what is described in + the paper, we do not test whether v_klvl = u.klvl nor we assign + v_klvl to v.klvl. Indeed, the first call to forward_traverse + will do all that. *) + forward_traverse [] g v_klvl (repr g v) v + in + + (* STEP 4: merge nodes if needed. *) + let to_merge, b_reindex, f_reindex = + if (repr g u).klvl = v_klvl then + begin + let merge, to_revert = find_to_merge [] g u v in + let r = + if merge then + List.filter (fun u -> u.status = ToMerge) to_revert, + List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, + List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed + else [], b_traversed, f_traversed + in + List.iter (fun u -> u.status <- NoMark) to_revert; + r + end + else [], b_traversed, f_traversed + in + let to_reindex, g = + match to_merge with + | [] -> List.rev_append f_reindex b_reindex, g + | n0::q0 -> + (* Computing new root. *) + let root, rank_rest = + List.fold_left (fun ((best, _rank_rest) as acc) n -> + if n.rank >= best.rank then n, best.rank else acc) + (n0, min_int) q0 + in + let ltle, gtge = get_new_edges g to_merge in + (* Inserting the new root. *) + let g = change_node g + { root with ltle; gtge; + rank = max root.rank (rank_rest + 1); } + in + + (* Inserting shortcuts for old nodes. *) + let g = List.fold_left (fun g n -> + if Point.equal n.canon root.canon then g else enter_equiv g n.canon root.canon) + g to_merge + in + + (* Updating g.n_edges *) + let oldsz = + List.fold_left (fun sz u -> sz+PMap.cardinal u.ltle) + 0 to_merge + in + let sz = PMap.cardinal ltle in + let g = { g with n_edges = g.n_edges + sz - oldsz } in + + (* Not clear in the paper: we have to put the newly + created component just between B and F. *) + List.rev_append f_reindex (root.canon::b_reindex), g + + in + + (* STEP 5: reindex traversed nodes. *) + List.fold_left use_index g to_reindex + + (* Assumes [u] and [v] are already in the graph. *) + (* Does NOT assume that ucan != vcan. *) + let insert_edge strict ucan vcan g = + try + let u = ucan.canon and v = vcan.canon in + (* STEP 1: do we need to reorder nodes ? *) + let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in + + (* STEP 6: insert the new edge in the graph. *) + let u = repr g u in + let v = repr g v in + if u == v then + if strict then raise CycleDetected else g + else + let g = + try let oldstrict = PMap.find v.canon u.ltle in + if strict && not oldstrict then + change_node g { u with ltle = PMap.add v.canon true u.ltle } + else g + with Not_found -> + { (change_node g { u with ltle = PMap.add v.canon strict u.ltle }) + with n_edges = g.n_edges + 1 } + in + if u.klvl <> v.klvl || PSet.mem u.canon v.gtge then g + else + let v = { v with gtge = PSet.add u.canon v.gtge } in + change_node g v + with + | CycleDetected as e -> raise e + | e -> + (* Unlikely event: fatal error or signal *) + let () = cleanup_marks g in + raise e + + let add ?(rank=0) v g = + try + let _arcv = PMap.find v g.entries in + raise AlreadyDeclared + with Not_found -> + assert (g.index > min_int); + let node = { + canon = v; + ltle = PMap.empty; + gtge = PSet.empty; + rank; + klvl = 0; + ilvl = g.index; + status = NoMark; + } + in + let entries = PMap.add v (Canonical node) g.entries in + { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } + + exception Undeclared of Point.t + let check_declared g us = + let check l = if not (PMap.mem l g.entries) then raise (Undeclared l) in + PSet.iter check us + + exception Found_explanation of (constraint_type * Point.t) list + + let get_explanation strict u v g = + let v = repr g v in + let visited_strict = ref PMap.empty in + let rec traverse strict u = + if u == v then + if strict then None else Some [] + else if topo_compare u v = 1 then None + else + let visited = + try not (PMap.find u.canon !visited_strict) || strict + with Not_found -> false + in + if visited then None + else begin + visited_strict := PMap.add u.canon strict !visited_strict; + try + PMap.iter (fun u' strictu' -> + match traverse (strict && not strictu') (repr g u') with + | None -> () + | Some exp -> + let typ = if strictu' then Lt else Le in + raise (Found_explanation ((typ, u') :: exp))) + u.ltle; + None + with Found_explanation exp -> Some exp + end + in + let u = repr g u in + if u == v then [(Eq, v.canon)] + else match traverse strict u with Some exp -> exp | None -> assert false + + let get_explanation strict u v g = + Some (lazy (get_explanation strict u v g)) + + (* To compare two nodes, we simply do a forward search. + We implement two improvements: + - we ignore nodes that are higher than the destination; + - we do a BFS rather than a DFS because we expect to have a short + path (typically, the shortest path has length 1) + *) + exception Found of canonical_node list + let search_path strict u v g = + let rec loop to_revert todo next_todo = + match todo, next_todo with + | [], [] -> to_revert (* No path found *) + | [], _ -> loop to_revert next_todo [] + | (u, strict)::todo, _ -> + if u.status = Visited || (u.status = WeakVisited && strict) + then loop to_revert todo next_todo + else + let to_revert = + if u.status = NoMark then u::to_revert else to_revert + in + u.status <- if strict then WeakVisited else Visited; + if try PMap.find v.canon u.ltle || not strict + with Not_found -> false + then raise (Found to_revert) + else + begin + let next_todo = + PMap.fold (fun u strictu next_todo -> + let strict = not strictu && strict in + let u = repr g u in + if u == v && not strict then raise (Found to_revert) + else if topo_compare u v = 1 then next_todo + else (u, strict)::next_todo) + u.ltle next_todo + in + loop to_revert todo next_todo + end + in + if u == v then not strict + else + try + let res, to_revert = + try false, loop [] [u, strict] [] + with Found to_revert -> true, to_revert + in + List.iter (fun u -> u.status <- NoMark) to_revert; + res + with e -> + (* Unlikely event: fatal error or signal *) + let () = cleanup_marks g in + raise e + + (** Uncomment to debug the cycle detection algorithm. *) + (*let insert_edge strict ucan vcan g = + let check_invariants = check_invariants ~required_canonical:(fun _ -> false) in + check_invariants g; + let g = insert_edge strict ucan vcan g in + check_invariants g; + let ucan = repr g ucan.canon in + let vcan = repr g vcan.canon in + assert (search_path strict ucan vcan g); + g*) + + (** User interface *) + + type 'a check_function = t -> 'a -> 'a -> bool + + let check_eq g u v = + u == v || + let arcu = repr g u and arcv = repr g v in + arcu == arcv + + let check_smaller g strict u v = + search_path strict (repr g u) (repr g v) g + + let check_leq g u v = check_smaller g false u v + let check_lt g u v = check_smaller g true u v + + (* enforce_eq g u v will force u=v if possible, will fail otherwise *) + + let rec enforce_eq u v g = + let ucan = repr g u in + let vcan = repr g v in + if topo_compare ucan vcan = 1 then enforce_eq v u g + else + let g = insert_edge false ucan vcan g in (* Cannot fail *) + try insert_edge false vcan ucan g + with CycleDetected -> + Point.error_inconsistency Eq v u (get_explanation true u v g) + + (* enforce_leq g u v will force u<=v if possible, will fail otherwise *) + let enforce_leq u v g = + let ucan = repr g u in + let vcan = repr g v in + try insert_edge false ucan vcan g + with CycleDetected -> + Point.error_inconsistency Le u v (get_explanation true v u g) + + (* enforce_lt u v will force u<v if possible, will fail otherwise *) + let enforce_lt u v g = + let ucan = repr g u in + let vcan = repr g v in + try insert_edge true ucan vcan g + with CycleDetected -> + Point.error_inconsistency Lt u v (get_explanation false v u g) + + let empty = + { entries = PMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + + (* Normalization *) + + (** [normalize g] returns a graph where all edges point + directly to the canonical representent of their target. The output + graph should be equivalent to the input graph from a logical point + of view, but optimized. We maintain the invariant that the key of + a [Canonical] element is its own name, by keeping [Equiv] edges. *) + let normalize g = + let g = + { g with + entries = PMap.map (fun entry -> + match entry with + | Equiv u -> Equiv ((repr g u).canon) + | Canonical ucan -> Canonical { ucan with rank = 1 }) + g.entries } + in + PMap.fold (fun _ u g -> + match u with + | Equiv _u -> g + | Canonical u -> + let _, u, g = get_ltle g u in + let _, _, g = get_gtge g u in + g) + g.entries g + + let constraints_of g = + let module UF = Unionfind.Make (PSet) (PMap) in + let uf = UF.create () in + let constraints_of u v acc = + match v with + | Canonical {canon=u; ltle; _} -> + PMap.fold (fun v strict acc-> + let typ = if strict then Lt else Le in + Constraint.add (u,typ,v) acc) ltle acc + | Equiv v -> UF.union u v uf; acc + in + let csts = PMap.fold constraints_of g.entries Constraint.empty in + csts, UF.partition uf + + (* domain g.entries = kept + removed *) + let constraints_for ~kept g = + (* rmap: partial map from canonical points to kept points *) + let rmap, csts = PSet.fold (fun u (rmap,csts) -> + let arcu = repr g u in + if PSet.mem arcu.canon kept then + PMap.add arcu.canon arcu.canon rmap, Constraint.add (u,Eq,arcu.canon) csts + else + match PMap.find arcu.canon rmap with + | v -> rmap, Constraint.add (u,Eq,v) csts + | exception Not_found -> PMap.add arcu.canon u rmap, csts) + kept (PMap.empty,Constraint.empty) + in + let rec add_from u csts todo = match todo with + | [] -> csts + | (v,strict)::todo -> + let v = repr g v in + (match PMap.find v.canon rmap with + | v -> + let d = if strict then Lt else Le in + let csts = Constraint.add (u,d,v) csts in + add_from u csts todo + | exception Not_found -> + (* v is not equal to any kept point *) + let todo = PMap.fold (fun v' strict' todo -> + (v',strict || strict') :: todo) + v.ltle todo + in + add_from u csts todo) + in + PSet.fold (fun u csts -> + let arc = repr g u in + PMap.fold (fun v strict csts -> add_from u csts [v,strict]) + arc.ltle csts) + kept csts + + let domain g = PMap.domain g.entries + + let choose p g u = + let exception Found of Point.t in + let ru = (repr g u).canon in + if p ru then Some ru + else + try PMap.iter (fun v -> function + | Canonical _ -> () (* we already tried [p ru] *) + | Equiv v' -> + let rv = (repr g v').canon in + if rv == ru && p v then raise (Found v) + (* NB: we could also try [p v'] but it will come up in the + rest of the iteration regardless. *) + ) g.entries; None + with Found v -> Some v + + let sort make_dummy first g = + let cans = + PMap.fold (fun _ u l -> + match u with + | Equiv _ -> l + | Canonical can -> can :: l + ) g.entries [] + in + let cans = List.sort topo_compare cans in + let lowest = + PMap.mapi (fun u _ -> if CList.mem_f Point.equal u first then 0 else 2) + (PMap.filter + (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) + g.entries) + in + let lowest = + List.fold_left (fun lowest can -> + let lvl = PMap.find can.canon lowest in + PMap.fold (fun u' strict lowest -> + let cost = if strict then 1 else 0 in + let u' = (repr g u').canon in + PMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest) + can.ltle lowest) + lowest cans + in + let max_lvl = PMap.fold (fun _ a b -> max a b) lowest 0 in + let types = Array.init (max_lvl + 1) (fun i -> + match List.nth_opt first i with + | Some u -> u + | None -> make_dummy (i-2)) + in + let g = Array.fold_left (fun g u -> + let g, u = safe_repr g u in + change_node g { u with rank = big_rank }) g types + in + let g = if max_lvl > List.length first && not (CList.is_empty first) then + enforce_lt (CList.last first) types.(List.length first) g + else g + in + let g = + PMap.fold (fun u lvl g -> enforce_eq u (types.(lvl)) g) + lowest g + in + normalize g + + (** Pretty-printing *) + + let pr_pmap sep pr map = + let cmp (u,_) (v,_) = Point.compare u v in + Pp.prlist_with_sep sep pr (List.sort cmp (PMap.bindings map)) + + let pr_arc prl = let open Pp in + function + | _, Canonical {canon=u; ltle; _} -> + if PMap.is_empty ltle then mt () + else + prl u ++ str " " ++ + v 0 + (pr_pmap spc (fun (v, strict) -> + (if strict then str "< " else str "<= ") ++ prl v) + ltle) ++ + fnl () + | u, Equiv v -> + prl u ++ str " = " ++ prl v ++ fnl () + + let pr prl g = + pr_pmap Pp.mt (pr_arc prl) g.entries + + (* Dumping constraints to a file *) + + let dump output g = + let dump_arc u = function + | Canonical {canon=u; ltle; _} -> + PMap.iter (fun v strict -> + let typ = if strict then Lt else Le in + output typ u v) ltle; + | Equiv v -> + output Eq u v + in + PMap.iter dump_arc g.entries + +end diff --git a/lib/acyclicGraph.mli b/lib/acyclicGraph.mli new file mode 100644 index 0000000000..b53a4c018f --- /dev/null +++ b/lib/acyclicGraph.mli @@ -0,0 +1,82 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Graphs representing strict orders *) + +type constraint_type = Lt | Le | Eq + +module type Point = sig + type t + + module Set : CSig.SetS with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set + + module Constraint : CSet.S with type elt = (t * constraint_type * t) + + val equal : t -> t -> bool + val compare : t -> t -> int + + type explanation = (constraint_type * t) list + val error_inconsistency : constraint_type -> t -> t -> explanation lazy_t option -> 'a + + val pr : t -> Pp.t +end + +module Make (Point:Point) : sig + + type t + + val empty : t + + val check_invariants : required_canonical:(Point.t -> bool) -> t -> unit + + exception AlreadyDeclared + val add : ?rank:int -> Point.t -> t -> t + (** All points must be pre-declared through this function before + they can be mentioned in the others. NB: use a large [rank] to + keep the node canonical *) + + exception Undeclared of Point.t + val check_declared : t -> Point.Set.t -> unit + (** @raise Undeclared if one of the points is not present in the graph. *) + + type 'a check_function = t -> 'a -> 'a -> bool + + val check_eq : Point.t check_function + val check_leq : Point.t check_function + val check_lt : Point.t check_function + + val enforce_eq : Point.t -> Point.t -> t -> t + val enforce_leq : Point.t -> Point.t -> t -> t + val enforce_lt : Point.t -> Point.t -> t -> t + + val constraints_of : t -> Point.Constraint.t * Point.Set.t list + + val constraints_for : kept:Point.Set.t -> t -> Point.Constraint.t + + val domain : t -> Point.Set.t + + val choose : (Point.t -> bool) -> t -> Point.t -> Point.t option + + val sort : (int -> Point.t) -> Point.t list -> t -> t + (** [sort mk first g] builds a totally ordered graph. The output + graph should imply the input graph (and the implication will be + strict most of the time), but is not necessarily minimal. The + lowest points in the result are identified with [first]. + Moreover, it adds levels [Type.n] to identify the points (not in + [first]) at level n. An artificial constraint (last first < mk + (length first)) is added to ensure that they are not merged. + Note: the result is unspecified if the input graph already + contains [mk n] nodes. *) + + val pr : (Point.t -> Pp.t) -> t -> Pp.t + + val dump : (constraint_type -> Point.t -> Point.t -> unit) -> t -> unit +end diff --git a/lib/control.ml b/lib/control.ml index 3fbeb168c4..e09068740d 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -62,8 +62,8 @@ let windows_timeout n f x e = let res = f x in let () = killed := true in let cur = Unix.gettimeofday () in - (** The thread did not interrupt, but the computation took longer than - expected. *) + (* The thread did not interrupt, but the computation took longer than + expected. *) let () = if float_of_int n <= cur -. init then begin exited := true; raise Sys.Break @@ -71,7 +71,7 @@ let windows_timeout n f x e = res with | Sys.Break -> - (** Just in case, it could be a regular Ctrl+C *) + (* Just in case, it could be a regular Ctrl+C *) if not !exited then begin killed := true; raise Sys.Break end else raise e | e -> diff --git a/lib/lib.mllib b/lib/lib.mllib index 206b2504db..2db59712b9 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -11,6 +11,7 @@ Feedback CErrors CWarnings +AcyclicGraph Rtree System Explore diff --git a/lib/system.ml b/lib/system.ml index a9db95318f..fd6579dd69 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -287,20 +287,20 @@ let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) = real (round (sstop -. sstart)) ++ str "s" ++ str ")" -let with_time ~batch f x = +let with_time ~batch ~header f x = let tstart = get_time() in let msg = if batch then "" else "Finished transaction in " in try let y = f x in let tend = get_time() in let msg2 = if batch then "" else " (successful)" in - Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_info (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); y with e -> let tend = get_time() in let msg = if batch then "" else "Finished failing transaction in " in let msg2 = if batch then "" else " (failure)" in - Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_info (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); raise e (* We use argv.[0] as we don't want to resolve symlinks *) diff --git a/lib/system.mli b/lib/system.mli index f13fd30923..6dd1eb5a84 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -102,9 +102,10 @@ type time val get_time : unit -> time val time_difference : time -> time -> float (** in seconds *) + val fmt_time_difference : time -> time -> Pp.t -val with_time : batch:bool -> ('a -> 'b) -> 'a -> 'b +val with_time : batch:bool -> header:Pp.t -> ('a -> 'b) -> 'a -> 'b (** [get_toplevel_path program] builds a complete path to the executable denoted by [program]. This involves: diff --git a/lib/util.ml b/lib/util.ml index 38d73d3453..0389336258 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -20,6 +20,12 @@ let on_pi1 f (a,b,c) = (f a,b,c) let on_pi2 f (a,b,c) = (a,f b,c) let on_pi3 f (a,b,c) = (a,b,f c) +(* Comparing pairs *) + +let pair_compare cmpx cmpy (x1,y1 as p1) (x2,y2 as p2) = + if p1 == p2 then 0 else + let c = cmpx x1 x2 in if c == 0 then cmpy y1 y2 else c + (* Projections from triplets *) let pi1 (a,_,_) = a diff --git a/lib/util.mli b/lib/util.mli index 1eb60f509a..fa3b622621 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -17,6 +17,10 @@ val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b val map_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b +(** Comparing pairs *) + +val pair_compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a * 'b -> 'a * 'b -> int) + (** Mapping under triple *) val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd diff --git a/library/coqlib.mli b/library/coqlib.mli index 351a0a7e84..f6779dbbde 100644 --- a/library/coqlib.mli +++ b/library/coqlib.mli @@ -190,12 +190,18 @@ val build_bool_type : coq_bool_data delayed val build_prod : coq_sigma_data delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] -val build_coq_eq : GlobRef.t delayed (** = [(build_coq_eq_data()).eq] *) +val build_coq_eq : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] -val build_coq_eq_refl : GlobRef.t delayed (** = [(build_coq_eq_data()).refl] *) +(** = [(build_coq_eq_data()).eq] *) + +val build_coq_eq_refl : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] -val build_coq_eq_sym : GlobRef.t delayed (** = [(build_coq_eq_data()).sym] *) +(** = [(build_coq_eq_data()).refl] *) + +val build_coq_eq_sym : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] +(** = [(build_coq_eq_data()).sym] *) + val build_coq_f_equal2 : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] @@ -222,8 +228,8 @@ val build_coq_inversion_eq_true_data : coq_inversion_data delayed val build_coq_sumbool : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] -(** {6 ... } *) -(** Connectives +(** {6 ... } + Connectives The False proposition *) val build_coq_False : GlobRef.t delayed [@@ocaml.deprecated "Please use Coqlib.lib_ref"] diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml index c1a673edf0..171d51800e 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -57,7 +57,6 @@ type assumption_object_kind = Definitional | Logical | Conjectural *) type assumption_kind = locality * polymorphic * assumption_object_kind - type definition_kind = locality * polymorphic * definition_object_kind (** Kinds used in proofs *) diff --git a/library/declaremods.ml b/library/declaremods.ml index d20775a0d7..8699583cdf 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -845,7 +845,7 @@ end (** {6 Module operations handling summary freeze/unfreeze} *) let protect_summaries f = - let fs = Summary.freeze_summaries ~marshallable:`No in + let fs = Summary.freeze_summaries ~marshallable:false in try f fs with reraise -> (* Something wrong: undo the whole process *) diff --git a/library/decls.mli b/library/decls.mli index 401884736e..c0db537427 100644 --- a/library/decls.mli +++ b/library/decls.mli @@ -19,7 +19,7 @@ open Decl_kinds (** Registration and access to the table of variable *) type variable_data = - DirPath.t * bool (** opacity *) * Univ.ContextSet.t * polymorphic * logical_kind + DirPath.t * bool (* opacity *) * Univ.ContextSet.t * polymorphic * logical_kind val add_variable_data : variable -> variable_data -> unit val variable_path : variable -> DirPath.t diff --git a/library/global.ml b/library/global.ml index 67b00cf411..84d2a37170 100644 --- a/library/global.ml +++ b/library/global.ml @@ -36,10 +36,9 @@ let is_joined_environment () = let global_env_summary_tag = Summary.declare_summary_tag global_env_summary_name - { Summary.freeze_function = (function - | `Yes -> join_safe_environment (); !global_env - | `No -> !global_env - | `Shallow -> !global_env); + { Summary.freeze_function = (fun ~marshallable -> if marshallable then + (join_safe_environment (); !global_env) + else !global_env); unfreeze_function = (fun fr -> global_env := fr); init_function = (fun () -> global_env := Safe_typing.empty_environment) } diff --git a/library/globnames.ml b/library/globnames.ml index 9aca7788d2..db2e8bfaed 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -31,8 +31,8 @@ let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destCon let subst_constructor subst (ind,j as ref) = let ind' = subst_ind subst ind in - if ind==ind' then ref, mkConstruct ref - else (ind',j), mkConstruct (ind',j) + if ind==ind' then ref + else (ind',j) let subst_global_reference subst ref = match ref with | VarRef var -> ref @@ -43,20 +43,20 @@ let subst_global_reference subst ref = match ref with let ind' = subst_ind subst ind in if ind==ind' then ref else IndRef ind' | ConstructRef ((kn,i),j as c) -> - let c',t = subst_constructor subst c in - if c'==c then ref else ConstructRef c' + let c' = subst_constructor subst c in + if c'==c then ref else ConstructRef c' let subst_global subst ref = match ref with - | VarRef var -> ref, mkVar var + | VarRef var -> ref, None | ConstRef kn -> - let kn',t = subst_con_kn subst kn in - if kn==kn' then ref, mkConst kn else ConstRef kn', t + let kn',t = subst_con subst kn in + if kn==kn' then ref, None else ConstRef kn', t | IndRef ind -> let ind' = subst_ind subst ind in - if ind==ind' then ref, mkInd ind else IndRef ind', mkInd ind' + if ind==ind' then ref, None else IndRef ind', None | ConstructRef ((kn,i),j as c) -> - let c',t = subst_constructor subst c in - if c'==c then ref,t else ConstructRef c', t + let c' = subst_constructor subst c in + if c'==c then ref,None else ConstructRef c', None let canonical_gr = function | ConstRef con -> ConstRef(Constant.make1 (Constant.canonical con)) diff --git a/library/globnames.mli b/library/globnames.mli index a96a42ced2..d49ed453f5 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -36,8 +36,8 @@ val destConstructRef : GlobRef.t -> constructor val is_global : GlobRef.t -> constr -> bool -val subst_constructor : substitution -> constructor -> constructor * constr -val subst_global : substitution -> GlobRef.t -> GlobRef.t * constr +val subst_constructor : substitution -> constructor -> constructor +val subst_global : substitution -> GlobRef.t -> GlobRef.t * constr Univ.univ_abstracted option val subst_global_reference : substitution -> GlobRef.t -> GlobRef.t (** This constr is not safe to be typechecked, universe polymorphism is not diff --git a/library/goptions.ml b/library/goptions.ml index 98efb512ab..1b907fd966 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -235,7 +235,7 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) let default = read() in let change = let _ = Summary.declare_summary (nickname key) - { Summary.freeze_function = (fun _ -> read ()); + { Summary.freeze_function = (fun ~marshallable -> read ()); Summary.unfreeze_function = write; Summary.init_function = (fun () -> write default) } in let cache_options (_,(l,m,v)) = @@ -246,14 +246,14 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) | OptGlobal -> cache_options o | OptExport -> () | OptLocal | OptDefault -> - (** Ruled out by classify_function *) + (* Ruled out by classify_function *) assert false in let open_options i (_, (l, _, _) as o) = match l with | OptExport -> if Int.equal i 1 then cache_options o | OptGlobal -> () | OptLocal | OptDefault -> - (** Ruled out by classify_function *) + (* Ruled out by classify_function *) assert false in let subst_options (subst,obj) = obj in diff --git a/library/keys.ml b/library/keys.ml index 53447a679a..58883ccc88 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -100,18 +100,13 @@ let discharge_keys (_,(k,k')) = | Some x, Some y -> Some (x, y) | _ -> None -let rebuild_keys (ref,ref') = (ref, ref') - type key_obj = key * key let inKeys : key_obj -> obj = - declare_object {(default_object "KEYS") with - cache_function = cache_keys; - load_function = load_keys; - subst_function = subst_keys; - classify_function = (fun x -> Substitute x); - discharge_function = discharge_keys; - rebuild_function = rebuild_keys } + declare_object @@ superglobal_object "KEYS" + ~cache:cache_keys + ~subst:(Some subst_keys) + ~discharge:discharge_keys let declare_equiv_keys ref ref' = Lib.add_anonymous_leaf (inKeys (ref,ref')) diff --git a/library/lib.ml b/library/lib.ml index 9c13cdafdb..d4381a6923 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -481,8 +481,8 @@ 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. *) + (* 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 @@ -491,8 +491,8 @@ let name_instance inst = 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. *) + (* 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) @@ -571,7 +571,7 @@ let open_section id = let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in if Nametab.exists_section obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); - let fs = Summary.freeze_summaries ~marshallable:`No in + let fs = Summary.freeze_summaries ~marshallable:false in add_entry (make_foname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirOpenSection prefix)); @@ -608,24 +608,21 @@ let close_section () = type frozen = lib_state -let freeze ~marshallable = - match marshallable with - | `Shallow -> - (* TASSI: we should do something more sensible here *) - let lib_stk = - CList.map_filter (function +let freeze ~marshallable = !lib_state + +let unfreeze st = lib_state := st + +let drop_objects st = + let lib_stk = + CList.map_filter (function | _, Leaf _ -> None | n, (CompilingLibrary _ as x) -> Some (n,x) | n, OpenedModule (it,e,op,_) -> - Some(n,OpenedModule(it,e,op,Summary.empty_frozen)) + Some(n,OpenedModule(it,e,op,Summary.empty_frozen)) | n, OpenedSection (op, _) -> - Some(n,OpenedSection(op,Summary.empty_frozen))) - !lib_state.lib_stk in - { !lib_state with lib_stk } - | _ -> - !lib_state - -let unfreeze st = lib_state := st + Some(n,OpenedSection(op,Summary.empty_frozen))) + st.lib_stk in + { st with lib_stk } let init () = unfreeze initial_lib_state; diff --git a/library/lib.mli b/library/lib.mli index d1b4977dd5..30569197bc 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -148,9 +148,12 @@ val close_section : unit -> unit type frozen -val freeze : marshallable:Summary.marshallable -> frozen +val freeze : marshallable:bool -> frozen val unfreeze : frozen -> unit +(** Keep only the libobject structure, not the objects themselves *) +val drop_objects : frozen -> frozen + val init : unit -> unit (** {6 Section management for discharge } *) diff --git a/library/libnames.mli b/library/libnames.mli index 9960603cbb..bbb4d2a058 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -94,8 +94,8 @@ val qualid_basename : qualid -> Id.t val default_library : DirPath.t (** This is the root of the standard library of Coq *) -val coq_root : module_ident (** "Coq" *) -val coq_string : string (** "Coq" *) +val coq_root : module_ident (* "Coq" *) +val coq_string : string (* "Coq" *) (** This is the default root prefix for developments which doesn't mention a root *) diff --git a/library/libobject.ml b/library/libobject.ml index c153e9a09a..3d17b4a605 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -129,3 +129,46 @@ let rebuild_object lobj = apply_dyn_fun (fun d -> d.dyn_rebuild_function lobj) lobj let dump = Dyn.dump + +let local_object_nodischarge s ~cache = + { (default_object s) with + cache_function = cache; + classify_function = (fun _ -> Dispose); + } + +let local_object s ~cache ~discharge = + { (local_object_nodischarge s ~cache) with + discharge_function = discharge } + +let global_object_nodischarge s ~cache ~subst = + let import i o = if Int.equal i 1 then cache o in + { (default_object s) with + cache_function = cache; + open_function = import; + subst_function = (match subst with + | None -> fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!") + | Some subst -> subst; + ); + classify_function = + if Option.has_some subst then (fun o -> Substitute o) else (fun o -> Keep o); + } + +let global_object s ~cache ~subst ~discharge = + { (global_object_nodischarge s ~cache ~subst) with + discharge_function = discharge } + +let superglobal_object_nodischarge s ~cache ~subst = + { (default_object s) with + load_function = (fun _ x -> cache x); + cache_function = cache; + subst_function = (match subst with + | None -> fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!") + | Some subst -> subst; + ); + classify_function = + if Option.has_some subst then (fun o -> Substitute o) else (fun o -> Keep o); + } + +let superglobal_object s ~cache ~subst ~discharge = + { (superglobal_object_nodischarge s ~cache ~subst) with + discharge_function = discharge } diff --git a/library/libobject.mli b/library/libobject.mli index 32ffc5b79e..00515bd273 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -119,6 +119,51 @@ val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option val rebuild_object : obj -> obj +(** Higher-level API for objects with fixed scope. + +- Local means that the object cannot be imported from outside. +- Global means that it can be imported (by importing the module that contains the +object). +- Superglobal means that the object survives to closing a module, and is imported +when the file which contains it is Required (even without Import). +- With the nodischarge variants, the object does not survive section closing. + With the normal variants, it does. + +We recommend to avoid declaring superglobal objects and using the nodischarge +variants. +*) + +val local_object : string -> + cache:(object_name * 'a -> unit) -> + discharge:(object_name * 'a -> 'a option) -> + 'a object_declaration + +val local_object_nodischarge : string -> + cache:(object_name * 'a -> unit) -> + 'a object_declaration + +val global_object : string -> + cache:(object_name * 'a -> unit) -> + subst:(Mod_subst.substitution * 'a -> 'a) option -> + discharge:(object_name * 'a -> 'a option) -> + 'a object_declaration + +val global_object_nodischarge : string -> + cache:(object_name * 'a -> unit) -> + subst:(Mod_subst.substitution * 'a -> 'a) option -> + 'a object_declaration + +val superglobal_object : string -> + cache:(object_name * 'a -> unit) -> + subst:(Mod_subst.substitution * 'a -> 'a) option -> + discharge:(object_name * 'a -> 'a option) -> + 'a object_declaration + +val superglobal_object_nodischarge : string -> + cache:(object_name * 'a -> unit) -> + subst:(Mod_subst.substitution * 'a -> 'a) option -> + 'a object_declaration + (** {6 Debug} *) val dump : unit -> (int * string) list diff --git a/library/library.mli b/library/library.mli index d298a371b5..c016352808 100644 --- a/library/library.mli +++ b/library/library.mli @@ -19,8 +19,8 @@ open Libnames written at various dates. *) -(** {6 ... } *) -(** Require = load in the environment + open (if the optional boolean +(** {6 ... } + Require = load in the environment + open (if the optional boolean is not [None]); mark also for export if the boolean is [Some true] *) val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> unit diff --git a/library/nametab.ml b/library/nametab.ml index f0f643d9b5..95890b2edf 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -107,6 +107,7 @@ module type NAMETREE = sig val user_name : qualid -> t -> user_name val shortest_qualid : ?loc:Loc.t -> Id.Set.t -> user_name -> t -> qualid val find_prefixes : qualid -> t -> elt list + (** Matches a prefix of [qualid], useful for completion *) val match_prefixes : qualid -> t -> elt list end diff --git a/library/nametab.mli b/library/nametab.mli index b7926cf515..fccb8fd918 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -171,7 +171,9 @@ val exists_cci : full_path -> bool val exists_modtype : full_path -> bool val exists_dir : DirPath.t -> bool val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) + val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) + val exists_universe : full_path -> bool (** {6 These functions locate qualids into full user names } *) diff --git a/library/states.ml b/library/states.ml index ae45b18b9c..92bdc410a3 100644 --- a/library/states.ml +++ b/library/states.ml @@ -13,8 +13,10 @@ open System type state = Lib.frozen * Summary.frozen +let lib_of_state = fst let summary_of_state = snd -let replace_summary (lib,_) s = lib, s +let replace_summary (lib,_) st = lib, st +let replace_lib (_,st) lib = lib, st let freeze ~marshallable = (Lib.freeze ~marshallable, Summary.freeze_summaries ~marshallable) @@ -24,7 +26,7 @@ let unfreeze (fl,fs) = Summary.unfreeze_summaries fs let extern_state s = - System.extern_state Coq_config.state_magic_number s (freeze ~marshallable:`Yes) + System.extern_state Coq_config.state_magic_number s (freeze ~marshallable:true) let intern_state s = unfreeze (with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); @@ -33,7 +35,7 @@ let intern_state s = (* Rollback. *) let with_state_protection f x = - let st = freeze ~marshallable:`No in + let st = freeze ~marshallable:false in try let a = f x in unfreeze st; a with reraise -> diff --git a/library/states.mli b/library/states.mli index 1e0361ea4f..52feb95222 100644 --- a/library/states.mli +++ b/library/states.mli @@ -19,11 +19,13 @@ val intern_state : string -> unit val extern_state : string -> unit type state -val freeze : marshallable:Summary.marshallable -> state +val freeze : marshallable:bool -> state val unfreeze : state -> unit val summary_of_state : state -> Summary.frozen +val lib_of_state : state -> Lib.frozen val replace_summary : state -> Summary.frozen -> state +val replace_lib : state -> Lib.frozen -> state (** {6 Rollback } *) diff --git a/library/summary.ml b/library/summary.ml index 9b22945919..8fbca44353 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -14,10 +14,8 @@ open Util module Dyn = Dyn.Make () -type marshallable = [ `Yes | `No | `Shallow ] - type 'a summary_declaration = { - freeze_function : marshallable -> 'a; + freeze_function : marshallable:bool -> 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } @@ -31,7 +29,7 @@ let ml_modules = "ML-MODULES" let internal_declare_summary fadd sumname sdecl = let infun, outfun, tag = Dyn.Easy.make_dyn_tag (mangle sumname) in - let dyn_freeze b = infun (sdecl.freeze_function b) + let dyn_freeze ~marshallable = infun (sdecl.freeze_function ~marshallable) and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) and dyn_init = sdecl.init_function in let ddecl = { @@ -70,9 +68,9 @@ type frozen = { let empty_frozen = { summaries = String.Map.empty; ml_module = None } let freeze_summaries ~marshallable : frozen = - let smap decl = decl.freeze_function marshallable in + let smap decl = decl.freeze_function ~marshallable in { summaries = String.Map.map smap !sum_map; - ml_module = Option.map (fun decl -> decl.freeze_function marshallable) !sum_mod; + ml_module = Option.map (fun decl -> decl.freeze_function ~marshallable) !sum_mod; } let warn_summary_out_of_scope = @@ -92,7 +90,7 @@ let unfreeze_summaries ?(partial=false) { summaries; ml_module } = | None -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".") | Some decl -> Option.iter (fun state -> decl.unfreeze_function state) ml_module end; - (** We must be independent on the order of the map! *) + (* We must be independent on the order of the map! *) let ufz name decl = try decl.unfreeze_function String.Map.(find name summaries) with Not_found -> @@ -130,10 +128,10 @@ let remove_from_summary st tag = (** All-in-one reference declaration + registration *) -let ref_tag ?(freeze=fun _ r -> r) ~name x = +let ref_tag ?(freeze=fun ~marshallable r -> r) ~name x = let r = ref x in let tag = declare_summary_tag name - { freeze_function = (fun b -> freeze b !r); + { freeze_function = (fun ~marshallable -> freeze ~marshallable !r); unfreeze_function = ((:=) r); init_function = (fun () -> r := x) } in r, tag @@ -157,7 +155,7 @@ let (!) r = let ref ?(freeze=fun x -> x) ~name init = let r = Pervasives.ref (CEphemeron.create init, name) in declare_summary name - { freeze_function = (fun _ -> freeze !r); + { freeze_function = (fun ~marshallable -> freeze !r); unfreeze_function = ((:=) r); init_function = (fun () -> r := init) }; r diff --git a/library/summary.mli b/library/summary.mli index 7d91a79188..0d77d725ac 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -11,17 +11,12 @@ (** This module registers the declaration of global tables, which will be kept in synchronization during the various backtracks of the system. *) -type marshallable = - [ `Yes (* Full data will be marshalled to disk *) - | `No (* Full data will be store in memory, e.g. for Undo *) - | `Shallow ] (* Only part of the data will be marshalled to a slave process *) - (** Types of global Coq states. The ['a] type should be pure and marshallable by the standard OCaml marshalling function. *) type 'a summary_declaration = { - (** freeze_function [true] is for marshalling to disk. + freeze_function : marshallable:bool -> 'a; + (** freeze_function [true] is for marshalling to disk. * e.g. lazy must be forced *) - freeze_function : marshallable -> 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } @@ -50,8 +45,8 @@ val declare_summary_tag : string -> 'a summary_declaration -> 'a Dyn.tag The [init_function] restores the reference to its initial value. The [freeze_function] can be overridden *) -val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref -val ref_tag : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref * 'a Dyn.tag +val ref : ?freeze:(marshallable:bool -> 'a -> 'a) -> name:string -> 'a -> 'a ref +val ref_tag : ?freeze:(marshallable:bool -> 'a -> 'a) -> name:string -> 'a -> 'a ref * 'a Dyn.tag (* As [ref] but the value is local to a process, i.e. not sent to, say, proof * workers. It is useful to implement a local cache for example. *) @@ -81,7 +76,7 @@ val nop : unit -> unit type frozen val empty_frozen : frozen -val freeze_summaries : marshallable:marshallable -> frozen +val freeze_summaries : marshallable:bool -> frozen val unfreeze_summaries : ?partial:bool -> frozen -> unit val init_summaries : unit -> unit diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index c2b7fa117d..49d6cf01d9 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -548,20 +548,27 @@ let process_sequence loc bp c cs = aux 1 cs (* Must be a special token *) -let process_chars loc bp c cs = +let process_chars ~diff_mode loc bp c cs = let t = progress_from_byte loc None (-1) !token_tree cs c in let ep = Stream.count cs in match t with | Some t -> (KEYWORD t, set_loc_pos loc bp ep) | None -> let ep' = bp + utf8_char_size loc cs c in - njunk (ep' - ep) cs; - let loc = set_loc_pos loc bp ep' in - err loc Undefined_token + if diff_mode then begin + let len = ep' - bp in + ignore (store 0 c); + ignore (nstore (len - 1) 1 cs); + IDENT (get_buff len), set_loc_pos loc bp ep + end else begin + njunk (ep' - ep) cs; + let loc = set_loc_pos loc bp ep' in + err loc Undefined_token + end (* Parse what follows a dot *) -let parse_after_dot loc c bp s = match Stream.peek s with +let parse_after_dot ~diff_mode loc c bp s = match Stream.peek s with | Some ('a'..'z' | 'A'..'Z' | '_' as d) -> Stream.junk s; let len = @@ -576,11 +583,11 @@ let parse_after_dot loc c bp s = match Stream.peek s with let len = ident_tail loc (nstore n 0 s) s in let field = get_buff len in (try find_keyword loc ("."^field) s with Not_found -> FIELD field) - | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars loc bp c s) + | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars ~diff_mode loc bp c s) (* Parse what follows a question mark *) -let parse_after_qmark loc bp s = +let parse_after_qmark ~diff_mode loc bp s = match Stream.peek s with | Some ('a'..'z' | 'A'..'Z' | '_') -> LEFTQMARK | None -> KEYWORD "?" @@ -588,7 +595,7 @@ let parse_after_qmark loc bp s = match lookup_utf8 loc s with | Utf8Token (st, _) when Unicode.is_valid_ident_initial st -> LEFTQMARK | AsciiChar | Utf8Token _ | EmptyStream -> - fst (process_chars loc bp '?' s) + fst (process_chars ~diff_mode loc bp '?' s) let blank_or_eof cs = match Stream.peek cs with @@ -598,20 +605,20 @@ let blank_or_eof cs = (* Parse a token in a char stream *) -let rec next_token loc s = +let rec next_token ~diff_mode loc s = let bp = Stream.count s in match Stream.peek s with | Some ('\n' as c) -> Stream.junk s; let ep = Stream.count s in - comm_loc bp; push_char c; next_token (bump_loc_line loc ep) s + comm_loc bp; push_char c; next_token ~diff_mode (bump_loc_line loc ep) s | Some (' ' | '\t' | '\r' as c) -> Stream.junk s; - comm_loc bp; push_char c; next_token loc s + comm_loc bp; push_char c; next_token ~diff_mode loc s | Some ('.' as c) -> Stream.junk s; let t = - try parse_after_dot loc c bp s with + try parse_after_dot ~diff_mode loc c bp s with Stream.Failure -> raise (Stream.Error "") in let ep = Stream.count s in @@ -630,13 +637,13 @@ let rec next_token loc s = Stream.junk s; let t,new_between_commands = if !between_commands then process_sequence loc bp c s, true - else process_chars loc bp c s,false + else process_chars ~diff_mode loc bp c s,false in comment_stop bp; between_commands := new_between_commands; t | Some '?' -> Stream.junk s; let ep = Stream.count s in - let t = parse_after_qmark loc bp s in + let t = parse_after_qmark ~diff_mode loc bp s in comment_stop bp; (t, set_loc_pos loc bp ep) | Some ('a'..'z' | 'A'..'Z' | '_' as c) -> Stream.junk s; @@ -670,12 +677,16 @@ let rec next_token loc s = Stream.junk s; begin try match Stream.peek s with + | Some '*' when diff_mode -> + Stream.junk s; + let ep = Stream.count s in + (IDENT "(*", set_loc_pos loc bp ep) | Some '*' -> Stream.junk s; comm_loc bp; push_string "(*"; - let loc = comment loc bp s in next_token loc s - | _ -> let t = process_chars loc bp c s in comment_stop bp; t + let loc = comment loc bp s in next_token ~diff_mode loc s + | _ -> let t = process_chars ~diff_mode loc bp c s in comment_stop bp; t with Stream.Failure -> raise (Stream.Error "") end | Some ('{' | '}' as c) -> @@ -683,7 +694,7 @@ let rec next_token loc s = let ep = Stream.count s in let t,new_between_commands = if !between_commands then (KEYWORD (String.make 1 c), set_loc_pos loc bp ep), true - else process_chars loc bp c s, false + else process_chars ~diff_mode loc bp c s, false in comment_stop bp; between_commands := new_between_commands; t | _ -> @@ -695,14 +706,14 @@ let rec next_token loc s = comment_stop bp; (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep | AsciiChar | Utf8Token _ -> - let t = process_chars loc bp (Stream.next s) s in + let t = process_chars ~diff_mode loc bp (Stream.next s) s in comment_stop bp; t | EmptyStream -> comment_stop bp; (EOI, set_loc_pos loc bp (bp+1)) (* (* Debug: uncomment this for tracing tokens seen by coq...*) -let next_token loc s = - let (t,loc as r) = next_token loc s in +let next_token ~diff_mode loc s = + let (t,loc as r) = next_token ~diff_mode loc s in Printf.eprintf "(line %i, %i-%i)[%s]\n%!" (Ploc.line_nb loc) (Ploc.first_pos loc) (Ploc.last_pos loc) (Tok.to_string t); r *) @@ -743,7 +754,7 @@ let token_text = function | (con, "") -> con | (con, prm) -> con ^ " \"" ^ prm ^ "\"" -let func cs = +let func next_token cs = let loct = loct_create () in let cur_loc = ref (Loc.create !current_file 1 0 0 0) in let ts = @@ -755,8 +766,8 @@ let func cs = in (ts, loct_func loct) -let lexer = { - Plexing.tok_func = func; +let make_lexer ~diff_mode = { + Plexing.tok_func = func (next_token ~diff_mode); Plexing.tok_using = (fun pat -> match Tok.of_pattern pat with | KEYWORD s -> add_keyword s @@ -765,6 +776,8 @@ let lexer = { Plexing.tok_match = Tok.match_pattern; Plexing.tok_text = token_text } +let lexer = make_lexer ~diff_mode:false + (** Terminal symbols interpretation *) let is_ident_not_keyword s = diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index c0ebdd45ef..af3fd7f318 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -56,3 +56,14 @@ val set_lexer_state : lexer_state -> unit val get_lexer_state : unit -> lexer_state val drop_lexer_state : unit -> unit val get_comment_state : lexer_state -> ((int * int) * string) list + +(** Create a lexer. true enables alternate handling for computing diffs. +It ensures that, ignoring white space, the concatenated tokens equal the input +string. Specifically: +- for strings, return the enclosing quotes as tokens and treat the quoted value +as if it was unquoted, possibly becoming multiple tokens +- for comments, return the "(*" as a token and treat the contents of the comment as if +it was not in a comment, possibly becoming multiple tokens +- return any unrecognized Ascii or UTF-8 character as a string +*) +val make_lexer : diff_mode:bool -> Tok.t Gramlib.Plexing.lexer diff --git a/parsing/extend.ml b/parsing/extend.ml index 050ed49622..9b5537d7f6 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -106,11 +106,11 @@ type 'a production_rule = type 'a single_extend_statement = string option * - (** Level *) + (* Level *) Gramlib.Gramext.g_assoc option * - (** Associativity *) + (* Associativity *) 'a production_rule list - (** Symbol list with the interpretation function *) + (* Symbol list with the interpretation function *) type 'a extend_statement = Gramlib.Gramext.position option * diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 923147ba2e..19ae97da77 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -553,7 +553,7 @@ type frozen_t = (grammar_entry * GramState.t) list * CLexer.keyword_state -let freeze _ : frozen_t = +let freeze ~marshallable : frozen_t = (!grammar_stack, CLexer.get_keyword_state ()) (* We compare the current state of the grammar and the state to unfreeze, @@ -586,7 +586,7 @@ let parser_summary_tag = Summary.init_function = Summary.nop } let with_grammar_rule_protection f x = - let fs = freeze false in + let fs = freeze ~marshallable:false in try let a = f x in unfreeze fs; a with reraise -> let reraise = CErrors.push reraise in diff --git a/parsing/tok.ml b/parsing/tok.ml index 91b4f25ba3..03825e350f 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -36,12 +36,25 @@ let equal t1 t2 = match t1, t2 with | EOI, EOI -> true | _ -> false -let extract_string = function +let extract_string diff_mode = function | KEYWORD s -> s | IDENT s -> s - | STRING s -> s + | STRING s -> + if diff_mode then + let escape_quotes s = + let len = String.length s in + let buf = Buffer.create len in + for i = 0 to len-1 do + let ch = String.get s i in + Buffer.add_char buf ch; + if ch = '"' then Buffer.add_char buf '"' else () + done; + Buffer.contents buf + in + "\"" ^ (escape_quotes s) ^ "\"" + else s | PATTERNIDENT s -> s - | FIELD s -> s + | FIELD s -> if diff_mode then "." ^ s else s | INT s -> s | LEFTQMARK -> "?" | BULLET s -> s diff --git a/parsing/tok.mli b/parsing/tok.mli index 9b8c008555..5750096a28 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -22,11 +22,13 @@ type t = | EOI val equal : t -> t -> bool -val extract_string : t -> string +(* pass true for diff_mode *) +val extract_string : bool -> t -> string val to_string : t -> string (* Needed to fit Camlp5 signature *) val print : Format.formatter -> t -> unit val match_keyword : string -> t -> bool + (** for camlp5 *) val of_pattern : string*string -> t val to_pattern : t -> string*string diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 07f50f6cd5..4d817625f5 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -164,11 +164,12 @@ module Btauto = struct let reify env t = lapp eval [|convert_env env; convert t|] - let print_counterexample p env gl = + let print_counterexample p penv gl = let var = lapp witness [|p|] in let var = EConstr.of_constr var in (* Compute an assignment that dissatisfies the goal *) - let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in + let redfun, _ = Redexpr.reduction_of_red_expr (Refiner.pf_env gl) Genredexpr.(CbvVm None) in + let _, var = redfun Refiner.(pf_env gl) Refiner.(project gl) var in let var = EConstr.Unsafe.to_constr var in let rec to_list l = match decomp_term (Tacmach.project gl) l with | App (c, _) @@ -192,7 +193,7 @@ module Btauto = struct let msg = try let var = to_list var in - let assign = List.combine env var in + let assign = List.combine penv var in let map_msg (key, v) = let b = if v then str "true" else str "false" in let sigma, env = Pfedit.get_current_context () in diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 480819ebe1..6f9384941b 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -27,12 +27,12 @@ let start_deriving f suchthat lemma = let sigma = Evd.from_env env in let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in - (** create a sort variable for the type of [f] *) + (* create a sort variable for the type of [f] *) (* spiwack: I don't know what the rigidity flag does, picked the one that looked the most general. *) let (sigma,f_type_sort) = Evd.new_sort_variable Evd.univ_flexible_alg sigma in let f_type_type = EConstr.mkSort f_type_sort in - (** create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *) + (* create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *) let goals = let open Proofview in TCons ( env , sigma , f_type_type , (fun sigma f_type -> @@ -45,14 +45,14 @@ let start_deriving f suchthat lemma = TNil sigma)))))) in - (** The terminator handles the registering of constants when the proof is closed. *) + (* The terminator handles the registering of constants when the proof is closed. *) let terminator com = let open Proof_global in - (** Extracts the relevant information from the proof. [Admitted] - and [Save] result in user errors. [opaque] is [true] if the - proof was concluded by [Qed], and [false] if [Defined]. [f_def] - and [lemma_def] correspond to the proof of [f] and of - [suchthat], respectively. *) + (* Extracts the relevant information from the proof. [Admitted] + and [Save] result in user errors. [opaque] is [true] if the + proof was concluded by [Qed], and [false] if [Defined]. [f_def] + and [lemma_def] correspond to the proof of [f] and of + [suchthat], respectively. *) let (opaque,f_def,lemma_def) = match com with | Admitted _ -> CErrors.user_err Pp.(str "Admitted isn't supported in Derive.") @@ -64,26 +64,26 @@ let start_deriving f suchthat lemma = opaque <> Proof_global.Transparent , f_def , lemma_def | _ -> assert false in - (** The opacity of [f_def] is adjusted to be [false], as it - must. Then [f] is declared in the global environment. *) + (* The opacity of [f_def] is adjusted to be [false], as it + must. Then [f] is declared in the global environment. *) let f_def = { f_def with Entries.const_entry_opaque = false } in let f_def = Entries.DefinitionEntry f_def , Decl_kinds.(IsDefinition Definition) in let f_kn = Declare.declare_constant f f_def in let f_kn_term = mkConst f_kn in - (** In the type and body of the proof of [suchthat] there can be - references to the variable [f]. It needs to be replaced by - references to the constant [f] declared above. This substitution - performs this precise action. *) + (* In the type and body of the proof of [suchthat] there can be + references to the variable [f]. It needs to be replaced by + references to the constant [f] declared above. This substitution + performs this precise action. *) let substf c = Vars.replace_vars [f,f_kn_term] c in - (** Extracts the type of the proof of [suchthat]. *) + (* Extracts the type of the proof of [suchthat]. *) let lemma_pretype = match Entries.(lemma_def.const_entry_type) with | Some t -> t | None -> assert false (* Proof_global always sets type here. *) in - (** The references of [f] are subsituted appropriately. *) + (* The references of [f] are subsituted appropriately. *) let lemma_type = substf lemma_pretype in - (** The same is done in the body of the proof. *) + (* The same is done in the body of the proof. *) let lemma_body = map_const_entry_body substf Entries.(lemma_def.const_entry_body) in @@ -105,7 +105,3 @@ let start_deriving f suchthat lemma = Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p end in () - - - - diff --git a/plugins/extraction/ExtrHaskellString.v b/plugins/extraction/ExtrHaskellString.v index a4a40d3c5a..8c61f4e96b 100644 --- a/plugins/extraction/ExtrHaskellString.v +++ b/plugins/extraction/ExtrHaskellString.v @@ -6,6 +6,7 @@ Require Coq.extraction.Extraction. Require Import Ascii. Require Import String. +Require Import Coq.Strings.Byte. (** * At the moment, Coq's extraction has no way to add extra import @@ -40,3 +41,22 @@ Extract Inlined Constant Ascii.eqb => "(Prelude.==)". Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. Extract Inlined Constant String.string_dec => "(Prelude.==)". Extract Inlined Constant String.eqb => "(Prelude.==)". + +(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) +Extract Inductive byte => "Prelude.Char" +["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. + +Extract Inlined Constant Byte.eqb => "(Prelude.==)". +Extract Inlined Constant Byte.byte_eq_dec => "(Prelude.==)". +Extract Inlined Constant Ascii.ascii_of_byte => "(\x -> x)". +Extract Inlined Constant Ascii.byte_of_ascii => "(\x -> x)". + +(* +Require Import ExtrHaskellBasic. +Definition test := "ceci est un test"%string. +Definition test2 := List.map (option_map Byte.to_nat) (List.map Byte.of_nat (List.seq 0 256)). +Definition test3 := List.map ascii_of_nat (List.seq 0 256). + +Extraction Language Haskell. +Recursive Extraction test Ascii.zero Ascii.one test2 test3 byte_rect. +*) diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index a2a6a8fe67..f094d4860e 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -12,7 +12,7 @@ Require Coq.extraction.Extraction. -Require Import Ascii String. +Require Import Ascii String Coq.Strings.Byte. Extract Inductive ascii => char [ @@ -37,7 +37,19 @@ Extract Inlined Constant Ascii.eqb => "(=)". Extract Inductive string => "char list" [ "[]" "(::)" ]. +(* python -c 'print(" ".join(r""" "%s" """.strip() % (r"'"'\''"'" if chr(i) == "'"'"'" else repr(""" "" """.strip()) if chr(i) == """ " """.strip() else repr(chr(i))) for i in range(256)))' # " to satisfy Coq's comment parser *) +Extract Inductive byte => char +["'\x00'" "'\x01'" "'\x02'" "'\x03'" "'\x04'" "'\x05'" "'\x06'" "'\x07'" "'\x08'" "'\t'" "'\n'" "'\x0b'" "'\x0c'" "'\r'" "'\x0e'" "'\x0f'" "'\x10'" "'\x11'" "'\x12'" "'\x13'" "'\x14'" "'\x15'" "'\x16'" "'\x17'" "'\x18'" "'\x19'" "'\x1a'" "'\x1b'" "'\x1c'" "'\x1d'" "'\x1e'" "'\x1f'" "' '" "'!'" "'""'" "'#'" "'$'" "'%'" "'&'" "'\''" "'('" "')'" "'*'" "'+'" "','" "'-'" "'.'" "'/'" "'0'" "'1'" "'2'" "'3'" "'4'" "'5'" "'6'" "'7'" "'8'" "'9'" "':'" "';'" "'<'" "'='" "'>'" "'?'" "'@'" "'A'" "'B'" "'C'" "'D'" "'E'" "'F'" "'G'" "'H'" "'I'" "'J'" "'K'" "'L'" "'M'" "'N'" "'O'" "'P'" "'Q'" "'R'" "'S'" "'T'" "'U'" "'V'" "'W'" "'X'" "'Y'" "'Z'" "'['" "'\\'" "']'" "'^'" "'_'" "'`'" "'a'" "'b'" "'c'" "'d'" "'e'" "'f'" "'g'" "'h'" "'i'" "'j'" "'k'" "'l'" "'m'" "'n'" "'o'" "'p'" "'q'" "'r'" "'s'" "'t'" "'u'" "'v'" "'w'" "'x'" "'y'" "'z'" "'{'" "'|'" "'}'" "'~'" "'\x7f'" "'\x80'" "'\x81'" "'\x82'" "'\x83'" "'\x84'" "'\x85'" "'\x86'" "'\x87'" "'\x88'" "'\x89'" "'\x8a'" "'\x8b'" "'\x8c'" "'\x8d'" "'\x8e'" "'\x8f'" "'\x90'" "'\x91'" "'\x92'" "'\x93'" "'\x94'" "'\x95'" "'\x96'" "'\x97'" "'\x98'" "'\x99'" "'\x9a'" "'\x9b'" "'\x9c'" "'\x9d'" "'\x9e'" "'\x9f'" "'\xa0'" "'\xa1'" "'\xa2'" "'\xa3'" "'\xa4'" "'\xa5'" "'\xa6'" "'\xa7'" "'\xa8'" "'\xa9'" "'\xaa'" "'\xab'" "'\xac'" "'\xad'" "'\xae'" "'\xaf'" "'\xb0'" "'\xb1'" "'\xb2'" "'\xb3'" "'\xb4'" "'\xb5'" "'\xb6'" "'\xb7'" "'\xb8'" "'\xb9'" "'\xba'" "'\xbb'" "'\xbc'" "'\xbd'" "'\xbe'" "'\xbf'" "'\xc0'" "'\xc1'" "'\xc2'" "'\xc3'" "'\xc4'" "'\xc5'" "'\xc6'" "'\xc7'" "'\xc8'" "'\xc9'" "'\xca'" "'\xcb'" "'\xcc'" "'\xcd'" "'\xce'" "'\xcf'" "'\xd0'" "'\xd1'" "'\xd2'" "'\xd3'" "'\xd4'" "'\xd5'" "'\xd6'" "'\xd7'" "'\xd8'" "'\xd9'" "'\xda'" "'\xdb'" "'\xdc'" "'\xdd'" "'\xde'" "'\xdf'" "'\xe0'" "'\xe1'" "'\xe2'" "'\xe3'" "'\xe4'" "'\xe5'" "'\xe6'" "'\xe7'" "'\xe8'" "'\xe9'" "'\xea'" "'\xeb'" "'\xec'" "'\xed'" "'\xee'" "'\xef'" "'\xf0'" "'\xf1'" "'\xf2'" "'\xf3'" "'\xf4'" "'\xf5'" "'\xf6'" "'\xf7'" "'\xf8'" "'\xf9'" "'\xfa'" "'\xfb'" "'\xfc'" "'\xfd'" "'\xfe'" "'\xff'"]. + +Extract Inlined Constant Byte.eqb => "(=)". +Extract Inlined Constant Byte.byte_eq_dec => "(=)". +Extract Inlined Constant Ascii.ascii_of_byte => "(fun x -> x)". +Extract Inlined Constant Ascii.byte_of_ascii => "(fun x -> x)". + (* Definition test := "ceci est un test"%string. -Recursive Extraction test Ascii.zero Ascii.one. +Definition test2 := List.map (option_map Byte.to_nat) (List.map Byte.of_nat (List.seq 0 256)). +Definition test3 := List.map ascii_of_nat (List.seq 0 256). + +Recursive Extraction test Ascii.zero Ascii.one test2 test3 byte_rect. *) diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml index 9c0f373c6a..c675eacc92 100644 --- a/plugins/extraction/big.ml +++ b/plugins/extraction/big.ml @@ -20,8 +20,10 @@ type big_int = Big_int.big_int let zero = zero_big_int (** The big integer [0]. *) + let one = unit_big_int (** The big integer [1]. *) + let two = big_int_of_int 2 (** The big integer [2]. *) @@ -29,28 +31,39 @@ let two = big_int_of_int 2 let opp = minus_big_int (** Unary negation. *) + let abs = abs_big_int (** Absolute value. *) + let add = add_big_int (** Addition. *) + let succ = succ_big_int (** Successor (add 1). *) + let add_int = add_int_big_int (** Addition of a small integer to a big integer. *) + let sub = sub_big_int (** Subtraction. *) + let pred = pred_big_int (** Predecessor (subtract 1). *) + let mult = mult_big_int (** Multiplication of two big integers. *) + let mult_int = mult_int_big_int (** Multiplication of a big integer by a small integer *) + let square = square_big_int (** Return the square of the given big integer *) + let sqrt = sqrt_big_int (** [sqrt_big_int a] returns the integer square root of [a], that is, the largest big integer [r] such that [r * r <= a]. Raise [Invalid_argument] if [a] is negative. *) + let quomod = quomod_big_int (** Euclidean division of two big integers. The first part of the result is the quotient, @@ -58,14 +71,18 @@ let quomod = quomod_big_int Writing [(q,r) = quomod_big_int a b], we have [a = q * b + r] and [0 <= r < |b|]. Raise [Division_by_zero] if the divisor is zero. *) + let div = div_big_int (** Euclidean quotient of two big integers. This is the first result [q] of [quomod_big_int] (see above). *) + let modulo = mod_big_int (** Euclidean modulus of two big integers. This is the second result [r] of [quomod_big_int] (see above). *) + let gcd = gcd_big_int (** Greatest common divisor of two big integers. *) + let power = power_big_int_positive_big_int (** Exponentiation functions. Return the big integer representing the first argument [a] raised to the power [b] @@ -78,18 +95,22 @@ let power = power_big_int_positive_big_int let sign = sign_big_int (** Return [0] if the given big integer is zero, [1] if it is positive, and [-1] if it is negative. *) + let compare = compare_big_int (** [compare_big_int a b] returns [0] if [a] and [b] are equal, [1] if [a] is greater than [b], and [-1] if [a] is smaller than [b]. *) + let eq = eq_big_int let le = le_big_int let ge = ge_big_int let lt = lt_big_int let gt = gt_big_int (** Usual boolean comparisons between two big integers. *) + let max = max_big_int (** Return the greater of its two arguments. *) + let min = min_big_int (** Return the smaller of its two arguments. *) @@ -98,6 +119,7 @@ let min = min_big_int let to_string = string_of_big_int (** Return the string representation of the given big integer, in decimal (base 10). *) + let of_string = big_int_of_string (** Convert a string to a big integer, in decimal. The string consists of an optional [-] or [+] sign, @@ -107,6 +129,7 @@ let of_string = big_int_of_string let of_int = big_int_of_int (** Convert a small integer to a big integer. *) + let is_int = is_int_big_int (** Test whether the given big integer is small enough to be representable as a small integer (type [int]) @@ -115,6 +138,7 @@ let is_int = is_int_big_int [a] is between 2{^30} and 2{^30}-1. On a 64-bit platform, [is_int_big_int a] returns [true] if and only if [a] is between -2{^62} and 2{^62}-1. *) + let to_int = int_of_big_int (** Convert a big integer to a small integer (type [int]). Raises [Failure "int_of_big_int"] if the big integer diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index bdeb6fca60..59c57cc544 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -125,7 +125,7 @@ module KOrd = struct type t = kind * string let compare (k1, s1) (k2, s2) = - let c = Pervasives.compare k1 k2 (** OK *) in + let c = Pervasives.compare k1 k2 (* OK *) in if c = 0 then String.compare s1 s2 else c end diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 16890ea260..2058837b8e 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -621,10 +621,9 @@ let lang_ref = Summary.ref Ocaml ~name:"ExtrLang" let lang () = !lang_ref let extr_lang : lang -> obj = - declare_object - {(default_object "Extraction Lang") with - cache_function = (fun (_,l) -> lang_ref := l); - load_function = (fun _ (_,l) -> lang_ref := l)} + declare_object @@ superglobal_object_nodischarge "Extraction Lang" + ~cache:(fun (_,l) -> lang_ref := l) + ~subst:None let extraction_language x = Lib.add_anonymous_leaf (extr_lang x) @@ -648,15 +647,10 @@ let add_inline_entries b l = (* Registration of operations for rollback. *) let inline_extraction : bool * GlobRef.t list -> obj = - declare_object - {(default_object "Extraction Inline") with - cache_function = (fun (_,(b,l)) -> add_inline_entries b l); - load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); - classify_function = (fun o -> Substitute o); - discharge_function = (fun (_,x) -> Some x); - subst_function = - (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) - } + declare_object @@ superglobal_object "Extraction Inline" + ~cache:(fun (_,(b,l)) -> add_inline_entries b l) + ~subst:(Some (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))) + ~discharge:(fun (_,x) -> Some x) (* Grammar entries. *) @@ -685,10 +679,9 @@ let print_extraction_inline () = (* Reset part *) let reset_inline : unit -> obj = - declare_object - {(default_object "Reset Extraction Inline") with - cache_function = (fun (_,_)-> inline_table := empty_inline_table); - load_function = (fun _ (_,_)-> inline_table := empty_inline_table)} + declare_object @@ superglobal_object_nodischarge "Reset Extraction Inline" + ~cache:(fun (_,_)-> inline_table := empty_inline_table) + ~subst:None let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) @@ -731,13 +724,9 @@ let add_implicits r l = (* Registration of operations for rollback. *) let implicit_extraction : GlobRef.t * int_or_id list -> obj = - declare_object - {(default_object "Extraction Implicit") with - cache_function = (fun (_,(r,l)) -> add_implicits r l); - load_function = (fun _ (_,(r,l)) -> add_implicits r l); - classify_function = (fun o -> Substitute o); - subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l)) - } + declare_object @@ superglobal_object_nodischarge "Extraction Implicit" + ~cache:(fun (_,(r,l)) -> add_implicits r l) + ~subst:(Some (fun (s,(r,l)) -> (fst (subst_global s r), l))) (* Grammar entries. *) @@ -784,12 +773,9 @@ let add_blacklist_entries l = (* Registration of operations for rollback. *) let blacklist_extraction : string list -> obj = - declare_object - {(default_object "Extraction Blacklist") with - cache_function = (fun (_,l) -> add_blacklist_entries l); - load_function = (fun _ (_,l) -> add_blacklist_entries l); - subst_function = (fun (_,x) -> x) - } + declare_object @@ superglobal_object_nodischarge "Extraction Blacklist" + ~cache:(fun (_,l) -> add_blacklist_entries l) + ~subst:None (* Grammar entries. *) @@ -805,10 +791,9 @@ let print_extraction_blacklist () = (* Reset part *) let reset_blacklist : unit -> obj = - declare_object - {(default_object "Reset Extraction Blacklist") with - cache_function = (fun (_,_)-> blacklist_table := Id.Set.empty); - load_function = (fun _ (_,_)-> blacklist_table := Id.Set.empty)} + declare_object @@ superglobal_object_nodischarge "Reset Extraction Blacklist" + ~cache:(fun (_,_)-> blacklist_table := Id.Set.empty) + ~subst:None let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ()) @@ -852,23 +837,14 @@ let find_custom_match pv = (* Registration of operations for rollback. *) let in_customs : GlobRef.t * string list * string -> obj = - declare_object - {(default_object "ML extractions") with - cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); - load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s); - classify_function = (fun o -> Substitute o); - subst_function = - (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) - } + declare_object @@ superglobal_object_nodischarge "ML extractions" + ~cache:(fun (_,(r,ids,s)) -> add_custom r ids s) + ~subst:(Some (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str))) let in_custom_matchs : GlobRef.t * string -> obj = - declare_object - {(default_object "ML extractions custom matchs") with - cache_function = (fun (_,(r,s)) -> add_custom_match r s); - load_function = (fun _ (_,(r,s)) -> add_custom_match r s); - classify_function = (fun o -> Substitute o); - subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s)) - } + declare_object @@ superglobal_object_nodischarge "ML extractions custom matchs" + ~cache:(fun (_,(r,s)) -> add_custom_match r s) + ~subst:(Some (fun (subs,(r,s)) -> (fst (subst_global subs r), s))) (* Grammar entries. *) diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 37fc81ee38..ea86a4b514 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -132,7 +132,7 @@ let normalize_evaluables= open Ppconstr open Printer let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_qualid -let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (pr_or_var (fun x -> pr_global (snd x))) +let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (Pputils.pr_or_var (fun x -> pr_global (snd x))) let pr_firstorder_using_typed _ _ _ = Pptactic.pr_auto_using pr_global let warn_deprecated_syntax = diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 4cdfc6fac5..12b68e208c 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -41,7 +41,7 @@ let pop t = Vars.lift (-1) t *) let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let princ_type = EConstr.of_constr princ_type in - let princ_type_info = compute_elim_sig Evd.empty princ_type (** FIXME *) in + let princ_type_info = compute_elim_sig Evd.empty princ_type (* FIXME *) in let env = Global.env () in let env_with_params = EConstr.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 98aaa081c3..4b6caea70d 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1494,7 +1494,7 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive ~template:None None rel_inds false false false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds false false false ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with | UserError(s,msg) as e -> diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 19f954c10d..f9938c0356 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -237,7 +237,6 @@ let cache_Function (_,finfos) = from_graph := Indmap.add finfos.graph_ind finfos !from_graph -let load_Function _ = cache_Function let subst_Function (subst,finfos) = let do_subst_con c = Mod_subst.subst_constant subst c and do_subst_ind i = Mod_subst.subst_ind subst i @@ -271,9 +270,6 @@ let subst_Function (subst,finfos) = is_general = finfos.is_general } -let classify_Function infos = Libobject.Substitute infos - - let discharge_Function (_,finfos) = Some finfos let pr_ocst c = @@ -302,15 +298,11 @@ let pr_table tb = Pp.prlist_with_sep fnl pr_info l let in_Function : function_info -> Libobject.obj = - Libobject.declare_object - {(Libobject.default_object "FUNCTIONS_DB") with - Libobject.cache_function = cache_Function; - Libobject.load_function = load_Function; - Libobject.classify_function = classify_Function; - Libobject.subst_function = subst_Function; - Libobject.discharge_function = discharge_Function -(* Libobject.open_function = open_Function; *) - } + let open Libobject in + declare_object @@ superglobal_object "FUNCTIONS_DB" + ~cache:cache_Function + ~subst:(Some subst_Function) + ~discharge:discharge_Function let find_or_none id = @@ -500,7 +492,7 @@ type tcc_lemma_value = (* We only "purify" on exceptions. XXX: What is this doing here? *) let funind_purify f x = - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in try f x with e -> let e = CErrors.push e in diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index 156ee94a66..5d5d45c58f 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -314,7 +314,7 @@ END let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c -let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl +let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Pputils.pr_lident cl let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl let in_clause' = Pltac.in_clause diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 603dd60cf2..47f593ff3e 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -306,8 +306,8 @@ let add_rewrite_hint ~poly bases ort t lcsr = let ctx = let ctx = UState.context_set ctx in if poly then ctx - else (** This is a global universe context that shouldn't be - refreshed at every use of the hint, declare it globally. *) + else (* This is a global universe context that shouldn't be + refreshed at every use of the hint, declare it globally. *) (Declare.declare_universe_context false ctx; Univ.ContextSet.empty) in @@ -531,11 +531,9 @@ let cache_transitivity_lemma (_,(left,lem)) = let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) let inTransitivity : bool * Constr.t -> obj = - declare_object {(default_object "TRANSITIVITY-STEPS") with - cache_function = cache_transitivity_lemma; - open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); - subst_function = subst_transitivity_lemma; - classify_function = (fun o -> Substitute o) } + declare_object @@ global_object_nodischarge "TRANSITIVITY-STEPS" + ~cache:cache_transitivity_lemma + ~subst:(Some subst_transitivity_lemma) (* Main entry points *) @@ -738,7 +736,8 @@ let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - (** FIXME: this looks really wrong. Does anybody really use this tactic? *) + (* FIXME: this looks really wrong. Does anybody really use + this tactic? *) let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env (Evd.from_env env) concl in change_concl c end; diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index ef18dd6cdc..1ea6ff84d4 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -24,7 +24,7 @@ let (set_default_tactic, get_default_tactic, print_default_tactic) = Tactic_option.declare_tactic_option "Program tactic" let () = - (** Delay to recover the tactic imperatively *) + (* Delay to recover the tactic imperatively *) let tac = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> snd (get_default_tactic ()) end in diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 55e58187b0..5e3f4df192 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -22,8 +22,8 @@ open Tactypes open Locus open Decl_kinds open Genredexpr -open Pputils open Ppconstr +open Pputils open Printer open Genintern @@ -159,8 +159,8 @@ let string_of_genarg_arg (ArgumentType arg) = end | _ -> default - let pr_with_occurrences pr c = pr_with_occurrences pr keyword c - let pr_red_expr pr c = pr_red_expr pr keyword c + let pr_with_occurrences pr c = Ppred.pr_with_occurrences pr keyword c + let pr_red_expr pr c = Ppred.pr_red_expr pr keyword c let pr_may_eval test prc prlc pr2 pr3 = function | ConstrEval (r,c) -> @@ -186,12 +186,6 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_and_short_name pr (c,_) = pr c - let pr_or_by_notation f = CAst.with_val (function - | AN v -> f v - | ByNotation (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc) - - let pr_located pr (_,x) = pr x - let pr_evaluable_reference = function | EvalVarRef id -> pr_id id | EvalConstRef sp -> pr_global (Globnames.ConstRef sp) @@ -235,8 +229,8 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_tacarg_using_rule pr_gen l = let l = match l with | TacTerm s :: l -> - (** First terminal token should be considered as the name of the tactic, - so we tag it differently than the other terminal tokens. *) + (* First terminal token should be considered as the name of the tactic, + so we tag it differently than the other terminal tokens. *) primitive s :: tacarg_using_rule_token pr_gen l | _ -> tacarg_using_rule_token pr_gen l in @@ -694,7 +688,7 @@ let pr_goal_selector ~toplevel s = (* match t with | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal | _ ->*) - let s = prlist_with_sep spc Ppconstr.pr_lname nal ++ str ":" ++ pr.pr_lconstr t in + let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in spc() ++ hov 1 (str"(" ++ s ++ str")") in let pr_fix_tac (id,n,c) = @@ -1180,7 +1174,7 @@ let pr_goal_selector ~toplevel s = pr_constant = pr_evaluable_reference_env env; pr_reference = pr_located pr_ltac_constant; pr_name = pr_id; - (** Those are not used by the atomic printer *) + (* Those are not used by the atomic printer *) pr_generic = (fun _ -> assert false); pr_extend = (fun _ _ _ -> assert false); pr_alias = (fun _ _ _ -> assert false); diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 0ab9e501bc..bc47036d92 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -98,8 +98,7 @@ val pr_may_eval : ('a -> Pp.t) -> ('a -> Pp.t) -> ('b -> Pp.t) -> ('c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t -val pr_and_short_name : ('a -> Pp.t) -> 'a Stdarg.and_short_name -> Pp.t -val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t +val pr_and_short_name : ('a -> Pp.t) -> 'a Genredexpr.and_short_name -> Pp.t val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 06783de614..4bb52f599a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -97,7 +97,7 @@ let goalevars evars = fst evars let cstrevars evars = snd evars let new_cstr_evar (evd,cstrs) env t = - (** We handle the typeclass resolution of constraints ourselves *) + (* We handle the typeclass resolution of constraints ourselves *) let (evd', t) = Evarutil.new_evar env evd ~typeclass_candidate:false t in let ev, _ = destEvar evd' t in (evd', Evar.Set.add ev cstrs), t @@ -474,7 +474,7 @@ let get_symmetric_proof b = let error_no_relation () = user_err Pp.(str "Cannot find a relation to rewrite.") let rec decompose_app_rel env evd t = - (** Head normalize for compatibility with the old meta mechanism *) + (* Head normalize for compatibility with the old meta mechanism *) let t = Reductionops.whd_betaiota evd t in match EConstr.kind evd t with | App (f, [||]) -> assert false @@ -613,7 +613,7 @@ let solve_remaining_by env sigma holes by = Some evk | _ -> None in - (** Only solve independent holes *) + (* Only solve independent holes *) let indep = List.map_filter map holes in let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in let solve_tac = match tac with @@ -628,11 +628,12 @@ let solve_remaining_by env sigma holes by = in match evi with | None -> sigma - (** Evar should not be defined, but just in case *) + (* Evar should not be defined, but just in case *) | Some evi -> let env = Environ.reset_with_named_context evi.evar_hyps env in let ty = evi.evar_concl in - let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in + let name, poly = Id.of_string "rewrite", false in + let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma ty solve_tac in Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep @@ -646,6 +647,7 @@ let poly_inverse sort = type rewrite_proof = | RewPrf of constr * constr (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) + | RewCast of cast_kind (** A proof of convertibility (with casts) *) @@ -1561,7 +1563,7 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in - (** For compatibility *) + (* For compatibility *) let beta = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in let beta_hyp id = Tactics.reduct_in_hyp Reductionops.nf_betaiota (id, InHyp) in let treat sigma res = @@ -1611,7 +1613,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let env = match clause with | None -> env | Some id -> - (** Only consider variables not depending on [id] *) + (* Only consider variables not depending on [id] *) let ctx = named_context env in let filter decl = not (occur_var_in_decl env sigma id decl) in let nctx = List.filter filter ctx in @@ -1623,7 +1625,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in treat sigma res <*> - (** For compatibility *) + (* For compatibility *) beta <*> Proofview.shelve_unifiable with | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 2aee809eb6..b770b97384 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -169,7 +169,7 @@ let add_tactic_entry (kn, ml, tg) state = let entry, pos = get_tactic_entry tg.tacgram_level in let mkact loc l = let map arg = - (** HACK to handle especially the tactic(...) entry *) + (* HACK to handle especially the tactic(...) entry *) let wit = Genarg.rawwit Tacarg.wit_tactic in if Genarg.has_type arg wit && not ml then Tacexp (Genarg.out_gen wit arg) @@ -223,7 +223,7 @@ let interp_prod_item = function | Some arg -> arg end | Some n -> - (** FIXME: do better someday *) + (* FIXME: do better someday *) assert (String.equal s "tactic"); begin match Tacarg.wit_tactic with | ExtraArg tag -> ArgT.Any tag @@ -241,9 +241,9 @@ let make_fresh_key = | TacNonTerm _ -> "#" in let prods = String.concat "_" (List.map map prods) in - (** We embed the hash of the kernel name in the label so that the identifier - should be mostly unique. This ensures that including two modules - together won't confuse the corresponding labels. *) + (* We embed the hash of the kernel name in the label so that the identifier + should be mostly unique. This ensures that including two modules + together won't confuse the corresponding labels. *) let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in Lib.make_kn lbl @@ -281,7 +281,7 @@ let open_tactic_notation i (_, tobj) = let load_tactic_notation i (_, tobj) = let key = tobj.tacobj_key in let () = check_key key in - (** Only add the printing and interpretation rules. *) + (* Only add the printing and interpretation rules. *) Tacenv.register_alias key tobj.tacobj_body; Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram); if Int.equal i 1 && not tobj.tacobj_local then @@ -342,7 +342,7 @@ let extend_atomic_tactic name entries = let map_prod prods = let (hd, rem) = match prods with | TacTerm s :: rem -> (s, rem) - | _ -> assert false (** Not handled by the ML extension syntax *) + | _ -> assert false (* Not handled by the ML extension syntax *) in let empty_value = function | TacTerm s -> raise NonEmptyArgument @@ -383,8 +383,8 @@ let add_ml_tactic_notation name ~level ?deprecation prods = add_glob_tactic_notation false ~level ?deprecation prods true ids tac in List.iteri iter (List.rev prods); - (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at - tactic_expr level 0) *) + (* We call [extend_atomic_tactic] only for "basic tactics" (the ones + at tactic_expr level 0) *) if Int.equal level 0 then extend_atomic_tactic name prods (**********************************************************************) @@ -474,8 +474,9 @@ let register_ltac local ?deprecation tacl = (name, body) in let defs () = - (** Register locally the tactic to handle recursivity. This function affects - the whole environment, so that we transactify it afterwards. *) + (* Register locally the tactic to handle recursivity. This + function affects the whole environment, so that we transactify + it afterwards. *) let iter_rec (sp, kn) = Tacenv.push_tactic (Nametab.Until 1) sp kn in let () = List.iter iter_rec recvars in List.map map rfun @@ -557,7 +558,7 @@ let () = register_grammars_by_name "tactic" entries let get_identifier i = - (** Workaround for badly-designed generic arguments lacking a closure *) + (* Workaround for badly-designed generic arguments lacking a closure *) Names.Id.of_string_soft (Printf.sprintf "$%i" i) type _ ty_sig = @@ -650,20 +651,22 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = in match sign with | [TyML (TyIdent (name, s),tac) as ml_tac] when only_constr s -> - (** The extension is only made of a name followed by constr entries: we do not - add any grammar nor printing rule and add it as a true Ltac definition. *) + (* The extension is only made of a name followed by constr + entries: we do not add any grammar nor printing rule and add it + as a true Ltac definition. *) let vars = mk_sign_vars 1 s in let ml = { Tacexpr.mltac_name = ml_tactic_name; Tacexpr.mltac_index = 0 } in let tac = match s with | TyNil -> eval ml_tac - (** Special handling of tactics without arguments: such tactics do not do - a Proofview.Goal.nf_enter to compute their arguments. It matters for some - whole-prof tactics like [shelve_unifiable]. *) + (* Special handling of tactics without arguments: such tactics do + not do a Proofview.Goal.nf_enter to compute their arguments. It + matters for some whole-prof tactics like [shelve_unifiable]. *) | _ -> lift_constr_tac_to_ml_tac vars (eval ml_tac) in - (** 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. *) + (* 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 (CAst.make (ml, [])))in let id = Names.Id.of_string name in let obj () = Tacenv.register_ltac true false id body ?deprecation in diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 2bd21f9d7a..30e316b36d 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -78,12 +78,12 @@ type ('a,'t) match_rule = (** Extension indentifiers for the TACTIC EXTEND mechanism. *) type ml_tactic_name = { + mltac_plugin : string; (** Name of the plugin where the tactic is defined, typically coming from a DECLARE PLUGIN statement in the source. *) - mltac_plugin : string; + mltac_tactic : string; (** Name of the tactic entry where the tactic is defined, typically found after the TACTIC EXTEND statement in the source. *) - mltac_tactic : string; } type ml_tactic_entry = { @@ -270,7 +270,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Stdarg.and_short_name or_var +type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -296,9 +296,6 @@ type glob_tactic_arg = (** Raw tactics *) -type r_trm = constr_expr -type r_pat = constr_pattern_expr -type r_cst = qualid or_by_notation type r_ref = qualid type r_nam = lident type r_lev = rlevel diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 0c27f3bfe2..8b6b14322b 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -78,12 +78,12 @@ type ('a,'t) match_rule = (** Extension indentifiers for the TACTIC EXTEND mechanism. *) type ml_tactic_name = { + mltac_plugin : string; (** Name of the plugin where the tactic is defined, typically coming from a DECLARE PLUGIN statement in the source. *) - mltac_plugin : string; + mltac_tactic : string; (** Name of the tactic entry where the tactic is defined, typically found after the TACTIC EXTEND statement in the source. *) - mltac_tactic : string; } type ml_tactic_entry = { @@ -269,7 +269,7 @@ constraint 'a = < type g_trm = Genintern.glob_constr_and_expr type g_pat = Genintern.glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference Stdarg.and_short_name or_var +type g_cst = evaluable_global_reference Genredexpr.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -295,9 +295,6 @@ type glob_tactic_arg = (** Raw tactics *) -type r_trm = constr_expr -type r_pat = constr_pattern_expr -type r_cst = qualid or_by_notation type r_ref = qualid type r_nam = lident type r_lev = rlevel diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 85c6348b52..a1e21aab04 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -843,8 +843,9 @@ let notation_subst bindings tac = (make ?loc @@ Name id, c) :: accu in let bindings = Id.Map.fold fold bindings [] in - (** This is theoretically not correct due to potential variable capture, but - Ltac has no true variables so one cannot simply substitute *) + (* This is theoretically not correct due to potential variable + capture, but Ltac has no true variables so one cannot simply + substitute *) TacLetIn (false, bindings, tac) let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index cf5eb442be..3e7479903a 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -50,7 +50,7 @@ let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v w let Val.Dyn (t, _) = v in let t' = match val_tag wit with | Val.Base t' -> t' - | _ -> assert false (** not used in this module *) + | _ -> assert false (* not used in this module *) in match Val.eq t t' with | None -> false @@ -68,13 +68,13 @@ let in_list tag v = let in_gen wit v = let t = match val_tag wit with | Val.Base t -> t - | _ -> assert false (** not used in this module *) + | _ -> assert false (* not used in this module *) in Val.Dyn (t, v) let out_gen wit v = let t = match val_tag wit with | Val.Base t -> t - | _ -> assert false (** not used in this module *) + | _ -> assert false (* not used in this module *) in match prj t v with None -> assert false | Some x -> x @@ -104,7 +104,7 @@ let pr_appl h vs = let rec name_with_list appl t = match appl with | [] -> t - | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) + | (h,vs)::l -> Proofview.Trace.name_tactic (fun _ _ -> pr_appl h vs) (name_with_list l t) let name_if_glob appl t = match appl with | UnnamedAppl -> t @@ -585,8 +585,8 @@ let interp_pure_open_constr ist = let interp_typed_pattern ist env sigma (_,c,_) = let sigma, c = interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in - (** FIXME: it is necessary to be unsafe here because of the way we handle - evars in the pretyper. Sometimes they get solved eagerly. *) + (* FIXME: it is necessary to be unsafe here because of the way we handle + evars in the pretyper. Sometimes they get solved eagerly. *) pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) (* Interprets a constr expression *) @@ -897,7 +897,7 @@ let interp_destruction_arg ist gl arg = end) in try - (** FIXME: should be moved to taccoerce *) + (* FIXME: should be moved to taccoerce *) let v = Id.Map.find id ist.lfun in if has_type v (topwit wit_intro_pattern) then let v = out_gen (topwit wit_intro_pattern) v in @@ -1020,7 +1020,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr | TacArg {loc;v} -> interp_tacarg ist v | t -> - (** Delayed evaluation *) + (* Delayed evaluation *) Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) in let open Ftactic in @@ -1050,7 +1050,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with return (hov 0 msg , hov 0 msg) in let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in - let log (msg,_) = Proofview.Trace.log (fun () -> msg) in + let log (msg,_) = Proofview.Trace.log (fun _ _ -> msg) in let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in Ftactic.run msgnl begin fun msgnl -> print msgnl <*> log msgnl <*> break @@ -1132,7 +1132,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> - let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in + let name _ _ = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, @@ -1153,7 +1153,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let tac = Tacenv.interp_ml_tactic opn in let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = - let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in + let name _ _ = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) in Ftactic.run args tac @@ -1396,12 +1396,12 @@ and interp_match_successes lz ist s = general | Select -> begin - (** Only keep the first matching result, we don't backtrack on it *) + (* Only keep the first matching result, we don't backtrack on it *) let s = Proofview.tclONCE s in s >>= fun ans -> interp_match_success ist ans end | Once -> - (** Once a tactic has succeeded, do not backtrack anymore *) + (* Once a tactic has succeeded, do not backtrack anymore *) Proofview.tclONCE general (* Interprets the Match expressions *) @@ -1438,7 +1438,7 @@ and interp_match_goal ist lz lr lmr = (* Interprets extended tactic generic arguments *) and interp_genarg ist x : Val.t Ftactic.t = let open Ftactic.Notations in - (** Ad-hoc handling of some types. *) + (* Ad-hoc handling of some types. *) let tag = genarg_tag x in if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then interp_genarg_var_list ist x @@ -1539,7 +1539,7 @@ and name_atomic ?env tacexpr tac : unit Proofview.tactic = | None -> Proofview.tclENV end >>= fun env -> Proofview.tclEVARMAP >>= fun sigma -> - let name () = Pptactic.pr_atomic_tactic env sigma tacexpr in + let name _ _ = Pptactic.pr_atomic_tactic env sigma tacexpr in Proofview.Trace.name_tactic name tac (* Interprets a primitive tactic *) @@ -1560,7 +1560,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<apply>") begin Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in @@ -1601,7 +1601,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<mutual fix>") begin Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = @@ -1616,7 +1616,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<mutual cofix>") begin Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = @@ -1731,7 +1731,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacChange (None,c,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> let is_onhyps = match cl.onhyps with | None | Some [] -> true @@ -1756,7 +1756,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end | TacChange (Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in @@ -1957,7 +1957,9 @@ let lifts f = (); fun ist x -> Ftactic.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let (sigma, v) = f ist env sigma x in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Ftactic.return v) + (* FIXME once we don't need to catch side effects *) + (Proofview.tclTHEN (Proofview.Unsafe.tclSETENV (Global.env())) + (Ftactic.return v)) end let interp_bindings' ist bl = Ftactic.return begin fun env sigma -> @@ -2031,7 +2033,8 @@ let _ = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in let ist = { lfun = lfun; extra; } in let tac = interp_tactic ist tac in - let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in + let name, poly = Id.of_string "ltac_sub", false in + let (c, sigma) = Pfedit.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index c949589e22..54924f1644 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -59,7 +59,7 @@ let id_map_try_add_name id x m = the binding of the right-hand argument shadows that of the left-hand argument. *) let id_map_right_biased_union m1 m2 = - if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *) + if Id.Map.is_empty m1 then m2 (* Don't reconstruct the whole map *) else Id.Map.fold Id.Map.add m2 m1 (** Tests whether the substitution [s] is empty. *) @@ -102,7 +102,7 @@ let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = else raise Not_coherent_metas in let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in - (** ppedrot: Is that even correct? *) + (* ppedrot: Is that even correct? *) let merged = ln +++ ln1 in (merged, Id.Map.merge merge lcm lm) @@ -263,8 +263,8 @@ module PatternMatching (E:StaticEnvironment) = struct | All lhs -> wildcard_match_term lhs | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs | Pat _ -> - (** Rules with hypotheses, only work in match goal. *) - fail + (* Rules with hypotheses, only work in match goal. *) + fail (** [match_term term rules] matches the term [term] with the set of matching rules [rules].*) diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 4042959b50..eb84b1203d 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -118,6 +118,7 @@ Section MakeRingPol. - (Pinj i (Pc c)) is (Pc c) *) + #[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol @@ -939,6 +940,7 @@ Qed. (** Definition of polynomial expressions *) + #[universes(template)] Inductive PExpr : Type := | PEc : C -> PExpr | PEX : positive -> PExpr diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index f066ea462f..782fab5e68 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -289,6 +289,7 @@ destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). now apply (Rplus_nonneg_nonneg sor). Qed. +#[universes(template)] Inductive Psatz : Type := | PsatzIn : nat -> Psatz | PsatzSquare : PolC -> Psatz @@ -685,6 +686,7 @@ end. Definition eval_pexpr : PolEnv -> PExpr C -> R := PEeval rplus rtimes rminus ropp phi pow_phi rpow. +#[universes(template)] Record Formula (T:Type) : Type := { Flhs : PExpr T; Fop : Op2; diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 458844e1b9..587f2f1fa4 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -21,6 +21,7 @@ Require Import Bool. Set Implicit Arguments. + #[universes(template)] Inductive BFormula (A:Type) : Type := | TT : BFormula A | FF : BFormula A diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 2d2c0bc77a..c888f9af45 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -30,6 +30,7 @@ Section MakeVarMap. Variable A : Type. Variable default : A. + #[universes(template)] Inductive t : Type := | Empty : t | Leaf : A -> t diff --git a/plugins/micromega/itv.ml b/plugins/micromega/itv.ml index dc1df7ec9f..44cad820ed 100644 --- a/plugins/micromega/itv.ml +++ b/plugins/micromega/itv.ml @@ -11,10 +11,11 @@ (** Intervals (extracted from mfourier.ml) *) open Num + (** The type of intervals is *) type interval = num option * num option - (** None models the absence of bound i.e. infinity *) - (** As a result, + (** None models the absence of bound i.e. infinity + As a result, - None , None -> \]-oo,+oo\[ - None , Some v -> \]-oo,v\] - Some v, None -> \[v,+oo\[ diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index f5e9a9f34c..23f3470d77 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -103,7 +103,7 @@ module Poly : sig end -type cstr = {coeffs : Vect.t ; op : op ; cst : Num.num} (** Representation of linear constraints *) +type cstr = {coeffs : Vect.t ; op : op ; cst : Num.num} (* Representation of linear constraints *) and op = Eq | Ge | Gt val eval_op : op -> Num.num -> Num.num -> bool diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index 8d8c6ea90b..4465aa1ee1 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -20,6 +20,7 @@ type iset = unit IMap.t type tableau = Vect.t IMap.t (** Mapping basic variables to their equation. All variables >= than a threshold rst are restricted.*) + module Restricted = struct type t = diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index f8fc943713..1825a4d77c 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -609,7 +609,7 @@ type current_problem = { exception NotInIdealUpdate of current_problem let test_dans_ideal cur_pb table metadata p lp len0 = - (** Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) + (* Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) let (c,r) = reduce2 table cur_pb.cur_poly lp in info (fun () -> "remainder: "^(stringPcut metadata r)); let cur_pb = { @@ -657,7 +657,7 @@ let deg_hom p = | (a,m)::_ -> Monomial.deg m let pbuchf table metadata cur_pb homogeneous (lp, lpc) p = - (** Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) + (* Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) sinfo "computation of the Groebner basis"; let () = match table.hmon with | None -> () diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index ef60a23e80..1777418ef6 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -374,7 +374,7 @@ let remove_zeros lci = let m = List.length lci in let u = Array.make m false in let rec utiles k = - (** TODO: Find a more reasonable implementation of this traversal. *) + (* TODO: Find a more reasonable implementation of this traversal. *) if k >= m || u.(k) then () else let () = u.(k) <- true in diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 99c02995fb..751f0d8334 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -81,10 +81,12 @@ Section Store. Variable A:Type. +#[universes(template)] Inductive Poption : Type:= PSome : A -> Poption | PNone : Poption. +#[universes(template)] Inductive Tree : Type := Tempty : Tree | Branch0 : Tree -> Tree -> Tree @@ -177,6 +179,7 @@ generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. Qed. +#[universes(template)] Record Store : Type := mkStore {index:positive;contents:Tree}. @@ -191,6 +194,7 @@ Lemma get_empty : forall i, get i empty = PNone. intro i; case i; unfold empty,get; simpl;reflexivity. Qed. +#[universes(template)] Inductive Full : Store -> Type:= F_empty : Full empty | F_push : forall a S, Full S -> Full (push a S). diff --git a/plugins/rtauto/g_rtauto.mlg b/plugins/rtauto/g_rtauto.mlg index 9c9fdcfa2f..d8724eb976 100644 --- a/plugins/rtauto/g_rtauto.mlg +++ b/plugins/rtauto/g_rtauto.mlg @@ -17,6 +17,6 @@ open Ltac_plugin DECLARE PLUGIN "rtauto_plugin" TACTIC EXTEND rtauto -| [ "rtauto" ] -> { Proofview.V82.tactic (Refl_tauto.rtauto_tac) } +| [ "rtauto" ] -> { Refl_tauto.rtauto_tac } END diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index e66fa10d5b..a6b6c57ff9 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -16,7 +16,6 @@ open CErrors open Util open Term open Constr -open Tacmach open Proof_search open Context.Named.Declaration @@ -60,12 +59,11 @@ let l_I_Or_r = gen_constant "plugins.rtauto.I_Or_r" let l_E_Or = gen_constant "plugins.rtauto.E_Or" let l_D_Or = gen_constant "plugins.rtauto.D_Or" +let special_whd env sigma c = + Reductionops.clos_whd_flags CClosure.all env sigma c -let special_whd gl c = - Reductionops.clos_whd_flags CClosure.all (pf_env gl) (Tacmach.project gl) c - -let special_nf gl c = - Reductionops.clos_norm_flags CClosure.betaiotazeta (pf_env gl) (Tacmach.project gl) c +let special_nf env sigma c = + Reductionops.clos_norm_flags CClosure.betaiotazeta env sigma c type atom_env= {mutable next:int; @@ -83,61 +81,58 @@ let make_atom atom_env term= atom_env.next<- i + 1; Atom i -let rec make_form atom_env gls term = +let rec make_form env sigma atom_env term = let open EConstr in let open Vars in - let normalize=special_nf gls in - let cciterm=special_whd gls term in - let sigma = Tacmach.project gls in - match EConstr.kind sigma cciterm with - Prod(_,a,b) -> - if noccurn sigma 1 b && - Retyping.get_sort_family_of - (pf_env gls) sigma a == InProp - then - let fa=make_form atom_env gls a in - let fb=make_form atom_env gls b in - Arrow (fa,fb) - else - make_atom atom_env (normalize term) - | Cast(a,_,_) -> - make_form atom_env gls a - | Ind (ind, _) -> - if Names.eq_ind ind (fst (Lazy.force li_False)) then - Bot - else - make_atom atom_env (normalize term) - | App(hd,argv) when Int.equal (Array.length argv) 2 -> - begin - try - let ind, _ = destInd sigma hd in - if Names.eq_ind ind (fst (Lazy.force li_and)) then - let fa=make_form atom_env gls argv.(0) in - let fb=make_form atom_env gls argv.(1) in - Conjunct (fa,fb) - else if Names.eq_ind ind (fst (Lazy.force li_or)) then - let fa=make_form atom_env gls argv.(0) in - let fb=make_form atom_env gls argv.(1) in - Disjunct (fa,fb) - else make_atom atom_env (normalize term) - with DestKO -> make_atom atom_env (normalize term) - end - | _ -> make_atom atom_env (normalize term) - -let rec make_hyps atom_env gls lenv = function + let normalize = special_nf env sigma in + let cciterm = special_whd env sigma term in + match EConstr.kind sigma cciterm with + Prod(_,a,b) -> + if noccurn sigma 1 b && + Retyping.get_sort_family_of env sigma a == InProp + then + let fa = make_form env sigma atom_env a in + let fb = make_form env sigma atom_env b in + Arrow (fa,fb) + else + make_atom atom_env (normalize term) + | Cast(a,_,_) -> + make_form env sigma atom_env a + | Ind (ind, _) -> + if Names.eq_ind ind (fst (Lazy.force li_False)) then + Bot + else + make_atom atom_env (normalize term) + | App(hd,argv) when Int.equal (Array.length argv) 2 -> + begin + try + let ind, _ = destInd sigma hd in + if Names.eq_ind ind (fst (Lazy.force li_and)) then + let fa = make_form env sigma atom_env argv.(0) in + let fb = make_form env sigma atom_env argv.(1) in + Conjunct (fa,fb) + else if Names.eq_ind ind (fst (Lazy.force li_or)) then + let fa = make_form env sigma atom_env argv.(0) in + let fb = make_form env sigma atom_env argv.(1) in + Disjunct (fa,fb) + else make_atom atom_env (normalize term) + with DestKO -> make_atom atom_env (normalize term) + end + | _ -> make_atom atom_env (normalize term) + +let rec make_hyps env sigma atom_env lenv = function [] -> [] | LocalDef (_,body,typ)::rest -> - make_hyps atom_env gls (typ::body::lenv) rest + make_hyps env sigma atom_env (typ::body::lenv) rest | LocalAssum (id,typ)::rest -> - let hrec= - make_hyps atom_env gls (typ::lenv) rest in - if List.exists (fun c -> Termops.local_occur_var Evd.empty (** FIXME *) id c) lenv || - (Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) typ != InProp) - then - hrec - else - (id,make_form atom_env gls typ)::hrec + let hrec= + make_hyps env sigma atom_env (typ::lenv) rest in + if List.exists (fun c -> Termops.local_occur_var Evd.empty (* FIXME *) id c) lenv || + (Retyping.get_sort_family_of env sigma typ != InProp) + then + hrec + else + (id,make_form env sigma atom_env typ)::hrec let rec build_pos n = if n<=1 then force node_count l_xH @@ -251,73 +246,76 @@ let () = declare_bool_option opt_check open Pp -let rtauto_tac gls= - Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; - let gamma={next=1;env=[]} in - let gl=pf_concl gls in - let () = - if Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) gl != InProp - then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in - let glf=make_form gamma gls gl in - let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in - let formula= - List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in - let search_fun = match Tacinterp.get_debug() with - | Tactic_debug.DebugOn 0 -> Search.debug_depth_first - | _ -> Search.depth_first - in - let () = - begin - reset_info (); +let rtauto_tac = + Proofview.Goal.enter begin fun gl -> + let hyps = Proofview.Goal.hyps gl in + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; + let gamma={next=1;env=[]} in + let () = + if Retyping.get_sort_family_of env sigma concl != InProp + then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in + let glf = make_form env sigma gamma concl in + let hyps = make_hyps env sigma gamma [concl] hyps in + let formula= + List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in + let search_fun = match Tacinterp.get_debug() with + | Tactic_debug.DebugOn 0 -> Search.debug_depth_first + | _ -> Search.depth_first + in + let () = + begin + reset_info (); + if !verbose then + Feedback.msg_info (str "Starting proof-search ..."); + end in + let search_start_time = System.get_time () in + let prf = + try project (search_fun (init_state [] formula)) + with Not_found -> + user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in + let search_end_time = System.get_time () in + let () = if !verbose then + begin + Feedback.msg_info (str "Proof tree found in " ++ + System.fmt_time_difference search_start_time search_end_time); + pp_info (); + Feedback.msg_info (str "Building proof term ... ") + end in + let build_start_time=System.get_time () in + let () = step_count := 0; node_count := 0 in + let main = mkApp (force node_count l_Reflect, + [|build_env gamma; + build_form formula; + build_proof [] 0 prf|]) in + let term= + applistc main (List.rev_map (fun (id,_) -> mkVar id) hyps) in + let build_end_time=System.get_time () in + let () = if !verbose then + begin + Feedback.msg_info (str "Proof term built in " ++ + System.fmt_time_difference build_start_time build_end_time ++ + fnl () ++ + str "Proof size : " ++ int !step_count ++ + str " steps" ++ fnl () ++ + str "Proof term size : " ++ int (!step_count+ !node_count) ++ + str " nodes (constants)" ++ fnl () ++ + str "Giving proof term to Coq ... ") + end in + let tac_start_time = System.get_time () in + let term = EConstr.of_constr term in + let result= + if !check then + Tactics.exact_check term + else + Tactics.exact_no_check term in + let tac_end_time = System.get_time () in + let () = + if !check then Feedback.msg_info (str "Proof term type-checking is on"); if !verbose then - Feedback.msg_info (str "Starting proof-search ..."); - end in - let search_start_time = System.get_time () in - let prf = - try project (search_fun (init_state [] formula)) - with Not_found -> - user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in - let search_end_time = System.get_time () in - let () = if !verbose then - begin - Feedback.msg_info (str "Proof tree found in " ++ - System.fmt_time_difference search_start_time search_end_time); - pp_info (); - Feedback.msg_info (str "Building proof term ... ") - end in - let build_start_time=System.get_time () in - let () = step_count := 0; node_count := 0 in - let main = mkApp (force node_count l_Reflect, - [|build_env gamma; - build_form formula; - build_proof [] 0 prf|]) in - let term= - applistc main (List.rev_map (fun (id,_) -> mkVar id) hyps) in - let build_end_time=System.get_time () in - let () = if !verbose then - begin - Feedback.msg_info (str "Proof term built in " ++ - System.fmt_time_difference build_start_time build_end_time ++ - fnl () ++ - str "Proof size : " ++ int !step_count ++ - str " steps" ++ fnl () ++ - str "Proof term size : " ++ int (!step_count+ !node_count) ++ - str " nodes (constants)" ++ fnl () ++ - str "Giving proof term to Coq ... ") - end in - let tac_start_time = System.get_time () in - let term = EConstr.of_constr term in - let result= - if !check then - Proofview.V82.of_tactic (Tactics.exact_check term) gls - else - Proofview.V82.of_tactic (Tactics.exact_no_check term) gls in - let tac_end_time = System.get_time () in - let () = - if !check then Feedback.msg_info (str "Proof term type-checking is on"); - if !verbose then - Feedback.msg_info (str "Internal tactic executed in " ++ - System.fmt_time_difference tac_start_time tac_end_time) in + Feedback.msg_info (str "Internal tactic executed in " ++ + System.fmt_time_difference tac_start_time tac_end_time) in result - + end diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index a91dd666a6..49b5ee5ac7 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -14,14 +14,15 @@ type atom_env= {mutable next:int; mutable env:(Constr.t*int) list} -val make_form : atom_env -> - Goal.goal Evd.sigma -> EConstr.types -> Proof_search.form +val make_form + : Environ.env -> Evd.evar_map -> atom_env + -> EConstr.types -> Proof_search.form -val make_hyps : - atom_env -> - Goal.goal Evd.sigma -> - EConstr.types list -> - EConstr.named_context -> - (Names.Id.t * Proof_search.form) list +val make_hyps + : Environ.env -> Evd.evar_map + -> atom_env + -> EConstr.types list + -> EConstr.named_context + -> (Names.Id.t * Proof_search.form) list -val rtauto_tac : Tacmach.tactic +val rtauto_tac : unit Proofview.tactic diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index ce115f564f..dba72337b2 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -730,6 +730,7 @@ Qed. (* The input: syntax of a field expression *) +#[universes(template)] Inductive FExpr : Type := | FEO : FExpr | FEI : FExpr @@ -762,6 +763,7 @@ Strategy expand [FEeval]. (* The result of the normalisation *) +#[universes(template)] Record linear : Type := mk_linear { num : PExpr C; denum : PExpr C; @@ -944,6 +946,7 @@ induction e2; intros p1 p2; now rewrite <- PEpow_mul_r. Qed. +#[universes(template)] Record rsplit : Type := mk_rsplit { rsplit_left : PExpr C; rsplit_common : PExpr C; diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index f5db275465..15d490a6ab 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -740,6 +740,7 @@ Ltac abstract_ring_morphism set ext rspec := | _ => fail 1 "bad ring structure" end. +#[universes(template)] Record hypo : Type := mkhypo { hypo_type : Type; hypo_proof : hypo_type diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v index 12208ff6b9..31182f51e2 100644 --- a/plugins/setoid_ring/Ncring_polynom.v +++ b/plugins/setoid_ring/Ncring_polynom.v @@ -32,6 +32,7 @@ Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. with coefficients in C : *) +#[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | PX : Pol -> positive -> positive -> Pol -> Pol. @@ -43,6 +44,7 @@ Definition cI:C . exact ring1. Defined. Definition P1 := Pc 1. Variable Ceqb:C->C->bool. +#[universes(template)] Class Equalityb (A : Type):= {equalityb : A -> A -> bool}. Notation "x =? y" := (equalityb x y) (at level 70, no associativity). Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y). diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index ccd82eabcd..9ef24144d2 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -121,6 +121,7 @@ Section MakeRingPol. - (Pinj i (Pc c)) is (Pc c) *) + #[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol @@ -908,6 +909,7 @@ Section MakeRingPol. (** Definition of polynomial expressions *) + #[universes(template)] Inductive PExpr : Type := | PEO : PExpr | PEI : PExpr diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index d67a8d8dce..6c782269ab 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -540,6 +540,7 @@ Section AddRing. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. *) +#[universes(template)] Inductive ring_kind : Type := | Abstract | Computational diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 4109e9cf38..65201d922f 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -194,12 +194,12 @@ let exec_tactic env evd n f args = in let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - (** Build the getter *) + (* 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 (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 *) + (* Evaluate the whole result *) let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in let evd = Evd.minimize_universes (Refiner.project gls) in @@ -394,13 +394,9 @@ let subst_th (subst,th) = let theory_to_obj : ring_info -> obj = let cache_th (name,th) = add_entry name th in - declare_object - {(default_object "tactic-new-ring-theory") with - open_function = (fun i o -> if Int.equal i 1 then cache_th o); - cache_function = cache_th; - subst_function = subst_th; - classify_function = (fun x -> Substitute x)} - + declare_object @@ global_object_nodischarge "tactic-new-ring-theory" + ~cache:cache_th + ~subst:(Some subst_th) let setoid_of_relation env evd a r = try @@ -891,12 +887,9 @@ let subst_th (subst,th) = let ftheory_to_obj : field_info -> obj = let cache_th (name,th) = add_field_entry name th in - declare_object - {(default_object "tactic-new-field-theory") with - open_function = (fun i o -> if Int.equal i 1 then cache_th o); - cache_function = cache_th; - subst_function = subst_th; - classify_function = (fun x -> Substitute x) } + declare_object @@ global_object_nodischarge "tactic-new-field-theory" + ~cache:cache_th + ~subst:(Some subst_th) let field_equality evd r inv req = match EConstr.kind !evd req with diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index bb8a0faf2e..dd2c2d0ba4 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -64,38 +64,36 @@ type ast_closure_term = { type ssrview = ast_closure_term list -(* TODO -type id_mod = Hat | HatTilde | Sharp - *) +type id_block = Prefix of Id.t | SuffixId of Id.t | SuffixNum of int (* Only [One] forces an introduction, possibly reducing the goal. *) type anon_iter = - | One + | One of string option (* name hint *) | Drop | All -(* TODO - | Dependent (* fast mode *) - | UntilMark - | Temporary (* "+" *) - *) + | Temporary type ssripat = | IPatNoop - | IPatId of (*TODO id_mod option * *) Id.t + | IPatId of Id.t | IPatAnon of anon_iter (* inaccessible name *) (* TODO | IPatClearMark *) - | IPatDispatch of bool (* ssr exception: accept a dispatch on the empty list even when there are subgoals *) * ssripatss (* (..|..) *) - | IPatCase of (* ipats_mod option * *) ssripatss (* this is not equivalent to /case /[..|..] if there are already multiple goals *) + | IPatDispatch of bool (* ssr exception: accept a dispatch on the empty list even when there are subgoals *) * ssripatss_or_block (* (..|..) *) + | IPatCase of (* ipats_mod option * *) ssripatss_or_block (* this is not equivalent to /case /[..|..] if there are already multiple goals *) | IPatInj of ssripatss | IPatRewrite of (*occurrence option * rewrite_pattern **) ssrocc * ssrdir | IPatView of bool * ssrview (* {}/view (true if the clear is present) *) | IPatClear of ssrclear (* {H1 H2} *) | IPatSimpl of ssrsimpl | IPatAbstractVars of Id.t list - | IPatTac of unit Proofview.tactic + | IPatFastNondep + | IPatEqGen of unit Proofview.tactic (* internal use: generation of eqn *) and ssripats = ssripat list and ssripatss = ssripats list +and ssripatss_or_block = + | Block of id_block + | Regular of ssripats list type ssrhpats = ((ssrclear * ssripats) * ssripats) * ssripats type ssrhpats_wtransp = bool * ssrhpats @@ -104,6 +102,7 @@ type ssrintrosarg = Tacexpr.raw_tactic_expr * ssripats type ssrfwdid = Id.t + (** Binders (for fwd tactics) *) type 'term ssrbind = | Bvar of Name.t diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index 3a7cf41d43..ed4ff2aa66 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -609,6 +609,7 @@ Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. (** Allow the direct application of a reflection lemma to a boolean assertion. **) Coercion elimT : reflect >-> Funclass. +#[universes(template)] Variant implies P Q := Implies of P -> Q. Lemma impliesP P Q : implies P Q -> P -> Q. Proof. by case. Qed. Lemma impliesPn (P Q : Prop) : implies P Q -> ~ Q -> ~ P. @@ -1130,10 +1131,12 @@ Proof. by move=> *; apply/orP; left. Qed. Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). Proof. by move=> *; apply/orP; right. Qed. +#[universes(template)] Variant mem_pred := Mem of pred T. Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). +#[universes(template)] Structure predType := PredType { pred_sort :> Type; topred : pred_sort -> pred T; @@ -1275,6 +1278,7 @@ Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). implementation of unification, notably improper expansion of telescope projections and overwriting of a variable assignment by a later unification (probably due to conversion cache cross-talk). **) +#[universes(template)] Structure manifest_applicative_pred p := ManifestApplicativePred { manifest_applicative_pred_value :> pred T; _ : manifest_applicative_pred_value = p @@ -1283,18 +1287,21 @@ Definition ApplicativePred p := ManifestApplicativePred (erefl p). Canonical applicative_pred_applicative sp := ApplicativePred (applicative_pred_of_simpl sp). +#[universes(template)] Structure manifest_simpl_pred p := ManifestSimplPred { manifest_simpl_pred_value :> simpl_pred T; _ : manifest_simpl_pred_value = SimplPred p }. Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). +#[universes(template)] Structure manifest_mem_pred p := ManifestMemPred { manifest_mem_pred_value :> mem_pred T; _ : manifest_mem_pred_value= Mem [eta p] }. Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). +#[universes(template)] Structure applicative_mem_pred p := ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. Canonical check_applicative_mem_pred p (ap : manifest_applicative_pred p) mp := @@ -1345,6 +1352,7 @@ End simpl_mem. (** Qualifiers and keyed predicates. **) +#[universes(template)] Variant qualifier (q : nat) T := Qualifier of predPredType T. Coercion has_quality n T (q : qualifier n T) : pred_class := @@ -1392,9 +1400,11 @@ Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) Section KeyPred. Variable T : Type. +#[universes(template)] Variant pred_key (p : predPredType T) := DefaultPredKey. Variable p : predPredType T. +#[universes(template)] Structure keyed_pred (k : pred_key p) := PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. @@ -1426,6 +1436,7 @@ Section KeyedQualifier. Variables (T : Type) (n : nat) (q : qualifier n T). +#[universes(template)] Structure keyed_qualifier (k : pred_key q) := PackKeyedQualifier {unkey_qualifier; _ : unkey_qualifier = q}. Definition KeyedQualifier k := PackKeyedQualifier k (erefl q). diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index efc4a2c743..311d912efd 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -263,7 +263,7 @@ let of_ftactic ftac gl = let tac = Proofview.V82.of_tactic tac in let { sigma = sigma } = tac gl in let ans = match !r with - | None -> assert false (** If the tactic failed we should not reach this point *) + | None -> assert false (* If the tactic failed we should not reach this point *) | Some ans -> ans in (sigma, ans) @@ -401,6 +401,7 @@ let max_suffix m (t, j0 as tj0) id = dt < ds && skip_digits s i = n in loop m +(** creates a fresh (w.r.t. `gl_ids` and internal names) inaccessible name of the form _tXX_ *) let mk_anon_id t gl_ids = let m, si0, id0 = let s = ref (Printf.sprintf "_%s_" t) in @@ -409,7 +410,7 @@ let mk_anon_id t gl_ids = let rec loop i j = let d = !s.[i] in if not (is_digit d) then i + 1, j else loop (i - 1) (if d = '0' then j else i) in - let m, j = loop (n - 1) n in m, (!s, j), Id.of_string !s in + let m, j = loop (n - 1) n in m, (!s, j), Id.of_string_soft !s in if not (List.mem id0 gl_ids) then id0 else let s, i = List.fold_left (max_suffix m) si0 gl_ids in let open Bytes in @@ -419,7 +420,7 @@ let mk_anon_id t gl_ids = if get s i = '9' then (set s i '0'; loop (i - 1)) else if i < m then (set s n '0'; set s m '1'; cat s (of_string "_")) else (set s i (Char.chr (Char.code (get s i) + 1)); s) in - Id.of_bytes (loop (n - 1)) + Id.of_string_soft (Bytes.to_string (loop (n - 1))) let convert_concl_no_check t = Tactics.convert_concl_no_check t DEFAULTcast let convert_concl t = Tactics.convert_concl t DEFAULTcast @@ -808,18 +809,6 @@ let clear_wilds_and_tmp_and_delayed_ids gl = (clear_with_wilds ctx.wild_ids ctx.delayed_clears) (clear_wilds (List.map fst ctx.tmp_ids @ ctx.wild_ids))) gl -let rec is_name_in_ipats name = function - | IPatClear clr :: tl -> - List.exists (function SsrHyp(_,id) -> id = name) clr - || is_name_in_ipats name tl - | IPatId id :: tl -> id = name || is_name_in_ipats name tl - | IPatAbstractVars ids :: tl -> - CList.mem_f Id.equal name ids || is_name_in_ipats name tl - | (IPatCase l | IPatDispatch (_,l) | IPatInj l) :: tl -> - List.exists (is_name_in_ipats name) l || is_name_in_ipats name tl - | (IPatView _ | IPatAnon _ | IPatSimpl _ | IPatRewrite _ | IPatTac _ | IPatNoop) :: tl -> is_name_in_ipats name tl - | [] -> false - let view_error s gv = errorstrm (str ("Cannot " ^ s ^ " view ") ++ pr_term gv) @@ -1187,9 +1176,23 @@ let gen_tmp_ids ctx.tmp_ids) gl) ;; -let pf_interp_gen gl to_ind gen = +let pf_interp_gen to_ind gen gl = let _, _, a, b, c, ucst,gl = pf_interp_gen_aux gl to_ind gen in - a, b ,c, pf_merge_uc ucst gl + (a, b ,c), pf_merge_uc ucst gl + +let pfLIFT f = + let open Proofview.Notations in + let hack = ref None in + Proofview.V82.tactic (fun gl -> + let g = sig_it gl in + let x, gl = f gl in + hack := Some (x,project gl); + re_sig [g] (project gl)) + >>= fun () -> + let x, sigma = option_assert_get !hack (Pp.str"pfLIFT") in + Proofview.Unsafe.tclEVARS sigma <*> + Proofview.tclUNIT x +;; (* TASSI: This version of unprotects inlines the unfold tactic definition, * since we don't want to wipe out let-ins, and it seems there is no flag @@ -1273,7 +1276,7 @@ let unfold cl = open Proofview open Notations -let tacSIGMA = Goal.enter_one begin fun g -> +let tacSIGMA = Goal.enter_one ~__LOC__ begin fun g -> let k = Goal.goal g in let sigma = Goal.sigma g in tclUNIT (Tacmach.re_sig k sigma) @@ -1347,6 +1350,11 @@ let tclFULL_BETAIOTA = Goal.enter begin fun gl -> Tactics.e_reduct_in_concl ~check:false (r,Constr.DEFAULTcast) end +type intro_id = + | Anon + | Id of Id.t + | Seed of string + (** [intro id k] introduces the first premise (product or let-in) of the goal under the name [id], reducing the head of the goal (using beta, iota, delta but not zeta) if necessary. If [id] is None, a name is generated, that will @@ -1360,11 +1368,12 @@ let tclINTRO ~id ~conclusion:k = Goal.enter begin fun gl -> let original_name = Rel.Declaration.get_name decl in let already_used = Tacmach.New.pf_ids_of_hyps gl in let id = match id, original_name with - | Some id, _ -> id - | _, Name id -> + | Id id, _ -> id + | Seed id, _ -> mk_anon_id id already_used + | Anon, Name id -> if is_discharged_id id then id else mk_anon_id (Id.to_string id) already_used - | _, _ -> + | Anon, Anonymous -> let ids = Tacmach.New.pf_ids_of_hyps gl in mk_anon_id ssr_anon_hyp ids in @@ -1377,8 +1386,11 @@ end let return ~orig_name:_ ~new_name:_ = tclUNIT () -let tclINTRO_ID id = tclINTRO ~id:(Some id) ~conclusion:return -let tclINTRO_ANON = tclINTRO ~id:None ~conclusion:return +let tclINTRO_ID id = tclINTRO ~id:(Id id) ~conclusion:return +let tclINTRO_ANON ?seed () = + match seed with + | None -> tclINTRO ~id:Anon ~conclusion:return + | Some seed -> tclINTRO ~id:(Seed seed) ~conclusion:return let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> let convert_concl_no_check t = @@ -1391,8 +1403,8 @@ let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> | _ -> CErrors.anomaly (Pp.str "rename_hd_prod: no head product") end -let tcl0G tac = - numgoals >>= fun ng -> if ng = 0 then tclUNIT () else tac +let tcl0G ~default tac = + numgoals >>= fun ng -> if ng = 0 then tclUNIT default else tac let rec tclFIRSTa = function | [] -> Tacticals.New.tclZEROMSG Pp.(str"No applicable tactic.") @@ -1491,6 +1503,12 @@ let tclGET k = Goal.enter begin fun gl -> k (Option.default S.init (get (Goal.state gl) state_field)) end +let tclGET1 k = Goal.enter_one begin fun gl -> + let open Proofview_monad.StateStore in + k (Option.default S.init (get (Goal.state gl) state_field)) +end + + let tclSET new_s = let open Proofview_monad.StateStore in Unsafe.tclGETGOALS >>= fun gls -> diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 824827e90c..51116ccd75 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -359,24 +359,17 @@ val genstac : Tacmach.tactic val pf_interp_gen : - Goal.goal Evd.sigma -> bool -> (Ssrast.ssrhyp list option * Ssrmatching.occ) * Ssrmatching.cpattern -> - EConstr.t * EConstr.t * Ssrast.ssrhyp list * - Goal.goal Evd.sigma - -val pf_interp_gen_aux : Goal.goal Evd.sigma -> - bool -> - (Ssrast.ssrhyp list option * Ssrmatching.occ) * - Ssrmatching.cpattern -> - bool * Ssrmatching.pattern * EConstr.t * - EConstr.t * Ssrast.ssrhyp list * UState.t * - Goal.goal Evd.sigma + (EConstr.t * EConstr.t * Ssrast.ssrhyp list) * + Goal.goal Evd.sigma -val is_name_in_ipats : - Id.t -> ssripats -> bool +(* HACK: use to put old pf_code in the tactic monad *) +val pfLIFT + : (Goal.goal Evd.sigma -> 'a * Goal.goal Evd.sigma) + -> 'a Proofview.tactic (** Basic tactics *) @@ -431,18 +424,23 @@ val tacREDUCE_TO_QUANTIFIED_IND : val tacTYPEOF : EConstr.t -> EConstr.types Proofview.tactic val tclINTRO_ID : Id.t -> unit Proofview.tactic -val tclINTRO_ANON : unit Proofview.tactic +val tclINTRO_ANON : ?seed:string -> unit -> unit Proofview.tactic (* Lower level API, calls conclusion with the name taken from the prod *) +type intro_id = + | Anon + | Id of Id.t + | Seed of string + val tclINTRO : - id:Id.t option -> + id:intro_id -> conclusion:(orig_name:Name.t -> new_name:Id.t -> unit Proofview.tactic) -> unit Proofview.tactic val tclRENAME_HD_PROD : Name.t -> unit Proofview.tactic (* calls the tactic only if there are more than 0 goals *) -val tcl0G : unit Proofview.tactic -> unit Proofview.tactic +val tcl0G : default:'a -> 'a Proofview.tactic -> 'a Proofview.tactic (* like tclFIRST but with 'a tactic *) val tclFIRSTa : 'a Proofview.tactic list -> 'a Proofview.tactic @@ -474,6 +472,7 @@ end module MakeState(S : StateType) : sig val tclGET : (S.state -> unit Proofview.tactic) -> unit Proofview.tactic + val tclGET1 : (S.state -> 'a Proofview.tactic) -> 'a Proofview.tactic val tclSET : S.state -> unit Proofview.tactic val tacUPDATE : (S.state -> S.state Proofview.tactic) -> unit Proofview.tactic diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 01af67912a..4721e19a8b 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -86,10 +86,16 @@ Export SsrMatchingSyntax. Export SsrSyntax. (** + To define notations for tactic in intro patterns. + When "=> /t" is parsed, "t:%ssripat" is actually interpreted. **) +Declare Scope ssripat_scope. +Delimit Scope ssripat_scope with ssripat. + +(** Make the general "if" into a notation, so that we can override it below. The notations are "only parsing" because the Coq decompiler will not recognize the expansion of the boolean if; using the default printer - avoids a spurrious trailing %%GEN_IF. **) + avoids a spurrious trailing %%GEN_IF. **) Declare Scope general_if_scope. Delimit Scope general_if_scope with GEN_IF. @@ -172,6 +178,7 @@ Register abstract_key as plugins.ssreflect.abstract_key. Register abstract as plugins.ssreflect.abstract. (** Constants for tactic-views **) +#[universes(template)] Inductive external_view : Type := tactic_view of Type. (** @@ -200,6 +207,7 @@ Inductive external_view : Type := tactic_view of Type. Module TheCanonical. +#[universes(template)] Variant put vT sT (v1 v2 : vT) (s : sT) := Put. Definition get vT sT v s (p : @put vT sT v v s) := let: Put _ _ _ := p in s. @@ -295,9 +303,11 @@ Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) We also define a simpler version ("phant" / "Phant") of phantom for the common case where p_type is Type. **) +#[universes(template)] Variant phantom T (p : T) := Phantom. Arguments phantom : clear implicits. Arguments Phantom : clear implicits. +#[universes(template)] Variant phant (p : Type) := Phant. (** Internal tagging used by the implementation of the ssreflect elim. **) @@ -383,6 +393,7 @@ Ltac ssrdone0 := | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. (** To unlock opaque constants. **) +#[universes(template)] Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 2c9ec3a7cf..a0b1d784f1 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -102,20 +102,28 @@ let get_eq_type gl = let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in gl, EConstr.of_constr eq -let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac gl = +let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = + let open Proofview.Notations in + Proofview.tclEVARMAP >>= begin fun sigma -> (* some sanity checks *) - let oc, orig_clr, occ, c_gen, gl = match what with - | `EConstr(_,_,t) when EConstr.isEvar (project gl) t -> - anomaly "elim called on a constr evar" + match what with + | `EConstr(_,_,t) when EConstr.isEvar sigma t -> + anomaly "elim called on a constr evar" | `EGen (_, g) when elim = None && is_wildcard g -> errorstrm Pp.(str"Indeterminate pattern and no eliminator") | `EGen ((Some clr,occ), g) when is_wildcard g -> - None, clr, occ, None, gl - | `EGen ((None, occ), g) when is_wildcard g -> None,[],occ,None,gl + Proofview.tclUNIT (None, clr, occ, None) + | `EGen ((None, occ), g) when is_wildcard g -> + Proofview.tclUNIT (None,[],occ,None) | `EGen ((_, occ), p as gen) -> - let _, c, clr,gl = pf_interp_gen gl true gen in - Some c, clr, occ, Some p,gl - | `EConstr (clr, occ, c) -> Some c, clr, occ, None,gl in + pfLIFT (pf_interp_gen true gen) >>= fun (_,c,clr) -> + Proofview.tclUNIT (Some c, clr, occ, Some p) + | `EConstr (clr, occ, c) -> + Proofview.tclUNIT (Some c, clr, occ, None) + end >>= + + fun (oc, orig_clr, occ, c_gen) -> pfLIFT begin fun gl -> + let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); let fire_subst gl t = Reductionops.nf_evar (project gl) t in @@ -145,13 +153,26 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac (* finds the eliminator applies it to evars and c saturated as needed *) (* obtaining "elim ??? (c ???)". pred is the higher order evar *) (* cty is None when the user writes _ (hence we can't make a pattern *) - let cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = + (* `seed` represents the array of types from which we derive the name seeds + for the block intro patterns *) + let seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl = match elim with | Some elim -> let gl, elimty = pf_e_type_of gl elim in + let elimty = + let rename_elimty r = + EConstr.of_constr + (Arguments_renaming.rename_type + (EConstr.to_constr ~abort_on_undefined_evars:false (project gl) + elimty) r) in + match EConstr.kind (project gl) elim with + | Constr.Var kn -> rename_elimty (GlobRef.VarRef kn) + | Constr.Const (kn,_) -> rename_elimty (GlobRef.ConstRef kn) + | _ -> elimty + in let pred_id, n_elim_args, is_rec, elim_is_dep, n_pred_args,ctx_concl = analyze_eliminator elimty env (project gl) in - ind := Some (0, subgoals_tys (project gl) ctx_concl); + let seed = subgoals_tys (project gl) ctx_concl in let elim, elimty, elim_args, gl = pf_saturate ~beta:is_case gl elim ~ty:elimty n_elim_args in let pred = List.assoc pred_id elim_args in @@ -164,7 +185,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac | Some p -> interp_cpattern orig_gl p None | _ -> mkTpat gl c in Some(c, c_ty, pc), gl in - cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl | None -> let c = Option.get oc in let gl, c_ty = pfe_type_of gl c in let ((kn, i),_ as indu), unfolded_c_ty = @@ -183,11 +204,26 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let gl, elimty = pfe_type_of gl elim in let pred_id,n_elim_args,is_rec,elim_is_dep,n_pred_args,ctx_concl = analyze_eliminator elimty env (project gl) in - if is_case then - let mind,indb = Inductive.lookup_mind_specif env (kn,i) in - ind := Some(mind.Declarations.mind_nparams,Array.map EConstr.of_constr indb.Declarations.mind_nf_lc); - else - ind := Some (0, subgoals_tys (project gl) ctx_concl); + let seed = + if is_case then + let mind,indb = Inductive.lookup_mind_specif env (kn,i) in + let tys = indb.Declarations.mind_nf_lc in + let renamed_tys = + Array.mapi (fun j t -> + ppdebug(lazy Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); + let t = Arguments_renaming.rename_type t + (GlobRef.ConstructRef((kn,i),j+1)) in + ppdebug(lazy Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); + t) + tys + in + let drop_params x = + snd @@ EConstr.decompose_prod_n_assum (project gl) + mind.Declarations.mind_nparams (EConstr.of_constr x) in + Array.map drop_params renamed_tys + else + subgoals_tys (project gl) ctx_concl + in let rctx = fst (EConstr.decompose_prod_assum (project gl) unfolded_c_ty) in let n_c_args = Context.Rel.length rctx in let c, c_ty, t_args, gl = pf_saturate gl c ~ty:c_ty n_c_args in @@ -199,7 +235,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac | _ -> mkTpat gl c in let cty = Some (c, c_ty, pc) in let elimty = Reductionops.whd_all env (project gl) elimty in - cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl + seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl in ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat (EConstr.Unsafe.to_constr elim))); ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat (EConstr.Unsafe.to_constr elimty))); @@ -377,16 +413,29 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac in (* the elim tactic, with the eliminator and the predicated we computed *) let elim = project gl, elim in - let elim_tac gl = - Tacticals.tclTHENLIST [refine_with ~with_evars:false elim; old_cleartac clr] gl in - Tacticals.tclTHENLIST [gen_eq_tac; elim_intro_tac what eqid elim_tac is_rec clr] orig_gl + let seed = + Array.map (fun ty -> + let ctx,_ = EConstr.decompose_prod_assum (project gl) ty in + CList.rev_map Context.Rel.Declaration.get_name ctx) seed in + (elim,seed,clr,is_rec,gen_eq_tac), orig_gl -let no_intro ?ist what eqid elim_tac is_rec clr = elim_tac + end >>= fun (elim, seed,clr,is_rec,gen_eq_tac) -> + + let elim_tac = + Tacticals.New.tclTHENLIST [ + Proofview.V82.tactic (refine_with ~with_evars:false elim); + cleartac clr] in + let gen_eq_tac = Proofview.V82.tactic gen_eq_tac in + Tacticals.New.tclTHENLIST [gen_eq_tac; elim_intro_tac ?seed:(Some seed) what eqid elim_tac is_rec clr] +;; let elimtac x = - Proofview.V82.tactic ~nf_evars:false - (ssrelim ~is_case:false [] (`EConstr ([],None,x)) None no_intro) -let casetac x = ssrelim ~is_case:true [] (`EConstr ([],None,x)) None no_intro + let k ?seed:_ _what _eqid elim_tac _is_rec _clr = elim_tac in + ssrelim ~is_case:false [] (`EConstr ([],None,x)) None k + +let casetac x k = + let k ?seed _what _eqid elim_tac _is_rec _clr = k ?seed elim_tac in + ssrelim ~is_case:true [] (`EConstr ([],None,x)) None k let pf_nb_prod gl = nb_prod (project gl) (pf_concl gl) @@ -444,7 +493,4 @@ let perform_injection c gl = let ssrscase_or_inj_tac c = Proofview.V82.tactic ~nf_evars:false (fun gl -> if is_injection_case c gl then perform_injection c gl - else casetac c gl) - -let ssrscasetac c = - Proofview.V82.tactic ~nf_evars:false (fun gl -> casetac c gl) + else Proofview.V82.of_tactic (casetac c (fun ?seed:_ k -> k)) gl) diff --git a/plugins/ssr/ssrelim.mli b/plugins/ssr/ssrelim.mli index c7ffba917e..a1e2f63b8f 100644 --- a/plugins/ssr/ssrelim.mli +++ b/plugins/ssr/ssrelim.mli @@ -13,7 +13,6 @@ open Ssrmatching_plugin val ssrelim : - ?ind:(int * EConstr.types array) option ref -> ?is_case:bool -> ((Ssrast.ssrhyps option * Ssrast.ssrocc) * Ssrmatching.cpattern) @@ -29,27 +28,24 @@ val ssrelim : as 'a) -> ?elim:EConstr.constr -> Ssrast.ssripat option -> - ( 'a -> + (?seed:Names.Name.t list array -> 'a -> Ssrast.ssripat option -> - (Goal.goal Evd.sigma -> Goal.goal list Evd.sigma) -> - bool -> Ssrast.ssrhyp list -> Tacmach.tactic) -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + unit Proofview.tactic -> + bool -> Ssrast.ssrhyp list -> unit Proofview.tactic) -> + unit Proofview.tactic val elimtac : EConstr.constr -> unit Proofview.tactic val casetac : EConstr.constr -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma + (?seed:Names.Name.t list array -> unit Proofview.tactic -> unit Proofview.tactic) -> + unit Proofview.tactic val is_injection_case : EConstr.t -> Goal.goal Evd.sigma -> bool val perform_injection : EConstr.constr -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma -val ssrscasetac : - EConstr.constr -> - unit Proofview.tactic - val ssrscase_or_inj_tac : EConstr.constr -> unit Proofview.tactic diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 490e8fbdbc..64e023c68a 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -181,13 +181,18 @@ let norwocc = noclr, None let simplintac occ rdx sim gl = let simptac m gl = - if m <> ~-1 then - CErrors.user_err (Pp.str "Localized custom simpl tactic not supported"); - let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in - let simp env c _ _ = EConstr.Unsafe.to_constr (red_safe Tacred.simpl env sigma0 (EConstr.of_constr c)) in - Proofview.V82.of_tactic - (convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.Unsafe.to_constr concl0) rdx occ simp))) - gl in + if m <> ~-1 then begin + if rdx <> None then + CErrors.user_err (Pp.str "Custom simpl tactic does not support patterns"); + if occ <> None then + CErrors.user_err (Pp.str "Custom simpl tactic does not support occurrence numbers"); + simpltac (Simpl m) gl + end else + let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in + let simp env c _ _ = EConstr.Unsafe.to_constr (red_safe Tacred.simpl env sigma0 (EConstr.of_constr c)) in + Proofview.V82.of_tactic + (convert_concl_no_check (EConstr.of_constr (eval_pattern env0 sigma0 (EConstr.Unsafe.to_constr concl0) rdx occ simp))) + gl in match sim with | Simpl m -> simptac m gl | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) gl @@ -644,6 +649,6 @@ let unlocktac ist args gl = let key, gl = pf_mkSsrConst "master_key" gl in let ktacs = [ (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); - Ssrelim.casetac key ] in + Proofview.V82.of_tactic (Ssrelim.casetac key (fun ?seed:_ k -> k)) ] in tclTHENLIST (List.map utac args @ ktacs) gl diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index 6535cad8b7..b51ffada0c 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -285,6 +285,7 @@ Lemma unitE : all_equal_to tt. Proof. by case. Qed. (** A generic wrapper type **) +#[universes(template)] Structure wrapped T := Wrap {unwrap : T}. Canonical wrap T x := @Wrap T x. @@ -334,6 +335,7 @@ Section SimplFun. Variables aT rT : Type. +#[universes(template)] Variant simpl_fun := SimplFun of aT -> rT. Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 8cebe62e16..257ecd2a85 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -104,7 +104,7 @@ let havetac ist let itac_c = introstac (IPatClear clr :: pats) in let itac, id, clr = introstac pats, Tacticals.tclIDTAC, old_cleartac clr in let binderstac n = - let rec aux = function 0 -> [] | n -> IPatAnon One :: aux (n-1) in + let rec aux = function 0 -> [] | n -> IPatAnon (One None) :: aux (n-1) in Tacticals.tclTHEN (if binders <> [] then introstac (aux n) else Tacticals.tclIDTAC) (introstac binders) in let simpltac = introstac simpl in diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 0553260472..ce81d83661 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -27,15 +27,31 @@ module IpatMachine : sig val main : ?eqtac:unit tactic -> first_case_is_dispatch:bool -> ssripats -> unit tactic + + val tclSEED_SUBGOALS : Names.Name.t list array -> unit tactic -> unit tactic + end = struct (* {{{ *) module State : sig + type delayed_gen = { + tmp_id : Id.t; (* Temporary name *) + orig_name : Name.t (* Old name *) + } + (* to_clear API *) val isCLR_PUSH : Id.t -> unit tactic val isCLR_PUSHL : Id.t list -> unit tactic val isCLR_CONSUME : unit tactic + (* to_generalize API *) + val isGEN_PUSH : delayed_gen -> unit tactic + val isGEN_CONSUME : unit tactic + + (* name_seed API *) + val isNSEED_SET : Names.Name.t list -> unit tactic + val isNSEED_CONSUME : (Names.Name.t list option -> unit tactic) -> unit tactic + (* Some data may expire *) val isTICK : ssripat -> unit tactic @@ -48,10 +64,23 @@ type istate = { (* Delayed clear *) to_clear : Id.t list; + (* Temporary intros, to be generalized back *) + to_generalize : delayed_gen list; + + (* The type of the inductive constructor corresponding to the current proof + * branch: name seeds are taken from that in an intro block *) + name_seed : Names.Name.t list option; + +} +and delayed_gen = { + tmp_id : Id.t; (* Temporary name *) + orig_name : Name.t (* Old name *) } let empty_state = { to_clear = []; + to_generalize = []; + name_seed = None; } include Ssrcommon.MakeState(struct @@ -59,36 +88,77 @@ include Ssrcommon.MakeState(struct let init = empty_state end) +let print_name_seed env sigma = function + | None -> Pp.str "-" + | Some nl -> Pp.prlist Names.Name.print nl + +let print_delayed_gen { tmp_id; orig_name } = + Pp.(Id.print tmp_id ++ str"->" ++ Name.print orig_name) + let isPRINT g = + let env, sigma = Goal.env g, Goal.sigma g in let state = get g in Pp.(str"{{ to_clear: " ++ prlist_with_sep spc Id.print state.to_clear ++ spc () ++ - str" }}") + str"to_generalize: " ++ + prlist_with_sep spc print_delayed_gen state.to_generalize ++ spc () ++ + str"name_seed: " ++ print_name_seed env sigma state.name_seed ++ str" }}") let isCLR_PUSH id = - tclGET (fun { to_clear = ids } -> - tclSET { to_clear = id :: ids }) + tclGET (fun ({ to_clear = ids } as s) -> + tclSET { s with to_clear = id :: ids }) let isCLR_PUSHL more_ids = - tclGET (fun { to_clear = ids } -> - tclSET { to_clear = more_ids @ ids }) + tclGET (fun ({ to_clear = ids } as s) -> + tclSET { s with to_clear = more_ids @ ids }) let isCLR_CONSUME = - tclGET (fun { to_clear = ids } -> - tclSET { to_clear = [] } <*> + tclGET (fun ({ to_clear = ids } as s) -> + tclSET { s with to_clear = [] } <*> Tactics.clear ids) -let isTICK _ = tclUNIT () +let isGEN_PUSH dg = + tclGET (fun s -> + tclSET { s with to_generalize = dg :: s.to_generalize }) + +(* generalize `id` as `new_name` *) +let gen_astac id new_name = + let gen = ((None,Some(false,[])),Ssrmatching.cpattern_of_id id) in + V82.tactic (Ssrcommon.gentac gen) + <*> Ssrcommon.tclRENAME_HD_PROD new_name + +(* performs and resets all delayed generalizations *) +let isGEN_CONSUME = + tclGET (fun ({ to_generalize = dgs } as s) -> + tclSET { s with to_generalize = [] } <*> + Tacticals.New.tclTHENLIST + (List.map (fun { tmp_id; orig_name } -> + gen_astac tmp_id orig_name) dgs) <*> + Tactics.clear (List.map (fun gen -> gen.tmp_id) dgs)) + + +let isNSEED_SET ty = + tclGET (fun s -> + tclSET { s with name_seed = Some ty }) + +let isNSEED_CONSUME k = + tclGET (fun ({ name_seed = x } as s) -> + tclSET { s with name_seed = None } <*> + k x) + +let isTICK = function + | IPatSimpl _ | IPatClear _ -> tclUNIT () + | _ -> tclGET (fun s -> tclSET { s with name_seed = None }) end (* }}} *************************************************************** *) open State -(** [=> *] ****************************************************************) -(** [nb_assums] returns the number of dependent premises *) -(** Warning: unlike [nb_deps_assums], it does not perform reduction *) +(***[=> *] ****************************************************************) +(** [nb_assums] returns the number of dependent premises + Warning: unlike [nb_deps_assums], it does not perform reduction *) let rec nb_assums cur env sigma t = match EConstr.kind sigma t with | Prod(name,ty,body) -> @@ -105,18 +175,49 @@ let intro_anon_all = Goal.enter begin fun gl -> let sigma = Goal.sigma gl in let g = Goal.concl gl in let n = nb_assums env sigma g in - Tacticals.New.tclDO n Ssrcommon.tclINTRO_ANON + Tacticals.New.tclDO n (Ssrcommon.tclINTRO_ANON ()) +end + +(*** [=> >*] **************************************************************) +(** [nb_deps_assums] returns the number of dependent premises *) +let rec nb_deps_assums cur env sigma t = + let t' = Reductionops.whd_allnolet env sigma t in + match EConstr.kind sigma t' with + | Constr.Prod(name,ty,body) -> + if EConstr.Vars.noccurn sigma 1 body && + not (Typeclasses.is_class_type sigma ty) then cur + else nb_deps_assums (cur+1) env sigma body + | Constr.LetIn(name,ty,t1,t2) -> + nb_deps_assums (cur+1) env sigma t2 + | Constr.Cast(t,_,_) -> + nb_deps_assums cur env sigma t + | _ -> cur +let nb_deps_assums = nb_deps_assums 0 + +let intro_anon_deps = Goal.enter begin fun gl -> + let env = Goal.env gl in + let sigma = Goal.sigma gl in + let g = Goal.concl gl in + let n = nb_deps_assums env sigma g in + Tacticals.New.tclDO n (Ssrcommon.tclINTRO_ANON ()) end (** [intro_drop] behaves like [intro_anon] but registers the id of the introduced assumption for a delayed clear. *) let intro_drop = - Ssrcommon.tclINTRO ~id:None + Ssrcommon.tclINTRO ~id:Ssrcommon.Anon ~conclusion:(fun ~orig_name:_ ~new_name -> isCLR_PUSH new_name) +(** [intro_temp] behaves like [intro_anon] but registers the id of the + introduced assumption for a regeneralization. *) +let intro_anon_temp = + Ssrcommon.tclINTRO ~id:Ssrcommon.Anon + ~conclusion:(fun ~orig_name ~new_name -> + isGEN_PUSH { tmp_id = new_name; orig_name }) + (** [intro_end] performs the actions that have been delayed. *) let intro_end = - Ssrcommon.tcl0G (isCLR_CONSUME) + Ssrcommon.tcl0G ~default:() (isCLR_CONSUME <*> isGEN_CONSUME) (** [=> _] *****************************************************************) let intro_clear ids = @@ -138,6 +239,27 @@ let tacCHECK_HYPS_EXIST hyps = Goal.enter begin fun gl -> end (** [=> []] *****************************************************************) + +(* calls t1 then t2 on each subgoal passing to t2 the index of the current + * subgoal (starting from 0) as well as the number of subgoals *) +let tclTHENin t1 t2 = + tclUNIT () >>= begin fun () -> let i = ref (-1) in + t1 <*> numgoals >>= fun n -> + Goal.enter begin fun g -> incr i; t2 !i n end +end + +(* Attaches one element of `seeds` to each of the last k goals generated by +`tac`, where k is the size of `seeds` *) +let tclSEED_SUBGOALS seeds tac = + tclTHENin tac (fun i n -> + Ssrprinters.ppdebug (lazy Pp.(str"seeding")); + (* eg [case: (H _ : nat)] generates 3 goals: + - 1 for _ + - 2 for the nat constructors *) + let extra_goals = n - Array.length seeds in + if i < extra_goals then tclUNIT () + else isNSEED_SET seeds.(i - extra_goals)) + let tac_case t = Goal.enter begin fun _ -> Ssrcommon.tacTYPEOF t >>= fun ty -> @@ -145,10 +267,36 @@ let tac_case t = if is_inj then V82.tactic ~nf_evars:false (Ssrelim.perform_injection t) else - Ssrelim.ssrscasetac t + Goal.enter begin fun g -> + (Ssrelim.casetac t (fun ?seed k -> + match seed with + | None -> k + | Some seed -> tclSEED_SUBGOALS seed k)) + end end -(** [=> [: id]] ************************************************************) +(** [=> [^ seed ]] *********************************************************) +let tac_intro_seed interp_ipats fix = Goal.enter begin fun gl -> + isNSEED_CONSUME begin fun seeds -> + let seeds = + Ssrcommon.option_assert_get seeds Pp.(str"tac_intro_seed: no seed") in + let ipats = List.map (function + | Anonymous -> + let s = match fix with + | Prefix id -> Id.to_string id ^ "?" + | SuffixNum n -> "?" ^ string_of_int n + | SuffixId id -> "?" ^ Id.to_string id in + IPatAnon (One (Some s)) + | Name id -> + let s = match fix with + | Prefix fix -> Id.to_string fix ^ Id.to_string id + | SuffixNum n -> Id.to_string id ^ string_of_int n + | SuffixId fix -> Id.to_string id ^ Id.to_string fix in + IPatId (Id.of_string s)) seeds in + interp_ipats ipats +end end + +(*** [=> [: id]] ************************************************************) [@@@ocaml.warning "-3"] let mk_abstract_id = let open Coqlib in @@ -205,95 +353,111 @@ let tclLOG p t = end <*> t p - <*> + >>= fun ret -> Goal.enter begin fun g -> Ssrprinters.ppdebug (lazy Pp.(str "done: " ++ isPRINT g)); tclUNIT () end + >>= fun () -> tclUNIT ret -let rec ipat_tac1 ipat : unit tactic = +let notTAC = tclUNIT false + +(* returns true if it was a tactic (eg /ltac:tactic) *) +let rec ipat_tac1 ipat : bool tactic = match ipat with | IPatView (clear_if_id,l) -> - Ssrview.tclIPAT_VIEWS ~views:l ~clear_if_id + Ssrview.tclIPAT_VIEWS + ~views:l ~clear_if_id ~conclusion:(fun ~to_clear:clr -> intro_clear clr) - | IPatDispatch(true,[[]]) -> - tclUNIT () - | IPatDispatch(_,ipatss) -> - tclDISPATCH (List.map ipat_tac ipatss) + | IPatDispatch(true, Regular [[]]) -> + notTAC + | IPatDispatch(_, Regular ipatss) -> + tclDISPATCH (List.map ipat_tac ipatss) <*> notTAC + | IPatDispatch(_,Block id_block) -> + tac_intro_seed ipat_tac id_block <*> notTAC + + | IPatId id -> Ssrcommon.tclINTRO_ID id <*> notTAC + | IPatFastNondep -> intro_anon_deps <*> notTAC - | IPatId id -> Ssrcommon.tclINTRO_ID id + | IPatCase (Block id_block) -> + Ssrcommon.tclWITHTOP tac_case <*> tac_intro_seed ipat_tac id_block <*> notTAC - | IPatCase ipatss -> - tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss + | IPatCase (Regular ipatss) -> + tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss <*> notTAC | IPatInj ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) ipatss + <*> notTAC - | IPatAnon Drop -> intro_drop - | IPatAnon One -> Ssrcommon.tclINTRO_ANON - | IPatAnon All -> intro_anon_all + | IPatAnon Drop -> intro_drop <*> notTAC + | IPatAnon (One seed) -> Ssrcommon.tclINTRO_ANON ?seed () <*> notTAC + | IPatAnon All -> intro_anon_all <*> notTAC + | IPatAnon Temporary -> intro_anon_temp <*> notTAC - | IPatNoop -> tclUNIT () - | IPatSimpl Nop -> tclUNIT () + | IPatNoop -> notTAC + | IPatSimpl Nop -> notTAC | IPatClear ids -> tacCHECK_HYPS_EXIST ids <*> - intro_clear (List.map Ssrcommon.hyp_id ids) + intro_clear (List.map Ssrcommon.hyp_id ids) <*> + notTAC - | IPatSimpl (Simpl n) -> - V82.tactic ~nf_evars:false (Ssrequality.simpltac (Simpl n)) - | IPatSimpl (Cut n) -> - V82.tactic ~nf_evars:false (Ssrequality.simpltac (Cut n)) - | IPatSimpl (SimplCut (n,m)) -> - V82.tactic ~nf_evars:false (Ssrequality.simpltac (SimplCut (n,m))) + | IPatSimpl x -> + V82.tactic ~nf_evars:false (Ssrequality.simpltac x) <*> notTAC | IPatRewrite (occ,dir) -> Ssrcommon.tclWITHTOP - (fun x -> V82.tactic ~nf_evars:false (Ssrequality.ipat_rewrite occ dir x)) + (fun x -> V82.tactic ~nf_evars:false (Ssrequality.ipat_rewrite occ dir x)) <*> notTAC - | IPatAbstractVars ids -> tclMK_ABSTRACT_VARS ids + | IPatAbstractVars ids -> tclMK_ABSTRACT_VARS ids <*> notTAC - | IPatTac t -> t + | IPatEqGen t -> t <*> notTAC and ipat_tac pl : unit tactic = match pl with | [] -> tclUNIT () | pat :: pl -> - Ssrcommon.tcl0G (tclLOG pat ipat_tac1) <*> - isTICK pat <*> - ipat_tac pl + Ssrcommon.tcl0G ~default:false (tclLOG pat ipat_tac1) >>= fun was_tac -> + isTICK pat (* drops expired seeds *) >>= fun () -> + if was_tac then (* exception *) + let ip_before, case, ip_after = split_at_first_case pl in + let case = ssr_exception true case in + let case = option_to_list case in + ipat_tac (ip_before @ case @ ip_after) + else ipat_tac pl and tclIORPAT tac = function | [[]] -> tac | p -> Tacticals.New.tclTHENS tac (List.map ipat_tac p) -let split_at_first_case ipats = +and ssr_exception is_on = function + | Some (IPatCase l) when is_on -> Some (IPatDispatch(true, l)) + | x -> x + +and option_to_list = function None -> [] | Some x -> [x] + +and split_at_first_case ipats = let rec loop acc = function | (IPatSimpl _ | IPatClear _) as x :: rest -> loop (x :: acc) rest - | IPatCase _ as x :: xs -> CList.rev acc, Some x, xs + | (IPatCase _ | IPatDispatch _) as x :: xs -> CList.rev acc, Some x, xs | pats -> CList.rev acc, None, pats in loop [] ipats - -let ssr_exception is_on = function - | Some (IPatCase l) when is_on -> Some (IPatDispatch(true, l)) - | x -> x - -let option_to_list = function None -> [] | Some x -> [x] +;; (* Simple pass doing {x}/v -> /v{x} *) let elaborate_ipats l = let rec elab = function | [] -> [] | (IPatClear _ as p1) :: (IPatView _ as p2) :: rest -> p2 :: p1 :: elab rest - | IPatDispatch(s,p) :: rest -> IPatDispatch (s,List.map elab p) :: elab rest - | IPatCase p :: rest -> IPatCase (List.map elab p) :: elab rest + | IPatDispatch(s, Regular p) :: rest -> IPatDispatch (s, Regular (List.map elab p)) :: elab rest + | IPatCase (Regular p) :: rest -> IPatCase (Regular (List.map elab p)) :: elab rest | IPatInj p :: rest -> IPatInj (List.map elab p) :: elab rest - | (IPatTac _ | IPatId _ | IPatSimpl _ | IPatClear _ | + | (IPatEqGen _ | IPatId _ | IPatSimpl _ | IPatClear _ | IPatFastNondep | IPatAnon _ | IPatView _ | IPatNoop | IPatRewrite _ | - IPatAbstractVars _) as x :: rest -> x :: elab rest + IPatAbstractVars _ | IPatDispatch(_, Block _) | IPatCase(Block _)) as x :: rest -> x :: elab rest in elab l @@ -302,8 +466,8 @@ let main ?eqtac ~first_case_is_dispatch ipats = let ip_before, case, ip_after = split_at_first_case ipats in let case = ssr_exception first_case_is_dispatch case in let case = option_to_list case in - let eqtac = option_to_list (Option.map (fun x -> IPatTac x) eqtac) in - Ssrcommon.tcl0G (ipat_tac (ip_before @ case @ eqtac @ ip_after) <*> intro_end) + let eqtac = option_to_list (Option.map (fun x -> IPatEqGen x) eqtac) in + Ssrcommon.tcl0G ~default:() (ipat_tac (ip_before @ case @ eqtac @ ip_after) <*> intro_end) end (* }}} *) @@ -344,7 +508,7 @@ let mkCoqRefl t c env sigma = (** Intro patterns processing for elim tactic, in particular when used in conjunction with equation generation as in [elim E: x] *) -let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = +let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = let intro_eq = match eqid with | Some (IPatId ipat) when not is_rec -> @@ -356,7 +520,7 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = | Term.AtomicType (hd, _) when Ssrcommon.is_protect hd env sigma -> V82.tactic ~nf_evars:false Ssrcommon.unprotecttac <*> Ssrcommon.tclINTRO_ID ipat - | _ -> Ssrcommon.tclINTRO_ANON <*> intro_eq () + | _ -> Ssrcommon.tclINTRO_ANON () <*> intro_eq () end |_ -> Ssrcommon.errorstrm (Pp.str "Too many names in intro pattern") end in @@ -369,12 +533,9 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = | _, `EConstr(_,_,t) when EConstr.isVar sigma t -> EConstr.destVar sigma t | _ -> Ssrcommon.mk_anon_id "K" (Tacmach.New.pf_ids_of_hyps g) in - let elim_name = - if Ssrcommon.is_name_in_ipats elim_name ipats then - Ssrcommon.mk_anon_id "K" (Tacmach.New.pf_ids_of_hyps g) - else elim_name - in - Ssrcommon.tclINTRO_ID elim_name + Tacticals.New.tclFIRST + [ Ssrcommon.tclINTRO_ID elim_name + ; Ssrcommon.tclINTRO_ANON ~seed:"K" ()] end in let rec gen_eq_tac () = Goal.enter begin fun g -> let sigma, env, concl = Goal.(sigma g, env g, concl g) in @@ -389,7 +550,7 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = | _ -> assert false in let case = args.(Array.length args-1) in if not(EConstr.Vars.closed0 sigma case) - then Ssrcommon.tclINTRO_ANON <*> gen_eq_tac () + then Ssrcommon.tclINTRO_ANON () <*> gen_eq_tac () else Ssrcommon.tacTYPEOF case >>= fun case_ty -> let open EConstr in @@ -407,13 +568,14 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = intro_lhs <*> Ssrcommon.tclINTRO_ID ipat | _ -> tclUNIT () in - let unprot = + let unprotect = if eqid <> None && is_rec then V82.tactic ~nf_evars:false Ssrcommon.unprotecttac else tclUNIT () in - V82.of_tactic begin - V82.tactic ~nf_evars:false ssrelim <*> - tclIPAT_EQ (intro_eq <*> unprot) ipats - end + begin match seed with + | None -> ssrelim + | Some s -> IpatMachine.tclSEED_SUBGOALS s ssrelim end <*> + tclIPAT_EQ (intro_eq <*> unprotect) ipats +;; let mkEq dir cl c t n env sigma = let open EConstr in @@ -506,13 +668,11 @@ let ssrelimtac (view, (eqid, (dgens, ipats))) = | [v] -> Ssrcommon.tclINTERP_AST_CLOSURE_TERM_AS_CONSTR v >>= fun cs -> tclDISPATCH (List.map (fun elim -> - V82.tactic ~nf_evars:false (Ssrelim.ssrelim deps (`EGen gen) ~elim eqid (elim_intro_tac ipats))) cs) | [] -> tclINDEPENDENT - (V82.tactic ~nf_evars:false - (Ssrelim.ssrelim deps (`EGen gen) eqid (elim_intro_tac ipats))) + (Ssrelim.ssrelim deps (`EGen gen) eqid (elim_intro_tac ipats)) | _ -> Ssrcommon.errorstrm Pp.(str "elim: only one elimination lemma can be provided") @@ -535,9 +695,8 @@ let ssrcasetac (view, (eqid, (dgens, ipats))) = if view <> [] && eqid <> None && deps = [] then [gen], [], None else deps, clear, occ in - V82.tactic ~nf_evars:false - (Ssrelim.ssrelim ~is_case:true deps (`EConstr (clear, occ, vc)) - eqid (elim_intro_tac ipats)) + Ssrelim.ssrelim ~is_case:true deps (`EConstr (clear, occ, vc)) + eqid (elim_intro_tac ipats) in if view = [] then conclusion false c clear c else tacVIEW_THEN_GRAB ~simple_types:false view ~conclusion info) @@ -556,18 +715,16 @@ let pushmoveeqtac cl c = Goal.enter begin fun g -> Tactics.apply_type ~typecheck:true (EConstr.mkProd (x, t, cl2)) [c; eqc] end -let eqmovetac _ gen = Goal.enter begin fun g -> - Ssrcommon.tacSIGMA >>= fun gl -> - let cl, c, _, gl = Ssrcommon.pf_interp_gen gl false gen in - Unsafe.tclEVARS (Tacmach.project gl) <*> - pushmoveeqtac cl c -end +let eqmovetac _ gen = + Ssrcommon.pfLIFT (Ssrcommon.pf_interp_gen false gen) >>= + fun (cl, c, _) -> pushmoveeqtac cl c +;; let rec eqmoveipats eqpat = function | (IPatSimpl _ | IPatClear _ as ipat) :: ipats -> ipat :: eqmoveipats eqpat ipats | (IPatAnon All :: _ | []) as ipats -> - IPatAnon One :: eqpat :: ipats + IPatAnon (One None) :: eqpat :: ipats | ipat :: ipats -> ipat :: eqpat :: ipats @@ -700,7 +857,7 @@ let ssrabstract dgens = let open Ssrmatching in let ipats = List.map (fun (_,cp) -> match id_of_pattern (interp_cpattern gl0 cp None) with - | None -> IPatAnon One + | None -> IPatAnon (One None) | Some id -> IPatId id) (List.tl gens) in conclusion ipats diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index c9221ef758..76726009ac 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -608,15 +608,15 @@ let ipat_of_intro_pattern p = Tactypes.( | IntroNaming (IntroIdentifier id) -> IPatId id | IntroAction IntroWildcard -> IPatAnon Drop | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> - IPatCase - (List.map (List.map ipat_of_intro_pattern) - (List.map (List.map remove_loc) iorpat)) + IPatCase (Regular( + List.map (List.map ipat_of_intro_pattern) + (List.map (List.map remove_loc) iorpat))) | IntroAction (IntroOrAndPattern (IntroAndPattern iandpat)) -> IPatCase - [List.map ipat_of_intro_pattern (List.map remove_loc iandpat)] - | IntroNaming IntroAnonymous -> IPatAnon One + (Regular [List.map ipat_of_intro_pattern (List.map remove_loc iandpat)]) + | IntroNaming IntroAnonymous -> IPatAnon (One None) | IntroAction (IntroRewrite b) -> IPatRewrite (allocc, if b then L2R else R2L) - | IntroNaming (IntroFresh id) -> IPatAnon One + | IntroNaming (IntroFresh id) -> IPatAnon (One None) | IntroAction (IntroApplyOn _) -> (* to do *) CErrors.user_err (Pp.str "TO DO") | IntroAction (IntroInjection ips) -> IPatInj [List.map ipat_of_intro_pattern (List.map remove_loc ips)] @@ -629,15 +629,21 @@ let ipat_of_intro_pattern p = Tactypes.( ) let rec map_ipat map_id map_ssrhyp map_ast_closure_term = function - | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x + | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop | IPatFastNondep) as x -> x | IPatId id -> IPatId (map_id id) | IPatAbstractVars l -> IPatAbstractVars (List.map map_id l) | IPatClear clr -> IPatClear (List.map map_ssrhyp clr) - | IPatCase iorpat -> IPatCase (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) - | IPatDispatch (s,iorpat) -> IPatDispatch (s,List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) + | IPatCase (Regular iorpat) -> IPatCase (Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) + | IPatCase (Block(hat)) -> IPatCase (Block(map_block map_id hat)) + | IPatDispatch (s, Regular iorpat) -> IPatDispatch (s, Regular (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat)) + | IPatDispatch (s, Block (hat)) -> IPatDispatch (s, Block(map_block map_id hat)) | IPatInj iorpat -> IPatInj (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) | IPatView (clr,v) -> IPatView (clr,List.map map_ast_closure_term v) - | IPatTac _ -> assert false (*internal usage only *) + | IPatEqGen _ -> assert false (*internal usage only *) +and map_block map_id = function + | Prefix id -> Prefix (map_id id) + | SuffixId id -> SuffixId (map_id id) + | SuffixNum _ as x -> x type ssripatrep = ssripat let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat @@ -688,6 +694,18 @@ let rec add_intro_pattern_hyps ipat hyps = * we have no clue what a name could be bound to (maybe another ipat) *) let interp_ipat ist gl = let ltacvar id = Id.Map.mem id ist.Tacinterp.lfun in + let interp_block = function + | Prefix id when ltacvar id -> + begin match interp_introid ist gl id with + | IntroNaming (IntroIdentifier id) -> Prefix id + | _ -> Ssrcommon.errorstrm Pp.(str"Variable " ++ Id.print id ++ str" in block intro pattern should be bound to an identifier.") + end + | SuffixId id when ltacvar id -> + begin match interp_introid ist gl id with + | IntroNaming (IntroIdentifier id) -> SuffixId id + | _ -> Ssrcommon.errorstrm Pp.(str"Variable " ++ Id.print id ++ str" in block intro pattern should be bound to an identifier.") + end + | x -> x in let rec interp = function | IPatId id when ltacvar id -> ipat_of_intro_pattern (interp_introid ist gl id) @@ -698,17 +716,21 @@ let interp_ipat ist gl = add_intro_pattern_hyps CAst.(make ?loc (interp_introid ist gl id)) hyps in let clr' = List.fold_right add_hyps clr [] in check_hyps_uniq [] clr'; IPatClear clr' - | IPatCase(iorpat) -> - IPatCase(List.map (List.map interp) iorpat) - | IPatDispatch(s,iorpat) -> - IPatDispatch(s,List.map (List.map interp) iorpat) + | IPatCase(Regular iorpat) -> + IPatCase(Regular(List.map (List.map interp) iorpat)) + | IPatCase(Block(hat)) -> IPatCase(Block(interp_block hat)) + + | IPatDispatch(s,Regular iorpat) -> + IPatDispatch(s,Regular (List.map (List.map interp) iorpat)) + | IPatDispatch(s,Block(hat)) -> IPatDispatch(s,Block(interp_block hat)) + | IPatInj iorpat -> IPatInj (List.map (List.map interp) iorpat) | IPatAbstractVars l -> IPatAbstractVars (List.map get_intro_id (List.map (interp_introid ist gl) l)) | IPatView (clr,l) -> IPatView (clr,List.map (fun x -> snd(interp_ast_closure_term ist gl x)) l) - | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x - | IPatTac _ -> assert false (*internal usage only *) + | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop | IPatFastNondep) as x -> x + | IPatEqGen _ -> assert false (*internal usage only *) in interp @@ -729,19 +751,11 @@ ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } GLOBALIZED BY { intern_ipats } | [ "_" ] -> { [IPatAnon Drop] } | [ "*" ] -> { [IPatAnon All] } - (* - | [ "^" "*" ] -> { [IPatFastMode] } - | [ "^" "_" ] -> { [IPatSeed `Wild] } - | [ "^_" ] -> { [IPatSeed `Wild] } - | [ "^" "?" ] -> { [IPatSeed `Anon] } - | [ "^?" ] -> { [IPatSeed `Anon] } - | [ "^" ident(id) ] -> { [IPatSeed (`Id(id,`Pre))] } - | [ "^" "~" ident(id) ] -> { [IPatSeed (`Id(id,`Post))] } - | [ "^~" ident(id) ] -> { [IPatSeed (`Id(id,`Post))] } - *) + | [ ">" ] -> { [IPatFastNondep] } | [ ident(id) ] -> { [IPatId id] } - | [ "?" ] -> { [IPatAnon One] } -(* TODO | [ "+" ] -> [ [IPatAnon Temporary] ] *) + | [ "?" ] -> { [IPatAnon (One None)] } + | [ "+" ] -> { [IPatAnon Temporary] } + | [ "++" ] -> { [IPatAnon Temporary; IPatAnon Temporary] } | [ ssrsimpl_ne(sim) ] -> { [IPatSimpl sim] } | [ ssrdocc(occ) "->" ] -> { match occ with | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") @@ -805,28 +819,42 @@ let reject_ssrhid strm = let test_nohidden = Pcoq.Entry.of_parser "test_ssrhid" reject_ssrhid +let rec reject_binder crossed_paren k s = + match + try Some (Util.stream_nth k s) + with Stream.Failure -> None + with + | Some (Tok.KEYWORD "(") when not crossed_paren -> reject_binder true (k+1) s + | Some (Tok.IDENT _) when crossed_paren -> reject_binder true (k+1) s + | Some (Tok.KEYWORD ":" | Tok.KEYWORD ":=") when crossed_paren -> + raise Stream.Failure + | Some (Tok.KEYWORD ")") when crossed_paren -> raise Stream.Failure + | _ -> if crossed_paren then () else raise Stream.Failure + +let _test_nobinder = Pcoq.Entry.of_parser "test_nobinder" (reject_binder false 0) + } ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY { pr_ssripat } - | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> { IPatCase(x) } + | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> { IPatCase(Regular x) } END (* Pcoq *) GRAMMAR EXTEND Gram GLOBAL: ssrcpat; + hat: [ + [ "^"; id = ident -> { Prefix id } + | "^"; "~"; id = ident -> { SuffixId id } + | "^"; "~"; n = natural -> { SuffixNum n } + | "^~"; id = ident -> { SuffixId id } + | "^~"; n = natural -> { SuffixNum n } + ]]; ssrcpat: [ - [ test_nohidden; "["; iorpat = ssriorpat; "]" -> { -(* check_no_inner_seed !@loc false iorpat; - IPatCase (understand_case_type iorpat) *) - IPatCase iorpat } -(* - | test_nohidden; "("; iorpat = ssriorpat; ")" -> -(* check_no_inner_seed !@loc false iorpat; - IPatCase (understand_case_type iorpat) *) - IPatDispatch iorpat -*) + [ test_nohidden; "["; hat_id = hat; "]" -> { + IPatCase (Block(hat_id)) } + | test_nohidden; "["; iorpat = ssriorpat; "]" -> { + IPatCase (Regular iorpat) } | test_nohidden; "[="; iorpat = ssriorpat; "]" -> { -(* check_no_inner_seed !@loc false iorpat; *) IPatInj iorpat } ]]; END @@ -1474,9 +1502,9 @@ let intro_id_to_binder = List.map (function let binder_to_intro_id = CAst.(List.map (function | (FwdPose, [BFvar]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } | (FwdPose, [BFdecl _]), { v = CLambdaN ([CLocalAssum(ids,_,_)],_) } -> - List.map (function {v=Name id} -> IPatId id | _ -> IPatAnon One) ids + List.map (function {v=Name id} -> IPatId id | _ -> IPatAnon (One None)) ids | (FwdPose, [BFdef]), { v = CLetIn ({v=Name id},_,_,_) } -> [IPatId id] - | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon One] + | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon (One None)] | _ -> anomaly "ssrbinder is not a binder")) let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = @@ -1968,7 +1996,8 @@ GRAMMAR EXTEND Gram ssreqpat: [ [ id = Prim.ident -> { IPatId id } | "_" -> { IPatAnon Drop } - | "?" -> { IPatAnon One } + | "?" -> { IPatAnon (One None) } + | "+" -> { IPatAnon Temporary } | occ = ssrdocc; "->" -> { match occ with | None, occ -> IPatRewrite (occ, L2R) | _ -> CErrors.user_err ~loc (str"Only occurrences are allowed here") } diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 8bf4816e99..898e03b00e 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -100,21 +100,27 @@ let rec pr_ipat p = | IPatId id -> Id.print id | IPatSimpl sim -> pr_simpl sim | IPatClear clr -> pr_clear mt clr - | IPatCase iorpat -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") - | IPatDispatch(_,iorpat) -> hov 1 (str "/[" ++ pr_iorpat iorpat ++ str "]") + | IPatCase (Regular iorpat) -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") + | IPatCase (Block m) -> hov 1 (str"[" ++ pr_block m ++ str"]") + | IPatDispatch(_,Regular iorpat) -> hov 1 (str "(" ++ pr_iorpat iorpat ++ str ")") + | IPatDispatch (_,Block m) -> hov 1 (str"(" ++ pr_block m ++ str")") | IPatInj iorpat -> hov 1 (str "[=" ++ pr_iorpat iorpat ++ str "]") | IPatRewrite (occ, dir) -> pr_occ occ ++ pr_dir dir | IPatAnon All -> str "*" | IPatAnon Drop -> str "_" - | IPatAnon One -> str "?" + | IPatAnon (One _) -> str "?" | IPatView (false,v) -> pr_view2 v | IPatView (true,v) -> str"{}" ++ pr_view2 v + | IPatAnon Temporary -> str "+" | IPatNoop -> str "-" | IPatAbstractVars l -> str "[:" ++ pr_list spc Id.print l ++ str "]" - | IPatTac _ -> str "<tac>" -(* TODO | IPatAnon Temporary -> str "+" *) + | IPatFastNondep -> str">" + | IPatEqGen _ -> str "<tac>" and pr_ipats ipats = pr_list spc pr_ipat ipats and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat +and pr_block = function (Prefix id) -> str"^" ++ Id.print id + | (SuffixId id) -> str"^~" ++ Id.print id + | (SuffixNum n) -> str"^~" ++ int n (* 0 cost pp function. Active only if Debug Ssreflect is Set *) let ppdebug_ref = ref (fun _ -> ()) diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 4ed75cdbe4..191a4e9a20 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -359,7 +359,7 @@ let coerce_search_pattern_to_sort hpat = Pattern.PApp (fp, args') in let hr, na = splay_search_pattern 0 hpat in let dc, ht = - let hr, _ = Typeops.type_of_global_in_context env hr (** FIXME *) in + let hr, _ = Typeops.type_of_global_in_context env hr (* FIXME *) in Reductionops.splay_prod env sigma (EConstr.of_constr hr) in let np = List.length dc in if np < na then CErrors.user_err (Pp.str "too many arguments in head search pattern") else diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 3f974ea063..4816027296 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -45,16 +45,11 @@ module AdaptorDb = struct let t' = Detyping.subst_glob_constr subst t in if t' == t then a else k, t' - let classify_adaptor x = Libobject.Substitute x - let in_db = - Libobject.declare_object { - (Libobject.default_object "VIEW_ADAPTOR_DB") - with - Libobject.open_function = (fun i o -> if i = 1 then cache_adaptor o); - Libobject.cache_function = cache_adaptor; - Libobject.subst_function = subst_adaptor; - Libobject.classify_function = classify_adaptor } + let open Libobject in + declare_object @@ global_object_nodischarge "VIEW_ADAPTOR_DB" + ~cache:cache_adaptor + ~subst:(Some subst_adaptor) let declare kind terms = List.iter (fun term -> Lib.add_anonymous_leaf (in_db (kind,term))) @@ -64,18 +59,23 @@ end (* Forward View application code *****************************************) +let reduce_or l = tclUNIT (List.fold_left (||) false l) + module State : sig (* View storage API *) - val vsINIT : EConstr.t * Id.t list -> unit tactic + val vsINIT : view:EConstr.t -> subject_name:Id.t list -> to_clear:Id.t list -> unit tactic val vsPUSH : (EConstr.t -> (EConstr.t * Id.t list) tactic) -> unit tactic - val vsCONSUME : (name:Id.t option -> EConstr.t -> to_clear:Id.t list -> unit tactic) -> unit tactic + val vsCONSUME : (names:Id.t list -> EConstr.t -> to_clear:Id.t list -> unit tactic) -> unit tactic + + (* The bool is the || of the bool returned by the continuations *) + val vsCONSUME_IF_PRESENT : (names:Id.t list -> EConstr.t option -> to_clear:Id.t list -> bool tactic) -> bool tactic val vsASSERT_EMPTY : unit tactic end = struct (* {{{ *) type vstate = { - subject_name : Id.t option; (* top *) + subject_name : Id.t list; (* top *) (* None if views are being applied to a term *) view : EConstr.t; (* v2 (v1 top) *) to_clear : Id.t list; @@ -86,34 +86,43 @@ include Ssrcommon.MakeState(struct let init = None end) -let vsINIT (view, to_clear) = - tclSET (Some { subject_name = None; view; to_clear }) +let vsINIT ~view ~subject_name ~to_clear = + tclSET (Some { subject_name; view; to_clear }) + +(** Initializes the state in which view data is accumulated when views are +applied to the first assumption in the goal *) +let vsBOOTSTRAP = Goal.enter_one ~__LOC__ begin fun gl -> + let concl = Goal.concl gl in + let id = (* We keep the orig name for checks in "in" tcl *) + match EConstr.kind_of_type (Goal.sigma gl) concl with + | Term.ProdType(Name.Name id, _, _) + when Ssrcommon.is_discharged_id id -> id + | _ -> mk_anon_id "view_subject" (Tacmach.New.pf_ids_of_hyps gl) in + let view = EConstr.mkVar id in + Ssrcommon.tclINTRO_ID id <*> + tclSET (Some { subject_name = [id]; view; to_clear = [] }) +end -let vsPUSH k = - tacUPDATE (fun s -> match s with +let rec vsPUSH k = + tclINDEPENDENT (tclGET (function | Some { subject_name; view; to_clear } -> k view >>= fun (view, clr) -> - tclUNIT (Some { subject_name; view; to_clear = to_clear @ clr }) - | None -> - Goal.enter_one ~__LOC__ begin fun gl -> - let concl = Goal.concl gl in - let id = (* We keep the orig name for checks in "in" tcl *) - match EConstr.kind_of_type (Goal.sigma gl) concl with - | Term.ProdType(Name.Name id, _, _) - when Ssrcommon.is_discharged_id id -> id - | _ -> mk_anon_id "view_subject" (Tacmach.New.pf_ids_of_hyps gl) in - let view = EConstr.mkVar id in - Ssrcommon.tclINTRO_ID id <*> - k view >>= fun (view, to_clear) -> - tclUNIT (Some { subject_name = Some id; view; to_clear }) - end) - -let vsCONSUME k = - tclGET (fun s -> match s with + tclSET (Some { subject_name; view; to_clear = to_clear @ clr }) + | None -> vsBOOTSTRAP <*> vsPUSH k)) + +let rec vsCONSUME k = + tclINDEPENDENT (tclGET (function | Some { subject_name; view; to_clear } -> tclSET None <*> - k ~name:subject_name view ~to_clear - | None -> anomaly "vsCONSUME: empty storage") + k ~names:subject_name view ~to_clear + | None -> vsBOOTSTRAP <*> vsCONSUME k)) + +let vsCONSUME_IF_PRESENT k = + tclINDEPENDENTL (tclGET1 (function + | Some { subject_name; view; to_clear } -> + tclSET None <*> + k ~names:subject_name (Some view) ~to_clear + | None -> k ~names:[] None ~to_clear:[])) >>= reduce_or let vsASSERT_EMPTY = tclGET (function @@ -133,13 +142,19 @@ let intern_constr_expr { Genintern.genv; ltacvars = vars } sigma ce = To allow for t being a notation, like "Notation foo x := ltac:(foo x)", we need to internalize t. *) -let is_tac_in_term { body; glob_env; interp_env } = +let is_tac_in_term ?extra_scope { body; glob_env; interp_env } = Goal.(enter_one ~__LOC__ begin fun goal -> let genv = env goal in let sigma = sigma goal in let ist = Ssrcommon.option_assert_get glob_env (Pp.str"not a term") in (* We use the env of the goal, not the global one *) let ist = { ist with Genintern.genv } in + (* We open extra_scope *) + let body = + match extra_scope with + | None -> body + | Some s -> CAst.make (Constrexpr.CDelimiters(s,body)) + in (* We unravel notations *) let g = intern_constr_expr ist sigma body in match DAst.get g with @@ -305,51 +320,83 @@ end let pose_proof subject_name p = Tactics.generalize [p] <*> - Option.cata - (fun id -> Ssrcommon.tclRENAME_HD_PROD (Name.Name id)) (tclUNIT()) - subject_name + begin match subject_name with + | id :: _ -> Ssrcommon.tclRENAME_HD_PROD (Name.Name id) + | _ -> tclUNIT() end <*> Tactics.New.reduce_after_refine -let rec apply_all_views ~clear_if_id ending vs s0 = +(* returns true if the last item was a tactic *) +let rec apply_all_views_aux ~clear_if_id vs finalization conclusion s0 = match vs with - | [] -> ending s0 + | [] -> finalization s0 (fun name p -> + (match p with + | None -> conclusion ~to_clear:[] + | Some p -> + pose_proof name p <*> conclusion ~to_clear:name) <*> + tclUNIT false) | v :: vs -> Ssrprinters.ppdebug (lazy Pp.(str"piling...")); - is_tac_in_term v >>= function - | `Tac tac -> - Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); - ending s0 <*> Tacinterp.eval_tactic tac <*> - Ssrcommon.tacSIGMA >>= apply_all_views ~clear_if_id ending vs + is_tac_in_term ~extra_scope:"ssripat" v >>= function | `Term v -> Ssrprinters.ppdebug (lazy Pp.(str"..a term")); pile_up_view ~clear_if_id v <*> - apply_all_views ~clear_if_id ending vs s0 + apply_all_views_aux ~clear_if_id vs finalization conclusion s0 + | `Tac tac -> + Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); + finalization s0 (fun name p -> + (match p with + | None -> tclUNIT () + | Some p -> pose_proof name p) <*> + Tacinterp.eval_tactic tac <*> + if vs = [] then begin + Ssrprinters.ppdebug (lazy Pp.(str"..was the last view")); + conclusion ~to_clear:name <*> tclUNIT true + end else + Tactics.clear name <*> + tclINDEPENDENTL begin + Ssrprinters.ppdebug (lazy Pp.(str"..was NOT the last view")); + Ssrcommon.tacSIGMA >>= + apply_all_views_aux ~clear_if_id vs finalization conclusion + end >>= reduce_or) + +let apply_all_views vs ~conclusion ~clear_if_id = + let finalization s0 k = + State.vsCONSUME_IF_PRESENT (fun ~names t ~to_clear -> + match t with + | None -> k [] None + | Some t -> + finalize_view s0 t >>= fun p -> k (names @ to_clear) (Some p)) in + Ssrcommon.tacSIGMA >>= + apply_all_views_aux ~clear_if_id vs finalization conclusion + +(* We apply a view to a term given by the user, e.g. `case/V: x`. `x` is + `subject` *) +let apply_all_views_to subject ~simple_types vs ~conclusion = begin + let rec process_all_vs = function + | [] -> tclUNIT () + | v :: vs -> is_tac_in_term v >>= function + | `Tac _ -> Ssrcommon.errorstrm Pp.(str"tactic view not supported") + | `Term v -> pile_up_view ~clear_if_id:false v <*> process_all_vs vs in + State.vsASSERT_EMPTY <*> + State.vsINIT ~subject_name:[] ~to_clear:[] ~view:subject <*> + Ssrcommon.tacSIGMA >>= fun s0 -> + process_all_vs vs <*> + State.vsCONSUME (fun ~names:_ t ~to_clear:_ -> + finalize_view s0 ~simple_types t >>= conclusion) +end (* Entry points *********************************************************) -let tclIPAT_VIEWS ~views:vs ?(clear_if_id=false) ~conclusion:tac = - let end_view_application s0 = - State.vsCONSUME (fun ~name t ~to_clear -> - let to_clear = Option.cata (fun x -> [x]) [] name @ to_clear in - finalize_view s0 t >>= pose_proof name <*> tac ~to_clear) in - tclINDEPENDENT begin +let tclIPAT_VIEWS ~views:vs ?(clear_if_id=false) ~conclusion = + tclINDEPENDENTL begin State.vsASSERT_EMPTY <*> - Ssrcommon.tacSIGMA >>= - apply_all_views ~clear_if_id end_view_application vs <*> - State.vsASSERT_EMPTY - end - -let tclWITH_FWD_VIEWS ~simple_types ~subject ~views:vs ~conclusion:tac = - let ending_tac s0 = - State.vsCONSUME (fun ~name:_ t ~to_clear:_ -> - finalize_view s0 ~simple_types t >>= tac) in - tclINDEPENDENT begin + apply_all_views vs ~conclusion ~clear_if_id >>= fun was_tac -> State.vsASSERT_EMPTY <*> - State.vsINIT (subject,[]) <*> - Ssrcommon.tacSIGMA >>= - apply_all_views ~clear_if_id:false ending_tac vs <*> - State.vsASSERT_EMPTY - end + tclUNIT was_tac + end >>= reduce_or + +let tclWITH_FWD_VIEWS ~simple_types ~subject ~views:vs ~conclusion = + tclINDEPENDENT (apply_all_views_to subject ~simple_types vs ~conclusion) (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrview.mli b/plugins/ssr/ssrview.mli index b128a95da7..fb9203263a 100644 --- a/plugins/ssr/ssrview.mli +++ b/plugins/ssr/ssrview.mli @@ -22,11 +22,12 @@ end (* Apply views to the top of the stack (intro pattern). If clear_if_id is * true (default false) then views that happen to be a variable are considered - * as to be cleared (see the to_clear argument to the continuation) *) -val tclIPAT_VIEWS : - views:ast_closure_term list -> ?clear_if_id:bool -> + * as to be cleared (see the to_clear argument to the continuation) + * + * returns true if the last view was a tactic *) +val tclIPAT_VIEWS : views:ast_closure_term list -> ?clear_if_id:bool -> conclusion:(to_clear:Names.Id.t list -> unit Proofview.tactic) -> - unit Proofview.tactic + bool Proofview.tactic (* Apply views to a given subject (as if was the top of the stack), then call conclusion on the obtained term (something like [v2 (v1 subject)]). diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 6497b6ff98..efd65ade15 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -122,6 +122,7 @@ let add_genarg tag pr = (** Constructors for cast type *) let dC t = CastConv t + (** Constructors for constr_expr *) let isCVar = function { CAst.v = CRef (qid,_) } -> qualid_is_ident qid | _ -> false let destCVar = function @@ -139,6 +140,7 @@ let mkCLambda ?loc name ty t = CAst.make ?loc @@ let mkCLetIn ?loc name bo t = CAst.make ?loc @@ CLetIn ((CAst.make ?loc name), bo, None, t) let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, dC ty) + (** Constructors for rawconstr *) let mkRHole = DAst.make @@ GHole (InternalHole, IntroAnonymous, None) let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) @@ -925,7 +927,7 @@ let of_ftactic ftac gl = let tac = Proofview.V82.of_tactic tac in let { sigma = sigma } = tac gl in let ans = match !r with - | None -> assert false (** If the tactic failed we should not reach this point *) + | None -> assert false (* If the tactic failed we should not reach this point *) | Some ans -> ans in (sigma, ans) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 8672c55767..ff2c900130 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -1,5 +1,14 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + (* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) -(* Distributed under the terms of CeCILL-B. *) open Goal open Environ @@ -194,6 +203,7 @@ val cpattern_of_term : char * glob_constr_and_expr -> Geninterp.interp_sign -> c (** [do_once r f] calls [f] and updates the ref only once *) val do_once : 'a option ref -> (unit -> 'a) -> unit + (** [assert_done r] return the content of r. @raise Anomaly is r is [None] *) val assert_done : 'a option ref -> 'a diff --git a/plugins/ssrmatching/ssrmatching.v b/plugins/ssrmatching/ssrmatching.v index 9a53e1dd1a..a39f76db9e 100644 --- a/plugins/ssrmatching/ssrmatching.v +++ b/plugins/ssrmatching/ssrmatching.v @@ -1,5 +1,15 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + (* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) -(* Distributed under the terms of CeCILL-B. *) + Declare ML Module "ssrmatching_plugin". Module SsrMatchingSyntax. diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml deleted file mode 100644 index 94255bab6c..0000000000 --- a/plugins/syntax/ascii_syntax.ml +++ /dev/null @@ -1,100 +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) *) -(************************************************************************) - - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "ascii_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -open Pp -open CErrors -open Util -open Names -open Glob_term -open Globnames -open Coqlib - -exception Non_closed_ascii - -let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) - -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false - -let ascii_module = ["Coq";"Strings";"Ascii"] -let ascii_modpath = MPfile (make_dir ascii_module) - -let ascii_path = make_path ascii_module "ascii" - -let ascii_label = Label.make "ascii" -let ascii_kn = MutInd.make2 ascii_modpath ascii_label -let path_of_Ascii = ((ascii_kn,0),1) -let static_glob_Ascii = ConstructRef path_of_Ascii - -let glob_Ascii = lazy (lib_ref "plugins.syntax.Ascii") - -open Lazy - -let interp_ascii ?loc p = - let rec aux n p = - if Int.equal n 0 then [] else - let mp = p mod 2 in - (DAst.make ?loc @@ GRef (lib_ref (if Int.equal mp 0 then "core.bool.false" else "core.bool.true"),None)) - :: (aux (n-1) (p/2)) in - DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) - -let interp_ascii_string ?loc s = - let p = - if Int.equal (String.length s) 1 then int_of_char s.[0] - else - if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] - then int_of_string s - else - user_err ?loc ~hdr:"interp_ascii_string" - (str "Expects a single character or a three-digits ascii code.") in - interp_ascii ?loc p - -let uninterp_ascii r = - let rec uninterp_bool_list n = function - | [] when Int.equal n 0 -> 0 - | r::l when is_gr r (lib_ref "core.bool.true") -> 1+2*(uninterp_bool_list (n-1) l) - | r::l when is_gr r (lib_ref "core.bool.false") -> 2*(uninterp_bool_list (n-1) l) - | _ -> raise Non_closed_ascii in - try - let aux c = match DAst.get c with - | GApp (r, l) when is_gr r (force glob_Ascii) -> uninterp_bool_list 8 l - | _ -> raise Non_closed_ascii in - Some (aux r) - with - Non_closed_ascii -> None - -let make_ascii_string n = - if n>=32 && n<=126 then String.make 1 (char_of_int n) - else Printf.sprintf "%03d" n - -let uninterp_ascii_string (AnyGlobConstr r) = Option.map make_ascii_string (uninterp_ascii r) - -open Notation - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -let _ = - let sc = "char_scope" in - register_string_interpretation sc (interp_ascii_string,uninterp_ascii_string); - at_declare_ml_module enable_prim_token_interpretation - { pt_local = false; - pt_scope = sc; - pt_interp_info = Uid sc; - pt_required = (ascii_path,ascii_module); - pt_refs = [static_glob_Ascii]; - pt_in_match = true } diff --git a/plugins/syntax/ascii_syntax_plugin.mlpack b/plugins/syntax/ascii_syntax_plugin.mlpack deleted file mode 100644 index 7b9213a0e2..0000000000 --- a/plugins/syntax/ascii_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -Ascii_syntax diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg new file mode 100644 index 0000000000..1e06cd8ddb --- /dev/null +++ b/plugins/syntax/g_string.mlg @@ -0,0 +1,25 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +DECLARE PLUGIN "string_notation_plugin" + +{ + +open String_notation +open Names +open Stdarg + +} + +VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" + ident(sc) ] -> + { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } +END diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 10a0af0b8f..470deb4a60 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -125,7 +125,7 @@ let vernac_numeral_notation local ty f g scope opts = | None -> type_error_of g ty true in let o = { to_kind; to_ty; of_kind; of_ty; - num_ty = ty; + ty_name = ty; warning = opts } in (match opts, to_kind with diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/plugin_base.dune index bfdd480fe9..1ab16c700d 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/plugin_base.dune @@ -6,6 +6,13 @@ (libraries coq.plugins.ltac)) (library + (name string_notation_plugin) + (public_name coq.plugins.string_notation) + (synopsis "Coq string notation plugin") + (modules g_string string_notation) + (libraries coq.vernac)) + +(library (name r_syntax_plugin) (public_name coq.plugins.r_syntax) (synopsis "Coq syntax plugin: reals") @@ -13,23 +20,8 @@ (libraries coq.vernac)) (library - (name ascii_syntax_plugin) - (public_name coq.plugins.ascii_syntax) - (synopsis "Coq syntax plugin: ASCII") - (modules ascii_syntax) - (libraries coq.vernac)) - -(library - (name string_syntax_plugin) - (public_name coq.plugins.string_syntax) - (synopsis "Coq syntax plugin: strings") - (modules string_syntax) - (libraries coq.plugins.ascii_syntax)) - -(library (name int31_syntax_plugin) (public_name coq.plugins.int31_syntax) (synopsis "Coq syntax plugin: int31") (modules int31_syntax) (libraries coq.vernac)) - diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml new file mode 100644 index 0000000000..12ee4c6eda --- /dev/null +++ b/plugins/syntax/string_notation.ml @@ -0,0 +1,98 @@ +(************************************************************************) +(* * 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 Util +open Names +open Libnames +open Globnames +open Constrexpr +open Constrexpr_ops +open Notation + +(** * String notation *) + +let get_constructors ind = + let mib,oib = Global.lookup_inductive ind in + let mc = oib.Declarations.mind_consnames in + Array.to_list + (Array.mapi (fun j c -> ConstructRef (ind, j + 1)) mc) + +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_option () = qualid_of_ref "core.option.type" +let q_list () = qualid_of_ref "core.list.type" +let q_byte () = qualid_of_ref "core.byte.type" + +let has_type f ty = + let (sigma, env) = Pfedit.get_current_context () in + let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in + try let _ = Constrintern.interp_constr env sigma c in true + with Pretype_errors.PretypeError _ -> false + +let type_error_to f ty = + CErrors.user_err + (pr_qualid f ++ str " should go from Byte.byte or (list Byte.byte) to " ++ + pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ").") + +let type_error_of g ty = + CErrors.user_err + (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ + str " to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)).") + +let vernac_string_notation local ty f g scope = + let app x y = mkAppC (x,[y]) in + let cref q = mkRefC q in + let cbyte = cref (q_byte ()) in + let clist = cref (q_list ()) in + let coption = cref (q_option ()) in + let opt r = app coption r in + let clist_byte = app clist cbyte in + let tyc = Smartlocate.global_inductive_with_alias ty in + let to_ty = Smartlocate.global_with_alias f in + let of_ty = Smartlocate.global_with_alias g in + let cty = cref ty in + let arrow x y = + mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, x, y) + in + let constructors = get_constructors tyc in + (* Check the type of f *) + let to_kind = + if has_type f (arrow clist_byte cty) then ListByte, Direct + else if has_type f (arrow clist_byte (opt cty)) then ListByte, Option + else if has_type f (arrow cbyte cty) then Byte, Direct + else if has_type f (arrow cbyte (opt cty)) then Byte, Option + else type_error_to f ty + in + (* Check the type of g *) + let of_kind = + if has_type g (arrow cty clist_byte) then ListByte, Direct + else if has_type g (arrow cty (opt clist_byte)) then ListByte, Option + else if has_type g (arrow cty cbyte) then Byte, Direct + else if has_type g (arrow cty (opt cbyte)) then Byte, Option + else type_error_of g ty + in + let o = { to_kind = to_kind; + to_ty = to_ty; + of_kind = of_kind; + of_ty = of_ty; + ty_name = ty; + warning = () } + in + let i = + { pt_local = local; + pt_scope = scope; + pt_interp_info = StringNotation o; + pt_required = Nametab.path_of_global (IndRef tyc),[]; + pt_refs = constructors; + pt_in_match = true } + in + enable_prim_token_interpretation i diff --git a/plugins/syntax/string_notation.mli b/plugins/syntax/string_notation.mli new file mode 100644 index 0000000000..9a0174abf2 --- /dev/null +++ b/plugins/syntax/string_notation.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Libnames +open Vernacexpr + +(** * String notation *) + +val vernac_string_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> unit diff --git a/plugins/syntax/string_notation_plugin.mlpack b/plugins/syntax/string_notation_plugin.mlpack new file mode 100644 index 0000000000..6aa081dab4 --- /dev/null +++ b/plugins/syntax/string_notation_plugin.mlpack @@ -0,0 +1,2 @@ +String_notation +G_string diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml deleted file mode 100644 index 59e65a0672..0000000000 --- a/plugins/syntax/string_syntax.ml +++ /dev/null @@ -1,81 +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 Names -open Globnames -open Ascii_syntax_plugin.Ascii_syntax -open Glob_term -open Coqlib - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "string_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -exception Non_closed_string - -(* make a string term from the string s *) - -let string_module = ["Coq";"Strings";"String"] - -let string_modpath = MPfile (make_dir string_module) -let string_path = make_path string_module "string" - -let string_kn = MutInd.make2 string_modpath @@ Label.make "string" -let static_glob_EmptyString = ConstructRef ((string_kn,0),1) -let static_glob_String = ConstructRef ((string_kn,0),2) - -let glob_String = lazy (lib_ref "plugins.syntax.String") -let glob_EmptyString = lazy (lib_ref "plugins.syntax.EmptyString") - -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false - -open Lazy - -let interp_string ?loc s = - let le = String.length s in - let rec aux n = - if n = le then DAst.make ?loc @@ GRef (force glob_EmptyString, None) else - DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef (force glob_String, None), - [interp_ascii ?loc (int_of_char s.[n]); aux (n+1)]) - in aux 0 - -let uninterp_string (AnyGlobConstr r) = - try - let b = Buffer.create 16 in - let rec aux c = match DAst.get c with - | GApp (k,[a;s]) when is_gr k (force glob_String) -> - (match uninterp_ascii a with - | Some c -> Buffer.add_char b (Char.chr c); aux s - | _ -> raise Non_closed_string) - | GRef (z,_) when GlobRef.equal z (force glob_EmptyString) -> - Some (Buffer.contents b) - | _ -> - raise Non_closed_string - in aux r - with - Non_closed_string -> None - -open Notation - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -let _ = - let sc = "string_scope" in - register_string_interpretation sc (interp_string,uninterp_string); - at_declare_ml_module enable_prim_token_interpretation - { pt_local = false; - pt_scope = sc; - pt_interp_info = Uid sc; - pt_required = (string_path,["Coq";"Strings";"String"]); - pt_refs = [static_glob_String; static_glob_EmptyString]; - pt_in_match = true } diff --git a/plugins/syntax/string_syntax_plugin.mlpack b/plugins/syntax/string_syntax_plugin.mlpack deleted file mode 100644 index 45d6e0fa23..0000000000 --- a/plugins/syntax/string_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -String_syntax diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 3da1ab7439..0ace11839e 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -69,19 +69,23 @@ let rename_arguments local r names = let arguments_names r = GlobRef.Map.find r !name_table -let rec rename_prod c = function - | [] -> c - | (Name _ as n) :: tl -> - (match kind_of_type c with - | ProdType (_, s, t) -> mkProd (n, s, rename_prod t tl) - | _ -> c) - | _ :: tl -> - match kind_of_type c with - | ProdType (n, s, t) -> mkProd (n, s, rename_prod t tl) - | _ -> c - let rename_type ty ref = - try rename_prod ty (arguments_names ref) + let name_override old_name override = + match override with + | Name _ as x -> x + | Anonymous -> old_name in + let rec rename_type_aux c = function + | [] -> c + | rename :: rest as renamings -> + match kind_of_type c with + | ProdType (old, s, t) -> + mkProd (name_override old rename, s, rename_type_aux t rest) + | LetInType(old, s, b, t) -> + mkLetIn (old ,s, b, rename_type_aux t renamings) + | CastType (t,_) -> rename_type_aux t renamings + | SortType _ -> c + | AtomicType _ -> c in + try rename_type_aux ty (arguments_names ref) with Not_found -> ty let rename_type_of_constant env c = diff --git a/pretyping/cases.ml b/pretyping/cases.ml index fe67f5767b..62c27297f3 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1015,9 +1015,9 @@ let add_assert_false_case pb tomatch = let adjust_impossible_cases sigma pb pred tomatch submat = match submat with | [] -> - (** FIXME: This breaks if using evar-insensitive primitives. In particular, - this means that the Evd.define below may redefine an already defined - evar. See e.g. first definition of test for bug #3388. *) + (* FIXME: This breaks if using evar-insensitive primitives. In particular, + this means that the Evd.define below may redefine an already defined + evar. See e.g. first definition of test for bug #3388. *) let pred = EConstr.Unsafe.to_constr pred in begin match Constr.kind pred with | Evar (evk,_) when snd (evar_source evk sigma) == Evar_kinds.ImpossibleCase -> @@ -1684,8 +1684,8 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = convertible subterms of the substitution *) let evdref = ref sigma in let rec aux (k,env,subst as x) t = - (** Use a reference because the [map_constr_with_full_binders] does not - allow threading a state. *) + (* Use a reference because the [map_constr_with_full_binders] does not + allow threading a state. *) let sigma = !evdref in match EConstr.kind sigma t with | Rel n when is_local_def (lookup_rel n !!env) -> t @@ -2021,7 +2021,7 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = let refresh_tycon sigma t = - (** If we put the typing constraint in the term, it has to be + (* If we put the typing constraint in the term, it has to be refreshed to preserve the invariant that no algebraic universe can appear in the term. *) refresh_universes ~status:Evd.univ_flexible ~onlyalg:true (Some true) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index f18040accb..306a76e35e 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -192,9 +192,11 @@ let subst_cl_typ subst ct = match ct with let c' = subst_proj_repr subst c in if c' == c then ct else CL_PROJ c' | CL_CONST c -> - let c',t = subst_con_kn subst c in - if c' == c then ct else - pi1 (find_class_type Evd.empty (EConstr.of_constr t)) + let c',t = subst_con subst c in + if c' == c then ct else (match t with + | None -> CL_CONST c' + | Some t -> + pi1 (find_class_type Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value))) | CL_IND i -> let i' = subst_ind subst i in if i' == i then ct else CL_IND i' diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index d7118efd7a..032e4bbf85 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -96,8 +96,8 @@ let rec build_lambda sigma vars ctx m = match vars with | (_, id, t) :: suf -> (Name id, t, suf) in - (** Check that the abstraction is legal by generating a transitive closure of - its dependencies. *) + (* Check that the abstraction is legal by generating a transitive closure of + its dependencies. *) let is_nondep t clear = match clear with | [] -> true | _ -> @@ -106,12 +106,12 @@ let rec build_lambda sigma vars ctx m = match vars with List.for_all_i check 1 clear in let fold (_, _, t) clear = is_nondep t clear :: clear in - (** Produce a list of booleans: true iff we keep the hypothesis *) + (* Produce a list of booleans: true iff we keep the hypothesis *) let clear = List.fold_right fold pre [false] in let clear = List.drop_last clear in - (** If the conclusion depends on a variable we cleared, failure *) + (* If the conclusion depends on a variable we cleared, failure *) let () = if not (is_nondep m clear) then raise PatternMatchingFailure in - (** Create the abstracted term *) + (* Create the abstracted term *) let fold (k, accu) keep = if keep then let k = succ k in @@ -121,10 +121,10 @@ let rec build_lambda sigma vars ctx m = match vars with let keep, shift = List.fold_left fold (0, []) clear in let shift = List.rev shift in let map = function - | None -> mkProp (** dummy term *) + | None -> mkProp (* dummy term *) | Some i -> mkRel (i + 1) in - (** [x1 ... xn y z1 ... zm] -> [x1 ... xn f(z1) ... f(zm) y] *) + (* [x1 ... xn y z1 ... zm] -> [x1 ... xn f(z1) ... f(zm) y] *) let subst = List.map map shift @ mkRel 1 :: @@ -143,12 +143,12 @@ let rec build_lambda sigma vars ctx m = match vars with if i > n then i - n + keep else match List.nth shift (i - 1) with | None -> - (** We cleared a variable that we wanted to abstract! *) + (* We cleared a variable that we wanted to abstract! *) raise PatternMatchingFailure | Some k -> k in let vars = List.map map vars in - (** Create the abstraction *) + (* Create the abstraction *) let m = mkLambda (na, Vars.lift keep t, m) in build_lambda sigma vars (pre @ suf) m @@ -377,8 +377,8 @@ let matches_core env sigma allow_bound_rels let () = match ci1.cip_ind with | None -> () | Some ind1 -> - (** ppedrot: Something spooky going here. The comparison used to be - the generic one, so I may have broken something. *) + (* ppedrot: Something spooky going here. The comparison used to be + the generic one, so I may have broken something. *) if not (eq_ind ind1 ci2.ci_ind) then raise PatternMatchingFailure in let () = diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index ce7c7c8702..517834f014 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -703,7 +703,7 @@ and detype_r d flags avoid env sigma t = [detype d flags avoid env sigma c]) else if print_primproj_compatibility () && Projection.unfolded p then - (** Print the compatibility match version *) + (* Print the compatibility match version *) let c' = try let ind = Projection.inductive p in @@ -948,10 +948,13 @@ let (f_subst_genarg, subst_genarg_hook) = Hook.make () let rec subst_glob_constr subst = DAst.map (function | GRef (ref,u) as raw -> let ref',t = subst_global subst ref in - if ref' == ref then raw else - let env = Global.env () in - let evd = Evd.from_env env in - DAst.get (detype Now false Id.Set.empty env evd (EConstr.of_constr t)) + if ref' == ref then raw else (match t with + | None -> GRef (ref', u) + | Some t -> + let env = Global.env () in + let evd = Evd.from_env env in + let t = t.Univ.univ_abstracted_value in (* XXX This seems dangerous *) + DAst.get (detype Now false Id.Set.empty env evd (EConstr.of_constr t))) | GSort _ | GVar _ diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 6c268de3b3..ed28cc7725 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -46,15 +46,10 @@ let () = Goptions.(declare_bool_option { (* Functions to deal with impossible cases *) (*******************************************) let impossible_default_case env = - let type_of_id = - let open Names.GlobRef in - match Coqlib.lib_ref "core.IDProp.type" with - | ConstRef c -> c - | VarRef _ | IndRef _ | ConstructRef _ -> assert false - in + let type_of_id = Coqlib.lib_ref "core.IDProp.type" in let c, ctx = UnivGen.fresh_global_instance env (Coqlib.(lib_ref "core.IDProp.idProp")) in - let (_, u) = Constr.destConst c in - Some (c, Constr.mkConstU (type_of_id, u), ctx) + let (_, u) = Constr.destRef c in + Some (c, Constr.mkRef (type_of_id, u), ctx) let coq_unit_judge = let open Environ in @@ -1311,10 +1306,10 @@ let max_undefined_with_candidates evd = | None -> () | Some l -> raise (MaxUndefined (evk, evi, l)) in - (** [fold_right] traverses the undefined map in decreasing order of indices. - The evar with candidates of maximum index is thus the first evar with - candidates found by a [fold_right] traversal. This has a significant impact on - performance. *) + (* [fold_right] traverses the undefined map in decreasing order of + indices. The evar with candidates of maximum index is thus the + first evar with candidates found by a [fold_right] + traversal. This has a significant impact on performance. *) try let () = Evar.Map.fold_right fold (Evd.undefined_map evd) () in None diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4692fe0057..4c4a236620 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -80,7 +80,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) if v' == v then t else mkProd (na, u, v') | _ -> t in - (** Refresh the types of evars under template polymorphic references *) + (* Refresh the types of evars under template polymorphic references *) let rec refresh_term_evars ~onevars ~top t = match EConstr.kind !evdref t with | App (f, args) when Termops.is_template_polymorphic_ind env !evdref f -> @@ -1385,7 +1385,7 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = let occur_evar_upto_types sigma n c = let c = EConstr.Unsafe.to_constr c in let seen = ref Evar.Set.empty in - (** FIXME: Is that supposed to be evar-insensitive? *) + (* FIXME: Is that supposed to be evar-insensitive? *) let rec occur_rec c = match Constr.kind c with | Evar (sp,_) when Evar.equal sp n -> raise Occur | Evar (sp,args as e) -> @@ -1581,7 +1581,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = Id.Set.subset (collect_vars evd rhs) !names in let body = - if fast rhs then nf_evar evd rhs (** FIXME? *) + if fast rhs then nf_evar evd rhs (* FIXME? *) else let t' = imitate (env,0) rhs in if !progress then diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 9b2da0b084..e14766f370 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -148,7 +148,7 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with Array.equal f c1 c2 && Array.equal f t1 t2 | GSort s1, GSort s2 -> glob_sort_eq s1 s2 | GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) -> - Option.equal (==) gn1 gn2 (** Only thing sensible *) && + Option.equal (==) gn1 gn2 (* Only thing sensible *) && Namegen.intro_pattern_naming_eq nam1 nam2 | GCast (c1, t1), GCast (c2, t2) -> f c1 c2 && cast_type_eq f t1 t2 diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index c6fdb0ec14..c405fcfc72 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -106,6 +106,7 @@ and 'a tomatch_tuples_g = 'a tomatch_tuple_g list and 'a cases_clause_g = (Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) CAst.t (** [(p,il,cl,t)] = "|'cl' => 't'". Precondition: the free variables of [t] are members of [il]. *) + and 'a cases_clauses_g = 'a cases_clause_g list type glob_constr = [ `any ] glob_constr_g diff --git a/pretyping/heads.ml b/pretyping/heads.ml index e533930267..ccbb2934bc 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -147,13 +147,16 @@ let cache_head o = let subst_head_approximation subst = function | RigidHead (RigidParameter cst) as k -> - let cst,c = subst_con_kn subst cst in - if isConst c && Constant.equal (fst (destConst c)) cst then - (* A change of the prefix of the constant *) - k - else - (* A substitution of the constant by a functor argument *) - kind_of_head (Global.env()) c + let cst',c = subst_con subst cst in + if cst == cst' then k + else + (match c with + | None -> + (* A change of the prefix of the constant *) + RigidHead (RigidParameter cst') + | Some c -> + (* A substitution of the constant by a functor argument *) + kind_of_head (Global.env()) c.Univ.univ_abstracted_value) | x -> x let subst_head (subst,(ref,k)) = diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 10d8451947..ff552c7caf 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -469,9 +469,9 @@ let compute_projections env (kn, i as ind) = let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in - (** We build a substitution smashing the lets in the record parameters so - that typechecking projections requires just a substitution and not - matching with a parameter context. *) + (* We build a substitution smashing the lets in the record parameters so + that typechecking projections requires just a substitution and not + matching with a parameter context. *) let indty = (* [ty] = [Ind inst] is typed in context [params] *) let inst = Context.Rel.to_extended_vect mkRel 0 paramslet in @@ -748,7 +748,7 @@ let type_of_projection_knowing_arg env sigma p c ty = let control_only_guard env sigma c = let c = Evarutil.nf_evar sigma c in let check_fix_cofix e c = - (** [c] has already been normalized upfront *) + (* [c] has already been normalized upfront *) let c = EConstr.Unsafe.to_constr c in match kind c with | CoFix (_,(_,_,_) as cofix) -> diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 022c383f60..dc2663c1ca 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -406,14 +406,15 @@ and nf_evar env sigma evk args = mkEvar (evk, [||]), ty end else - (** Let-bound arguments are present in the evar arguments but not in the - type, so we turn the let into a product. *) + (* Let-bound arguments are present in the evar arguments but not + in the type, so we turn the let into a product. *) let hyps = Context.Named.drop_bodies hyps in let fold accu d = Term.mkNamedProd_or_LetIn d accu in let t = List.fold_left fold ty hyps in let ty, args = nf_args env sigma args t in - (** nf_args takes arguments in the reverse order but produces them in the - correct one, so we have to reverse them again for the evar node *) + (* nf_args takes arguments in the reverse order but produces them + in the correct one, so we have to reverse them again for the + evar node *) mkEvar (evk, Array.rev_of_list args), ty let evars_of_evar_map sigma = diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 3c1c470053..248d5d0a0e 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -256,7 +256,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - (** FIXME: Stupid workaround to pattern_of_constr being evar sensitive *) + (* FIXME: Stupid workaround to pattern_of_constr being evar sensitive *) let c = Evarutil.nf_evar sigma c in pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) with Not_found (* List.index failed *) -> @@ -279,10 +279,12 @@ let rec subst_pattern subst pat = match pat with | PRef ref -> let ref',t = subst_global subst ref in - if ref' == ref then pat else - let env = Global.env () in - let evd = Evd.from_env env in - pattern_of_constr env evd t + if ref' == ref then pat else (match t with + | None -> PRef ref' + | Some t -> + let env = Global.env () in + let evd = Evd.from_env env in + pattern_of_constr env evd t.Univ.univ_abstracted_value) | PVar _ | PEvar _ | PRel _ -> pat diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 054f0c76a9..51103ca194 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -38,12 +38,15 @@ type subterm_unification_error = bool * position_reporting * position_reporting type type_error = (constr, types) ptype_error type pretype_error = - (** Old Case *) | CantFindCaseType of constr - (** Type inference unification *) + (** Old Case *) + | ActualTypeNotCoercible of unsafe_judgment * types * unification_error - (** Tactic Unification *) + (** Type inference unification *) + | UnifOccurCheck of Evar.t * constr + (** Tactic Unification *) + | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option | CannotUnify of constr * constr * unification_error option | CannotUnifyLocal of constr * constr * constr diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 2be0f73ea4..ace2868255 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -212,7 +212,7 @@ type frozen = let frozen_and_pending_holes (sigma, sigma') = let undefined0 = Option.cata Evd.undefined_map Evar.Map.empty sigma in - (** Fast path when the undefined evars where not modified *) + (* Fast path when the undefined evars where not modified *) if undefined0 == Evd.undefined_map sigma' then FrozenId undefined0 else @@ -579,7 +579,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma sigma ctxtv vdef in let sigma = Typing.check_type_fixpoint ?loc !!env sigma names ftys vdefj in let nf c = nf_evar sigma c in - let ftys = Array.map nf ftys in (** FIXME *) + let ftys = Array.map nf ftys in (* FIXME *) let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in let fixj = match fixkind with | GFix (vn,i) -> diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index fe9b69dbbc..6e3b19ae61 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -71,12 +71,12 @@ let subst_structure (subst,((kn,i),id,kl,projs as obj)) = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) List.Smart.map - (Option.Smart.map (fun kn -> fst (subst_con_kn subst kn))) + (Option.Smart.map (subst_constant subst)) projs in - let id' = fst (subst_constructor subst id) in - if projs' == projs && kn' == kn && id' == id then obj else - ((kn',i),id',kl,projs') + let id' = subst_constructor subst id in + if projs' == projs && kn' == kn && id' == id then obj else + ((kn',i),id',kl,projs') let discharge_structure (_,x) = Some x @@ -374,7 +374,7 @@ let decompose_projection sigma c args = match EConstr.kind sigma c with | Const (c, u) -> let n = find_projection_nparams (ConstRef c) in - (** Check if there is some canonical projection attached to this structure *) + (* Check if there is some canonical projection attached to this structure *) let _ = GlobRef.Map.find (ConstRef c) !object_table in let arg = Stack.nth args n in arg diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index a57ee6e292..9c9877fd23 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -69,11 +69,9 @@ let subst_reduction_effect (subst,(con,funkey)) = (subst_constant subst con,funkey) let inReductionEffect : Constant.t * string -> obj = - declare_object {(default_object "REDUCTION-EFFECT") with - cache_function = cache_reduction_effect; - open_function = (fun i o -> if Int.equal i 1 then cache_reduction_effect o); - subst_function = subst_reduction_effect; - classify_function = (fun o -> Substitute o) } + declare_object @@ global_object_nodischarge "REDUCTION-EFFECT" + ~cache:cache_reduction_effect + ~subst:(Some subst_reduction_effect) let declare_reduction_effect funkey f = if String.Map.mem funkey !effect_table then @@ -203,6 +201,7 @@ end (** Machinery about stack of unfolded constants *) module Cst_stack = struct open EConstr + (** constant * params * args - constant applied to params = term in head applied to args @@ -1342,7 +1341,7 @@ let sigma_univ_state = let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=TransparentState.full) env sigma x y = - (** FIXME *) + (* FIXME *) try let ans = match pb with | Reduction.CUMUL -> @@ -1632,7 +1631,7 @@ let meta_reducible_instance evd b = in let metas = Metaset.fold fold fm Metamap.empty in let rec irec u = - let u = whd_betaiota Evd.empty u (** FIXME *) in + let u = whd_betaiota Evd.empty u (* FIXME *) in match EConstr.kind evd u with | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> let m = destMeta evd (strip_outer_cast evd c) in diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 088e898a99..a1fd610676 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -77,7 +77,9 @@ module Stack : sig | Case of case_info * 'a * 'a array * Cst_stack.t | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t - | Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *) + | Cst of cst_member + * int (* current foccussed arg *) + * int list (* remaining args *) * 'a t * Cst_stack.t and 'a t = 'a member list @@ -93,6 +95,7 @@ module Stack : sig val compare_shape : 'a t -> 'a t -> bool exception IncompatibleFold2 + (** [fold2 f x sk1 sk2] folds [f] on any pair of term in [(sk1,sk2)]. @return the result and the lifts to apply on the terms @raise IncompatibleFold2 when [sk1] and [sk2] have incompatible shapes *) @@ -104,6 +107,7 @@ module Stack : sig (** if [strip_app s] = [(a,b)], then [s = a @ b] and [b] does not start by App *) val strip_app : 'a t -> 'a t * 'a t + (** @return (the nth first elements, the (n+1)th element, the remaining stack) *) val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index d9df8c8cf8..2e7176a6b3 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -250,7 +250,7 @@ let invert_name labs l na0 env sigma ref = function let labs',ccl = decompose_lam sigma c in let _, l' = whd_betalet_stack sigma ccl in let labs' = List.map snd labs' in - (** ppedrot: there used to be generic equality on terms here *) + (* ppedrot: there used to be generic equality on terms here *) let eq_constr c1 c2 = EConstr.eq_constr sigma c1 c2 in if List.equal eq_constr labs' labs && List.equal eq_constr l l' then Some (minfxargs,ref) @@ -450,7 +450,7 @@ let substl_checking_arity env subst sigma c = the other ones are replaced by the function symbol *) let rec nf_fix c = match EConstr.kind sigma c with | Evar (i,[|fx;f|]) when Evar.Map.mem i minargs -> - (** FIXME: find a less hackish way of doing this *) + (* FIXME: find a less hackish way of doing this *) begin match EConstr.kind sigma' c with | Evar _ -> f | c -> EConstr.of_kind c @@ -943,7 +943,7 @@ let whd_simpl_orelse_delta_but_fix env sigma c = | _ -> false) -> let npars = Projection.npars p in if List.length stack <= npars then - (** Do not show the eta-expanded form *) + (* Do not show the eta-expanded form *) s' else redrec (applist (c, stack)) | _ -> redrec (applist(c, stack))) @@ -993,7 +993,7 @@ let e_contextually byhead (occs,c) f = begin fun env sigma t -> let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in - (** FIXME: we do suspicious things with this evarmap *) + (* FIXME: we do suspicious things with this evarmap *) let evd = ref sigma in let rec traverse nested (env,c as envc) t = if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index d00195678b..f8aedf88c2 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -25,33 +25,33 @@ type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen (** This module defines type-classes *) type typeclass = { + cl_univs : Univ.AUContext.t; (** The toplevel universe quantification in which the typeclass lives. In particular, [cl_props] and [cl_context] are quantified over it. *) - cl_univs : Univ.AUContext.t; + cl_impl : GlobRef.t; (** The class implementation: a record parameterized by the context with defs in it or a definition if the class is a singleton. This acts as the class' global identifier. *) - cl_impl : GlobRef.t; + cl_context : GlobRef.t option list * Constr.rel_context; (** Context in which the definitions are typed. Includes both typeclass parameters and superclasses. The global reference gives a direct link to the class itself. *) - cl_context : GlobRef.t option list * Constr.rel_context; - (** Context of definitions and properties on defs, will not be shared *) cl_props : Constr.rel_context; + (** Context of definitions and properties on defs, will not be shared *) + cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; (** The methods implementations of the typeclass as projections. Some may be undefinable due to sorting restrictions or simply undefined if no name is provided. The [int option option] indicates subclasses whose hint has the given priority. *) - cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; - (** Whether we use matching or full unification during resolution *) cl_strict : bool; + (** Whether we use matching or full unification during resolution *) + cl_unique : bool; (** Whether we can assume that instances are unique, which allows no backtracking and sharing of resolution. *) - cl_unique : bool; } type instance diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 366af0772f..79f2941554 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -36,8 +36,8 @@ val meta_type : evar_map -> metavariable -> types (** Solve existential variables using typing *) val solve_evars : env -> evar_map -> constr -> evar_map * constr -(** Raise an error message if incorrect elimination for this inductive *) -(** (first constr is term to match, second is return predicate) *) +(** Raise an error message if incorrect elimination for this inductive + (first constr is term to match, second is return predicate) *) val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> unit diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 094fcd923e..f0cd5c5f6a 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -76,8 +76,8 @@ let unsafe_occur_meta_or_existential c = let occur_meta_or_undefined_evar evd c = - (** This is performance-critical. Using the evar-insensitive API changes the - resulting heuristic. *) + (* This is performance-critical. Using the evar-insensitive API changes the + resulting heuristic. *) let c = EConstr.Unsafe.to_constr c in let rec occrec c = match Constr.kind c with | Meta _ -> raise Occur @@ -134,7 +134,7 @@ let abstract_list_all env evd typ c l = | UserError _ -> error_cannot_find_well_typed_abstraction env evd p l None | Type_errors.TypeError (env',x) -> - (** FIXME: plug back the typing information *) + (* FIXME: plug back the typing information *) error_cannot_find_well_typed_abstraction env evd p l None | Pretype_errors.PretypeError (env',evd,TypingError x) -> error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in @@ -154,11 +154,9 @@ let abstract_list_all_with_dependencies env evd typ c l = if b then let p = nf_evar evd ev in evd, p - else error_cannot_find_well_typed_abstraction env evd + else error_cannot_find_well_typed_abstraction env evd c l None -(**) - (* A refinement of [conv_pb]: the integers tells how many arguments were applied in the context of the conversion problem; if the number is non zero, steps of eta-expansion will be allowed @@ -598,8 +596,9 @@ let isAllowedEvar sigma flags c = match EConstr.kind sigma c with let subst_defined_metas_evars sigma (bl,el) c = - (** This seems to be performance-critical, and using the evar-insensitive - primitives blow up the time passed in this function. *) + (* This seems to be performance-critical, and using the + evar-insensitive primitives blow up the time passed in this + function. *) let c = EConstr.Unsafe.to_constr c in let rec substrec c = match Constr.kind c with | Meta i -> @@ -656,7 +655,7 @@ let is_eta_constructor_app env sigma ts f l1 term = | PrimRecord info when mib.Declarations.mind_finite == Declarations.BiFinite && let (_, projs, _) = info.(i) in Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> - (** Check that the other term is neutral *) + (* Check that the other term is neutral *) is_neutral env sigma ts term | _ -> false) | _ -> false @@ -783,7 +782,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) - (** Fast path for projections. *) + (* Fast path for projections. *) | Proj (p1,c1), Proj (p2,c2) when Constant.equal (Projection.constant p1) (Projection.constant p2) -> (try unify_same_proj curenvnb cv_pb {opt with at_top = true} @@ -908,7 +907,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e match EConstr.kind sigma c with | Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' -> (try destApp sigma (Retyping.expand_projection curenv sigma p t (Array.to_list l)) - with RetypeError _ -> (** Unification can be called on ill-typed terms, due + with RetypeError _ -> (* Unification can be called on ill-typed terms, due to FO and eta in particular, fail gracefully in that case *) (c, l)) | _ -> (c, l) @@ -1604,7 +1603,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = with | PretypeError (_,_,CannotUnify (c1,c2,Some e)) -> raise (NotUnifiable (Some (c1,c2,e))) - (** MS: This is pretty bad, it catches Not_found for example *) + (* MS: This is pretty bad, it catches Not_found for example *) | e when CErrors.noncritical e -> raise (NotUnifiable None) in let merge_fun c1 c2 = match c1, c2 with diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index c30c4f0932..113aac25da 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -207,10 +207,10 @@ and nf_evar env sigma evk stk = nf_stk env sigma (mkEvar (evk, [||])) concl stk else match stk with | Zapp args :: stk -> - (** We assume that there is no consecutive Zapp nodes in a VM stack. Is that - really an invariant? *) - (** Let-bound arguments are present in the evar arguments but not in the - type, so we turn the let into a product. *) + (* We assume that there is no consecutive Zapp nodes in a VM stack. Is that + really an invariant? *) + (* Let-bound arguments are present in the evar arguments but not in the + type, so we turn the let into a product. *) let hyps = Context.Named.drop_bodies hyps in let fold accu d = Term.mkNamedProd_or_LetIn d accu in let t = List.fold_left fold concl hyps in @@ -388,7 +388,7 @@ and nf_cofix env sigma cf = let cbv_vm env sigma c t = if Termops.occur_meta sigma c then CErrors.user_err Pp.(str "vm_compute does not support metas."); - (** This evar-normalizes terms beforehand *) + (* This evar-normalizes terms beforehand *) let c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in let v = Csymtable.val_of_constr env c in diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 6d53349fa1..26202ef4ca 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -14,7 +14,6 @@ open Util open Pp open CAst open Names -open Nameops open Libnames open Pputils open Ppextend @@ -230,20 +229,6 @@ let tag_var = tag Tag.variable | { CAst.v = CHole (_,IntroAnonymous,_) } -> mt () | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t - let pr_lident {loc; v=id} = - match loc with - | None -> pr_id id - | Some loc -> let (b,_) = Loc.unloc loc in - pr_located pr_id (Some (Loc.make_loc (b,b + String.length (Id.to_string id))), id) - - let pr_lname = function - | {CAst.loc; v=Name id} -> pr_lident CAst.(make ?loc id) - | x -> pr_ast Name.print x - - let pr_or_var pr = function - | Locus.ArgArg x -> pr x - | Locus.ArgVar id -> pr_lident id - let pr_prim_token = function | Numeral (n,s) -> str (if s then n else "-"^n) | String s -> qs s diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index e7f71849a5..1cb3aa6d7a 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -21,11 +21,6 @@ val prec_less : precedence -> tolerability -> bool val pr_tight_coma : unit -> Pp.t -val pr_or_var : ('a -> Pp.t) -> 'a Locus.or_var -> Pp.t - -val pr_lident : lident -> Pp.t -val pr_lname : lname -> Pp.t - val pr_with_comments : ?loc:Loc.t -> Pp.t -> Pp.t val pr_com_at : int -> Pp.t val pr_sep_com : diff --git a/printing/pputils.ml b/printing/pputils.ml index 59e5f68f22..e6daf9544c 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -12,7 +12,6 @@ open Util open Pp open Genarg open Locus -open Genredexpr let beautify_comments = ref [] @@ -39,91 +38,25 @@ let pr_located pr (loc, x) = let pr_ast pr { CAst.loc; v } = pr_located pr (loc, v) -let pr_or_var pr = function - | ArgArg x -> pr x - | ArgVar {CAst.v=s} -> Names.Id.print s - -let pr_with_occurrences pr keyword (occs,c) = - match occs with - | AllOccurrences -> - pr c - | NoOccurrences -> - failwith "pr_with_occurrences: no occurrences" - | OnlyOccurrences nl -> - hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++ - hov 0 (prlist_with_sep spc (pr_or_var int) nl)) - | AllOccurrencesBut nl -> - hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++ - hov 0 (prlist_with_sep spc (pr_or_var int) nl)) - -exception ComplexRedFlag - -let pr_short_red_flag pr r = - if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then - raise ComplexRedFlag - else if List.is_empty r.rConst then - if r.rDelta then mt () else raise ComplexRedFlag - else (if r.rDelta then str "-" else mt ()) ++ - hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]") - -let pr_red_flag pr r = - try pr_short_red_flag pr r - with ComplexRedFlag -> - (if r.rBeta then pr_arg str "beta" else mt ()) ++ - (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else - (if r.rMatch then pr_arg str "match" else mt ()) ++ - (if r.rFix then pr_arg str "fix" else mt ()) ++ - (if r.rCofix then pr_arg str "cofix" else mt ())) ++ - (if r.rZeta then pr_arg str "zeta" else mt ()) ++ - (if List.is_empty r.rConst then - if r.rDelta then pr_arg str "delta" - else mt () - else - pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ - hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) - -let pr_union pr1 pr2 = function - | Inl a -> pr1 a - | Inr b -> pr2 b - -let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function - | Red false -> keyword "red" - | Hnf -> keyword "hnf" - | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f) - ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o - | Cbv f -> - if f.rBeta && f.rMatch && f.rFix && f.rCofix && - f.rZeta && f.rDelta && List.is_empty f.rConst then - keyword "compute" - else - hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f) - | Lazy f -> - hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f) - | Cbn f -> - hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f) - | Unfold l -> - hov 1 (keyword "unfold" ++ spc() ++ - prlist_with_sep pr_comma (pr_with_occurrences pr_ref keyword) l) - | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l) - | Pattern l -> - hov 1 (keyword "pattern" ++ - pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr keyword)) l) +let pr_lident { CAst.loc; v=id } = + let open Names.Id in + match loc with + | None -> print id + | Some loc -> let (b,_) = Loc.unloc loc in + pr_located print + (Some (Loc.make_loc (b,b + String.length (to_string id))), id) - | Red true -> - CErrors.user_err Pp.(str "Shouldn't be accessible from user.") - | ExtraRedExpr s -> - str s - | CbvVm o -> - keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o - | CbvNative o -> - keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o +let pr_lname = let open Names in function + | {CAst.loc; v=Name id} -> pr_lident CAst.(make ?loc id) + | x -> pr_ast Name.print x -let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) = - pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma) +let pr_or_var pr = function + | ArgArg x -> pr x + | ArgVar id -> pr_lident id -let pr_or_by_notation f = let open Constrexpr in function - | {CAst.loc; v=AN v} -> f v - | {CAst.loc; v=ByNotation (s,sc)} -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc +let pr_or_by_notation f = let open Constrexpr in CAst.with_val (function + | AN v -> f v + | ByNotation (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc) let hov_if_not_empty n p = if Pp.ismt p then p else hov n p diff --git a/printing/pputils.mli b/printing/pputils.mli index 5b1969e232..ea554355bc 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -8,33 +8,17 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open Genarg -open Locus -open Genredexpr val pr_located : ('a -> Pp.t) -> 'a Loc.located -> Pp.t val pr_ast : ('a -> Pp.t) -> 'a CAst.t -> Pp.t (** Prints an object surrounded by its commented location *) -val pr_or_var : ('a -> Pp.t) -> 'a or_var -> Pp.t +val pr_lident : lident -> Pp.t +val pr_lname : lname -> Pp.t +val pr_or_var : ('a -> Pp.t) -> 'a Locus.or_var -> Pp.t val pr_or_by_notation : ('a -> Pp.t) -> 'a Constrexpr.or_by_notation -> Pp.t -val pr_with_occurrences : - ('a -> Pp.t) -> (string -> Pp.t) -> 'a with_occurrences -> Pp.t - -val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t -val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t - -val pr_red_expr : - ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> - (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t - -val pr_red_expr_env : Environ.env -> Evd.evar_map -> - (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * - (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * - ('b -> Pp.t) * - (Environ.env -> Evd.evar_map -> 'c -> Pp.t) -> - (string -> Pp.t) -> - ('a,'b,'c) red_expr_gen -> Pp.t val pr_raw_generic : Environ.env -> rlevel generic_argument -> Pp.t val pr_glb_generic : Environ.env -> glevel generic_argument -> Pp.t diff --git a/printing/prettyp.ml b/printing/prettyp.ml index f9f4d7f7f8..c417ef8a66 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -427,7 +427,7 @@ let locate_modtype qid = let all = Nametab.locate_extended_all_modtype qid in let map mp = ModuleType mp, Nametab.shortest_qualid_of_modtype mp in let modtypes = List.map map all in - (** Don't forget the opened module types: they are not part of the same name tab. *) + (* Don't forget the opened module types: they are not part of the same name tab. *) let all = Nametab.locate_extended_all_dir qid in let map dir = let open Nametab.GlobDirRef in match dir with | DirOpenModtype _ -> Some (Dir dir, qid) @@ -575,7 +575,7 @@ let print_constant with_values sep sp udecl = in let env = Global.env () and sigma = Evd.from_ctx ctx in let pr_ltype = pr_ltype_env env sigma in - hov 0 (pr_polymorphic (Declareops.constant_is_polymorphic cb) ++ + hov 0 ( match val_0 with | None -> str"*** [ " ++ diff --git a/printing/printer.ml b/printing/printer.ml index 2bbda279bd..3f7837fd6e 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -546,10 +546,10 @@ let rec pr_evars_int_hd pr sigma i = function (hov 0 (pr i evk evi)) ++ (match rest with [] -> mt () | _ -> fnl () ++ pr_evars_int_hd pr sigma (i+1) rest) -let pr_evars_int sigma ~shelf ~givenup i evs = +let pr_evars_int sigma ~shelf ~given_up i evs = let pr_status i = if List.mem i shelf then str " (shelved)" - else if List.mem i givenup then str " (given up)" + else if List.mem i given_up then str " (given up)" else mt () in pr_evars_int_hd (fun i evk evi -> @@ -605,12 +605,12 @@ let print_evar_constraints gl sigma = let t1 = Evarutil.nf_evar sigma t1 and t2 = Evarutil.nf_evar sigma t2 in let env = - (** We currently allow evar instances to refer to anonymous de Bruijn - indices, so we protect the error printing code in this case by giving - names to every de Bruijn variable in the rel_context of the conversion - problem. MS: we should rather stop depending on anonymous variables, they - can be used to indicate independency. Also, this depends on a strategy for - naming/renaming *) + (* We currently allow evar instances to refer to anonymous de Bruijn + indices, so we protect the error printing code in this case by giving + names to every de Bruijn variable in the rel_context of the conversion + problem. MS: we should rather stop depending on anonymous variables, they + can be used to indicate independency. Also, this depends on a strategy for + naming/renaming *) Namegen.make_all_name_different env sigma in str" " ++ hov 2 (pr_env env ++ pr_leconstr_env env sigma t1 ++ spc () ++ @@ -686,7 +686,7 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map | None -> GoalMap.empty in - (** Printing functions for the extra informations. *) + (* Printing functions for the extra informations. *) let rec print_stack a = function | [] -> Pp.int a | b::l -> Pp.int a ++ str"-" ++ print_stack b l @@ -722,11 +722,11 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map let get_ogs g = match os_map with | Some (osigma, _) -> - (* if Not_found, returning None treats the goal as new and it will be highlighted; + (* if Not_found, returning None treats the goal as new and it will be diff 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)")) + with Not_found -> None) | None -> None in let rec pr_rec n = function @@ -753,7 +753,7 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map | None -> () in - (** Main function *) + (* Main function *) match goals with | [] -> begin @@ -761,7 +761,7 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map if Evar.Map.is_empty exl then (str"No more subgoals." ++ print_dependent_evars None sigma seeds) else - let pei = pr_evars_int sigma ~shelf ~givenup:[] 1 exl in + let pei = pr_evars_int sigma ~shelf ~given_up:[] 1 exl in v 0 ((str "No more subgoals," ++ str " but there are non-instantiated existential variables:" ++ cut () ++ (hov 0 pei) @@ -789,7 +789,7 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = straightforward, but seriously, [Proof.proof] should return [evar_info]-s instead. *) let p = proof in - let (goals , stack , shelf, given_up, sigma ) = Proof.proof p in + let Proof.{goals; stack; shelf; given_up; sigma} = Proof.data p in let stack = List.map (fun (l,r) -> List.length l + List.length r) stack in let seeds = Proof.V82.top_evars p in begin match goals with @@ -821,7 +821,7 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = let unfocused_if_needed = if should_unfoc() then bgoals_unfocused else [] in let os_map = match oproof with | Some op when diffs -> - let (_,_,_,_, osigma) = Proof.proof op in + let Proof.{sigma=osigma} = Proof.data op in let diff_goal_map = Proof_diffs.make_goal_map oproof proof in Some (osigma, diff_goal_map) | _ -> None @@ -834,8 +834,8 @@ let pr_open_subgoals ~proof = pr_open_subgoals_diff proof let pr_nth_open_subgoal ~proof n = - let gls,_,_,_,sigma = Proof.proof proof in - pr_subgoal n sigma gls + let Proof.{goals;sigma} = Proof.data proof in + pr_subgoal n sigma goals let pr_goal_by_id ~proof id = try @@ -982,14 +982,6 @@ let pr_assumptionset env sigma s = ] in prlist_with_sep fnl (fun x -> x) (Option.List.flatten assums) -let pr_cumulative poly cum = - if poly then - if cum then str "Cumulative " else str "NonCumulative " - else mt () - -let pr_polymorphic b = - if b then str"Polymorphic " else str"Monomorphic " - (* print the proof step, possibly with diffs highlighted, *) let print_and_diff oldp newp = match newp with diff --git a/printing/printer.mli b/printing/printer.mli index b0232ec4ac..9a06d555e4 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -81,8 +81,6 @@ val pr_sort : evar_map -> Sorts.t -> Pp.t (** Universe constraints *) -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 -> @@ -112,6 +110,7 @@ val pr_pconstructor : env -> evar_map -> pconstructor -> Pp.t (** Contexts *) + (** Display compact contexts of goals (simple hyps on the same line) *) val set_compact_context : bool -> unit val get_compact_context : unit -> bool @@ -181,7 +180,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.goal list -> givenup:Goal.goal list -> int -> evar_info Evar.Map.t -> Pp.t +val pr_evars_int : evar_map -> shelf:Goal.goal list -> given_up: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 a8d7b0c1a8..898f231a8b 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -123,11 +123,7 @@ let print_mutual_inductive env mind mib udecl = (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 - (Declareops.inductive_is_polymorphic mib) - (Declareops.inductive_is_cumulative mib) ++ - def keyword ++ spc () ++ + hov 0 (def keyword ++ spc () ++ prlist_with_sep (fun () -> fnl () ++ str" with ") (print_one_inductive env sigma mib) inds ++ match mib.mind_universes with @@ -172,10 +168,6 @@ let print_record env mind mib udecl = in hov 0 ( hov 0 ( - Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ - Printer.pr_cumulative - (Declareops.inductive_is_polymorphic mib) - (Declareops.inductive_is_cumulative mib) ++ def keyword ++ spc () ++ Id.print mip.mind_typename ++ brk(1,4) ++ print_params env sigma params ++ str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ brk(1,2) ++ diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 3e2093db4a..c1ea067567 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -83,12 +83,13 @@ let tokenize_string s = if Tok.(equal e EOI) then List.rev acc else - stream_tok ((Tok.extract_string e) :: acc) str + stream_tok ((Tok.extract_string true e) :: acc) str in let st = CLexer.get_lexer_state () in try let istr = Stream.of_string s in - let lex = CLexer.lexer.Gramlib.Plexing.tok_func istr in + let lexer = CLexer.make_lexer ~diff_mode:true in + let lex = lexer.Gramlib.Plexing.tok_func istr in let toks = stream_tok [] (fst lex) in CLexer.set_lexer_state st; toks @@ -138,13 +139,11 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = let hyp_diffs = diff_str ~tokenize_string o_line n_line in let (has_added, has_removed) = has_changes hyp_diffs in if show_removed () && has_removed then begin - let o_entry = StringMap.find (List.hd old_ids) o_map in - o_entry.done_ <- true; + List.iter (fun x -> (StringMap.find x o_map).done_ <- true) old_ids; rv := (add_diff_tags `Removed o_pp hyp_diffs) :: !rv; end; if n_line <> "" then begin - let n_entry = StringMap.find (List.hd new_ids) n_map in - n_entry.done_ <- true; + List.iter (fun x -> (StringMap.find x n_map).done_ <- true) new_ids; rv := (add_diff_tags `Added n_pp hyp_diffs) :: !rv end in @@ -157,7 +156,7 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = if dtype = `Removed then begin let o_idents = (StringMap.find ident o_map).idents in (* only show lines that have all idents removed here; other removed idents appear later *) - if show_removed () && + if show_removed () && not (is_done ident o_map) && List.for_all (fun x -> not (exists x n_map)) o_idents then output (List.rev o_idents) [] end @@ -399,6 +398,10 @@ let match_goals ot nt = It's set to the old goal's evar name once a rewitten goal is found, at which point the code only searches for the replacing goals (and ot is set to nt). *) + let iter2 f l1 l2 = + if List.length l1 = (List.length l2) then + List.iter2 f l1 l2 + in let rec match_goals_r ogname ot nt = let constr_expr ogname exp exp2 = match_goals_r ogname exp.v exp2.v @@ -434,13 +437,13 @@ let match_goals ot nt = let fix_expr ogname exp exp2 = let (l,(lo,ro),lb,ce1,ce2), (l2,(lo2,ro2),lb2,ce12,ce22) = exp,exp2 in recursion_order_expr ogname ro ro2; - List.iter2 (local_binder_expr ogname) lb lb2; + iter2 (local_binder_expr ogname) lb lb2; constr_expr ogname ce1 ce12; constr_expr ogname ce2 ce22 in let cofix_expr ogname exp exp2 = let (l,lb,ce1,ce2), (l2,lb2,ce12,ce22) = exp,exp2 in - List.iter2 (local_binder_expr ogname) lb lb2; + iter2 (local_binder_expr ogname) lb lb2; constr_expr ogname ce1 ce12; constr_expr ogname ce2 ce22 in @@ -454,38 +457,38 @@ let match_goals ot nt = in let constr_notation_substitution ogname exp exp2 = let (ce, cel, cp, lb), (ce2, cel2, cp2, lb2) = exp, exp2 in - List.iter2 (constr_expr ogname) ce ce2; - List.iter2 (fun a a2 -> List.iter2 (constr_expr ogname) a a2) cel cel2; - List.iter2 (fun a a2 -> List.iter2 (local_binder_expr ogname) a a2) lb lb2 + iter2 (constr_expr ogname) ce ce2; + iter2 (fun a a2 -> iter2 (constr_expr ogname) a a2) cel cel2; + iter2 (fun a a2 -> iter2 (local_binder_expr ogname) a a2) lb lb2 in begin match ot, nt with | CRef (ref,us), CRef (ref2,us2) -> () | CFix (id,fl), CFix (id2,fl2) -> - List.iter2 (fix_expr ogname) fl fl2 + iter2 (fix_expr ogname) fl fl2 | CCoFix (id,cfl), CCoFix (id2,cfl2) -> - List.iter2 (cofix_expr ogname) cfl cfl2 + iter2 (cofix_expr ogname) cfl cfl2 | CProdN (bl,c2), CProdN (bl2,c22) | CLambdaN (bl,c2), CLambdaN (bl2,c22) -> - List.iter2 (local_binder_expr ogname) bl bl2; + iter2 (local_binder_expr ogname) bl bl2; constr_expr ogname c2 c22 | CLetIn (na,c1,t,c2), CLetIn (na2,c12,t2,c22) -> constr_expr ogname c1 c12; constr_expr_opt ogname t t2; constr_expr ogname c2 c22 | CAppExpl ((isproj,ref,us),args), CAppExpl ((isproj2,ref2,us2),args2) -> - List.iter2 (constr_expr ogname) args args2 + iter2 (constr_expr ogname) args args2 | CApp ((isproj,f),args), CApp ((isproj2,f2),args2) -> constr_expr ogname f f2; - List.iter2 (fun a a2 -> let (c, _) = a and (c2, _) = a2 in + iter2 (fun a a2 -> let (c, _) = a and (c2, _) = a2 in constr_expr ogname c c2) args args2 | CRecord fs, CRecord fs2 -> - List.iter2 (fun a a2 -> let (_, c) = a and (_, c2) = a2 in + iter2 (fun a a2 -> let (_, c) = a and (_, c2) = a2 in constr_expr ogname c c2) fs fs2 | CCases (sty,rtnpo,tms,eqns), CCases (sty2,rtnpo2,tms2,eqns2) -> constr_expr_opt ogname rtnpo rtnpo2; - List.iter2 (case_expr ogname) tms tms2; - List.iter2 (branch_expr ogname) eqns eqns2 + iter2 (case_expr ogname) tms tms2; + iter2 (branch_expr ogname) eqns eqns2 | CLetTuple (nal,(na,po),b,c), CLetTuple (nal2,(na2,po2),b2,c2) -> constr_expr_opt ogname po po2; constr_expr ogname b b2; @@ -500,7 +503,7 @@ let match_goals ot nt = | CEvar (n,l), CEvar (n2,l2) -> let oevar = if ogname = "" then Id.to_string n else ogname in nevar_to_oevar := StringMap.add (Id.to_string n2) oevar !nevar_to_oevar; - List.iter2 (fun x x2 -> let (_, g) = x and (_, g2) = x2 in constr_expr ogname g g2) l l2 + iter2 (fun x x2 -> let (_, g) = x and (_, g2) = x2 in constr_expr ogname g g2) l l2 | CEvar (n,l), nt' -> (* pass down the old goal evar name *) match_goals_r (Id.to_string n) nt' nt' @@ -545,19 +548,31 @@ module GoalMap = Evar.Map let goal_to_evar g sigma = Id.to_string (Termops.pr_evar_suggested_name g sigma) +open Goal.Set + [@@@ocaml.warning "-32"] let db_goal_map op np ng_to_og = - Printf.printf "New Goals: "; - let (ngoals,_,_,_,nsigma) = Proof.proof np in - List.iter (fun ng -> Printf.printf "%d -> %s " (Evar.repr ng) (goal_to_evar ng nsigma)) ngoals; + let pr_goals title prf = + Printf.printf "%s: " title; + let Proof.{goals;sigma} = Proof.data prf in + List.iter (fun g -> Printf.printf "%d -> %s " (Evar.repr g) (goal_to_evar g sigma)) goals; + let gs = diff (Proof.all_goals prf) (List.fold_left (fun s g -> add g s) empty goals) in + List.iter (fun g -> Printf.printf "%d " (Evar.repr g)) (elements gs); + in + + pr_goals "New Goals" np; (match op with | Some op -> - let (ogoals,_,_,_,osigma) = Proof.proof op in - Printf.printf "\nOld Goals: "; - List.iter (fun og -> Printf.printf "%d -> %s " (Evar.repr og) (goal_to_evar og osigma)) ogoals + pr_goals "\nOld Goals" op | None -> ()); Printf.printf "\nGoal map: "; - GoalMap.iter (fun og ng -> Printf.printf "%d -> %d " (Evar.repr og) (Evar.repr ng)) ng_to_og; + GoalMap.iter (fun ng og -> Printf.printf "%d -> %d " (Evar.repr ng) (Evar.repr og)) ng_to_og; + let unmapped = ref (Proof.all_goals np) in + GoalMap.iter (fun ng _ -> unmapped := Goal.Set.remove ng !unmapped) ng_to_og; + if Goal.Set.cardinal !unmapped > 0 then begin + Printf.printf "\nUnmapped goals: "; + Goal.Set.iter (fun ng -> Printf.printf "%d " (Evar.repr ng)) !unmapped + end; Printf.printf "\n" [@@@ocaml.warning "+32"] @@ -612,11 +627,11 @@ let make_goal_map_i op np = let nevar_to_oevar = match_goals (Some (to_constr op)) (to_constr np) in let oevar_to_og = ref StringMap.empty in - let (_,_,_,_,osigma) = Proof.proof op in + let Proof.{sigma=osigma} = Proof.data op in List.iter (fun og -> oevar_to_og := StringMap.add (goal_to_evar og osigma) og !oevar_to_og) (Goal.Set.elements rem_gs); - let (_,_,_,_,nsigma) = Proof.proof np in + let Proof.{sigma=nsigma} = Proof.data np in let get_og ng = let nevar = goal_to_evar ng nsigma in let oevar = StringMap.find nevar nevar_to_oevar in diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index ce9ee5ae6f..1ebde3d572 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -12,6 +12,7 @@ (** Controls whether to show diffs. Takes values "on", "off", "removed" *) val write_diffs_option : string -> unit + (** Returns true if the diffs option is "on" or "removed" *) val show_diffs : unit -> bool diff --git a/proofs/clenv.ml b/proofs/clenv.ml index b7ccd647b5..1f1bdf4da7 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -601,17 +601,17 @@ let make_evar_clause env sigma ?len t = | None -> -1 | Some n -> assert (0 <= n); n in - (** FIXME: do the renaming online *) + (* FIXME: do the renaming online *) let t = rename_bound_vars_as_displayed sigma Id.Set.empty [] t in let rec clrec (sigma, holes) inst n t = if n = 0 then (sigma, holes, t) else match EConstr.kind sigma t with | Cast (t, _, _) -> clrec (sigma, holes) inst n t | Prod (na, t1, t2) -> - (** Share the evar instances as we are living in the same context *) + (* Share the evar instances as we are living in the same context *) let inst, ctx, args, subst = match inst with | None -> - (** Dummy type *) + (* Dummy type *) let ctx, _, args, subst = push_rel_context_to_named_context env sigma mkProp in Some (ctx, args, subst), ctx, args, subst | Some (ctx, args, subst) -> inst, ctx, args, subst @@ -688,7 +688,7 @@ let solve_evar_clause env sigma hyp_only clause = function let open EConstr in let fold holes h = if h.hole_deps then - (** Some subsequent term uses the hole *) + (* Some subsequent term uses the hole *) let (ev, _) = destEvar sigma h.hole_evar in let is_dep hole = occur_evar sigma ev hole.hole_type in let in_hyp = List.exists is_dep holes in @@ -697,7 +697,7 @@ let solve_evar_clause env sigma hyp_only clause = function let h = { h with hole_deps = dep } in h :: holes else - (** The hole does not occur anywhere *) + (* The hole does not occur anywhere *) h :: holes in let holes = List.fold_left fold [] (List.rev clause.cl_holes) in diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 4720328893..c36b0fa337 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -61,9 +61,9 @@ let clenv_pose_dependent_evars ?(with_evars=false) clenv = clenv_pose_metas_as_evars clenv dep_mvs let clenv_refine ?(with_evars=false) ?(with_classes=true) clenv = - (** ppedrot: a Goal.enter here breaks things, because the tactic below may - solve goals by side effects, while the compatibility layer keeps those - useless goals. That deserves a FIXME. *) + (* ppedrot: a Goal.enter here breaks things, because the tactic below may + solve goals by side effects, while the compatibility layer keeps those + useless goals. That deserves a FIXME. *) Proofview.V82.tactic begin fun gl -> let clenv, evars = clenv_pose_dependent_evars ~with_evars clenv in let evd' = diff --git a/proofs/logic.ml b/proofs/logic.ml index 15ba0a704f..3581e90b79 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -63,7 +63,7 @@ let catchable_exception = function | CErrors.UserError _ | TypeError _ | Proof.OpenProof _ (* abstract will call close_proof inside a tactic *) - | Notation.NumeralNotationError _ + | Notation.PrimTokenNotationError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ (* reduction errors *) @@ -373,8 +373,8 @@ let rec mk_refgoals sigma goal goalacc conclty trm = check_typability env sigma ty; let sigma = check_conv_leq_goal env sigma trm ty conclty in let res = mk_refgoals sigma goal goalacc ty t in - (** we keep the casts (in particular VMcast and NATIVEcast) except - when they are annotating metas *) + (* we keep the casts (in particular VMcast and NATIVEcast) except + when they are annotating metas *) if isMeta t then begin assert (k != VMcast && k != NATIVEcast); res diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 886a62cb89..7f1ae6d12b 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -33,7 +33,7 @@ let () = CErrors.register_handler begin function end let get_nth_V82_goal p i = - let goals,_,_,_,sigma = Proof.proof p in + let Proof.{ sigma; goals } = Proof.data p in try { it = List.nth goals (i-1) ; sigma } with Failure _ -> raise NoSuchGoal @@ -107,11 +107,14 @@ let solve ?with_end_tac gi info_lvl tac pr = Proofview.tclTHEN tac Refine.solve_constraints else tac in - let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in + let env = Global.env () in + let (p,(status,info)) = Proof.run_tactic env tac pr in + let env = Global.env () in + let sigma = Evd.from_env env in let () = match info_lvl with | None -> () - | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) + | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info env sigma ~lvl:i info)) in (p,status) with @@ -120,7 +123,8 @@ let solve ?with_end_tac gi info_lvl tac pr = let by tac = Proof_global.with_current_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) let instantiate_nth_evar_com n com = - Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.instantiate_evar n com p) + Proof_global.simple_with_current_proof (fun _ p -> + Proof.V82.instantiate_evar Global.(env ())n com p) (**********************************************************************) @@ -166,51 +170,51 @@ let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = let univs = UState.merge ~sideff:side_eff ~extend:true Evd.univ_rigid univs ctx in cb, status, univs -let refine_by_tactic env sigma ty tac = - (** Save the initial side-effects to restore them afterwards. We set the - current set of side-effects to be empty so that we can retrieve the - ones created during the tactic invocation easily. *) +let refine_by_tactic ~name ~poly env sigma ty tac = + (* Save the initial side-effects to restore them afterwards. We set the + current set of side-effects to be empty so that we can retrieve the + ones created during the tactic invocation easily. *) let eff = Evd.eval_side_effects sigma in let sigma = Evd.drop_side_effects sigma in - (** Save the existing goals *) + (* Save the existing goals *) let prev_future_goals = save_future_goals sigma in - (** Start a proof *) - let prf = Proof.start sigma [env, ty] in + (* Start a proof *) + let prf = Proof.start ~name ~poly sigma [env, ty] in let (prf, _) = try Proof.run_tactic env tac prf with Logic_monad.TacticFailure e as src -> - (** Catch the inner error of the monad tactic *) + (* Catch the inner error of the monad tactic *) let (_, info) = CErrors.push src in iraise (e, info) in - (** Plug back the retrieved sigma *) - let (goals,stack,shelf,given_up,sigma) = Proof.proof prf in + (* Plug back the retrieved sigma *) + let Proof.{ goals; stack; shelf; given_up; sigma; entry } = Proof.data prf in assert (stack = []); - let ans = match Proof.initial_goals prf with + let ans = match Proofview.initial_goals entry with | [c, _] -> c | _ -> assert false in let ans = EConstr.to_constr ~abort_on_undefined_evars:false sigma ans in - (** [neff] contains the freshly generated side-effects *) + (* [neff] contains the freshly generated side-effects *) let neff = Evd.eval_side_effects sigma in - (** Reset the old side-effects *) + (* Reset the old side-effects *) let sigma = Evd.drop_side_effects sigma in let sigma = Evd.emit_side_effects eff sigma in - (** Restore former goals *) + (* Restore former goals *) let sigma = restore_future_goals sigma prev_future_goals in - (** Push remaining goals as future_goals which is the only way we - have to inform the caller that there are goals to collect while - not being encapsulated in the monad *) - (** Goals produced by tactic "shelve" *) + (* Push remaining goals as future_goals which is the only way we + have to inform the caller that there are goals to collect while + not being encapsulated in the monad *) + (* Goals produced by tactic "shelve" *) let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in - (** Goals produced by tactic "give_up" *) + (* Goals produced by tactic "give_up" *) let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in - (** Other goals *) + (* Other goals *) let sigma = List.fold_right Evd.declare_future_goal goals sigma in - (** Get rid of the fresh side-effects by internalizing them in the term - itself. Note that this is unsound, because the tactic may have solved - other goals that were already present during its invocation, so that - those goals rely on effects that are not present anymore. Hopefully, - this hack will work in most cases. *) + (* Get rid of the fresh side-effects by internalizing them in the term + itself. Note that this is unsound, because the tactic may have solved + other goals that were already present during its invocation, so that + those goals rely on effects that are not present anymore. Hopefully, + this hack will work in most cases. *) let ans = Safe_typing.inline_private_constants_in_constr env ans neff in ans, sigma diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 155221947a..5699320af5 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -81,8 +81,13 @@ val build_by_tactic : ?side_eff:bool -> env -> UState.t -> ?poly:polymorphic -> EConstr.types -> unit Proofview.tactic -> constr * bool * UState.t -val refine_by_tactic : env -> Evd.evar_map -> EConstr.types -> unit Proofview.tactic -> - constr * Evd.evar_map +val refine_by_tactic + : name:Id.t + -> poly:bool + -> env -> Evd.evar_map + -> EConstr.types + -> unit Proofview.tactic + -> constr * Evd.evar_map (** A variant of the above function that handles open terms as well. Caveat: all effects are purged in the returned term at the end, but other evars solved by side-effects are NOT purged, so that unexpected failures may diff --git a/proofs/proof.ml b/proofs/proof.ml index 6c13c4946a..1aeb24606b 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -105,22 +105,29 @@ let done_cond ?(loose_end=false) k = CondDone (loose_end,k) (* Subpart of the type of proofs. It contains the parts of the proof which are under control of the undo mechanism *) -type t = { - (* Current focused proofview *) - proofview: Proofview.proofview; - (* Entry for the proofview *) - entry : Proofview.entry; - (* History of the focusings, provides information on how - to unfocus the proof and the extra information stored while focusing. - The list is empty when the proof is fully unfocused. *) - focus_stack: (_focus_condition*focus_info*Proofview.focus_context) list; - (* List of goals that have been shelved. *) - shelf : Goal.goal list; - (* List of goals that have been given up *) - given_up : Goal.goal list; - (* The initial universe context (for the statement) *) - initial_euctx : UState.t -} +type t = + { proofview: Proofview.proofview + (** Current focused proofview *) + ; entry : Proofview.entry + (** Entry for the proofview *) + ; focus_stack: (_focus_condition*focus_info*Proofview.focus_context) list + (** History of the focusings, provides information on how to unfocus + the proof and the extra information stored while focusing. The + list is empty when the proof is fully unfocused. *) + ; shelf : Goal.goal list + (** List of goals that have been shelved. *) + ; given_up : Goal.goal list + (** List of goals that have been given up *) + ; initial_euctx : UState.t + (** The initial universe context (for the statement) *) + ; name : Names.Id.t + (** the name of the theorem whose proof is being constructed *) + ; poly : bool + (** Locality, polymorphism, and "kind" [Coercion, Definition, etc...] *) + } + +let initial_goals pf = Proofview.initial_goals pf.entry +let initial_euctx pf = pf.initial_euctx (*** General proof functions ***) @@ -141,7 +148,7 @@ let proof p = (goals,stack,shelf,given_up,sigma) type 'a pre_goals = { - fg_goals : 'a list; + fg_goals : 'a list; (** List of the focussed goals *) bg_goals : ('a list * 'a list) list; (** Zipper representing the unfocussed background goals *) @@ -311,7 +318,7 @@ let end_of_stack = CondEndStack end_of_stack_kind let unfocused = is_last_focus end_of_stack_kind -let start sigma goals = +let start ~name ~poly sigma goals = let entry, proofview = Proofview.init sigma goals in let pr = { proofview; @@ -320,9 +327,13 @@ let start sigma goals = shelf = [] ; given_up = []; initial_euctx = - Evd.evar_universe_context (snd (Proofview.proofview proofview)) } in + Evd.evar_universe_context (snd (Proofview.proofview proofview)) + ; name + ; poly + } in _focus end_of_stack (Obj.repr ()) 1 (List.length goals) pr -let dependent_start goals = + +let dependent_start ~name ~poly goals = let entry, proofview = Proofview.dependent_init goals in let pr = { proofview; @@ -331,7 +342,10 @@ let dependent_start goals = shelf = [] ; given_up = []; initial_euctx = - Evd.evar_universe_context (snd (Proofview.proofview proofview)) } in + Evd.evar_universe_context (snd (Proofview.proofview proofview)) + ; name + ; poly + } in let number_of_goals = List.length (Proofview.initial_goals pr.entry) in _focus end_of_stack (Obj.repr ()) 1 number_of_goals pr @@ -375,9 +389,6 @@ let return ?pid (p : t) = let p = unfocus end_of_stack_kind p () in Proofview.return p.proofview -let initial_goals p = Proofview.initial_goals p.entry -let initial_euctx p = p.initial_euctx - let compact p = let entry, proofview = Proofview.compact p.entry p.proofview in { p with proofview; entry } @@ -468,7 +479,7 @@ module V82 = struct { p with proofview = Proofview.V82.grab p.proofview } (* Main component of vernac command Existential *) - let instantiate_evar n com pr = + let instantiate_evar env n com pr = let tac = Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> let (evk, evi) = @@ -487,7 +498,7 @@ module V82 = struct let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in Proofview.Unsafe.tclEVARS sigma end in - let ((), proofview, _, _) = Proofview.apply (Global.env ()) tac pr.proofview in + let ((), proofview, _, _) = Proofview.apply env tac pr.proofview in let shelf = List.filter begin fun g -> Evd.is_undefined (Proofview.return proofview) g @@ -507,3 +518,37 @@ let all_goals p = let set = add given_up set in let { Evd.it = bgoals ; sigma = bsigma } = V82.background_subgoals p in add bgoals set + +type data = + { sigma : Evd.evar_map + (** A representation of the evar_map [EJGA wouldn't it better to just return the proofview?] *) + ; goals : Evar.t list + (** Focused goals *) + ; entry : Proofview.entry + (** Entry for the proofview *) + ; stack : (Evar.t list * Evar.t list) list + (** A representation of the focus stack *) + ; shelf : Evar.t list + (** A representation of the shelf *) + ; given_up : Evar.t list + (** A representation of the given up goals *) + ; initial_euctx : UState.t + (** The initial universe context (for the statement) *) + ; name : Names.Id.t + (** The name of the theorem whose proof is being constructed *) + ; poly : bool + (** Locality, polymorphism, and "kind" [Coercion, Definition, etc...] *) + } + +let data { proofview; focus_stack; entry; shelf; given_up; initial_euctx; name; poly } = + let goals, sigma = Proofview.proofview proofview in + (* spiwack: beware, the bottom of the stack is used by [Proof] + internally, and should not be exposed. *) + let rec map_minus_one f = function + | [] -> assert false + | [_] -> [] + | a::l -> f a :: (map_minus_one f l) + in + let stack = + map_minus_one (fun (_,_,c) -> Proofview.focus_context c) focus_stack in + { sigma; goals; entry; stack; shelf; given_up; initial_euctx; name; poly } diff --git a/proofs/proof.mli b/proofs/proof.mli index aaabea3454..fd5e905a3b 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -50,27 +50,70 @@ val proof : t -> * Goal.goal list * Goal.goal list * Evd.evar_map +[@@ocaml.deprecated "use [Proof.data]"] + +val initial_goals : t -> (EConstr.constr * EConstr.types) list +[@@ocaml.deprecated "use [Proof.data]"] + +val initial_euctx : t -> UState.t +[@@ocaml.deprecated "use [Proof.data]"] + +type data = + { sigma : Evd.evar_map + (** A representation of the evar_map [EJGA wouldn't it better to just return the proofview?] *) + ; goals : Evar.t list + (** Focused goals *) + ; entry : Proofview.entry + (** Entry for the proofview *) + ; stack : (Evar.t list * Evar.t list) list + (** A representation of the focus stack *) + ; shelf : Evar.t list + (** A representation of the shelf *) + ; given_up : Evar.t list + (** A representation of the given up goals *) + ; initial_euctx : UState.t + (** The initial universe context (for the statement) *) + ; name : Names.Id.t + (** The name of the theorem whose proof is being constructed *) + ; poly : bool; + (** polymorphism *) + } + +val data : t -> data (* Generic records structured like the return type of proof *) type 'a pre_goals = { fg_goals : 'a list; + [@ocaml.deprecated "use [Proof.data]"] (** List of the focussed goals *) bg_goals : ('a list * 'a list) list; + [@ocaml.deprecated "use [Proof.data]"] (** Zipper representing the unfocussed background goals *) shelved_goals : 'a list; + [@ocaml.deprecated "use [Proof.data]"] (** List of the goals on the shelf. *) given_up_goals : 'a list; + [@ocaml.deprecated "use [Proof.data]"] (** List of the goals that have been given up *) } +[@@ocaml.deprecated "use [Proof.data]"] -val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) - +(* needed in OCaml 4.05.0, not needed in newer ones *) +[@@@ocaml.warning "-3"] +val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) [@ocaml.warning "-3"] +[@@ocaml.deprecated "use [Proof.data]"] +[@@@ocaml.warning "+3"] (*** General proof functions ***) -val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> t -val dependent_start : Proofview.telescope -> t -val initial_goals : t -> (EConstr.constr * EConstr.types) list -val initial_euctx : t -> UState.t +val start + : name:Names.Id.t + -> poly:bool + -> Evd.evar_map -> (Environ.env * EConstr.types) list -> t + +val dependent_start + : name:Names.Id.t + -> poly:bool + -> Proofview.telescope -> t (* Returns [true] if the considered proof is completed, that is if no goal remain to be considered (this does not require that all evars have been solved). *) @@ -177,8 +220,9 @@ val no_focused_goal : t -> bool (* the returned boolean signal whether an unsafe tactic has been used. In which case it is [false]. *) -val run_tactic : Environ.env -> - unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) +val run_tactic + : Environ.env + -> unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) val maximal_unfocus : 'a focus_kind -> t -> t @@ -208,7 +252,8 @@ module V82 : sig val grab_evars : t -> t (* Implements the Existential command *) - val instantiate_evar : int -> Constrexpr.constr_expr -> t -> t + val instantiate_evar : + Environ.env -> int -> Constrexpr.constr_expr -> t -> t end (* returns the set of all goals in the proof *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 67e19df0e7..f8adc58921 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -53,11 +53,12 @@ let default_proof_mode = ref (find_proof_mode "No") let get_default_proof_mode_name () = (CEphemeron.default !default_proof_mode standard).name +let proof_mode_opt_name = ["Default";"Proof";"Mode"] let () = Goptions.(declare_string_option { optdepr = false; optname = "default proof mode" ; - optkey = ["Default";"Proof";"Mode"] ; + optkey = proof_mode_opt_name ; optread = begin fun () -> (CEphemeron.default !default_proof_mode standard).name end; @@ -90,14 +91,13 @@ type proof_terminator = proof_ending -> unit type closed_proof = proof_object * proof_terminator type pstate = { - pid : Id.t; (* the name of the theorem whose proof is being constructed *) terminator : proof_terminator CEphemeron.key; endline_tactic : Genarg.glob_generic_argument option; section_vars : Constr.named_context option; proof : Proof.t; - strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; universe_decl: UState.universe_decl; + strength : Decl_kinds.goal_kind; } type t = pstate list @@ -142,7 +142,7 @@ end (*** Proof Global manipulation ***) let get_all_proof_names () = - List.map (function { pid = id } -> id) !pstates + List.map Proof.(function pf -> (data pf.proof).name) !pstates let cur_pstate () = match !pstates with @@ -151,7 +151,7 @@ let cur_pstate () = let give_me_the_proof () = (cur_pstate ()).proof let give_me_the_proof_opt () = try Some (give_me_the_proof ()) with | NoCurrentProof -> None -let get_current_proof_name () = (cur_pstate ()).pid +let get_current_proof_name () = (Proof.data (cur_pstate ()).proof).Proof.name let with_current_proof f = match !pstates with @@ -205,8 +205,12 @@ let check_no_pending_proof () = str"Use \"Abort All\" first or complete proof(s).") end +let pf_name_eq id ps = + let Proof.{ name } = Proof.data ps.proof in + Id.equal name id + let discard_gen id = - pstates := List.filter (fun { pid = id' } -> not (Id.equal id id')) !pstates + pstates := List.filter (fun pf -> not (pf_name_eq id pf)) !pstates let discard {CAst.loc;v=id} = let n = List.length !pstates in @@ -223,9 +227,9 @@ let discard_all () = pstates := [] (* [set_proof_mode] sets the proof mode to be used after it's called. It is typically called by the Proof Mode command. *) let set_proof_mode m id = - pstates := - List.map (function { pid = id' } as p -> - if Id.equal id' id then { p with mode = m } else p) !pstates; + pstates := List.map + (fun ps -> if pf_name_eq id ps then { ps with mode = m } else ps) + !pstates; update_proof_mode () let set_proof_mode mn = @@ -244,28 +248,26 @@ let disactivate_current_proof_mode () = end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -let start_proof sigma id ?(pl=UState.default_univ_decl) str goals terminator = +let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { - pid = id; terminator = CEphemeron.create terminator; - proof = Proof.start sigma goals; + proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; endline_tactic = None; section_vars = None; - strength = str; mode = find_proof_mode "No"; - universe_decl = pl } in + universe_decl = pl; + strength = kind } in push initial_state pstates -let start_dependent_proof id ?(pl=UState.default_univ_decl) str goals terminator = +let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = let initial_state = { - pid = id; terminator = CEphemeron.create terminator; - proof = Proof.dependent_start goals; + proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; endline_tactic = None; section_vars = None; - strength = str; mode = find_proof_mode "No"; - universe_decl = pl } in + universe_decl = pl; + strength = kind } in push initial_state pstates let get_used_variables () = (cur_pstate ()).section_vars @@ -301,10 +303,10 @@ let set_used_variables l = ctx, [] let get_open_goals () = - let gl, gll, shelf , _ , _ = Proof.proof (cur_pstate ()).proof in - List.length gl + + let Proof.{ goals; stack; shelf } = Proof.data (cur_pstate ()).proof in + List.length goals + List.fold_left (+) 0 - (List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) + + (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + List.length shelf type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t @@ -323,12 +325,9 @@ let private_poly_univs = let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now (fpl : closed_proof_output Future.computation) = - let { pid; section_vars; strength; proof; terminator; universe_decl } = - cur_pstate () in + let { section_vars; proof; terminator; universe_decl; strength } = cur_pstate () in + let Proof.{ name; poly; entry; initial_euctx } = Proof.data proof in let opaque = match opaque with Opaque -> true | Transparent -> false in - let poly = pi2 strength (* Polymorphic *) in - let initial_goals = Proof.initial_goals proof in - let initial_euctx = Proof.initial_euctx proof in let constrain_variables ctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) ctx in @@ -341,6 +340,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now Proof.in_proof proof (fun m -> Evd.existential_opt_value0 m k) in let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst universes) in + let make_body = if poly || now then let make_body t (c, eff) = @@ -388,14 +388,21 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now fun t p -> (* Already checked the univ_decl for the type universes when starting the proof. *) let univctx = Entries.Monomorphic_const_entry (UState.context_set universes) in - Future.from_val (univctx, nf t), + let t = nf t in + Future.from_val (univctx, t), Future.chain p (fun (pt,eff) -> (* Deferred proof, we already checked the universe declaration with the initial universes, ensure that the final universes respect the declaration as well. If the declaration is non-extensible, this will prevent the body from adding universes and constraints. *) - let bodyunivs = constrain_variables (Future.force univs) in - let univs = UState.check_mono_univ_decl bodyunivs universe_decl in + let univs = Future.force univs in + let univs = constrain_variables univs in + let used_univs = Univ.LSet.union + (Vars.universes_of_constr t) + (Vars.universes_of_constr pt) + in + let univs = UState.restrict univs used_univs in + let univs = UState.check_mono_univ_decl univs universe_decl in (pt,univs),eff) in let entry_fn p (_, t) = @@ -411,30 +418,31 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now const_entry_opaque = opaque; const_entry_universes = univs; } in - let entries = Future.map2 entry_fn fpl initial_goals in - { id = pid; entries = entries; persistence = strength; + let entries = Future.map2 entry_fn fpl Proofview.(initial_goals entry) in + { id = name; entries = entries; persistence = strength; universes }, fun pr_ending -> CEphemeron.get terminator pr_ending let return_proof ?(allow_partial=false) () = - let { pid; proof; strength = (_,poly,_) } = cur_pstate () in + let { proof } = cur_pstate () in if allow_partial then begin let proofs = Proof.partial_proof proof in - let _,_,_,_, evd = Proof.proof proof in + let Proof.{sigma=evd} = Proof.data proof in let eff = Evd.eval_side_effects evd in - (** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate - side-effects... This may explain why one need to uniquize side-effects - thereafter... *) + (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) let proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in proofs, Evd.evar_universe_context evd end else - let initial_goals = Proof.initial_goals proof in + let Proof.{name=pid;entry} = Proof.data proof in + let initial_goals = Proofview.initial_goals entry 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 - side-effects... This may explain why one need to uniquize side-effects - thereafter... *) + (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) let proofs = List.map (fun (c, _) -> (EConstr.to_constr evd c, eff)) initial_goals in proofs, Evd.evar_universe_context evd @@ -455,25 +463,23 @@ let set_terminator hook = module V82 = struct let get_current_initial_conclusions () = - let { pid; strength; proof } = cur_pstate () in - let initial = Proof.initial_goals proof in + let { proof; strength } = cur_pstate () in + let Proof.{ name; entry } = Proof.data proof in + let initial = Proofview.initial_goals entry in let goals = List.map (fun (o, c) -> c) initial in - pid, (goals, strength) + name, (goals, strength) end let freeze ~marshallable = - match marshallable with - | `Yes -> - CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") - | `Shallow -> !pstates - | `No -> !pstates + if marshallable then CErrors.anomaly (Pp.str"full marshalling of proof state not supported.") + else !pstates let unfreeze s = pstates := s; update_proof_mode () let proof_of_state = function { proof }::_ -> proof | _ -> raise NoCurrentProof let copy_terminators ~src ~tgt = assert(List.length src = List.length tgt); List.map2 (fun op p -> { p with terminator = op.terminator }) src tgt -let update_global_env () = +let update_global_env pf_info = with_current_proof (fun _ p -> Proof.in_proof p (fun sigma -> let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index d9c32cf9d5..e762f3b7dc 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -135,7 +135,7 @@ module V82 : sig Decl_kinds.goal_kind) end -val freeze : marshallable:[`Yes | `No | `Shallow] -> t +val freeze : marshallable:bool -> t val unfreeze : t -> unit val proof_of_state : t -> Proof.t val copy_terminators : src:t -> tgt:t -> t @@ -168,6 +168,8 @@ val register_proof_mode : proof_mode -> unit (* Can't make this deprecated due to limitations of camlp5 *) (* [@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] *) +val proof_mode_opt_name : string list + val get_default_proof_mode_name : unit -> proof_mode_name [@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] @@ -181,4 +183,3 @@ val activate_proof_mode : proof_mode_name -> unit val disactivate_current_proof_mode : unit -> unit [@@ocaml.deprecated "the current proof mode API is deprecated, use with care, see PR #459 and #566 "] - diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index dbd5be23ab..0ce726db25 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -7,7 +7,6 @@ Logic Goal_select Proof_bullet Proof_global -Redexpr Refiner Tacmach Pfedit diff --git a/proofs/refine.ml b/proofs/refine.ml index 540a8bb420..1d796fece5 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -27,7 +27,7 @@ let extract_prefix env info = let typecheck_evar ev env sigma = let info = Evd.find sigma ev in - (** Typecheck the hypotheses. *) + (* Typecheck the hypotheses. *) let type_hyp (sigma, env) decl = let t = NamedDecl.get_type decl in let sigma, _ = Typing.sort_of env sigma t in @@ -40,7 +40,7 @@ let typecheck_evar ev env sigma = let (common, changed) = extract_prefix env info in let env = Environ.reset_with_named_context (EConstr.val_of_named_context common) env in let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in - (** Typecheck the conclusion *) + (* Typecheck the conclusion *) let sigma, _ = Typing.sort_of env sigma (Evd.evar_concl info) in sigma @@ -60,39 +60,39 @@ let generic_refine ~typecheck f gl = let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let state = Proofview.Goal.state gl in - (** Save the [future_goals] state to restore them after the - refinement. *) + (* Save the [future_goals] state to restore them after the + refinement. *) let prev_future_goals = Evd.save_future_goals sigma in - (** Create the refinement term *) + (* Create the refinement term *) Proofview.Unsafe.tclEVARS (Evd.reset_future_goals sigma) >>= fun () -> f >>= fun (v, c) -> Proofview.tclEVARMAP >>= fun sigma -> Proofview.V82.wrap_exceptions begin fun () -> let evs = Evd.save_future_goals sigma in - (** Redo the effects in sigma in the monad's env *) + (* Redo the effects in sigma in the monad's env *) let privates_csts = Evd.eval_side_effects sigma in let sideff = Safe_typing.side_effects_of_private_constants privates_csts in let env = add_side_effects env sideff in - (** Check that the introduced evars are well-typed *) + (* Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in - (** Check that the refined term is typesafe *) + (* Check that the refined term is typesafe *) let sigma = if typecheck then Typing.check env sigma c concl else sigma in - (** Check that the goal itself does not appear in the refined term *) + (* Check that the goal itself does not appear in the refined term *) let self = Proofview.Goal.goal gl in let _ = if not (Evarutil.occur_evar_upto sigma self c) then () else Pretype_errors.error_occur_check env sigma self c in - (** Restore the [future goals] state. *) + (* Restore the [future goals] state. *) let sigma = Evd.restore_future_goals sigma prev_future_goals in - (** Select the goals *) + (* Select the goals *) let evs = Evd.map_filter_future_goals (Proofview.Unsafe.advance sigma) evs in let comb,shelf,given_up,evkmain = Evd.dispatch_future_goals evs in - (** Proceed to the refinement *) + (* Proceed to the refinement *) let sigma = match Proofview.Unsafe.advance sigma self with | None -> - (** Nothing to do, the goal has been solved by side-effect *) + (* Nothing to do, the goal has been solved by side-effect *) sigma | Some self -> match evkmain with @@ -104,11 +104,11 @@ let generic_refine ~typecheck f gl = | None -> sigma | Some id -> Evd.rename evk id sigma in - (** Mark goals *) + (* Mark goals *) let sigma = Proofview.Unsafe.mark_as_goals sigma comb in let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in - let trace () = Pp.(hov 2 (str"simple refine"++spc()++ - Termops.Internal.print_constr_env env sigma c)) in + let trace env sigma = Pp.(hov 2 (str"simple refine"++spc()++ + Termops.Internal.print_constr_env env sigma c)) in Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v -> Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*> Proofview.Unsafe.tclEVARS sigma <*> diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 64d7630d55..df90354717 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -15,7 +15,6 @@ open Environ open Reductionops open Evd open Typing -open Redexpr open Tacred open Logic open Context.Named.Declaration @@ -71,11 +70,6 @@ let pf_global gls id = let sigma = project gls in Evd.fresh_global env sigma (Constrintern.construct_reference (pf_hyps gls) id) -let pf_reduction_of_red_expr gls re c = - let (redfun, _) = reduction_of_red_expr (pf_env gls) re in - let sigma = project gls in - redfun (pf_env gls) sigma c - let pf_apply f gls = f (pf_env gls) (project gls) let pf_eapply f gls x = on_sig gls (fun evm -> f (pf_env gls) evm x) @@ -133,7 +127,7 @@ module New = struct f { Evd.it = Proofview.Goal.goal gl ; sigma = project gl; } let pf_global id gl = - (** We only check for the existence of an [id] in [hyps] *) + (* We only check for the existence of an [id] in [hyps] *) let hyps = Proofview.Goal.hyps gl in Constrintern.construct_reference hyps id @@ -149,12 +143,12 @@ module New = struct let pf_conv_x gl t1 t2 = pf_apply is_conv gl t1 t2 let pf_ids_of_hyps gl = - (** We only get the identifiers in [hyps] *) + (* We only get the identifiers in [hyps] *) let hyps = Proofview.Goal.hyps gl in ids_of_named_context hyps let pf_ids_set_of_hyps gl = - (** We only get the identifiers in [hyps] *) + (* We only get the identifiers in [hyps] *) let env = Proofview.Goal.env gl in Environ.ids_of_named_context_val (Environ.named_context_val env) @@ -186,7 +180,7 @@ module New = struct List.hd hyps let pf_nf_concl (gl : Proofview.Goal.t) = - (** We normalize the conclusion just after *) + (* We normalize the conclusion just after *) let concl = Proofview.Goal.concl gl in let sigma = project gl in nf_evar sigma concl diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index ef6a1544e4..213ed7bfda 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -12,7 +12,6 @@ open Names open Constr open Environ open EConstr -open Redexpr open Locus (** Operations for handling terms under a local typing context. *) @@ -44,9 +43,6 @@ val pf_get_hyp_typ : Goal.goal sigma -> Id.t -> types val pf_get_new_id : Id.t -> Goal.goal sigma -> Id.t -val pf_reduction_of_red_expr : Goal.goal sigma -> red_expr -> constr -> evar_map * constr - - val pf_apply : (env -> evar_map -> 'a) -> Goal.goal sigma -> 'a val pf_eapply : (env -> evar_map -> 'a -> evar_map * 'b) -> Goal.goal sigma -> 'a -> Goal.goal sigma * 'b diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index 6e6827c73f..067ea5df0c 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -70,6 +70,7 @@ module type Task = sig (** UID of the task kind, for -toploop *) val name : string ref + (** Extra arguments of the task kind, for -toploop *) val extra_env : unit -> string array diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index b8af2bcd56..230a3207a8 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -49,12 +49,12 @@ let is_focused_goal_simple ~doc id = match state_of_id ~doc id with | `Expired | `Error _ | `Valid None -> `Not | `Valid (Some { Vernacstate.proof }) -> - let proof = Proof_global.proof_of_state proof in - let focused, r1, r2, r3, sigma = Proof.proof proof in - let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in - if List.for_all (fun x -> simple_goal sigma x rest) focused - then `Simple focused - else `Not + let proof = Proof_global.proof_of_state proof in + let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in + let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in + if List.for_all (fun x -> simple_goal sigma x rest) focused + then `Simple focused + else `Not type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] diff --git a/stm/stm.ml b/stm/stm.ml index 3444229735..169d608d2d 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -76,18 +76,6 @@ let async_proofs_is_master opt = opt.async_proofs_mode = APon && !Flags.async_proofs_worker_id = "master" -(* Protect against state changes *) -let stm_purify f x = - let st = Vernacstate.freeze_interp_state `No in - try - let res = f x in - Vernacstate.unfreeze_interp_state st; - res - with e -> - let e = CErrors.push e in - Vernacstate.unfreeze_interp_state st; - Exninfo.iraise e - let execution_error ?loc state_id msg = feedback ~id:state_id (Message (Error, loc, msg)) @@ -343,7 +331,7 @@ module VCS : sig val set_ldir : Names.DirPath.t -> unit val get_ldir : unit -> Names.DirPath.t - val is_interactive : unit -> [`Yes | `No | `Shallow] + val is_interactive : unit -> bool val is_vio_doc : unit -> bool val current_branch : unit -> Branch.t @@ -543,8 +531,8 @@ end = struct (* {{{ *) let is_interactive () = match !doc_type with - | Interactive _ -> `Yes - | _ -> `No + | Interactive _ -> true + | _ -> false let is_vio_doc () = match !doc_type with @@ -632,13 +620,20 @@ end = struct (* {{{ *) " to "^Stateid.to_string block_stop^".")) in aux block_stop + (* [slice] copies a slice of the DAG, keeping only the last known valid state. + When it copies a state, it drops the libobjects and keeps only the structure. *) let slice ~block_start ~block_stop = let l = nodes_in_slice ~block_start ~block_stop in let copy_info v id = Vcs_.set_info v id { (get_info id) with state = Empty; vcs_backup = None,None } in + let make_shallow = function + | Valid st -> Valid (Vernacstate.make_shallow st) + | x -> x + in let copy_info_w_state v id = - Vcs_.set_info v id { (get_info id) with vcs_backup = None,None } in + let info = get_info id in + Vcs_.set_info v id { info with state = make_shallow info.state; vcs_backup = None,None } in let copy_proof_blockes v = let nodes = Vcs_.Dag.all_nodes (Vcs_.dag v) in let props = @@ -750,7 +745,7 @@ end = struct (* {{{ *) end let print ?(now=false) () = - if not !Flags.debug && not now then () else NB.command ~now (print_dag !vcs) + if !Flags.debug then NB.command ~now (print_dag !vcs) let backup () = !vcs let restore v = vcs := v @@ -768,6 +763,11 @@ let state_of_id ~doc id = (****** A cache: fills in the nodes of the VCS document with their value ******) module State : sig + type t + + val freeze : unit -> t + val unfreeze : t -> unit + (** The function is from unit, so it uses the current state to define a new one. I.e. one may been to install the right state before defining a new one. @@ -776,14 +776,14 @@ module State : sig val define : doc:doc -> ?safe_id:Stateid.t -> - ?redefine:bool -> ?cache:Summary.marshallable -> + ?redefine:bool -> ?cache:bool -> ?feedback_processed:bool -> (unit -> unit) -> Stateid.t -> unit val fix_exn_ref : (Exninfo.iexn -> Exninfo.iexn) ref val install_cached : Stateid.t -> unit - val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool - val is_cached_and_valid : ?cache:Summary.marshallable -> Stateid.t -> bool + val is_cached : ?cache:bool -> Stateid.t -> bool + val is_cached_and_valid : ?cache:bool -> Stateid.t -> bool val exn_on : Stateid.t -> valid:Stateid.t -> Exninfo.iexn -> Exninfo.iexn @@ -808,13 +808,22 @@ module State : sig be removed in the state handling refactoring. *) val cur_id : Stateid.t ref + val purify : ('a -> 'b) -> 'a -> 'b + end = struct (* {{{ *) + type t = { id : Stateid.t; vernac_state : Vernacstate.t } + (* cur_id holds Stateid.dummy in case the last attempt to define a state * failed, so the global state may contain garbage *) let cur_id = ref Stateid.dummy let fix_exn_ref = ref (fun x -> x) + let freeze () = { id = !cur_id; vernac_state = Vernacstate.freeze_interp_state ~marshallable:false } + let unfreeze st = + Vernacstate.unfreeze_interp_state st.vernac_state; + cur_id := st.id + type proof_part = Proof_global.t * int * (* Evarutil.meta_counter_summary_tag *) @@ -832,16 +841,15 @@ end = struct (* {{{ *) Summary.project_from_summary st Util.(pi2 summary_pstate), Summary.project_from_summary st Util.(pi3 summary_pstate) - let freeze marshallable id = - VCS.set_state id (Valid (Vernacstate.freeze_interp_state marshallable)) + let cache_state ~marshallable id = + VCS.set_state id (Valid (Vernacstate.freeze_interp_state ~marshallable)) let freeze_invalid id iexn = VCS.set_state id (Error iexn) - let is_cached ?(cache=`No) id only_valid = + let is_cached ?(cache=false) id only_valid = if Stateid.equal id !cur_id then try match VCS.get_info id with - | { state = Empty } when cache = `Yes -> freeze `No id; true - | { state = Empty } when cache = `Shallow -> freeze `Shallow id; true + | { state = Empty } when cache -> cache_state ~marshallable:false id; true | _ -> true with VCS.Expired -> false else @@ -861,12 +869,11 @@ end = struct (* {{{ *) cur_id := id | { state = Error ie } -> - cur_id := id; Exninfo.iraise ie | _ -> (* coqc has a 1 slot cache and only for valid states *) - if VCS.is_interactive () = `No && Stateid.equal id !cur_id then () + if not (VCS.is_interactive ()) && Stateid.equal id !cur_id then () else anomaly Pp.(str "installing a non cached state.") let get_cached id = @@ -924,7 +931,9 @@ end = struct (* {{{ *) let e2 = Summary.project_from_summary s2 Global.global_env_summary_tag in e1 == e2 - let define ~doc ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true) + (* [define] puts the system in state [id] calling [f ()] *) + (* [safe_id] is the last known valid state before execution *) + let define ~doc ?safe_id ?(redefine=false) ?(cache=false) ?(feedback_processed=true) f id = feedback ~id:id (ProcessingIn !Flags.async_proofs_worker_id); @@ -933,13 +942,12 @@ end = struct (* {{{ *) anomaly Pp.(str"defining state "++str str_id++str" twice."); try stm_prerr_endline (fun () -> "defining "^str_id^" (cache="^ - if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)"); + if cache then "Y)" else "N)"); let good_id = match safe_id with None -> !cur_id | Some id -> id in fix_exn_ref := exn_on id ~valid:good_id; f (); fix_exn_ref := (fun x -> x); - if cache = `Yes then freeze `No id - else if cache = `Shallow then freeze `Shallow id; + if cache then cache_state ~marshallable:false id; stm_prerr_endline (fun () -> "setting cur id to "^str_id); cur_id := id; if feedback_processed then @@ -958,18 +966,32 @@ end = struct (* {{{ *) | None, Some good_id -> (exn_on id ~valid:good_id (e, info)) | Some _, None -> (e, info) | Some (_,at), Some id -> (e, Stateid.add info ~valid:id at) in - if cache = `Yes || cache = `Shallow then freeze_invalid id ie; + if cache then freeze_invalid id ie; Hooks.(call unreachable_state ~doc id ie); Exninfo.iraise ie let init_state = ref None let register_root_state () = - init_state := Some (Vernacstate.freeze_interp_state `No) + init_state := Some (Vernacstate.freeze_interp_state ~marshallable:false) let restore_root_state () = cur_id := Stateid.dummy; - Vernacstate.unfreeze_interp_state (Option.get !init_state); + Vernacstate.unfreeze_interp_state (Option.get !init_state) + + (* Protect against state changes *) + let purify f x = + let st = freeze () in + try + let res = f x in + Vernacstate.invalidate_cache (); + unfreeze st; + res + with e -> + let e = CErrors.push e in + Vernacstate.invalidate_cache (); + unfreeze st; + Exninfo.iraise e end (* }}} *) @@ -1087,7 +1109,7 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) else match cmd with - | VernacShow ShowScript -> ShowScript.show_script (); st (** XX we are ignoring control here *) + | VernacShow ShowScript -> ShowScript.show_script (); st (* XX we are ignoring control here *) | _ -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (CAst.make ?loc expr) @@ -1178,7 +1200,7 @@ end = struct (* {{{ *) | _ -> None let undo_vernac_classifier v ~doc = - if VCS.is_interactive () = `No && !cur_opt.async_proofs_cache <> Some Force + if not (VCS.is_interactive ()) && !cur_opt.async_proofs_cache <> Some Force then undo_costly_in_batch_mode v; try match Vernacprop.under_control v with @@ -1508,9 +1530,7 @@ end = struct (* {{{ *) let build_proof_here ~doc ?loc ~drop_pt (id,valid) eop = Future.create (State.exn_on id ~valid) (fun () -> let wall_clock1 = Unix.gettimeofday () in - if VCS.is_interactive () = `No - then Reach.known_state ~doc ~cache:`No eop - else Reach.known_state ~doc ~cache:`Shallow eop; + Reach.known_state ~doc ~cache:(VCS.is_interactive ()) eop; let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); @@ -1532,20 +1552,20 @@ end = struct (* {{{ *) * a bad fixpoint *) let fix_exn = Future.fix_exn_of future_proof in (* STATE: We use the current installed imperative state *) - let st = Vernacstate.freeze_interp_state `No in + let st = State.freeze () in if not drop then begin let checked_proof = Future.chain future_proof (fun p -> let opaque = Proof_global.Opaque in (* Unfortunately close_future_proof and friends are not pure so we need to set the state manually here *) - Vernacstate.unfreeze_interp_state st; + State.unfreeze st; let pobject, _ = Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator []) in - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_vernac_interp stop ~proof:(pobject, terminator) st { verbose = false; loc; indentation = 0; strlen = 0; @@ -1553,7 +1573,7 @@ end = struct (* {{{ *) ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) - Vernacstate.unfreeze_interp_state st; + State.unfreeze st; RespBuiltProof(proof,time) with | e when CErrors.noncritical e || e = Stack_overflow -> @@ -1676,7 +1696,7 @@ end = struct (* {{{ *) with VCS.Expired -> cur in aux stop in try - Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:`No stop; + Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false stop; if drop then let _proof = Proof_global.return_proof ~allow_partial:true () in `OK_ADMITTED @@ -1689,14 +1709,14 @@ end = struct (* {{{ *) Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) - Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:`No start; + Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false start; (* STATE SPEC: * - start: First non-expired state! [This looks very fishy] * - end : start + qed * => takes nothing from the itermediate states. *) (* STATE We use the state resulting from reaching start. *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp stop ~proof st { verbose = false; loc; indentation = 0; strlen = 0; expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }); @@ -1750,7 +1770,7 @@ end = struct (* {{{ *) let uc = Option.get (Opaqueproof.get_constraints (Global.opaque_tables ()) o) in - (** We only manipulate monomorphic terms here. *) + (* We only manipulate monomorphic terms here. *) let map (c, ctx) = assert (Univ.AUContext.is_empty ctx); c in let pr = Future.from_val (map (Option.get (Global.body_of_constant_body c))) in @@ -1934,9 +1954,9 @@ end = struct (* {{{ *) let perform { r_state = id; r_state_fb; r_document = vcs; r_ast; r_goal } = Option.iter VCS.restore vcs; try - Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:`No id; - stm_purify (fun () -> - let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in + Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:false id; + State.purify (fun () -> + let Proof.{sigma=sigma0} = Proof.data (Proof_global.give_me_the_proof ()) in let g = Evd.find sigma0 r_goal in let is_ground c = Evarutil.is_ground_term sigma0 c in if not ( @@ -1955,9 +1975,9 @@ end = struct (* {{{ *) * => captures state id in a future closure, which will discard execution state but for the proof + univs. *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp r_state_fb st ast); - let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in + let Proof.{sigma} = Proof.data (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress | Evd.Evar_defined t -> @@ -1994,12 +2014,12 @@ end = struct (* {{{ *) | VernacFail e -> find ~time ~batch ~fail:true e | e -> e, time, batch, fail in find ~time:false ~batch:false ~fail:false e in - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in Vernacentries.with_fail st fail (fun () -> - (if time then System.with_time ~batch else (fun x -> x)) (fun () -> + (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> Proof_global.with_current_proof (fun _ p -> - let goals, _, _, _, _ = Proof.proof p in + let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> let f, assign = @@ -2089,9 +2109,9 @@ end = struct (* {{{ *) let perform { r_where; r_doc; r_what; r_for } = VCS.restore r_doc; VCS.print (); - Reach.known_state ~doc:dummy_doc (* XXX should be r_doc *) ~cache:`No r_where; + Reach.known_state ~doc:dummy_doc (* XXX should be r_doc *) ~cache:false r_where; (* STATE *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in try (* STATE SPEC: * - start: r_where @@ -2133,14 +2153,14 @@ end (* }}} *) and Reach : sig val known_state : - doc:doc -> ?redefine_qed:bool -> cache:Summary.marshallable -> + doc:doc -> ?redefine_qed:bool -> cache:bool -> Stateid.t -> unit end = struct (* {{{ *) let async_policy () = - if Attributes.is_universe_polymorphism () then false - else if VCS.is_interactive () = `Yes then + if Attributes.is_universe_polymorphism () then false (* FIXME this makes no sense, it is the default value of the attribute *) + else if VCS.is_interactive () then (async_proofs_is_master !cur_opt || !cur_opt.async_proofs_mode = APonLazy) else (VCS.is_vio_doc () || !cur_opt.async_proofs_mode <> APoff) @@ -2322,7 +2342,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = * - end : maybe after recovery command. *) (* STATE: We use an updated state with proof *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in Option.iter (fun expr -> ignore(stm_vernac_interp id st { verbose = true; loc = None; expr; indentation = 0; strlen = 0 } )) @@ -2358,17 +2378,17 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (* ugly functions to process nested lemmas, i.e. hard to reproduce * side effects *) let cherry_pick_non_pstate () = - let st = Summary.freeze_summaries ~marshallable:`No in + let st = Summary.freeze_summaries ~marshallable:false in let st = Summary.remove_from_summary st Util.(pi1 summary_pstate) in let st = Summary.remove_from_summary st Util.(pi2 summary_pstate) in let st = Summary.remove_from_summary st Util.(pi3 summary_pstate) in - st, Lib.freeze ~marshallable:`No in + st, Lib.freeze ~marshallable:false in let inject_non_pstate (s,l) = Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; update_global_env () in let rec pure_cherry_pick_non_pstate safe_id id = - stm_purify (fun id -> + State.purify (fun id -> stm_prerr_endline (fun () -> "cherry-pick non pstate " ^ Stateid.to_string id); reach ~safe_id id; cherry_pick_non_pstate ()) @@ -2393,7 +2413,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel_switch); cblock } -> (fun () -> resilient_tactic id cblock (fun () -> - reach ~cache:`Shallow view.next; + reach ~cache:true view.next; Partac.vernac_interp ~solve ~abstract ~cancel_switch !cur_opt.async_proofs_n_tacworkers view.next id x) ), cache, true @@ -2406,39 +2426,39 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = resilient_tactic id cblock (fun () -> reach view.next; (* State resulting from reach *) - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x) ); if eff then update_global_env () - ), (if eff then `Yes else cache), true + ), eff || cache, true | `Cmd { cast = x; ceff = eff } -> (fun () -> (match !cur_opt.async_proofs_mode with | APon | APonLazy -> resilient_command reach view.next | APoff -> reach view.next); - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); if eff then update_global_env () - ), (if eff then `Yes else cache), true + ), eff || cache, true | `Fork ((x,_,_,_), None) -> (fun () -> resilient_command reach view.next; - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); wall_clock_last_fork := Unix.gettimeofday () - ), `Yes, true + ), true, true | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *) - reach ~cache:`Shallow prev; + reach ~cache:true prev; reach view.next; (try - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in let info = Stateid.add info ~valid:prev id in Exninfo.iraise (e, info)); wall_clock_last_fork := Unix.gettimeofday () - ), `Yes, true + ), true, true | `Qed ({ qast = x; keep; brinfo; brname } as qed, eop) -> let rec aux = function | `ASync (block_start, nodes, name, delegate) -> (fun () -> @@ -2468,7 +2488,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = State.install_cached id | { VCS.kind = `Proof _ }, Some _ -> assert false | { VCS.kind = `Proof _ }, None -> - reach ~cache:`Shallow block_start; + reach ~cache:true block_start; let fp, cancel = if delegate then Slaves.build_proof ~doc @@ -2487,19 +2507,19 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = Proof_global.close_future_proof ~opaque ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id ~proof st x); feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; Proof_global.discard_all () - ), (if redefine_qed then `No else `Yes), true + ), not redefine_qed, true | `Sync (name, `Immediate) -> (fun () -> reach eop; - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); Proof_global.discard_all () - ), `Yes, true + ), true, true | `Sync (name, reason) -> (fun () -> log_processing_sync id name reason; reach eop; @@ -2523,25 +2543,25 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = if keep <> VtKeep VtKeepAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id ?proof st x); let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); Proof_global.discard_all () - ), `Yes, true + ), true, true | `MaybeASync (start, nodes, name, delegate) -> (fun () -> - reach ~cache:`Shallow start; + reach ~cache:true start; (* no sections *) if CList.is_empty (Environ.named_context (Global.env ())) then Util.pi1 (aux (`ASync (start, nodes, name, delegate))) () else Util.pi1 (aux (`Sync (name, `NoPU_NoHint_NoES))) () - ), (if redefine_qed then `No else `Yes), true + ), not redefine_qed, true in aux (collect_proof keep (view.next, x) brname brinfo eop) | `Sideff (ReplayCommand x,_) -> (fun () -> reach view.next; - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); update_global_env () ), cache, true @@ -2551,8 +2571,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = ), cache, true in let cache_step = - if !cur_opt.async_proofs_cache = Some Force then `Yes - else cache_step in + !cur_opt.async_proofs_cache = Some Force || cache_step + in State.define ~doc ?safe_id ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id; stm_prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in @@ -2671,7 +2691,7 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = load_objs require_libs; (* We record the state at this point! *) - State.define ~doc ~cache:`Yes ~redefine:true (fun () -> ()) Stateid.initial; + State.define ~doc ~cache:true ~redefine:true (fun () -> ()) Stateid.initial; Backtrack.record (); Slaves.init (); if async_proofs_is_master !cur_opt then begin @@ -2715,7 +2735,7 @@ let finish ~doc = ); doc let wait ~doc = - let doc = finish ~doc in + let doc = observe ~doc (VCS.get_branch_pos VCS.Branch.master) in Slaves.wait_all_done (); VCS.print (); doc @@ -2729,12 +2749,29 @@ let rec join_admitted_proofs id = join_admitted_proofs view.next | _ -> join_admitted_proofs view.next +(* Error resiliency may have tolerated some broken commands *) +let rec check_no_err_states ~doc visited id = + let open Stateid in + if Set.mem id visited then visited else + match state_of_id ~doc id with + | `Error e -> raise e + | _ -> + let view = VCS.visit id in + match view.step with + | `Qed(_,id) -> + let visited = check_no_err_states ~doc (Set.add id visited) id in + check_no_err_states ~doc visited view.next + | _ -> check_no_err_states ~doc (Set.add id visited) view.next + let join ~doc = let doc = wait ~doc in stm_prerr_endline (fun () -> "Joining the environment"); Global.join_safe_environment (); stm_prerr_endline (fun () -> "Joining Admitted proofs"); - join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ())); + join_admitted_proofs (VCS.get_branch_pos VCS.Branch.master); + stm_prerr_endline (fun () -> "Checking no error states"); + ignore(check_no_err_states ~doc (Stateid.Set.singleton Stateid.initial) + (VCS.get_branch_pos VCS.Branch.master)); VCS.print (); doc @@ -2745,7 +2782,7 @@ let check_task name (tasks,rcbackup) i = RemoteCounter.restore rcbackup; let vcs = VCS.backup () in try - let rc = stm_purify (Slaves.check_task name tasks) i in + let rc = State.purify (Slaves.check_task name tasks) i in VCS.restore vcs; rc with e when CErrors.noncritical e -> VCS.restore vcs; false @@ -2755,7 +2792,7 @@ let finish_tasks name u d p (t,rcbackup as tasks) = RemoteCounter.restore rcbackup; let finish_task u (_,_,i) = let vcs = VCS.backup () in - let u = stm_purify (Slaves.finish_task name u d p t) i in + let u = State.purify (Slaves.finish_task name u d p t) i in VCS.restore vcs; u in try @@ -2785,7 +2822,7 @@ let merge_proof_branch ~valid ?id qast keep brname = VCS.rewrite_merge qed_id ~ours:(Qed (qed ofp)) ~at:master_id brname; VCS.delete_branch brname; VCS.gc (); - let _st : unit = Reach.known_state ~doc:dummy_doc (* XXX should be taken in input *) ~redefine_qed:true ~cache:`No qed_id in + let _st : unit = Reach.known_state ~doc:dummy_doc (* XXX should be taken in input *) ~redefine_qed:true ~cache:false qed_id in VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> @@ -2794,17 +2831,9 @@ let merge_proof_branch ~valid ?id qast keep brname = (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) let handle_failure (e, info) vcs = - match Stateid.get info with - | None -> - VCS.restore vcs; - VCS.print (); - anomaly(str"error with no safe_id attached:" ++ spc() ++ - CErrors.iprint_no_report (e, info) ++ str".") - | Some (safe_id, id) -> - stm_prerr_endline (fun () -> "Failed at state " ^ Stateid.to_string id); - VCS.restore vcs; - VCS.print (); - Exninfo.iraise (e, info) + VCS.restore vcs; + VCS.print (); + Exninfo.iraise (e, info) let snapshot_vio ~doc ldir long_f_dot_vo = let doc = finish ~doc in @@ -2955,14 +2984,21 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) (* Unknown: we execute it, check for open goals and propagate sideeff *) | VtUnknown, VtNow -> let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in - let id = VCS.new_node ~id:newtip () in + if not (get_allow_nested_proofs ()) && in_proof then + "Commands which may open proofs are not allowed in a proof unless you turn option Nested Proofs Allowed on." + |> Pp.str + |> (fun s -> (UserError (None, s), Exninfo.null)) + |> State.exn_on ~valid:Stateid.dummy Stateid.dummy + |> Exninfo.iraise + else + let id = VCS.new_node ~id:newtip () in let head_id = VCS.get_branch_pos head in - let _st : unit = Reach.known_state ~doc ~cache:`Yes head_id in (* ensure it is ok *) + let _st : unit = Reach.known_state ~doc ~cache:true head_id in (* ensure it is ok *) let step () = VCS.checkout VCS.Branch.master; let mid = VCS.get_branch_pos VCS.Branch.master in let _st' : unit = Reach.known_state ~doc ~cache:(VCS.is_interactive ()) mid in - let st = Vernacstate.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); (* Vernac x may or may not start a proof *) if not in_proof && Proof_global.there_are_pending_proofs () then @@ -2987,7 +3023,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) end; VCS.checkout_shallowest_proof_branch (); end in - State.define ~doc ~safe_id:head_id ~cache:`Yes step id; + State.define ~doc ~safe_id:head_id ~cache:true step id; Backtrack.record (); `Ok | VtUnknown, VtLater -> @@ -3114,9 +3150,9 @@ type focus = { } let query ~doc ~at ~route s = - stm_purify (fun s -> + State.purify (fun s -> if Stateid.equal at Stateid.dummy then ignore(finish ~doc:dummy_doc) - else Reach.known_state ~doc ~cache:`Yes at; + else Reach.known_state ~doc ~cache:true at; try while true do let { CAst.loc; v=ast } = parse_sentence ~doc at s in diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 44d07279fc..454a4b66e7 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -56,7 +56,9 @@ let stm_allow_nested_proofs_option_name = ["Nested";"Proofs";"Allowed"] let options_affecting_stm_scheduling = [ Attributes.universe_polymorphism_option_name; - stm_allow_nested_proofs_option_name ] + stm_allow_nested_proofs_option_name; + Proof_global.proof_mode_opt_name; + ] let classify_vernac e = let static_classifier ~poly e = match e with @@ -212,6 +214,6 @@ let classify_vernac e = | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtNow - | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow) + | (VtStartProof _ | VtUnknown), _ -> VtQuery, VtLater) in static_control_classifier e diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 3c262de910..3a687a6b41 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -76,7 +76,7 @@ let shrink_entry sign const = | None -> assert false | Some t -> t in - (** The body has been forced by the call to [build_constant_by_tactic] *) + (* The body has been forced by the call to [build_constant_by_tactic] *) let () = assert (Future.is_over const.const_entry_body) in let ((body, uctx), eff) = Future.force const.const_entry_body in let (body, typ, ctx) = decompose (List.length sign) body typ [] in @@ -140,18 +140,18 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = let cd = Entries.DefinitionEntry { const with Entries.const_entry_opaque = opaque } in let decl = (cd, if opaque then IsProof Lemma else IsDefinition Definition) in let cst () = - (** do not compute the implicit arguments, it may be costly *) + (* do not compute the implicit arguments, it may be costly *) let () = Impargs.make_implicit_args false in - (** ppedrot: seems legit to have abstracted subproofs as local*) + (* ppedrot: seems legit to have abstracted subproofs as local*) Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl in 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) -> - (** 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. *) + (* 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. *) let (_, body_uctx), _ = Future.force const.Entries.const_entry_body in let () = assert (Univ.ContextSet.is_empty body_uctx) in EInstance.make (Univ.UContext.instance ctx) diff --git a/tactics/auto.ml b/tactics/auto.ml index 441fb68acc..2619620eb8 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -70,19 +70,19 @@ let auto_unif_flags = (* Try unification with the precompiled clause, then use registered Apply *) let connect_hint_clenv poly (c, _, ctx) clenv gl = - (** [clenv] has been generated by a hint-making function, so the only relevant - data in its evarmap is the set of metas. The [evar_reset_evd] function - below just replaces the metas of sigma by those coming from the clenv. *) + (* [clenv] has been generated by a hint-making function, so the only relevant + data in its evarmap is the set of metas. The [evar_reset_evd] function + below just replaces the metas of sigma by those coming from the clenv. *) let sigma = Tacmach.New.project gl in let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in - (** Still, we need to update the universes *) + (* Still, we need to update the universes *) let clenv, c = if poly then - (** Refresh the instance of the hint *) + (* Refresh the instance of the hint *) let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in let emap c = Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in - (** Only metas are mentioning the old universes. *) + (* Only metas are mentioning the old universes. *) let clenv = { templval = Evd.map_fl emap clenv.templval; templtyp = Evd.map_fl emap clenv.templtyp; @@ -211,30 +211,30 @@ let tclLOG (dbg,_,depth,trace) pp tac = match dbg with | Off -> tac | Debug -> - (* For "debug (trivial/auto)", we directly output messages *) + (* For "debug (trivial/auto)", we directly output messages *) let s = String.make (depth+1) '*' in - Proofview.V82.tactic begin fun gl -> - try - let out = Proofview.V82.of_tactic tac gl in - Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); - out - with reraise -> - let reraise = CErrors.push reraise in - Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); - iraise reraise - end + Proofview.(tclIFCATCH ( + tac >>= fun v -> + tclENV >>= fun env -> + tclEVARMAP >>= fun sigma -> + Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*success*)"); + tclUNIT v + ) tclUNIT + (fun (exn, info) -> + tclENV >>= fun env -> + tclEVARMAP >>= fun sigma -> + Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*fail*)"); + tclZERO ~info exn)) | Info -> (* For "info (trivial/auto)", we store a log trace *) - Proofview.V82.tactic begin fun gl -> - try - let out = Proofview.V82.of_tactic tac gl in - trace := (depth, Some pp) :: !trace; - out - with reraise -> - let reraise = CErrors.push reraise in - trace := (depth, None) :: !trace; - iraise reraise - end + Proofview.(tclIFCATCH ( + tac >>= fun v -> + trace := (depth, Some pp) :: !trace; + tclUNIT v + ) Proofview.tclUNIT + (fun (exn, info) -> + trace := (depth, None) :: !trace; + tclZERO ~info exn)) (** For info, from the linear trace information, we reconstitute the part of the proof tree we're interested in. The last executed tactic @@ -252,12 +252,12 @@ and erase_subtree depth = function | [] -> [] | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l -let pr_info_atom (d,pp) = - str (String.make d ' ') ++ pp () ++ str "." +let pr_info_atom env sigma (d,pp) = + str (String.make d ' ') ++ pp env sigma ++ str "." -let pr_info_trace = function +let pr_info_trace env sigma = function | (Info,_,_,{contents=(d,Some pp)::l}) -> - Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) + Feedback.msg_info (prlist_with_sep fnl (pr_info_atom env sigma) (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function @@ -273,8 +273,12 @@ let pr_dbg_header = function let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in - let tac = delay (fun () -> pr_dbg_header d; tac) >>= - fun () -> pr_info_trace d; Proofview.tclUNIT () in + let tac = + delay (fun () -> pr_dbg_header d; tac) >>= fun () -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + pr_info_trace env sigma d; + Proofview.tclUNIT () in let after = delay (fun () -> pr_info_nop d; Proofview.tclUNIT ()) in Tacticals.New.tclORELSE0 tac after @@ -304,8 +308,8 @@ let exists_evaluable_reference env = function | EvalConstRef _ -> true | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false -let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro -let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption +let dbg_intro dbg = tclLOG dbg (fun _ _ -> str "intro") intro +let dbg_assumption dbg = tclLOG dbg (fun _ _ -> str "assumption") assumption let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = @@ -389,12 +393,11 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= | Extern tacast -> conclPattern concl p tacast in - let pr_hint () = + let pr_hint env sigma = let origin = match dbname with | None -> mt () | Some n -> str " (in " ++ str n ++ str ")" in - let sigma, env = Pfedit.get_current_context () in pr_hint env sigma t ++ origin in tclLOG dbg pr_hint (run_hint t tactic) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 76cbdee0d5..f824552705 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -196,17 +196,12 @@ let subst_hintrewrite (subst,(rbase,list as node)) = if list' == list then node else (rbase,list') -let classify_hintrewrite x = Libobject.Substitute x - - (* Declaration of the Hint Rewrite library object *) let inHintRewrite : string * HintDN.t -> Libobject.obj = - Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with - Libobject.cache_function = cache_hintrewrite; - Libobject.load_function = (fun _ -> cache_hintrewrite); - Libobject.subst_function = subst_hintrewrite; - Libobject.classify_function = classify_hintrewrite } - + let open Libobject in + declare_object @@ superglobal_object_nodischarge "HINT_REWRITE" + ~cache:cache_hintrewrite + ~subst:(Some subst_hintrewrite) open Clenv diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index fd2a163f80..ba7645446d 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1096,8 +1096,8 @@ let resolve_all_evars debug depth unique env p oevd do_split fail = let initial_select_evars filter = fun evd ev evi -> filter ev (Lazy.from_val (snd evi.Evd.evar_source)) && - (** Typeclass evars can contain evars whose conclusion is not - yet determined to be a class or not. *) + (* Typeclass evars can contain evars whose conclusion is not + yet determined to be a class or not. *) Typeclasses.is_class_evar evd evi let resolve_typeclass_evars debug depth unique env evd filter split fail = diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index 46dff34f89..a6922213d0 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -39,20 +39,20 @@ val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic module Search : sig val eauto_tac : - ?st:TransparentState.t -> + ?st:TransparentState.t (** The transparent_state used when working with local hypotheses *) - ?unique:bool -> + -> ?unique:bool (** Should we force a unique solution *) - only_classes:bool -> + -> only_classes:bool (** Should non-class goals be shelved and resolved at the end *) - ?strategy:search_strategy -> + -> ?strategy:search_strategy (** Is a traversing-strategy specified? *) - depth:Int.t option -> + -> depth:Int.t option (** Bounded or unbounded search *) - dep:bool -> + -> dep:bool (** Should the tactic be made backtracking on the initial goals, - whatever their internal dependencies are. *) - Hints.hint_db list -> + whatever their internal dependencies are. *) + -> Hints.hint_db list (** The list of hint databases to use *) - unit Proofview.tactic + -> unit Proofview.tactic end diff --git a/tactics/equality.ml b/tactics/equality.ml index bdc95941b2..769e702da1 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1742,7 +1742,7 @@ let subst_one_var dep_proof_ok x = (* Find a non-recursive definition for x *) let res = try - (** [is_eq_x] ensures nf_evar on its side *) + (* [is_eq_x] ensures nf_evar on its side *) let hyps = Proofview.Goal.hyps gl in let test hyp _ = is_eq_x gl x hyp in Context.Named.fold_outside test ~init:() hyps; diff --git a/interp/genredexpr.ml b/tactics/genredexpr.ml index 607f2258fd..8209684c37 100644 --- a/interp/genredexpr.ml +++ b/tactics/genredexpr.ml @@ -63,3 +63,17 @@ type r_pat = constr_pattern_expr type r_cst = qualid or_by_notation type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen + +let make0 ?dyn name = + let wit = Genarg.make0 name in + let () = Geninterp.register_val0 wit dyn in + wit + +type 'a and_short_name = 'a * Names.lident option + +let wit_red_expr : + ((constr_expr,qualid or_by_notation,constr_expr) red_expr_gen, + (Genintern.glob_constr_and_expr,Names.evaluable_global_reference and_short_name Locus.or_var,Genintern.glob_constr_pattern_and_expr) red_expr_gen, + (EConstr.t,Names.evaluable_global_reference,Pattern.constr_pattern) red_expr_gen) + Genarg.genarg_type = + make0 "redexpr" diff --git a/tactics/hints.ml b/tactics/hints.ml index 77479f9efa..571ad9d160 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -210,9 +210,9 @@ let fresh_key = let lbl = Id.of_string ("_" ^ string_of_int cur) in let kn = Lib.make_kn lbl in let (mp, _) = KerName.repr kn in - (** We embed the full path of the kernel name in the label so that the - identifier should be unique. This ensures that including two modules - together won't confuse the corresponding labels. *) + (* We embed the full path of the kernel name in the label so that + the identifier should be unique. This ensures that including + two modules together won't confuse the corresponding labels. *) let lbl = Id.of_string_soft (Printf.sprintf "%s#%i" (ModPath.to_string mp) cur) in @@ -558,7 +558,7 @@ struct let realize_tac secvars (id,tac) = if Id.Pred.subset tac.secvars secvars then Some tac else - (** Warn about no longer typable hint? *) + (* Warn about no longer typable hint? *) None let head_evar sigma c = @@ -601,7 +601,7 @@ struct let se = find k db in merge_entry secvars db se.sentry_nopat se.sentry_pat - (** Precondition: concl has no existentials *) + (* Precondition: concl has no existentials *) let map_auto sigma ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in @@ -644,7 +644,7 @@ struct | None -> let is_present (_, (_, v')) = KerName.equal v.code.uid v'.code.uid in if not (List.exists is_present db.hintdb_nopat) then - (** FIXME *) + (* FIXME *) { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> @@ -738,7 +738,6 @@ module Hintdbmap = String.Map type hint_db = Hint_db.t (** Initially created hint databases, for typeclasses and rewrite *) - let typeclasses_db = "typeclass_instances" let rewrite_db = "rewrite" @@ -1064,12 +1063,12 @@ let cache_autohint (kn, obj) = let subst_autohint (subst, obj) = let subst_key gr = - let (lab'', elab') = subst_global subst gr in - let elab' = EConstr.of_constr elab' in - let gr' = - (try head_constr_bound Evd.empty elab' - with Bound -> lab'') - in if gr' == gr then gr else gr' + let (gr', t) = subst_global subst gr in + match t with + | None -> gr' + | Some t -> + (try head_constr_bound Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value) + with Bound -> gr') in let subst_hint (k,data as hint) = let k' = Option.Smart.map subst_key k in @@ -1517,8 +1516,8 @@ let pr_hint_term env sigma cl = let pr_applicable_hint () = let env = Global.env () in let pts = Proof_global.give_me_the_proof () in - let glss,_,_,_,sigma = Proof.proof pts in - match glss with + let Proof.{goals;sigma} = Proof.data pts in + match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") | g::_ -> pr_hint_term env sigma (Goal.V82.concl sigma g) @@ -1586,7 +1585,7 @@ let log_hint h = let store = get_extra_data sigma in match Store.get store hint_trace with | None -> - (** All calls to hint logging should be well-scoped *) + (* All calls to hint logging should be well-scoped *) assert false | Some trace -> let trace = KNmap.add h.uid h trace in diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index a53e3bf20d..a67f5f6d6e 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -59,12 +59,10 @@ let discharge_scheme (_,(kind,l)) = Some (kind, l) let inScheme : string * (inductive * Constant.t) array -> obj = - declare_object {(default_object "SCHEME") with - cache_function = cache_scheme; - load_function = (fun _ -> cache_scheme); - subst_function = subst_scheme; - classify_function = (fun obj -> Substitute obj); - discharge_function = discharge_scheme} + declare_object @@ superglobal_object "SCHEME" + ~cache:cache_scheme + ~subst:(Some subst_scheme) + ~discharge:discharge_scheme (**********************************************************************) (* The table of scheme building functions *) diff --git a/tactics/inv.ml b/tactics/inv.ml index 6a39a10fc4..2ae37ab471 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -365,7 +365,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = let substHypIfVariable tac id = Proofview.Goal.enter begin fun gl -> let sigma = project gl in - (** We only look at the type of hypothesis "id" *) + (* We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id gl) in let (t,t1,t2) = dest_nf_eq (pf_env gl) sigma hyp in match (EConstr.kind sigma t1, EConstr.kind sigma t2) with diff --git a/tactics/leminv.ml b/tactics/leminv.ml index caf4c1eca3..356b43ec14 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -183,7 +183,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = scheme on sort [sort]. Depending on the value of [dep_option] it will build a dependent lemma or a non-dependent one *) -let inversion_scheme env sigma t sort dep_option inv_op = +let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = let (env,i) = add_prods_sign env sigma t in let ind = try find_rectype env sigma i @@ -201,7 +201,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = user_err ~hdr:"lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) - let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in + let pf = Proof.start ~name ~poly (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in let pf = fst (Proof.run_tactic env ( tclTHEN intro (onLastHypId inv_op)) pf) @@ -217,7 +217,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = invEnv ~init:Context.Named.empty end in let avoid = ref Id.Set.empty in - let _,_,_,_,sigma = Proof.proof pf in + let Proof.{sigma} = Proof.data pf in let sigma = Evd.minimize_universes sigma in let rec fill_holes c = match EConstr.kind sigma c with @@ -236,7 +236,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = p, sigma let add_inversion_lemma ~poly name env sigma t sort dep inv_op = - let invProof, sigma = inversion_scheme env sigma t sort dep inv_op in + let invProof, sigma = inversion_scheme ~name ~poly env sigma t sort dep inv_op in let univs = Evd.const_univ_entry ~poly sigma in diff --git a/tactics/ppred.ml b/tactics/ppred.ml new file mode 100644 index 0000000000..dd1bcd4699 --- /dev/null +++ b/tactics/ppred.ml @@ -0,0 +1,83 @@ +open Util +open Pp +open Locus +open Genredexpr +open Pputils + +let pr_with_occurrences pr keyword (occs,c) = + match occs with + | AllOccurrences -> + pr c + | NoOccurrences -> + failwith "pr_with_occurrences: no occurrences" + | OnlyOccurrences nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + | AllOccurrencesBut nl -> + hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++ + hov 0 (prlist_with_sep spc (pr_or_var int) nl)) + +exception ComplexRedFlag + +let pr_short_red_flag pr r = + if not r.rBeta || not r.rMatch || not r.rFix || not r.rCofix || not r.rZeta then + raise ComplexRedFlag + else if List.is_empty r.rConst then + if r.rDelta then mt () else raise ComplexRedFlag + else (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]") + +let pr_red_flag pr r = + try pr_short_red_flag pr r + with ComplexRedFlag -> + (if r.rBeta then pr_arg str "beta" else mt ()) ++ + (if r.rMatch && r.rFix && r.rCofix then pr_arg str "iota" else + (if r.rMatch then pr_arg str "match" else mt ()) ++ + (if r.rFix then pr_arg str "fix" else mt ()) ++ + (if r.rCofix then pr_arg str "cofix" else mt ())) ++ + (if r.rZeta then pr_arg str "zeta" else mt ()) ++ + (if List.is_empty r.rConst then + if r.rDelta then pr_arg str "delta" + else mt () + else + pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++ + hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")) + +let pr_union pr1 pr2 = function + | Inl a -> pr1 a + | Inr b -> pr2 b + +let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function + | Red false -> keyword "red" + | Hnf -> keyword "hnf" + | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f) + ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | Cbv f -> + if f.rBeta && f.rMatch && f.rFix && f.rCofix && + f.rZeta && f.rDelta && List.is_empty f.rConst then + keyword "compute" + else + hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f) + | Lazy f -> + hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f) + | Cbn f -> + hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f) + | Unfold l -> + hov 1 (keyword "unfold" ++ spc() ++ + prlist_with_sep pr_comma (pr_with_occurrences pr_ref keyword) l) + | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l) + | Pattern l -> + hov 1 (keyword "pattern" ++ + pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr keyword)) l) + + | Red true -> + CErrors.user_err Pp.(str "Shouldn't be accessible from user.") + | ExtraRedExpr s -> + str s + | CbvVm o -> + keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + | CbvNative o -> + keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o + +let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) = + pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma) diff --git a/tactics/ppred.mli b/tactics/ppred.mli new file mode 100644 index 0000000000..b3a306a36f --- /dev/null +++ b/tactics/ppred.mli @@ -0,0 +1,19 @@ +open Genredexpr + +val pr_with_occurrences : + ('a -> Pp.t) -> (string -> Pp.t) -> 'a Locus.with_occurrences -> Pp.t + +val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t +val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t + +val pr_red_expr : + ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> + (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t + +val pr_red_expr_env : Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + ('b -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'c -> Pp.t) -> + (string -> Pp.t) -> + ('a,'b,'c) red_expr_gen -> Pp.t diff --git a/proofs/redexpr.ml b/tactics/redexpr.ml index 6658c37f41..aabfae444e 100644 --- a/proofs/redexpr.ml +++ b/tactics/redexpr.ml @@ -74,13 +74,13 @@ let set_strategy_one ref l = Csymtable.set_opaque_const sp | ConstKey sp, _ -> let cb = Global.lookup_constant sp in - (match cb.const_body with - | OpaqueDef _ -> + (match cb.const_body with + | OpaqueDef _ -> user_err ~hdr:"set_transparent_const" (str "Cannot make" ++ spc () ++ Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef sp) ++ - spc () ++ str "transparent because it was declared opaque."); - | _ -> Csymtable.set_transparent_const sp) + spc () ++ str "transparent because it was declared opaque."); + | _ -> Csymtable.set_transparent_const sp) | _ -> () let cache_strategy (_,str) = @@ -126,10 +126,10 @@ type strategy_obj = let inStrategy : strategy_obj -> obj = declare_object {(default_object "STRATEGY") with cache_function = (fun (_,obj) -> cache_strategy obj); - load_function = (fun _ (_,obj) -> cache_strategy obj); - subst_function = subst_strategy; + load_function = (fun _ (_,obj) -> cache_strategy obj); + subst_function = subst_strategy; discharge_function = discharge_strategy; - classify_function = classify_strategy } + classify_function = classify_strategy } let set_strategy local str = @@ -154,16 +154,16 @@ let make_flag env f = let red = if f.rDelta then (* All but rConst *) let red = red_add red fDELTA in - let red = red_add_transparent red + let red = red_add_transparent red (Conv_oracle.get_transp_state (Environ.oracle env)) in - List.fold_right - (fun v red -> red_sub red (make_flag_constant v)) - f.rConst red + List.fold_right + (fun v red -> red_sub red (make_flag_constant v)) + f.rConst red else (* Only rConst *) let red = red_add_transparent (red_add red fDELTA) TransparentState.empty in - List.fold_right - (fun v red -> red_add red (make_flag_constant v)) - f.rConst red + List.fold_right + (fun v red -> red_add red (make_flag_constant v)) + f.rConst red in red (* table of custom reductino fonctions, not synchronized, @@ -234,7 +234,7 @@ let reduction_of_red_expr env = let am = if !simplIsCbn then strong_cbn (make_flag f) else simpl in let () = if not (!simplIsCbn || List.is_empty f.rConst) then - warn_simpl_unfolding_modifiers () in + warn_simpl_unfolding_modifiers () in (contextualize (if head_style then whd_am else am) am o,DEFAULTcast) | Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast) | Cbn f -> @@ -246,9 +246,9 @@ let reduction_of_red_expr env = | ExtraRedExpr s -> (try (e_red (String.Map.find s !reduction_tab),DEFAULTcast) with Not_found -> - (try reduction_of_red_expr (String.Map.find s !red_expr_tab) - with Not_found -> - user_err ~hdr:"Redexpr.reduction_of_red_expr" + (try reduction_of_red_expr (String.Map.find s !red_expr_tab) + with Not_found -> + user_err ~hdr:"Redexpr.reduction_of_red_expr" (str "unknown user-defined reduction \"" ++ str s ++ str "\""))) | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) @@ -270,9 +270,9 @@ let inReduction : bool * string * red_expr -> obj = cache_function = (fun (_,(_,s,e)) -> decl_red_expr s e); load_function = (fun _ (_,(_,s,e)) -> decl_red_expr s e); subst_function = - (fun (subs,(b,s,e)) -> b,s,subst_red_expr subs e); + (fun (subs,(b,s,e)) -> b,s,subst_red_expr subs e); classify_function = - (fun ((b,_,_) as obj) -> if b then Dispose else Substitute obj) } + (fun ((b,_,_) as obj) -> if b then Dispose else Substitute obj) } let declare_red_expr locality s expr = Lib.add_anonymous_leaf (inReduction (locality,s,expr)) diff --git a/proofs/redexpr.mli b/tactics/redexpr.mli index 1e59f436c3..1f65862701 100644 --- a/proofs/redexpr.mli +++ b/tactics/redexpr.mli @@ -20,7 +20,7 @@ open Locus type red_expr = (constr, evaluable_global_reference, constr_pattern) red_expr_gen - + val out_with_occurrences : 'a with_occurrences -> occurrences * 'a val reduction_of_red_expr : diff --git a/interp/redops.ml b/tactics/redops.ml index b9a74136e4..6f83ea9a34 100644 --- a/interp/redops.ml +++ b/tactics/redops.ml @@ -21,14 +21,14 @@ let make_red_flag l = | FCofix :: lf -> add_flag { red with rCofix = true } lf | FZeta :: lf -> add_flag { red with rZeta = true } lf | FConst l :: lf -> - if red.rDelta then - CErrors.user_err Pp.(str - "Cannot set both constants to unfold and constants not to unfold"); + if red.rDelta then + CErrors.user_err Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); add_flag { red with rConst = union_consts red.rConst l } lf | FDeltaBut l :: lf -> - if red.rConst <> [] && not red.rDelta then - CErrors.user_err Pp.(str - "Cannot set both constants to unfold and constants not to unfold"); + if red.rConst <> [] && not red.rDelta then + CErrors.user_err Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); add_flag { red with rConst = union_consts red.rConst l; rDelta = true } lf diff --git a/interp/redops.mli b/tactics/redops.mli index 7254f29b25..7254f29b25 100644 --- a/interp/redops.mli +++ b/tactics/redops.mli diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 224cd68cf9..bfbce8f6eb 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -572,7 +572,7 @@ module New = struct with Failure _ -> CErrors.user_err Pp.(str "Not enough hypotheses in the goal.") let nthHypId m gl = - (** We only use [id] *) + (* We only use [id] *) nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = mkVar (nthHypId m gl) @@ -688,12 +688,12 @@ module New = struct end) end let elimination_sort_of_goal gl = - (** Retyping will expand evars anyway. *) + (* Retyping will expand evars anyway. *) let c = Proofview.Goal.concl gl in pf_apply Retyping.get_sort_family_of gl c let elimination_sort_of_hyp id gl = - (** Retyping will expand evars anyway. *) + (* Retyping will expand evars anyway. *) let c = pf_get_hyp_typ id gl in pf_apply Retyping.get_sort_family_of gl c diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 2947e44f7a..201b7801c3 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -191,6 +191,7 @@ module New : sig val tclTHENS3PARTS : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic val tclTHENSFIRSTn : unit tactic -> unit tactic array -> unit tactic -> unit tactic val tclTHENFIRSTn : unit tactic -> unit tactic array -> unit tactic + (** [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2] to the first resulting subgoal *) val tclTHENFIRST : unit tactic -> unit tactic -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b3ea13cf4f..1043c50f00 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -183,7 +183,7 @@ let convert_gen pb x y = | Some sigma -> Proofview.Unsafe.tclEVARS sigma | None -> Tacticals.New.tclFAIL 0 (str "Not convertible") | exception _ -> - (** FIXME: Sometimes an anomaly is raised from conversion *) + (* FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") end @@ -241,7 +241,7 @@ let clear_gen fail = function | ids -> Proofview.Goal.enter begin fun gl -> let ids = List.fold_right Id.Set.add ids Id.Set.empty in - (** clear_hyps_in_evi does not require nf terms *) + (* clear_hyps_in_evi does not require nf terms *) let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -307,7 +307,7 @@ let rename_hyp repl = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - (** Check that we do not mess variables *) + (* Check that we do not mess variables *) let fold accu decl = Id.Set.add (NamedDecl.get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = @@ -322,7 +322,7 @@ let rename_hyp repl = CErrors.user_err (Id.print elt ++ str " is already used") with Not_found -> () in - (** All is well *) + (* All is well *) let make_subst (src, dst) = (src, mkVar dst) in let subst = List.map make_subst repl in let subst c = Vars.replace_vars subst c in @@ -889,11 +889,7 @@ let reduce redexp cl = let trace env sigma = let open Printer in let pr = (pr_econstr_env, pr_leconstr_env, pr_evaluable_reference, pr_constr_pattern_env) in - Pp.(hov 2 (Pputils.pr_red_expr_env env sigma pr str redexp)) - in - let trace () = - let sigma, env = Pfedit.get_current_context () in - trace env sigma + Pp.(hov 2 (Ppred.pr_red_expr_env env sigma pr str redexp)) in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter begin fun gl -> @@ -1063,9 +1059,16 @@ let intros_replacing ids = (* The standard for implementing Automatic Introduction *) let auto_intros_tac ids = - Tacticals.New.tclMAP (function - | Name id -> intro_mustbe_force id - | Anonymous -> intro) (List.rev ids) + let fold used = function + | Name id -> Id.Set.add id used + | Anonymous -> used + in + let avoid = NamingAvoid (List.fold_left fold Id.Set.empty ids) in + let naming = function + | Name id -> NamingMustBe CAst.(make id) + | Anonymous -> avoid + in + Tacticals.New.tclMAP (fun name -> intro_gen (naming name) MoveLast true false) (List.rev ids) (* User-level introduction tactics *) @@ -1235,7 +1238,7 @@ let cut c = let concl = Proofview.Goal.concl gl in let is_sort = try - (** Backward compat: ensure that [c] is well-typed. *) + (* Backward compat: ensure that [c] is well-typed. *) let typ = Typing.unsafe_type_of env sigma c in let typ = whd_all env sigma typ in match EConstr.kind sigma typ with @@ -1245,7 +1248,7 @@ let cut c = in if is_sort then let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in - (** Backward compat: normalize [c]. *) + (* Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in Refine.refine ~typecheck:false begin fun h -> let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in @@ -1498,8 +1501,8 @@ let simplest_elim c = default_elim false None (c,NoBindings) *) let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = - (** The evarmap of elimclause is assumed to be an extension of hypclause, so - we do not need to merge the universes coming from hypclause. *) + (* The evarmap of elimclause is assumed to be an extension of hypclause, so + we do not need to merge the universes coming from hypclause. *) try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) @@ -1909,7 +1912,7 @@ let exact_no_check c = let exact_check c = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - (** We do not need to normalize the goal because we just check convertibility *) + (* We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma, ct = Typing.type_of env sigma c in @@ -2021,7 +2024,7 @@ let clear_body ids = let check = try let check (env, sigma, seen) decl = - (** Do no recheck hypotheses that do not depend *) + (* Do no recheck hypotheses that do not depend *) let sigma = if not seen then sigma else if List.exists (fun id -> occur_var_in_decl env sigma id decl) ids then @@ -2848,7 +2851,7 @@ let generalize_dep ?(with_let=false) c = in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in - (** Check that the generalization is indeed well-typed *) + (* Check that the generalization is indeed well-typed *) let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance mkVar to_quantify_rev in tclTHENLIST @@ -3021,7 +3024,7 @@ let specialize (c,lbind) ipat = let unfold_body x = let open Context.Named.Declaration in Proofview.Goal.enter begin fun gl -> - (** We normalize the given hypothesis immediately. *) + (* We normalize the given hypothesis immediately. *) let env = Proofview.Goal.env gl in let xval = match Environ.lookup_named x env with | LocalAssum _ -> user_err ~hdr:"unfold_body" diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 5afec74fae..1861c5b99b 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -6,6 +6,10 @@ Hipattern Ind_tables Eqschemes Elimschemes +Genredexpr +Redops +Redexpr +Ppred Tactics Abstract Elim diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 03d2a17eee..e273891500 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -281,7 +281,7 @@ struct open TDnet let pat_of_constr c : term_pattern = - (** To each evar we associate a unique identifier. *) + (* To each evar we associate a unique identifier. *) let metas = ref Evar.Map.empty in let rec pat_of_constr c = match Constr.kind c with | Rel _ -> Term DRel @@ -378,7 +378,7 @@ struct let c_id = Opt.reduce (Ident.constr_of id) in let c_id = EConstr.of_constr c_id in let (ctx,wc) = - try Termops.align_prod_letin Evd.empty whole_c c_id (** FIXME *) + try Termops.align_prod_letin Evd.empty whole_c c_id (* FIXME *) with Invalid_argument _ -> [],c_id in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in try diff --git a/test-suite/Makefile b/test-suite/Makefile index 9d2277c37e..37091a49e5 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -36,9 +36,10 @@ include ../Makefile.common # easily overridden LIB := .. BIN := $(shell cd ..; pwd)/bin/ +COQFLAGS?= -coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -batch -test-mode -R prerequisite TestSuite -coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite +coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -batch -test-mode -R prerequisite TestSuite $(COQFLAGS) +coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite $(COQFLAGS) coqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite coqdoc := $(BIN)coqdoc coqtopbyte := $(BIN)coqtop.byte @@ -90,19 +91,17 @@ FAIL = >&2 echo 'FAILED $@' # Testing subsystems ####################################################################### -# Apart so that it can be easily skipped with overriding +# These targets can be skipped by doing `make TARGET= test-suite` COMPLEXITY := $(if $(bogomips),complexity) - BUGS := bugs/opened bugs/closed - INTERACTIVE := interactive - +UNIT_TESTS := unit-tests VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ output-modulo-time $(INTERACTIVE) micromega $(COMPLEXITY) modules stm \ coqdoc ssr # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools unit-tests +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools $(UNIT_TESTS) PREREQUISITELOG = prerequisite/admit.v.log \ prerequisite/make_local.v.log prerequisite/make_notation.v.log \ @@ -119,6 +118,10 @@ PREREQUISITELOG = prerequisite/admit.v.log \ all: run $(MAKE) report +# do nothing +.PHONY: noop +noop: ; + run: $(SUBSYSTEMS) bugs: $(BUGS) @@ -569,7 +572,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ - $(BIN)fake_ide $< "-coqlib $(LIB) -boot -async-proofs on -async-proofs-tactic-error-resilience off -async-proofs-command-error-resilience off" 2>&1; \ + $(BIN)fake_ide $< "-coqlib $(LIB) -boot -async-proofs on -async-proofs-tactic-error-resilience off -async-proofs-command-error-resilience off $(call get_coq_prog_args,"$<")" 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ diff --git a/test-suite/bugs/closed/bug_4509.v b/test-suite/bugs/closed/bug_4509.v new file mode 100644 index 0000000000..ceae7c5fc3 --- /dev/null +++ b/test-suite/bugs/closed/bug_4509.v @@ -0,0 +1,11 @@ +(* Was solved at some time, suspectingly in PR #6328 *) + +Goal exists n, n > 1. +Proof. + unshelve eexists. (*2 goals, as expected*) + Undo. + unshelve (eexists; instantiate (1:=ltac:(idtac))). (*only 1 goal*) + shelve. + Undo. + 2:unshelve instantiate (1:=_). +Abort. diff --git a/test-suite/bugs/opened/bug_4781.v b/test-suite/bugs/closed/bug_4781.v index 8b651ac22e..464a3de1b3 100644 --- a/test-suite/bugs/opened/bug_4781.v +++ b/test-suite/bugs/closed/bug_4781.v @@ -25,29 +25,29 @@ Goal True. let x := match constr:(Set) with ?y => constr:(y) end in pose x. (* This fails with an error: *) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let x := match constr:(x) with ?y => constr:(y) end in pose x. (* The command has indeed failed with message: Error: Variable y should be bound to a term. *) (* And the rest fail with Anomaly: Uncaught exception Not_found. Please report. *) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let x := match constr:(x) with ?y => y end in pose x. - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let x := (eval cbv iota in x) in pose x. - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let x := type of x in pose x. (* should succeed *) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:(_ : abstract_term term) in let x := type of x in @@ -70,7 +70,7 @@ Even stranger, consider:*) (*This works fine. But if I change the period to a semicolon, I get:*) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let y := (eval cbv iota in (let v : T := x in v)) in @@ -82,7 +82,7 @@ Even stranger, consider:*) (* should succeed *) (*and if I use the second one instead of [pose x] (note that using [idtac] works fine), I get:*) - Fail let term := constr:(I) in + let term := constr:(I) in let T := type of term in let x := constr:((_ : abstract_term term) : T) in let y := (eval cbv iota in (let v : T := x in v)) in @@ -92,3 +92,5 @@ Even stranger, consider:*) let x := (eval cbv delta [x'] in x') in let z := (eval cbv iota in x) in (* Error: Variable x should be bound to a term. *) idtac. (* should succeed *) + exact I. +Qed. diff --git a/test-suite/bugs/closed/bug_6202.v b/test-suite/bugs/closed/bug_6202.v new file mode 100644 index 0000000000..899260f59a --- /dev/null +++ b/test-suite/bugs/closed/bug_6202.v @@ -0,0 +1,11 @@ +(* This was fixed at some time, suspectingly in PR #6328 *) + +Inductive foo := F (a : forall var : Type -> Type, unit -> var unit) (_ : a = a). +Goal foo. + eexists (fun var => fun u : unit => ltac:(clear u)). + shelve. + Unshelve. + all:[ > | ]. + shelve. + Fail Grab Existential Variables. +Abort. diff --git a/test-suite/bugs/closed/bug_7904.v b/test-suite/bugs/closed/bug_7904.v new file mode 100644 index 0000000000..1e518e2adf --- /dev/null +++ b/test-suite/bugs/closed/bug_7904.v @@ -0,0 +1,13 @@ + + +Class abstract_term {T} (x : T) := by_abstract_term : T. +Hint Extern 0 (@abstract_term ?T ?x) => change T; abstract (exact x) : typeclass_instances. + +Goal True. + let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let x := match constr:(x) with ?y => y end in + pose x as v. (* was Error: Variable x should be bound to a term but is bound to a constr. *) + exact v. +Qed. diff --git a/test-suite/bugs/closed/bug_8369.v b/test-suite/bugs/closed/bug_8369.v new file mode 100644 index 0000000000..9816954d0c --- /dev/null +++ b/test-suite/bugs/closed/bug_8369.v @@ -0,0 +1,3 @@ +(* Was failing in master with a not_found generated by the printer *) + +Fail Definition foo := fun '(u, v) p2 => (u, v). diff --git a/test-suite/bugs/closed/bug_8819.v b/test-suite/bugs/closed/bug_8819.v new file mode 100644 index 0000000000..a4cb9dcd14 --- /dev/null +++ b/test-suite/bugs/closed/bug_8819.v @@ -0,0 +1,2 @@ +Theorem foo (_ : nat) (H : bool) : bool. +Proof. exact H. Qed. diff --git a/test-suite/bugs/closed/bug_8951.v b/test-suite/bugs/closed/bug_8951.v new file mode 100644 index 0000000000..dce19318c5 --- /dev/null +++ b/test-suite/bugs/closed/bug_8951.v @@ -0,0 +1,14 @@ +Module Type T. + Polymorphic Parameter Inline t@{i} : Type@{i}. +End T. + +Module M. + Polymorphic Definition t@{i} := nat. +End M. + +Module Make (X:T). + Include X. + +End Make. + +Module P := Make M. diff --git a/test-suite/bugs/closed/bug_9166.v b/test-suite/bugs/closed/bug_9166.v new file mode 100644 index 0000000000..8a7e9c37b0 --- /dev/null +++ b/test-suite/bugs/closed/bug_9166.v @@ -0,0 +1,9 @@ +Set Warnings "+deprecated". + +Notation bar := option (compat "8.7"). + +Definition foo (x: nat) : nat := + match x with + | 0 => 0 + | S bar => bar + end. diff --git a/test-suite/bugs/closed/bug_9229.v b/test-suite/bugs/closed/bug_9229.v new file mode 100644 index 0000000000..7514741af4 --- /dev/null +++ b/test-suite/bugs/closed/bug_9229.v @@ -0,0 +1,6 @@ +(* There was a problem of freshness with Infix choice of vars *) + +(* In particular, x and y were special... *) + +Infix "#" := (fun x y => x + y) (at level 50, left associativity). +Check (3 # 5). diff --git a/test-suite/bugs/closed/bug_9240.v b/test-suite/bugs/closed/bug_9240.v new file mode 100644 index 0000000000..e0901dc2d9 --- /dev/null +++ b/test-suite/bugs/closed/bug_9240.v @@ -0,0 +1,12 @@ +Register unit as core.IDProp.type. +Register tt as core.IDProp.idProp. + + +Inductive vec (A : Type) : nat -> Type := +| nil : vec A 0 +| cons : forall n : nat, A -> vec A n -> vec A (S n). + +Definition hd (A : Type) (n : nat) (v : vec A (S n)) : A := +match v in (vec _ (S n)) return A with +| cons _ _ h _ => h +end. (* assertion failure in evarconv *) diff --git a/test-suite/bugs/closed/bug_9300.v b/test-suite/bugs/closed/bug_9300.v new file mode 100644 index 0000000000..a80f3233a3 --- /dev/null +++ b/test-suite/bugs/closed/bug_9300.v @@ -0,0 +1,6 @@ +Existing Class True. + +Instance foo {n : nat} (x := I) : forall {b : bool} (s : nat * nat), True. auto. Defined. + +Fail Check foo (n := 3) true (s := (4 , 5)). +Check foo (n := 3) (b := true) (4 , 5). diff --git a/test-suite/bugs/opened/bug_3166.v b/test-suite/bugs/opened/bug_3166.v index e1c29a954c..baf87631f0 100644 --- a/test-suite/bugs/opened/bug_3166.v +++ b/test-suite/bugs/opened/bug_3166.v @@ -81,3 +81,4 @@ Goal forall T (x y : T) (p : x = y), True. compute in H0. change (fun (x' : T) (_ : y = x') => x' = y) with ((fun y => fun (x' : T) (_ : y = x') => x' = y) y) in H0. Fail pose proof (fun k => @eq_trans _ _ _ k H0). +Abort. diff --git a/test-suite/bugs/opened/bug_3754.v b/test-suite/bugs/opened/bug_3754.v index a717bbe735..18820b1a4c 100644 --- a/test-suite/bugs/opened/bug_3754.v +++ b/test-suite/bugs/opened/bug_3754.v @@ -282,3 +282,4 @@ Defined. rewrite <- ap_p_pp; rewrite_moveL_Mp_p. Set Debug Tactic Unification. Fail rewrite (concat_Ap ff2). + Abort. diff --git a/test-suite/bugs/opened/bug_3890.v b/test-suite/bugs/opened/bug_3890.v index 5c74addb62..78b2aa69b9 100644 --- a/test-suite/bugs/opened/bug_3890.v +++ b/test-suite/bugs/opened/bug_3890.v @@ -1,3 +1,5 @@ +Set Nested Proofs Allowed. + Class Foo. Class Bar := b : Type. diff --git a/test-suite/bugs/opened/bug_3938.v b/test-suite/bugs/opened/bug_3938.v index 2d0d1930f1..3c7c945ed8 100644 --- a/test-suite/bugs/opened/bug_3938.v +++ b/test-suite/bugs/opened/bug_3938.v @@ -4,3 +4,4 @@ Goal forall a b (f : nat -> Set), Nat.eq a b -> f a = f b. intros a b f H. rewrite H. (* Toplevel input, characters 15-25: Anomaly: Evar ?X11 was not declared. Please report. *) +Abort. diff --git a/test-suite/coqchk/inductive_functor_params.v b/test-suite/coqchk/inductive_functor_params.v new file mode 100644 index 0000000000..f364a62818 --- /dev/null +++ b/test-suite/coqchk/inductive_functor_params.v @@ -0,0 +1,16 @@ + +Module Type T. + Parameter foo : nat -> nat. +End T. + +Module F (A:T). + Inductive ind (n:nat) : nat -> Prop := + | C : (forall x, x < n -> ind (A.foo n) x) -> ind n n. +End F. + +Module A. Definition foo (n:nat) := n. End A. + +Module M := F A. +(* Note: M.ind could be seen as having 1 recursively uniform + parameter, but module substitution does not recognize it, so it is + treated as a non-uniform parameter. *) diff --git a/test-suite/coqchk/inductive_functor_template.v b/test-suite/coqchk/inductive_functor_template.v new file mode 100644 index 0000000000..bc5cd0fb68 --- /dev/null +++ b/test-suite/coqchk/inductive_functor_template.v @@ -0,0 +1,11 @@ + +Module Type E. Parameter T : Type. End E. + +Module F (X:E). + #[universes(template)] Inductive foo := box : X.T -> foo. +End F. + +Module ME. Definition T := nat. End ME. +Module A := F ME. +(* Note: A.foo could live in Set, and coqchk sees that (because of + template polymorphism implementation details) *) diff --git a/test-suite/dune b/test-suite/dune index c5fa0bb14a..eae072553a 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -70,4 +70,4 @@ (progn ; XXX: we will allow to set the NJOBS variable in a future Dune ; version, either by using an env var or by letting Dune set `-j` - (run make -j 2 BIN= PRINT_LOGS=1)))) + (run make -j 2 BIN= PRINT_LOGS=1 UNIT_TESTS=%{env:COQ_UNIT_TEST=unit-tests})))) diff --git a/test-suite/ide/join-sync.fake b/test-suite/ide/join-sync.fake new file mode 100644 index 0000000000..236028ce46 --- /dev/null +++ b/test-suite/ide/join-sync.fake @@ -0,0 +1,20 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# Error resiliency + async proofs off +# coq-prog-args: ("-async-proofs" "off" "-async-proofs-command-error-resilience" "on") +# + +ADD { Lemma x : True. } +ADD { Proof using. } +ADD here { trivial. } +ADD { fail. } +ADD { Qed. } +ADD { Lemma y : True. } +ADD { Proof using. } +ADD { trivial. } +ADD { Qed. } +WAIT +FAILJOIN +ASSERT TIP here +ABORT diff --git a/test-suite/ide/join.fake b/test-suite/ide/join.fake new file mode 100644 index 0000000000..c4c696ad9a --- /dev/null +++ b/test-suite/ide/join.fake @@ -0,0 +1,20 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# Error resiliency +# + +ADD { Section x. } +ADD { Lemma x : True. } +ADD { Proof using. } +ADD here { trivial. } +ADD { fail. } +ADD { Qed. } +ADD { Lemma y : True. } +ADD { Proof using. } +ADD { trivial. } +ADD { Qed. } +ADD { End x. } +FAILJOIN +ASSERT TIP here +ABORT diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.v b/test-suite/output-modulo-time/ltacprof_cutoff.v index ae5d51bae8..b7c98aa134 100644 --- a/test-suite/output-modulo-time/ltacprof_cutoff.v +++ b/test-suite/output-modulo-time/ltacprof_cutoff.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-profile-ltac") -*- *) +(* -*- coq-prog-args: ("-async-proofs" "off" "-profile-ltac") -*- *) Require Coq.ZArith.BinInt. Module WithIdTac. Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v index 97df40f882..844f96aaa1 100644 --- a/test-suite/output/Arguments.v +++ b/test-suite/output/Arguments.v @@ -51,7 +51,7 @@ Arguments pi _ _%F _%B. Check (forall w : r, pi w $ $ = tt). Fail Check (forall w : r, w $ $ = tt). Axiom w : r. -Arguments w _%F _%B : extra scopes. +Arguments w x%F y%B : extra scopes. Check (w $ $ = tt). Fail Arguments w _%F _%B. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index b071da86c9..583ea0cb43 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -11,7 +11,7 @@ eq_refl : ?y = ?y where ?y : [ |- nat] -Monomorphic Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq_refl: Arguments are renamed to B, y For eq: Argument A is implicit and maximally inserted @@ -31,8 +31,7 @@ When applied to 1 argument: Argument B is implicit Argument scopes are [type_scope _] Expands to: Constructor Coq.Init.Logic.eq_refl -Monomorphic Inductive myEq (B : Type) (x : A) : A -> Prop := - myrefl : B -> myEq B x x +Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x For myrefl: Arguments are renamed to C, x, _ For myrefl: Argument C is implicit and maximally inserted @@ -45,7 +44,7 @@ Arguments are renamed to C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope _ _] Expands to: Constructor Arguments_renaming.Test1.myrefl -Monomorphic myplus = +myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := match n with | 0 => m @@ -69,7 +68,7 @@ myplus is transparent Expands to: Constant Arguments_renaming.Test1.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat -Monomorphic Inductive myEq (A B : Type) (x : A) : A -> Prop := +Inductive myEq (A B : Type) (x : A) : A -> Prop := myrefl : B -> myEq A B x x For myrefl: Arguments are renamed to A, C, x, _ @@ -85,7 +84,7 @@ Argument scopes are [type_scope type_scope _ _] Expands to: Constructor Arguments_renaming.myrefl myrefl : forall (A C : Type) (x : A), C -> myEq A C x x -Monomorphic myplus = +myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := match n with | 0 => m diff --git a/test-suite/output/Binder.out b/test-suite/output/Binder.out index 9c46ace463..6e27837b26 100644 --- a/test-suite/output/Binder.out +++ b/test-suite/output/Binder.out @@ -1,10 +1,10 @@ -Monomorphic foo = fun '(x, y) => x + y +foo = fun '(x, y) => x + y : nat * nat -> nat foo is not universe polymorphic forall '(a, b), a /\ b : Prop -Monomorphic foo = λ '(x, y), x + y +foo = λ '(x, y), x + y : nat * nat → nat foo is not universe polymorphic diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 0a02c5a7dd..efcc299e82 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -1,4 +1,4 @@ -Monomorphic t_rect = +t_rect = fun (P : t -> Type) (f : let x := t in forall x0 : x, P x0 -> P (k x0)) => fix F (t : t) : P t := match t as t0 return (P t0) with @@ -17,7 +17,7 @@ Argument scopes are [function_scope function_scope _] | {| f3 := b |} => b end : TT -> 0 = 0 -Monomorphic proj = +proj = fun (x y : nat) (P : nat -> Type) (def : P x) (prf : P y) => match Nat.eq_dec x y with | left eqprf => match eqprf in (_ = z) return (P z) with @@ -29,7 +29,7 @@ end proj is not universe polymorphic Argument scopes are [nat_scope nat_scope function_scope _ _] -Monomorphic foo = +foo = fix foo (A : Type) (l : list A) {struct l} : option A := match l with | nil => None @@ -40,7 +40,7 @@ fix foo (A : Type) (l : list A) {struct l} : option A := foo is not universe polymorphic Argument scopes are [type_scope list_scope] -Monomorphic uncast = +uncast = fun (A : Type) (x : I A) => match x with | x0 <: _ => x0 end @@ -48,11 +48,11 @@ fun (A : Type) (x : I A) => match x with uncast is not universe polymorphic Argument scopes are [type_scope _] -Monomorphic foo' = if A 0 then true else false +foo' = if A 0 then true else false : bool foo' is not universe polymorphic -Monomorphic f = +f = fun H : B => match H with | AC x => @@ -83,18 +83,18 @@ fun '(D n m p q) => n + m + p + q : J -> nat The command has indeed failed with message: The constructor D (in type J) expects 3 arguments. -Monomorphic lem1 = +lem1 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k lem1 is not universe polymorphic -Monomorphic lem2 = +lem2 = fun dd : bool => if dd as aa return (aa = aa) then eq_refl else eq_refl : forall k : bool, k = k lem2 is not universe polymorphic Argument scope is [bool_scope] -Monomorphic lem3 = +lem3 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 43718a0f07..4e949dcb04 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -43,6 +43,7 @@ Print foo. (* Accept and use notation with binded parameters *) +#[universes(template)] Inductive I (A: Type) : Type := C : A -> I A. Notation "x <: T" := (C T x) (at level 38). @@ -83,6 +84,7 @@ Print f. (* Was enhancement request #5142 (error message reported on the most general return clause heuristic) *) +#[universes(template)] Inductive gadt : Type -> Type := | gadtNat : nat -> gadt nat | gadtTy : forall T, T -> gadt T. diff --git a/test-suite/output/Coercions.v b/test-suite/output/Coercions.v index 0e84bf3966..6976f35a88 100644 --- a/test-suite/output/Coercions.v +++ b/test-suite/output/Coercions.v @@ -1,7 +1,7 @@ (* Submitted by Randy Pollack *) -Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. -Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. +#[universes(template)] Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. +#[universes(template)] Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. Section testSection. Variables (S : Set) (P : pred S) (R : rel S) (x : S). diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out index cf2d5b2850..14c48e8fa0 100644 --- a/test-suite/output/Errors.out +++ b/test-suite/output/Errors.out @@ -9,10 +9,11 @@ The command has indeed failed with message: Ltac call to "instantiate ( (ident) := (lglob) )" failed. Instance is not well-typed in the environment of ?x. The command has indeed failed with message: -Cannot infer the domain of the type of f. +Cannot infer ?T in the partial instance "?T -> nat" found for the type of f. The command has indeed failed with message: -Cannot infer the domain of the implicit parameter A of id whose type is -"Type". +Cannot infer ?T in the partial instance "?T -> nat" found for the implicit +parameter A of id whose type is "Type". The command has indeed failed with message: -Cannot infer the codomain of the type of f in environment: +Cannot infer ?T in the partial instance "forall x : nat, ?T" found for the +type of f in environment: x : nat diff --git a/test-suite/output/Extraction_matchs_2413.v b/test-suite/output/Extraction_matchs_2413.v index 1ecd9771eb..f9398fdca9 100644 --- a/test-suite/output/Extraction_matchs_2413.v +++ b/test-suite/output/Extraction_matchs_2413.v @@ -101,7 +101,7 @@ Section decoder_result. Variable inst : Type. - Inductive decoder_result : Type := + #[universes(template)] Inductive decoder_result : Type := | DecUndefined : decoder_result | DecUnpredictable : decoder_result | DecInst : inst -> decoder_result diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index 61ae4edbd1..9b25c2dbd3 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -44,7 +44,7 @@ fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). omega. Qed. -CoInductive Inf := S { projS : Inf }. +#[universes(template)] CoInductive Inf := S { projS : Inf }. Definition expand_Inf (x : Inf) := S (projS x). CoFixpoint inf := S inf. Eval compute in inf. diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index 71c7070f2b..0b0f501f9a 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -2,8 +2,7 @@ compose (C:=nat) S : (nat -> nat) -> nat -> nat ex_intro (P:=fun _ : nat => True) (x:=0) I : ex (fun _ : nat => True) -Monomorphic d2 = -fun x : nat => d1 (y:=x) +d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x d2 is not universe polymorphic diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index 5a548cfae4..2ba02924c9 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -1,8 +1,7 @@ The command has indeed failed with message: Last occurrence of "list'" must have "A" as 1st argument in "A -> list' A -> list' (A * A)". -Monomorphic Inductive foo (A : Type) (x : A) (y : A := x) : Prop := - Foo : foo A x +Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x For foo: Argument scopes are [type_scope _] For Foo: Argument scopes are [type_scope _] diff --git a/test-suite/output/Inductive.v b/test-suite/output/Inductive.v index 8ff91268a6..9eec9a7dad 100644 --- a/test-suite/output/Inductive.v +++ b/test-suite/output/Inductive.v @@ -3,5 +3,5 @@ Fail Inductive list' (A:Set) : Set := | cons' : A -> list' A -> list' (A*A). (* Check printing of let-ins *) -Inductive foo (A : Type) (x : A) (y := x) := Foo. +#[universes(template)] Inductive foo (A : Type) (x : A) (y := x) := Foo. Print foo. diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index 4743fb0d0a..c17c63e724 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -1,4 +1,4 @@ -Monomorphic Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := +Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} For sig2: Argument A is implicit diff --git a/test-suite/output/Load.out b/test-suite/output/Load.out index f84cedfa62..ebbd5d422b 100644 --- a/test-suite/output/Load.out +++ b/test-suite/output/Load.out @@ -1,8 +1,8 @@ -Monomorphic f = 2 +f = 2 : nat f is not universe polymorphic -Monomorphic u = I +u = I : True u is not universe polymorphic diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index f53313def9..71d92482d0 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -225,7 +225,7 @@ fun S : nat => [[S | S + S]] : Set exists2 '{{y, z}} : nat * nat, y > z & z > y : Prop -Monomorphic foo = +foo = fun l : list nat => match l with | _ :: (_ :: _) as l1 => l1 | _ => l @@ -261,11 +261,11 @@ myfoo01 tt {4; 5; 6}; {7; 8; 9}] : list (list nat) -Monomorphic amatch = mmatch 0 (with 0 => 1| 1 => 2 end) +amatch = mmatch 0 (with 0 => 1| 1 => 2 end) : unit amatch is not universe polymorphic -Monomorphic alist = [0; 1; 2] +alist = [0; 1; 2] : list nat alist is not universe polymorphic diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 15211f1233..2caffad1d9 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -123,7 +123,7 @@ Check fun n => foo4 n (fun x y z => (fun _ => y=0) z). (**********************************************************************) (* Test printing of #4932 *) -Inductive ftele : Type := +#[universes(template)] Inductive ftele : Type := | fb {T:Type} : T -> ftele | fr {T} : (T -> ftele) -> ftele. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index d58e4bf2d6..94016e170b 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -45,3 +45,5 @@ fun x : nat => (x.-1)%pred : Prop ## : Prop +Notation Cn := Foo.FooCn +Expands to: Notation Top.J.Mfoo.Foo.Bar.Cn diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 61206b6dd0..309115848f 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -164,3 +164,20 @@ Open Scope my_scope. Check ##. End H. + +(* Fixing a bug reported by G. Gonthier in #9207 *) + +Module J. + +Module Import Mfoo. +Module Foo. +Definition FooCn := 2. +Module Bar. +Notation Cn := FooCn. +End Bar. +End Foo. +Export Foo.Bar. +End Mfoo. +About Cn. + +End J. diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index bfeff20524..bdbc5a5960 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -1,4 +1,4 @@ -Monomorphic swap = fun '(x, y) => (y, x) +swap = fun '(x, y) => (y, x) : A * B -> B * A swap is not universe polymorphic @@ -6,22 +6,20 @@ fun '(x, y) => (y, x) : A * B -> B * A forall '(x, y), swap (x, y) = (y, x) : Prop -Monomorphic proj_informative = -fun '(exist _ x _) => x : A +proj_informative = fun '(exist _ x _) => x : A : {x : A | P x} -> A proj_informative is not universe polymorphic -Monomorphic foo = -fun '(Bar n b tt p) => if b then n + p else n - p +foo = fun '(Bar n b tt p) => if b then n + p else n - p : Foo -> nat foo is not universe polymorphic -Monomorphic baz = +baz = fun '(Bar n1 _ tt p1) '(Bar _ _ tt _) => n1 + p1 : Foo -> Foo -> nat baz is not universe polymorphic -Monomorphic swap = +swap = fun (A B : Type) '(x, y) => (y, x) : forall A B : Type, A * B -> B * A @@ -40,7 +38,7 @@ exists '(x, y) '(z, w), swap (x, y) = (z, w) : A * B → B * A ∀ '(x, y), swap (x, y) = (y, x) : Prop -Monomorphic both_z = +both_z = fun pat : nat * nat => let '(n, p) as x := pat return (F x) in (Z n, Z p) : F (n, p) : forall pat : nat * nat, F pat @@ -52,7 +50,7 @@ forall '(x, y) '(z, t), swap (x, y) = (z, t) : Prop fun (pat : nat) '(x, y) => x + y = pat : nat -> nat * nat -> Prop -Monomorphic f = fun x : nat => x + x +f = fun x : nat => x + x : nat -> nat f is not universe polymorphic diff --git a/test-suite/output/PatternsInBinders.v b/test-suite/output/PatternsInBinders.v index d671053c07..0c1b08f5a3 100644 --- a/test-suite/output/PatternsInBinders.v +++ b/test-suite/output/PatternsInBinders.v @@ -53,7 +53,7 @@ Module Suboptimal. (** This test shows an example which exposes the [let] introduced by the pattern notation in binders. *) -Inductive Fin (n:nat) := Z : Fin n. +#[universes(template)] Inductive Fin (n:nat) := Z : Fin n. Definition F '(n,p) : Type := (Fin n * Fin p)%type. Definition both_z '(n,p) : F (n,p) := (Z _,Z _). Print both_z. diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index be793dd453..da1fca7134 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -4,7 +4,7 @@ existT is template universe polymorphic Argument A is implicit Argument scopes are [type_scope function_scope _ _] Expands to: Constructor Coq.Init.Specif.existT -Monomorphic Inductive sigT (A : Type) (P : A -> Type) : Type := +Inductive sigT (A : Type) (P : A -> Type) : Type := existT : forall x : A, P x -> {x : A & P x} For sigT: Argument A is implicit @@ -14,7 +14,7 @@ For existT: Argument scopes are [type_scope function_scope _ _] existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit -Monomorphic Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: @@ -38,7 +38,7 @@ When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: Argument A is implicit -Monomorphic Nat.add = +Nat.add = fix add (n m : nat) {struct n} : nat := match n with | 0 => m @@ -62,7 +62,7 @@ plus_n_O is not universe polymorphic Argument scope is [nat_scope] plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O -Monomorphic Inductive le (n : nat) : nat -> Prop := +Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m For le_S: Argument m is implicit @@ -74,7 +74,7 @@ comparison : Set comparison is not universe polymorphic Expands to: Inductive Coq.Init.Datatypes.comparison -Monomorphic Inductive comparison : Set := +Inductive comparison : Set := Eq : comparison | Lt : comparison | Gt : comparison bar : foo @@ -84,7 +84,7 @@ bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted Expands to: Constant PrintInfos.bar -Monomorphic *** [ bar : foo ] +*** [ bar : foo ] bar is not universe polymorphic Expanded type for implicit arguments @@ -94,7 +94,7 @@ Argument x is implicit and maximally inserted Module Coq.Init.Peano Notation sym_eq := eq_sym Expands to: Notation Coq.Init.Logic.sym_eq -Monomorphic Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x +Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x For eq: Argument A is implicit and maximally inserted For eq_refl, when applied to no arguments: diff --git a/test-suite/output/Projections.v b/test-suite/output/Projections.v index 098a518dc4..2713e6a188 100644 --- a/test-suite/output/Projections.v +++ b/test-suite/output/Projections.v @@ -5,7 +5,7 @@ Class HostFunction := host_func : Type. Section store. Context `{HostFunction}. - Record store := { store_funcs : host_func }. + #[universes(template)] Record store := { store_funcs : host_func }. End store. Check (fun (S:@store nat) => S.(store_funcs)). diff --git a/test-suite/output/Record.v b/test-suite/output/Record.v index d9a649fadc..4fe7b051f8 100644 --- a/test-suite/output/Record.v +++ b/test-suite/output/Record.v @@ -20,12 +20,12 @@ Check {| field := 5 |}. Check build_r 5. Check build_c 5. -Record N := C { T : Type; _ : True }. +#[universes(template)] Record N := C { T : Type; _ : True }. Check fun x:N => let 'C _ p := x in p. Check fun x:N => let 'C T _ := x in T. Check fun x:N => let 'C T p := x in (T,p). -Record M := D { U : Type; a := 0; q : True }. +#[universes(template)] Record M := D { U : Type; a := 0; q : True }. Check fun x:M => let 'D T _ p := x in p. Check fun x:M => let 'D T _ p := x in T. Check fun x:M => let 'D T p := x in (T,p). diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 7446c17d98..f4544a0df3 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -34,17 +34,23 @@ bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b eq_true_rec: forall P : bool -> Set, P true -> forall b : bool, eq_true b -> P b -eq_true_ind: - forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b +bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b eq_true_rect_r: forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true eq_true_rec_r: forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true eq_true_rect: forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b -bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b +eq_true_ind: + forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b eq_true_ind_r: forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true +Byte.to_bits: + Byte.byte -> + bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) +Byte.of_bits: + bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) -> + Byte.byte andb_true_intro: forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true @@ -52,6 +58,10 @@ BoolSpec_ind: forall (P Q : Prop) (P0 : bool -> Prop), (P -> P0 true) -> (Q -> P0 false) -> forall b : bool, BoolSpec P Q b -> P0 b +Byte.to_bits_of_bits: + forall + b : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))), + Byte.to_bits (Byte.of_bits b) = b bool_choice: forall (S : Set) (R1 R2 : S -> Prop), (forall x : S, {R1 x} + {R2 x}) -> diff --git a/test-suite/output/ShowMatch.v b/test-suite/output/ShowMatch.v index 9cf6ad35b8..99183f2064 100644 --- a/test-suite/output/ShowMatch.v +++ b/test-suite/output/ShowMatch.v @@ -3,12 +3,12 @@ *) Module A. - Inductive foo := f. + #[universes(template)] Inductive foo := f. Show Match foo. (* no need to disambiguate *) End A. Module B. - Inductive foo := f. + #[universes(template)] Inductive foo := f. (* local foo shadows A.foo, so constructor "f" needs disambiguation *) Show Match A.foo. End B. diff --git a/test-suite/output/StringSyntax.out b/test-suite/output/StringSyntax.out new file mode 100644 index 0000000000..c7e6ef950e --- /dev/null +++ b/test-suite/output/StringSyntax.out @@ -0,0 +1,1089 @@ +byte_rect = +fun (P : byte -> Type) (f : P "000") (f0 : P "001") (f1 : P "002") (f2 : P "003") (f3 : P "004") (f4 : P "005") (f5 : P "006") (f6 : P "007") (f7 : P "008") (f8 : P "009") (f9 : P "010") (f10 : P "011") (f11 : P "012") (f12 : P "013") (f13 : P "014") (f14 : P "015") (f15 : P "016") (f16 : P "017") (f17 : P "018") (f18 : P "019") (f19 : P "020") (f20 : P "021") (f21 : P "022") (f22 : P "023") (f23 : P "024") (f24 : P "025") (f25 : P "026") (f26 : P "027") (f27 : P "028") (f28 : P "029") (f29 : P "030") (f30 : P "031") (f31 : P " ") (f32 : P "!") (f33 : P """") (f34 : P "#") (f35 : P "$") (f36 : P "%") (f37 : P "&") (f38 : P "'") (f39 : P "(") (f40 : P ")") (f41 : P "*") (f42 : P "+") (f43 : P ",") (f44 : P "-") (f45 : P ".") (f46 : P "/") (f47 : P "0") (f48 : P "1") (f49 : P "2") (f50 : P "3") (f51 : P "4") (f52 : P "5") (f53 : P "6") (f54 : P "7") (f55 : P "8") (f56 : P "9") (f57 : P ":") (f58 : P ";") (f59 : P "<") (f60 : P "=") (f61 : P ">") (f62 : P "?") + (f63 : P "@") (f64 : P "A") (f65 : P "B") (f66 : P "C") (f67 : P "D") (f68 : P "E") (f69 : P "F") (f70 : P "G") (f71 : P "H") (f72 : P "I") (f73 : P "J") (f74 : P "K") (f75 : P "L") (f76 : P "M") (f77 : P "N") (f78 : P "O") (f79 : P "P") (f80 : P "Q") (f81 : P "R") (f82 : P "S") (f83 : P "T") (f84 : P "U") (f85 : P "V") (f86 : P "W") (f87 : P "X") (f88 : P "Y") (f89 : P "Z") (f90 : P "[") (f91 : P "\") (f92 : P "]") (f93 : P "^") (f94 : P "_") (f95 : P "`") (f96 : P "a") (f97 : P "b") (f98 : P "c") (f99 : P "d") (f100 : P "e") (f101 : P "f") (f102 : P "g") (f103 : P "h") (f104 : P "i") (f105 : P "j") (f106 : P "k") (f107 : P "l") (f108 : P "m") (f109 : P "n") (f110 : P "o") (f111 : P "p") (f112 : P "q") (f113 : P "r") (f114 : P "s") (f115 : P "t") (f116 : P "u") (f117 : P "v") (f118 : P "w") (f119 : P "x") (f120 : P "y") (f121 : P "z") (f122 : P "{") (f123 : P "|") (f124 : P "}") (f125 : P "~") (f126 : P "127") (f127 : P "128") (f128 : P "129") (f129 : P "130") + (f130 : P "131") (f131 : P "132") (f132 : P "133") (f133 : P "134") (f134 : P "135") (f135 : P "136") (f136 : P "137") (f137 : P "138") (f138 : P "139") (f139 : P "140") (f140 : P "141") (f141 : P "142") (f142 : P "143") (f143 : P "144") (f144 : P "145") (f145 : P "146") (f146 : P "147") (f147 : P "148") (f148 : P "149") (f149 : P "150") (f150 : P "151") (f151 : P "152") (f152 : P "153") (f153 : P "154") (f154 : P "155") (f155 : P "156") (f156 : P "157") (f157 : P "158") (f158 : P "159") (f159 : P "160") (f160 : P "161") (f161 : P "162") (f162 : P "163") (f163 : P "164") (f164 : P "165") (f165 : P "166") (f166 : P "167") (f167 : P "168") (f168 : P "169") (f169 : P "170") (f170 : P "171") (f171 : P "172") (f172 : P "173") (f173 : P "174") (f174 : P "175") (f175 : P "176") (f176 : P "177") (f177 : P "178") (f178 : P "179") (f179 : P "180") (f180 : P "181") (f181 : P "182") (f182 : P "183") (f183 : P "184") (f184 : P "185") (f185 : P "186") (f186 : P "187") + (f187 : P "188") (f188 : P "189") (f189 : P "190") (f190 : P "191") (f191 : P "192") (f192 : P "193") (f193 : P "194") (f194 : P "195") (f195 : P "196") (f196 : P "197") (f197 : P "198") (f198 : P "199") (f199 : P "200") (f200 : P "201") (f201 : P "202") (f202 : P "203") (f203 : P "204") (f204 : P "205") (f205 : P "206") (f206 : P "207") (f207 : P "208") (f208 : P "209") (f209 : P "210") (f210 : P "211") (f211 : P "212") (f212 : P "213") (f213 : P "214") (f214 : P "215") (f215 : P "216") (f216 : P "217") (f217 : P "218") (f218 : P "219") (f219 : P "220") (f220 : P "221") (f221 : P "222") (f222 : P "223") (f223 : P "224") (f224 : P "225") (f225 : P "226") (f226 : P "227") (f227 : P "228") (f228 : P "229") (f229 : P "230") (f230 : P "231") (f231 : P "232") (f232 : P "233") (f233 : P "234") (f234 : P "235") (f235 : P "236") (f236 : P "237") (f237 : P "238") (f238 : P "239") (f239 : P "240") (f240 : P "241") (f241 : P "242") (f242 : P "243") (f243 : P "244") + (f244 : P "245") (f245 : P "246") (f246 : P "247") (f247 : P "248") (f248 : P "249") (f249 : P "250") (f250 : P "251") (f251 : P "252") (f252 : P "253") (f253 : P "254") (f254 : P "255") (b : byte) => +match b as b0 return (P b0) with +| "000" => f +| "001" => f0 +| "002" => f1 +| "003" => f2 +| "004" => f3 +| "005" => f4 +| "006" => f5 +| "007" => f6 +| "008" => f7 +| "009" => f8 +| "010" => f9 +| "011" => f10 +| "012" => f11 +| "013" => f12 +| "014" => f13 +| "015" => f14 +| "016" => f15 +| "017" => f16 +| "018" => f17 +| "019" => f18 +| "020" => f19 +| "021" => f20 +| "022" => f21 +| "023" => f22 +| "024" => f23 +| "025" => f24 +| "026" => f25 +| "027" => f26 +| "028" => f27 +| "029" => f28 +| "030" => f29 +| "031" => f30 +| " " => f31 +| "!" => f32 +| """" => f33 +| "#" => f34 +| "$" => f35 +| "%" => f36 +| "&" => f37 +| "'" => f38 +| "(" => f39 +| ")" => f40 +| "*" => f41 +| "+" => f42 +| "," => f43 +| "-" => f44 +| "." => f45 +| "/" => f46 +| "0" => f47 +| "1" => f48 +| "2" => f49 +| "3" => f50 +| "4" => f51 +| "5" => f52 +| "6" => f53 +| "7" => f54 +| "8" => f55 +| "9" => f56 +| ":" => f57 +| ";" => f58 +| "<" => f59 +| "=" => f60 +| ">" => f61 +| "?" => f62 +| "@" => f63 +| "A" => f64 +| "B" => f65 +| "C" => f66 +| "D" => f67 +| "E" => f68 +| "F" => f69 +| "G" => f70 +| "H" => f71 +| "I" => f72 +| "J" => f73 +| "K" => f74 +| "L" => f75 +| "M" => f76 +| "N" => f77 +| "O" => f78 +| "P" => f79 +| "Q" => f80 +| "R" => f81 +| "S" => f82 +| "T" => f83 +| "U" => f84 +| "V" => f85 +| "W" => f86 +| "X" => f87 +| "Y" => f88 +| "Z" => f89 +| "[" => f90 +| "\" => f91 +| "]" => f92 +| "^" => f93 +| "_" => f94 +| "`" => f95 +| "a" => f96 +| "b" => f97 +| "c" => f98 +| "d" => f99 +| "e" => f100 +| "f" => f101 +| "g" => f102 +| "h" => f103 +| "i" => f104 +| "j" => f105 +| "k" => f106 +| "l" => f107 +| "m" => f108 +| "n" => f109 +| "o" => f110 +| "p" => f111 +| "q" => f112 +| "r" => f113 +| "s" => f114 +| "t" => f115 +| "u" => f116 +| "v" => f117 +| "w" => f118 +| "x" => f119 +| "y" => f120 +| "z" => f121 +| "{" => f122 +| "|" => f123 +| "}" => f124 +| "~" => f125 +| "127" => f126 +| "128" => f127 +| "129" => f128 +| "130" => f129 +| "131" => f130 +| "132" => f131 +| "133" => f132 +| "134" => f133 +| "135" => f134 +| "136" => f135 +| "137" => f136 +| "138" => f137 +| "139" => f138 +| "140" => f139 +| "141" => f140 +| "142" => f141 +| "143" => f142 +| "144" => f143 +| "145" => f144 +| "146" => f145 +| "147" => f146 +| "148" => f147 +| "149" => f148 +| "150" => f149 +| "151" => f150 +| "152" => f151 +| "153" => f152 +| "154" => f153 +| "155" => f154 +| "156" => f155 +| "157" => f156 +| "158" => f157 +| "159" => f158 +| "160" => f159 +| "161" => f160 +| "162" => f161 +| "163" => f162 +| "164" => f163 +| "165" => f164 +| "166" => f165 +| "167" => f166 +| "168" => f167 +| "169" => f168 +| "170" => f169 +| "171" => f170 +| "172" => f171 +| "173" => f172 +| "174" => f173 +| "175" => f174 +| "176" => f175 +| "177" => f176 +| "178" => f177 +| "179" => f178 +| "180" => f179 +| "181" => f180 +| "182" => f181 +| "183" => f182 +| "184" => f183 +| "185" => f184 +| "186" => f185 +| "187" => f186 +| "188" => f187 +| "189" => f188 +| "190" => f189 +| "191" => f190 +| "192" => f191 +| "193" => f192 +| "194" => f193 +| "195" => f194 +| "196" => f195 +| "197" => f196 +| "198" => f197 +| "199" => f198 +| "200" => f199 +| "201" => f200 +| "202" => f201 +| "203" => f202 +| "204" => f203 +| "205" => f204 +| "206" => f205 +| "207" => f206 +| "208" => f207 +| "209" => f208 +| "210" => f209 +| "211" => f210 +| "212" => f211 +| "213" => f212 +| "214" => f213 +| "215" => f214 +| "216" => f215 +| "217" => f216 +| "218" => f217 +| "219" => f218 +| "220" => f219 +| "221" => f220 +| "222" => f221 +| "223" => f222 +| "224" => f223 +| "225" => f224 +| "226" => f225 +| "227" => f226 +| "228" => f227 +| "229" => f228 +| "230" => f229 +| "231" => f230 +| "232" => f231 +| "233" => f232 +| "234" => f233 +| "235" => f234 +| "236" => f235 +| "237" => f236 +| "238" => f237 +| "239" => f238 +| "240" => f239 +| "241" => f240 +| "242" => f241 +| "243" => f242 +| "244" => f243 +| "245" => f244 +| "246" => f245 +| "247" => f246 +| "248" => f247 +| "249" => f248 +| "250" => f249 +| "251" => f250 +| "252" => f251 +| "253" => f252 +| "254" => f253 +| "255" => f254 +end + : forall P : byte -> Type, + P "000" -> + P "001" -> + P "002" -> + P "003" -> + P "004" -> + P "005" -> + P "006" -> + P "007" -> + P "008" -> + P "009" -> + P "010" -> + P "011" -> + P "012" -> + P "013" -> + P "014" -> + P "015" -> + P "016" -> + P "017" -> + P "018" -> + P "019" -> + P "020" -> + P "021" -> + P "022" -> + P "023" -> + P "024" -> + P "025" -> + P "026" -> + P "027" -> + P "028" -> + P "029" -> + P "030" -> + P "031" -> + P " " -> + P "!" -> + P """" -> + P "#" -> + P "$" -> + P "%" -> + P "&" -> + P "'" -> + P "(" -> + P ")" -> + P "*" -> + P "+" -> + P "," -> + P "-" -> + P "." -> + P "/" -> + P "0" -> + P "1" -> + P "2" -> + P "3" -> + P "4" -> + P "5" -> + P "6" -> + P "7" -> + P "8" -> + P "9" -> + P ":" -> + P ";" -> + P "<" -> + P "=" -> + P ">" -> + P "?" -> + P "@" -> + P "A" -> + P "B" -> + P "C" -> + P "D" -> + P "E" -> + P "F" -> + P "G" -> + P "H" -> + P "I" -> + P "J" -> + P "K" -> + P "L" -> + P "M" -> + P "N" -> + P "O" -> + P "P" -> + P "Q" -> + P "R" -> + P "S" -> + P "T" -> + P "U" -> + P "V" -> + P "W" -> + P "X" -> + P "Y" -> + P "Z" -> + P "[" -> + P "\" -> + P "]" -> + P "^" -> + P "_" -> + P "`" -> + P "a" -> + P "b" -> + P "c" -> + P "d" -> + P "e" -> + P "f" -> + P "g" -> + P "h" -> + P "i" -> + P "j" -> + P "k" -> + P "l" -> + P "m" -> + P "n" -> + P "o" -> + P "p" -> + P "q" -> + P "r" -> + P "s" -> + P "t" -> + P "u" -> + P "v" -> + P "w" -> + P "x" -> + P "y" -> + P "z" -> + P "{" -> + P "|" -> + P "}" -> + P "~" -> + P "127" -> + P "128" -> + P "129" -> + P "130" -> + P "131" -> + P "132" -> + P "133" -> + P "134" -> + P "135" -> + P "136" -> + P "137" -> + P "138" -> + P "139" -> + P "140" -> + P "141" -> + P "142" -> + P "143" -> + P "144" -> + P "145" -> + P "146" -> + P "147" -> + P "148" -> + P "149" -> + P "150" -> + P "151" -> + P "152" -> + P "153" -> + P "154" -> + P "155" -> + P "156" -> + P "157" -> + P "158" -> + P "159" -> + P "160" -> + P "161" -> + P "162" -> + P "163" -> + P "164" -> + P "165" -> + P "166" -> + P "167" -> + P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b + +byte_rect is not universe polymorphic +Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] +byte_rec = +fun P : byte -> Set => byte_rect P + : forall P : byte -> Set, + P "000" -> + P "001" -> + P "002" -> + P "003" -> + P "004" -> + P "005" -> + P "006" -> + P "007" -> + P "008" -> + P "009" -> + P "010" -> + P "011" -> + P "012" -> + P "013" -> + P "014" -> + P "015" -> + P "016" -> + P "017" -> + P "018" -> + P "019" -> + P "020" -> + P "021" -> + P "022" -> + P "023" -> + P "024" -> + P "025" -> + P "026" -> + P "027" -> + P "028" -> + P "029" -> + P "030" -> + P "031" -> + P " " -> + P "!" -> + P """" -> + P "#" -> + P "$" -> + P "%" -> + P "&" -> + P "'" -> + P "(" -> + P ")" -> + P "*" -> + P "+" -> + P "," -> + P "-" -> + P "." -> + P "/" -> + P "0" -> + P "1" -> + P "2" -> + P "3" -> + P "4" -> + P "5" -> + P "6" -> + P "7" -> + P "8" -> + P "9" -> + P ":" -> + P ";" -> + P "<" -> + P "=" -> + P ">" -> + P "?" -> + P "@" -> + P "A" -> + P "B" -> + P "C" -> + P "D" -> + P "E" -> + P "F" -> + P "G" -> + P "H" -> + P "I" -> + P "J" -> + P "K" -> + P "L" -> + P "M" -> + P "N" -> + P "O" -> + P "P" -> + P "Q" -> + P "R" -> + P "S" -> + P "T" -> + P "U" -> + P "V" -> + P "W" -> + P "X" -> + P "Y" -> + P "Z" -> + P "[" -> + P "\" -> + P "]" -> + P "^" -> + P "_" -> + P "`" -> + P "a" -> + P "b" -> + P "c" -> + P "d" -> + P "e" -> + P "f" -> + P "g" -> + P "h" -> + P "i" -> + P "j" -> + P "k" -> + P "l" -> + P "m" -> + P "n" -> + P "o" -> + P "p" -> + P "q" -> + P "r" -> + P "s" -> + P "t" -> + P "u" -> + P "v" -> + P "w" -> + P "x" -> + P "y" -> + P "z" -> + P "{" -> + P "|" -> + P "}" -> + P "~" -> + P "127" -> + P "128" -> + P "129" -> + P "130" -> + P "131" -> + P "132" -> + P "133" -> + P "134" -> + P "135" -> + P "136" -> + P "137" -> + P "138" -> + P "139" -> + P "140" -> + P "141" -> + P "142" -> + P "143" -> + P "144" -> + P "145" -> + P "146" -> + P "147" -> + P "148" -> + P "149" -> + P "150" -> + P "151" -> + P "152" -> + P "153" -> + P "154" -> + P "155" -> + P "156" -> + P "157" -> + P "158" -> + P "159" -> + P "160" -> + P "161" -> + P "162" -> + P "163" -> + P "164" -> + P "165" -> + P "166" -> + P "167" -> + P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b + +byte_rec is not universe polymorphic +Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] +byte_ind = +fun (P : byte -> Prop) (f : P "000") (f0 : P "001") (f1 : P "002") (f2 : P "003") (f3 : P "004") (f4 : P "005") (f5 : P "006") (f6 : P "007") (f7 : P "008") (f8 : P "009") (f9 : P "010") (f10 : P "011") (f11 : P "012") (f12 : P "013") (f13 : P "014") (f14 : P "015") (f15 : P "016") (f16 : P "017") (f17 : P "018") (f18 : P "019") (f19 : P "020") (f20 : P "021") (f21 : P "022") (f22 : P "023") (f23 : P "024") (f24 : P "025") (f25 : P "026") (f26 : P "027") (f27 : P "028") (f28 : P "029") (f29 : P "030") (f30 : P "031") (f31 : P " ") (f32 : P "!") (f33 : P """") (f34 : P "#") (f35 : P "$") (f36 : P "%") (f37 : P "&") (f38 : P "'") (f39 : P "(") (f40 : P ")") (f41 : P "*") (f42 : P "+") (f43 : P ",") (f44 : P "-") (f45 : P ".") (f46 : P "/") (f47 : P "0") (f48 : P "1") (f49 : P "2") (f50 : P "3") (f51 : P "4") (f52 : P "5") (f53 : P "6") (f54 : P "7") (f55 : P "8") (f56 : P "9") (f57 : P ":") (f58 : P ";") (f59 : P "<") (f60 : P "=") (f61 : P ">") (f62 : P "?") + (f63 : P "@") (f64 : P "A") (f65 : P "B") (f66 : P "C") (f67 : P "D") (f68 : P "E") (f69 : P "F") (f70 : P "G") (f71 : P "H") (f72 : P "I") (f73 : P "J") (f74 : P "K") (f75 : P "L") (f76 : P "M") (f77 : P "N") (f78 : P "O") (f79 : P "P") (f80 : P "Q") (f81 : P "R") (f82 : P "S") (f83 : P "T") (f84 : P "U") (f85 : P "V") (f86 : P "W") (f87 : P "X") (f88 : P "Y") (f89 : P "Z") (f90 : P "[") (f91 : P "\") (f92 : P "]") (f93 : P "^") (f94 : P "_") (f95 : P "`") (f96 : P "a") (f97 : P "b") (f98 : P "c") (f99 : P "d") (f100 : P "e") (f101 : P "f") (f102 : P "g") (f103 : P "h") (f104 : P "i") (f105 : P "j") (f106 : P "k") (f107 : P "l") (f108 : P "m") (f109 : P "n") (f110 : P "o") (f111 : P "p") (f112 : P "q") (f113 : P "r") (f114 : P "s") (f115 : P "t") (f116 : P "u") (f117 : P "v") (f118 : P "w") (f119 : P "x") (f120 : P "y") (f121 : P "z") (f122 : P "{") (f123 : P "|") (f124 : P "}") (f125 : P "~") (f126 : P "127") (f127 : P "128") (f128 : P "129") (f129 : P "130") + (f130 : P "131") (f131 : P "132") (f132 : P "133") (f133 : P "134") (f134 : P "135") (f135 : P "136") (f136 : P "137") (f137 : P "138") (f138 : P "139") (f139 : P "140") (f140 : P "141") (f141 : P "142") (f142 : P "143") (f143 : P "144") (f144 : P "145") (f145 : P "146") (f146 : P "147") (f147 : P "148") (f148 : P "149") (f149 : P "150") (f150 : P "151") (f151 : P "152") (f152 : P "153") (f153 : P "154") (f154 : P "155") (f155 : P "156") (f156 : P "157") (f157 : P "158") (f158 : P "159") (f159 : P "160") (f160 : P "161") (f161 : P "162") (f162 : P "163") (f163 : P "164") (f164 : P "165") (f165 : P "166") (f166 : P "167") (f167 : P "168") (f168 : P "169") (f169 : P "170") (f170 : P "171") (f171 : P "172") (f172 : P "173") (f173 : P "174") (f174 : P "175") (f175 : P "176") (f176 : P "177") (f177 : P "178") (f178 : P "179") (f179 : P "180") (f180 : P "181") (f181 : P "182") (f182 : P "183") (f183 : P "184") (f184 : P "185") (f185 : P "186") (f186 : P "187") + (f187 : P "188") (f188 : P "189") (f189 : P "190") (f190 : P "191") (f191 : P "192") (f192 : P "193") (f193 : P "194") (f194 : P "195") (f195 : P "196") (f196 : P "197") (f197 : P "198") (f198 : P "199") (f199 : P "200") (f200 : P "201") (f201 : P "202") (f202 : P "203") (f203 : P "204") (f204 : P "205") (f205 : P "206") (f206 : P "207") (f207 : P "208") (f208 : P "209") (f209 : P "210") (f210 : P "211") (f211 : P "212") (f212 : P "213") (f213 : P "214") (f214 : P "215") (f215 : P "216") (f216 : P "217") (f217 : P "218") (f218 : P "219") (f219 : P "220") (f220 : P "221") (f221 : P "222") (f222 : P "223") (f223 : P "224") (f224 : P "225") (f225 : P "226") (f226 : P "227") (f227 : P "228") (f228 : P "229") (f229 : P "230") (f230 : P "231") (f231 : P "232") (f232 : P "233") (f233 : P "234") (f234 : P "235") (f235 : P "236") (f236 : P "237") (f237 : P "238") (f238 : P "239") (f239 : P "240") (f240 : P "241") (f241 : P "242") (f242 : P "243") (f243 : P "244") + (f244 : P "245") (f245 : P "246") (f246 : P "247") (f247 : P "248") (f248 : P "249") (f249 : P "250") (f250 : P "251") (f251 : P "252") (f252 : P "253") (f253 : P "254") (f254 : P "255") (b : byte) => +match b as b0 return (P b0) with +| "000" => f +| "001" => f0 +| "002" => f1 +| "003" => f2 +| "004" => f3 +| "005" => f4 +| "006" => f5 +| "007" => f6 +| "008" => f7 +| "009" => f8 +| "010" => f9 +| "011" => f10 +| "012" => f11 +| "013" => f12 +| "014" => f13 +| "015" => f14 +| "016" => f15 +| "017" => f16 +| "018" => f17 +| "019" => f18 +| "020" => f19 +| "021" => f20 +| "022" => f21 +| "023" => f22 +| "024" => f23 +| "025" => f24 +| "026" => f25 +| "027" => f26 +| "028" => f27 +| "029" => f28 +| "030" => f29 +| "031" => f30 +| " " => f31 +| "!" => f32 +| """" => f33 +| "#" => f34 +| "$" => f35 +| "%" => f36 +| "&" => f37 +| "'" => f38 +| "(" => f39 +| ")" => f40 +| "*" => f41 +| "+" => f42 +| "," => f43 +| "-" => f44 +| "." => f45 +| "/" => f46 +| "0" => f47 +| "1" => f48 +| "2" => f49 +| "3" => f50 +| "4" => f51 +| "5" => f52 +| "6" => f53 +| "7" => f54 +| "8" => f55 +| "9" => f56 +| ":" => f57 +| ";" => f58 +| "<" => f59 +| "=" => f60 +| ">" => f61 +| "?" => f62 +| "@" => f63 +| "A" => f64 +| "B" => f65 +| "C" => f66 +| "D" => f67 +| "E" => f68 +| "F" => f69 +| "G" => f70 +| "H" => f71 +| "I" => f72 +| "J" => f73 +| "K" => f74 +| "L" => f75 +| "M" => f76 +| "N" => f77 +| "O" => f78 +| "P" => f79 +| "Q" => f80 +| "R" => f81 +| "S" => f82 +| "T" => f83 +| "U" => f84 +| "V" => f85 +| "W" => f86 +| "X" => f87 +| "Y" => f88 +| "Z" => f89 +| "[" => f90 +| "\" => f91 +| "]" => f92 +| "^" => f93 +| "_" => f94 +| "`" => f95 +| "a" => f96 +| "b" => f97 +| "c" => f98 +| "d" => f99 +| "e" => f100 +| "f" => f101 +| "g" => f102 +| "h" => f103 +| "i" => f104 +| "j" => f105 +| "k" => f106 +| "l" => f107 +| "m" => f108 +| "n" => f109 +| "o" => f110 +| "p" => f111 +| "q" => f112 +| "r" => f113 +| "s" => f114 +| "t" => f115 +| "u" => f116 +| "v" => f117 +| "w" => f118 +| "x" => f119 +| "y" => f120 +| "z" => f121 +| "{" => f122 +| "|" => f123 +| "}" => f124 +| "~" => f125 +| "127" => f126 +| "128" => f127 +| "129" => f128 +| "130" => f129 +| "131" => f130 +| "132" => f131 +| "133" => f132 +| "134" => f133 +| "135" => f134 +| "136" => f135 +| "137" => f136 +| "138" => f137 +| "139" => f138 +| "140" => f139 +| "141" => f140 +| "142" => f141 +| "143" => f142 +| "144" => f143 +| "145" => f144 +| "146" => f145 +| "147" => f146 +| "148" => f147 +| "149" => f148 +| "150" => f149 +| "151" => f150 +| "152" => f151 +| "153" => f152 +| "154" => f153 +| "155" => f154 +| "156" => f155 +| "157" => f156 +| "158" => f157 +| "159" => f158 +| "160" => f159 +| "161" => f160 +| "162" => f161 +| "163" => f162 +| "164" => f163 +| "165" => f164 +| "166" => f165 +| "167" => f166 +| "168" => f167 +| "169" => f168 +| "170" => f169 +| "171" => f170 +| "172" => f171 +| "173" => f172 +| "174" => f173 +| "175" => f174 +| "176" => f175 +| "177" => f176 +| "178" => f177 +| "179" => f178 +| "180" => f179 +| "181" => f180 +| "182" => f181 +| "183" => f182 +| "184" => f183 +| "185" => f184 +| "186" => f185 +| "187" => f186 +| "188" => f187 +| "189" => f188 +| "190" => f189 +| "191" => f190 +| "192" => f191 +| "193" => f192 +| "194" => f193 +| "195" => f194 +| "196" => f195 +| "197" => f196 +| "198" => f197 +| "199" => f198 +| "200" => f199 +| "201" => f200 +| "202" => f201 +| "203" => f202 +| "204" => f203 +| "205" => f204 +| "206" => f205 +| "207" => f206 +| "208" => f207 +| "209" => f208 +| "210" => f209 +| "211" => f210 +| "212" => f211 +| "213" => f212 +| "214" => f213 +| "215" => f214 +| "216" => f215 +| "217" => f216 +| "218" => f217 +| "219" => f218 +| "220" => f219 +| "221" => f220 +| "222" => f221 +| "223" => f222 +| "224" => f223 +| "225" => f224 +| "226" => f225 +| "227" => f226 +| "228" => f227 +| "229" => f228 +| "230" => f229 +| "231" => f230 +| "232" => f231 +| "233" => f232 +| "234" => f233 +| "235" => f234 +| "236" => f235 +| "237" => f236 +| "238" => f237 +| "239" => f238 +| "240" => f239 +| "241" => f240 +| "242" => f241 +| "243" => f242 +| "244" => f243 +| "245" => f244 +| "246" => f245 +| "247" => f246 +| "248" => f247 +| "249" => f248 +| "250" => f249 +| "251" => f250 +| "252" => f251 +| "253" => f252 +| "254" => f253 +| "255" => f254 +end + : forall P : byte -> Prop, + P "000" -> + P "001" -> + P "002" -> + P "003" -> + P "004" -> + P "005" -> + P "006" -> + P "007" -> + P "008" -> + P "009" -> + P "010" -> + P "011" -> + P "012" -> + P "013" -> + P "014" -> + P "015" -> + P "016" -> + P "017" -> + P "018" -> + P "019" -> + P "020" -> + P "021" -> + P "022" -> + P "023" -> + P "024" -> + P "025" -> + P "026" -> + P "027" -> + P "028" -> + P "029" -> + P "030" -> + P "031" -> + P " " -> + P "!" -> + P """" -> + P "#" -> + P "$" -> + P "%" -> + P "&" -> + P "'" -> + P "(" -> + P ")" -> + P "*" -> + P "+" -> + P "," -> + P "-" -> + P "." -> + P "/" -> + P "0" -> + P "1" -> + P "2" -> + P "3" -> + P "4" -> + P "5" -> + P "6" -> + P "7" -> + P "8" -> + P "9" -> + P ":" -> + P ";" -> + P "<" -> + P "=" -> + P ">" -> + P "?" -> + P "@" -> + P "A" -> + P "B" -> + P "C" -> + P "D" -> + P "E" -> + P "F" -> + P "G" -> + P "H" -> + P "I" -> + P "J" -> + P "K" -> + P "L" -> + P "M" -> + P "N" -> + P "O" -> + P "P" -> + P "Q" -> + P "R" -> + P "S" -> + P "T" -> + P "U" -> + P "V" -> + P "W" -> + P "X" -> + P "Y" -> + P "Z" -> + P "[" -> + P "\" -> + P "]" -> + P "^" -> + P "_" -> + P "`" -> + P "a" -> + P "b" -> + P "c" -> + P "d" -> + P "e" -> + P "f" -> + P "g" -> + P "h" -> + P "i" -> + P "j" -> + P "k" -> + P "l" -> + P "m" -> + P "n" -> + P "o" -> + P "p" -> + P "q" -> + P "r" -> + P "s" -> + P "t" -> + P "u" -> + P "v" -> + P "w" -> + P "x" -> + P "y" -> + P "z" -> + P "{" -> + P "|" -> + P "}" -> + P "~" -> + P "127" -> + P "128" -> + P "129" -> + P "130" -> + P "131" -> + P "132" -> + P "133" -> + P "134" -> + P "135" -> + P "136" -> + P "137" -> + P "138" -> + P "139" -> + P "140" -> + P "141" -> + P "142" -> + P "143" -> + P "144" -> + P "145" -> + P "146" -> + P "147" -> + P "148" -> + P "149" -> + P "150" -> + P "151" -> + P "152" -> + P "153" -> + P "154" -> + P "155" -> + P "156" -> + P "157" -> + P "158" -> + P "159" -> + P "160" -> + P "161" -> + P "162" -> + P "163" -> + P "164" -> + P "165" -> + P "166" -> + P "167" -> + P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b + +byte_ind is not universe polymorphic +Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] +"000" + : byte +"a" + : byte +"127" + : byte +The command has indeed failed with message: +Expects a single character or a three-digits ascii code. +"000" + : ascii +"a" + : ascii +"127" + : ascii +The command has indeed failed with message: +Expects a single character or a three-digits ascii code. +"000" + : string +"a" + : string +"127" + : string +"€" + : string +"" + : string + = "a"%char + : ascii + = "a"%byte + : byte + = "a"%string + : string + = ["a"%byte] + : list byte + = ["000"; "001"; "002"; "003"; "004"; "005"; "006"; "007"; "008"; "009"; "010"; "011"; "012"; "013"; "014"; "015"; "016"; "017"; "018"; "019"; "020"; "021"; "022"; "023"; "024"; "025"; "026"; "027"; "028"; "029"; "030"; "031"; " "; "!"; """"; "#"; "$"; "%"; "&"; "'"; "("; ")"; "*"; "+"; ","; "-"; "."; "/"; "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; ":"; ";"; "<"; "="; ">"; "?"; "@"; "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"; "["; "\"; "]"; "^"; "_"; "`"; "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; "s"; "t"; "u"; "v"; "w"; "x"; "y"; "z"; "{"; "|"; "}"; "~"; "127"; "128"; "129"; "130"; "131"; "132"; "133"; "134"; "135"; "136"; "137"; "138"; "139"; "140"; "141"; "142"; "143"; "144"; "145"; "146"; "147"; "148"; "149"; "150"; "151"; "152"; "153"; "154"; "155"; "156"; "157"; "158"; "159"; "160"; "161"; "162"; "163"; "164"; "165"; "166"; "167"; + "168"; "169"; "170"; "171"; "172"; "173"; "174"; "175"; "176"; "177"; "178"; "179"; "180"; "181"; "182"; "183"; "184"; "185"; "186"; "187"; "188"; "189"; "190"; "191"; "192"; "193"; "194"; "195"; "196"; "197"; "198"; "199"; "200"; "201"; "202"; "203"; "204"; "205"; "206"; "207"; "208"; "209"; "210"; "211"; "212"; "213"; "214"; "215"; "216"; "217"; "218"; "219"; "220"; "221"; "222"; "223"; "224"; "225"; "226"; "227"; "228"; "229"; "230"; "231"; "232"; "233"; "234"; "235"; "236"; "237"; "238"; "239"; "240"; "241"; "242"; "243"; "244"; "245"; "246"; "247"; "248"; "249"; "250"; "251"; "252"; "253"; "254"; "255"] + : list byte + = ["000"; "001"; "002"; "003"; "004"; "005"; "006"; "007"; "008"; "009"; "010"; "011"; "012"; "013"; "014"; "015"; "016"; "017"; "018"; "019"; "020"; "021"; "022"; "023"; "024"; "025"; "026"; "027"; "028"; "029"; "030"; "031"; " "; "!"; """"; "#"; "$"; "%"; "&"; "'"; "("; ")"; "*"; "+"; ","; "-"; "."; "/"; "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; ":"; ";"; "<"; "="; ">"; "?"; "@"; "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"; "["; "\"; "]"; "^"; "_"; "`"; "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; "s"; "t"; "u"; "v"; "w"; "x"; "y"; "z"; "{"; "|"; "}"; "~"; "127"; "128"; "129"; "130"; "131"; "132"; "133"; "134"; "135"; "136"; "137"; "138"; "139"; "140"; "141"; "142"; "143"; "144"; "145"; "146"; "147"; "148"; "149"; "150"; "151"; "152"; "153"; "154"; "155"; "156"; "157"; "158"; "159"; "160"; "161"; "162"; "163"; "164"; "165"; "166"; "167"; + "168"; "169"; "170"; "171"; "172"; "173"; "174"; "175"; "176"; "177"; "178"; "179"; "180"; "181"; "182"; "183"; "184"; "185"; "186"; "187"; "188"; "189"; "190"; "191"; "192"; "193"; "194"; "195"; "196"; "197"; "198"; "199"; "200"; "201"; "202"; "203"; "204"; "205"; "206"; "207"; "208"; "209"; "210"; "211"; "212"; "213"; "214"; "215"; "216"; "217"; "218"; "219"; "220"; "221"; "222"; "223"; "224"; "225"; "226"; "227"; "228"; "229"; "230"; "231"; "232"; "233"; "234"; "235"; "236"; "237"; "238"; "239"; "240"; "241"; "242"; "243"; "244"; "245"; "246"; "247"; "248"; "249"; "250"; "251"; "252"; "253"; "254"; "255"] + : list ascii diff --git a/test-suite/output/StringSyntax.v b/test-suite/output/StringSyntax.v new file mode 100644 index 0000000000..aab6e0bb03 --- /dev/null +++ b/test-suite/output/StringSyntax.v @@ -0,0 +1,52 @@ +Require Import Coq.Lists.List. +Require Import Coq.Strings.String Coq.Strings.Byte Coq.Strings.Ascii. +Import ListNotations. + +Set Printing Depth 100000. +Set Printing Width 1000. + +Close Scope char_scope. +Close Scope string_scope. + +Open Scope byte_scope. +Print byte_rect. +Print byte_rec. +Print byte_ind. +Check "000". +Check "a". +Check "127". +Fail Check "€". +Close Scope byte_scope. + +Open Scope char_scope. +Check "000". +Check "a". +Check "127". +Fail Check "€". +Close Scope char_scope. + +Open Scope string_scope. +Check "000". +Check "a". +Check "127". +Check "€". +Check String "001" EmptyString. +Close Scope string_scope. + +Compute ascii_of_byte "a". +Compute byte_of_ascii "a". +Compute string_of_list_byte ("a"::nil)%byte. +Compute list_byte_of_string "a". + +Local Open Scope byte_scope. +Compute List.fold_right + (fun n ls => match Byte.of_nat n with + | Some b => cons b ls + | None => ls + end) + nil + (List.seq 0 256). +Local Close Scope byte_scope. +Local Open Scope char_scope. +Compute List.map Ascii.ascii_of_nat (List.seq 0 256). +Local Close Scope char_scope. diff --git a/test-suite/output/TranspModtype.out b/test-suite/output/TranspModtype.out index f080f6d0f0..67b65d4b81 100644 --- a/test-suite/output/TranspModtype.out +++ b/test-suite/output/TranspModtype.out @@ -1,15 +1,15 @@ -Monomorphic TrM.A = M.A +TrM.A = M.A : Set TrM.A is not universe polymorphic -Monomorphic OpM.A = M.A +OpM.A = M.A : Set OpM.A is not universe polymorphic -Monomorphic TrM.B = M.B +TrM.B = M.B : Set TrM.B is not universe polymorphic -Monomorphic *** [ OpM.B : Set ] +*** [ OpM.B : Set ] OpM.B is not universe polymorphic diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 4d3f7419e6..0bd6ade690 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -1,37 +1,34 @@ -Polymorphic NonCumulative Inductive Empty@{u} : Type@{u} := -Polymorphic NonCumulative Record PWrap (A : Type@{u}) : Type@{u} := pwrap - { punwrap : A } +Inductive Empty@{u} : Type@{u} := +Record PWrap (A : Type@{u}) : Type@{u} := pwrap { punwrap : A } PWrap has primitive projections with eta conversion. For PWrap: Argument scope is [type_scope] For pwrap: Argument scopes are [type_scope _] -Polymorphic punwrap@{u} = +punwrap@{u} = fun (A : Type@{u}) (p : PWrap@{u} A) => punwrap _ p : forall A : Type@{u}, PWrap@{u} A -> A (* u |= *) punwrap is universe polymorphic Argument scopes are [type_scope _] -Polymorphic NonCumulative Record RWrap (A : Type@{u}) : Type@{u} := rwrap - { runwrap : A } +Record RWrap (A : Type@{u}) : Type@{u} := rwrap { runwrap : A } For RWrap: Argument scope is [type_scope] For rwrap: Argument scopes are [type_scope _] -Polymorphic runwrap@{u} = +runwrap@{u} = fun (A : Type@{u}) (r : RWrap@{u} A) => let (runwrap) := r in runwrap : forall A : Type@{u}, RWrap@{u} A -> A (* u |= *) runwrap is universe polymorphic Argument scopes are [type_scope _] -Polymorphic Wrap@{u} = -fun A : Type@{u} => A +Wrap@{u} = fun A : Type@{u} => A : Type@{u} -> Type@{u} (* u |= *) Wrap is universe polymorphic Argument scope is [type_scope] -Polymorphic wrap@{u} = +wrap@{u} = fun (A : Type@{u}) (Wrap : Wrap@{u} A) => Wrap : forall A : Type@{u}, Wrap@{u} A -> A (* u |= *) @@ -39,12 +36,12 @@ fun (A : Type@{u}) (Wrap : Wrap@{u} A) => Wrap wrap is universe polymorphic Arguments A, Wrap are implicit and maximally inserted Argument scopes are [type_scope _] -Polymorphic bar@{u} = nat +bar@{u} = nat : Wrap@{u} Set (* u |= Set < u *) bar is universe polymorphic -Polymorphic foo@{u UnivBinders.17 v} = +foo@{u UnivBinders.17 v} = Type@{UnivBinders.17} -> Type@{v} -> Type@{u} : Type@{max(u+1,UnivBinders.17+1,v+1)} (* u UnivBinders.17 v |= *) @@ -56,7 +53,7 @@ Type@{i} -> Type@{j} = Type@{i} -> Type@{j} : Type@{max(i+1,j+1)} (* {j i} |= *) -Monomorphic mono = Type@{mono.u} +mono = Type@{mono.u} : Type@{mono.u+1} (* {mono.u} |= *) @@ -77,7 +74,7 @@ mono : Type@{mono.u+1} The command has indeed failed with message: Universe u already exists. -Monomorphic bobmorane = +bobmorane = let tt := Type@{UnivBinders.32} in let ff := Type@{UnivBinders.34} in tt -> ff : Type@{max(UnivBinders.31,UnivBinders.33)} @@ -85,21 +82,20 @@ let ff := Type@{UnivBinders.34} in tt -> ff bobmorane is not universe polymorphic The command has indeed failed with message: Universe u already bound. -Polymorphic foo@{E M N} = +foo@{E M N} = Type@{M} -> Type@{N} -> Type@{E} : Type@{max(E+1,M+1,N+1)} (* E M N |= *) foo is universe polymorphic -Polymorphic foo@{u UnivBinders.17 v} = +foo@{u UnivBinders.17 v} = Type@{UnivBinders.17} -> Type@{v} -> Type@{u} : Type@{max(u+1,UnivBinders.17+1,v+1)} (* u UnivBinders.17 v |= *) foo is universe polymorphic -Polymorphic NonCumulative Inductive Empty@{E} : Type@{E} := -Polymorphic NonCumulative Record PWrap (A : Type@{E}) : Type@{E} := pwrap - { punwrap : A } +Inductive Empty@{E} : Type@{E} := +Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } PWrap has primitive projections with eta conversion. For PWrap: Argument scope is [type_scope] @@ -119,58 +115,55 @@ The command has indeed failed with message: This object does not support universe names. The command has indeed failed with message: Cannot enforce v < u because u < gU < gV < v -Monomorphic bind_univs.mono = +bind_univs.mono = Type@{bind_univs.mono.u} : Type@{bind_univs.mono.u+1} (* {bind_univs.mono.u} |= *) bind_univs.mono is not universe polymorphic -Polymorphic bind_univs.poly@{u} = Type@{u} +bind_univs.poly@{u} = Type@{u} : Type@{u+1} (* u |= *) bind_univs.poly is universe polymorphic -Polymorphic insec@{v} = -Type@{u} -> Type@{v} +insec@{v} = Type@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* v |= *) insec is universe polymorphic -Polymorphic NonCumulative Inductive insecind@{k} : Type@{k+1} := - inseccstr : Type@{k} -> insecind@{k} +Inductive insecind@{k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{k} For inseccstr: Argument scope is [type_scope] -Polymorphic insec@{u v} = -Type@{u} -> Type@{v} +insec@{u v} = Type@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) insec is universe polymorphic -Polymorphic NonCumulative Inductive insecind@{u k} : Type@{k+1} := +Inductive insecind@{u k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{u k} For inseccstr: Argument scope is [type_scope] -Polymorphic insec2@{u} = Prop +insec2@{u} = Prop : Type@{Set+1} (* u |= *) insec2 is universe polymorphic -Polymorphic inmod@{u} = Type@{u} +inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) inmod is universe polymorphic -Polymorphic SomeMod.inmod@{u} = Type@{u} +SomeMod.inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) SomeMod.inmod is universe polymorphic -Polymorphic inmod@{u} = Type@{u} +inmod@{u} = Type@{u} : Type@{u+1} (* u |= *) inmod is universe polymorphic -Polymorphic Applied.infunct@{u v} = +Applied.infunct@{u v} = inmod@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) diff --git a/test-suite/output/Warnings.v b/test-suite/output/Warnings.v index 7465442cab..0eb5db1733 100644 --- a/test-suite/output/Warnings.v +++ b/test-suite/output/Warnings.v @@ -1,5 +1,5 @@ (* Term in warning was not printed in the right environment at some time *) -Record A := { B:Type; b:B->B }. +#[universes(template)] Record A := { B:Type; b:B->B }. Definition a B := {| B:=B; b:=fun x => x |}. Canonical Structure a. diff --git a/test-suite/output/goal_output.out b/test-suite/output/goal_output.out index 3dad2360c4..20568f742a 100644 --- a/test-suite/output/goal_output.out +++ b/test-suite/output/goal_output.out @@ -1,8 +1,8 @@ -Monomorphic Nat.t = nat +Nat.t = nat : Set Nat.t is not universe polymorphic -Monomorphic Nat.t = nat +Nat.t = nat : Set Nat.t is not universe polymorphic diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index a1326596bb..f545ca679c 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -1,4 +1,4 @@ -Monomorphic P = +P = fun e : option L => match e with | Some cl => Some cl | None => None diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 57a4739e9f..209fedc343 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -21,6 +21,6 @@ Print P. (* Note: exact numbers of evars are not important... *) -Inductive T (n:nat) : Type := A : T n. +#[universes(template)] Inductive T (n:nat) : Type := A : T n. Check fun n (y:=A n:T n) => _ _ : T n. Check fun n => _ _ : T n. diff --git a/test-suite/report.sh b/test-suite/report.sh index c5e698232f..cef615266b 100755 --- a/test-suite/report.sh +++ b/test-suite/report.sh @@ -15,7 +15,7 @@ mkdir "$SAVEDIR" FAILMARK="==========> FAILURE <==========" FAILED=$(mktemp /tmp/coq-check-XXXXXX) -find . '(' -path ./bugs/opened -prune ')' -o '(' -name '*.log' -exec grep "$FAILMARK" -q '{}' ';' -print0 ')' > "$FAILED" +find . '(' -name '*.log' -exec grep "$FAILMARK" -q '{}' ';' -print0 ')' > "$FAILED" rsync -a --from0 --files-from="$FAILED" . "$SAVEDIR" cp summary.log "$SAVEDIR"/ diff --git a/test-suite/ssr/elim.v b/test-suite/ssr/elim.v index 908249a369..720f4f6607 100644 --- a/test-suite/ssr/elim.v +++ b/test-suite/ssr/elim.v @@ -33,7 +33,7 @@ Qed. (* The same but without names for variables involved in the generated eq *) Lemma testL3 : forall A (s : seq A), s = s. Proof. -move=> A s; elim branch: s; move: (s) => _. +move=> A s; elim branch: s. match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end. move=> _; match goal with _ : _ = _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end. Qed. diff --git a/test-suite/ssr/ipat_clear_if_id.v b/test-suite/ssr/ipat_clear_if_id.v index 7a44db2ea0..cc087a62ad 100644 --- a/test-suite/ssr/ipat_clear_if_id.v +++ b/test-suite/ssr/ipat_clear_if_id.v @@ -8,6 +8,7 @@ Variable v2 : nat -> bool. Lemma test (v3 : nat -> bool) (v4 : bool -> bool) (v5 : bool -> bool) : nat -> nat -> nat -> nat -> True. Proof. +Set Debug Ssreflect. move=> {}/v1 b1 {}/v2 b2 {}/v3 b3 {}/v2/v4/v5 b4. Check b1 : bool. Check b2 : bool. @@ -20,4 +21,12 @@ Check v2 : nat -> bool. by []. Qed. +Lemma test2 (v : True <-> False) : True -> False. +Proof. +move=> {}/v. +Fail Check v. +by []. +Qed. + + End Foo. diff --git a/test-suite/ssr/ipat_fast_any.v b/test-suite/ssr/ipat_fast_any.v new file mode 100644 index 0000000000..a50984c7c0 --- /dev/null +++ b/test-suite/ssr/ipat_fast_any.v @@ -0,0 +1,21 @@ +Require Import ssreflect. + +Goal forall y x : nat, x = y -> x = x. +Proof. +move=> + > ->. match goal with |- forall y, y = y => by [] end. +Qed. + +Goal forall y x : nat, le x y -> x = y. +Proof. +move=> > [|]. + by []. +match goal with |- forall a, _ <= a -> _ = S a => admit end. +Admitted. + +Goal forall y x : nat, le x y -> x = y. +Proof. +move=> y x. +case E: x => >. + admit. +match goal with |- S _ <= y -> S _ = y => admit end. +Admitted. diff --git a/test-suite/ssr/ipat_fastid.v b/test-suite/ssr/ipat_fastid.v new file mode 100644 index 0000000000..b0985a0d2f --- /dev/null +++ b/test-suite/ssr/ipat_fastid.v @@ -0,0 +1,48 @@ +Require Import ssreflect. + +Axiom odd : nat -> Prop. + +Lemma simple : + forall x, 3 <= x -> forall y, odd (y+x) -> x = y -> True. +Proof. +move=> >x_ge_3 >xy_odd. +lazymatch goal with +| |- ?x = ?y -> True => done +end. +Qed. + +Lemma simple2 : + forall x, 3 <= x -> forall y, odd (y+x) -> x = y -> True. +Proof. +move=> >; move=>x_ge_3; move=> >; move=>xy_odd. +lazymatch goal with +| |- ?x = ?y -> True => done +end. +Qed. + + +Definition stuff x := 3 <= x -> forall y, odd (y+x) -> x = y -> True. + +Lemma harder : forall x, stuff x. +Proof. +move=> >x_ge_3 >xy_odd. +lazymatch goal with +| |- ?x = ?y -> True => done +end. +Qed. + +Lemma harder2 : forall x, stuff x. +Proof. +move=> >; move=>x_ge_3;move=> >; move=>xy_odd. +lazymatch goal with +| |- ?x = ?y -> True => done +end. +Qed. + +Lemma homotop : forall x : nat, forall e : x = x, e = e -> True. +Proof. +move=> >eq_ee. +lazymatch goal with +| |- True => done +end. +Qed. diff --git a/test-suite/ssr/ipat_seed.v b/test-suite/ssr/ipat_seed.v new file mode 100644 index 0000000000..e418d66917 --- /dev/null +++ b/test-suite/ssr/ipat_seed.v @@ -0,0 +1,60 @@ +Require Import ssreflect. + +Section foo. + +Variable A : Type. + +Record bar (X : Type) := mk_bar { + a : X * A; + b : A; + c := (a,7); + _ : X; + _ : X +}. + +Inductive baz (X : Type) (Y : Type) : nat -> Type := +| K1 x (e : 0=1) (f := 3) of x=x:>X : baz X Y O +| K2 n of n=n & baz X nat 0 : baz X Y (n+1). + +Axiom Q : nat -> Prop. +Axiom Qx : forall x, Q x. +Axiom my_ind : + forall P : nat -> Prop, P O -> (forall n m (w : P n /\ P m), P (n+m)) -> + forall w, P w. + +Lemma test x : bar nat -> baz nat nat x -> forall n : nat, Q n. +Proof. + +(* record *) +move => [^~ _ccc ]. +Check (refl_equal _ : c_ccc = (a_ccc, 7)). + +(* inductive *) +move=> [^ xxx_ ]. +Check (refl_equal _ : xxx_f = 3). + by []. +Check (refl_equal _ : xxx_n = xxx_n). + +(* eliminator *) +elim/my_ind => [^ wow_ ]. + exact: Qx 0. +Check (wow_w : Q wow_n /\ Q wow_m). +exact: Qx (wow_n + wow_m). + +Qed. + +Arguments mk_bar A x y z w : rename. +Arguments K1 A B a b c : rename. + + +Lemma test2 x : bar nat -> baz nat nat x -> forall n : nat, Q n. +Proof. +move=> [^~ _ccc ]. +Check (refl_equal _ : c_ccc = (x_ccc, 7)). +move=> [^ xxx_ ]. +Check (refl_equal _ : xxx_f = 3). + by []. +Check (refl_equal _ : xxx_n = xxx_n). +Abort. + +End foo. diff --git a/test-suite/ssr/ipat_tac.v b/test-suite/ssr/ipat_tac.v new file mode 100644 index 0000000000..cfef2e37be --- /dev/null +++ b/test-suite/ssr/ipat_tac.v @@ -0,0 +1,38 @@ +Require Import ssreflect. + +Ltac fancy := case; last first. + +Notation fancy := (ltac:( fancy )). + +Ltac replicate n := + let what := fresh "_replicate_" in + move=> what; do n! [ have := what ]; clear what. + +Notation replicate n := (ltac:( replicate n )). + +Lemma foo x (w : nat) (J : bool -> nat -> nat) : exists y, x=0+y. +Proof. +move: (w) => /ltac:(idtac) _. +move: w => /(replicate 6) w1 w2 w3 w4 w5 w6. +move: w1 => /J/fancy [w'||];last exact: false. + move: w' => /J/fancy[w''||]; last exact: false. + by exists x. + by exists x. +by exists x. +Qed. + +Ltac unfld what := rewrite /what. + +Notation "% n" := (ltac:( unfld n )) (at level 0) : ssripat_scope. +Notation "% n" := n : nat_scope. + +Open Scope nat_scope. + + +Definition def := 4. + +Lemma test : True -> def = 4. +Proof. +move=> _ /(% def). +match goal with |- 4 = 4 => reflexivity end. +Qed. diff --git a/test-suite/ssr/ipat_tmp.v b/test-suite/ssr/ipat_tmp.v new file mode 100644 index 0000000000..5f5421ac74 --- /dev/null +++ b/test-suite/ssr/ipat_tmp.v @@ -0,0 +1,22 @@ +Require Import ssreflect ssrbool. + + Axiom eqn : nat -> nat -> bool. + Infix "==" := eqn (at level 40). + Axiom eqP : forall x y : nat, reflect (x = y) (x == y). + + Lemma test1 : + forall x y : nat, x = y -> forall z : nat, y == z -> x = z. + Proof. + by move=> x y + z /eqP <-; apply. + Qed. + + Lemma test2 : forall (x y : nat) (e : x = y), e = e -> x = y. + Proof. + move=> + y + _ => x def_x; exact: (def_x : x = y). + Qed. + + Lemma test3 : + forall x y : nat, x = y -> forall z : nat, y == z -> x = z. + Proof. + move=> ++++ /eqP <- => x y e z; exact: e. + Qed. diff --git a/test-suite/ssr/misc_extended.v b/test-suite/ssr/misc_extended.v new file mode 100644 index 0000000000..81c86f1af4 --- /dev/null +++ b/test-suite/ssr/misc_extended.v @@ -0,0 +1,83 @@ +Require Import ssreflect. + +Require Import List. + +Lemma test_elim_pattern_1 : forall A (l:list A), l ++ nil = l. +Proof. +intros A. +elim/list_ind => [^~ 1 ]. + by []. +match goal with |- (a1 :: l1) ++ nil = a1 :: l1 => idtac end. +Abort. + +Lemma test_elim_pattern_2 : forall A (l:list A), l ++ nil = l. +Proof. +intros. elim: l => [^~ 1 ]. + by []. +match goal with |- (a1 :: l1) ++ nil = a1 :: l1 => idtac end. +Abort. + +Lemma test_elim_pattern_3 : forall A (l:list A), l ++ nil = l. +Proof. +intros. elim: l => [ | x l' IH ]. + by []. +match goal with |- (x :: l') ++ nil = x :: l' => idtac end. +Abort. + + +Generalizable Variables A. + +Class Inhab (A:Type) : Type := + { arbitrary : A }. + +Lemma test_intro_typeclass_1 : forall A `{Inhab A} (l1 l2:list A), l2 = nil -> l1 ++ l2 = l1. +Proof. +move =>> H. + match goal with |- _ = _ => idtac end. +Abort. + +Lemma test_intro_typeclass_2 : forall A `{Inhab A} (x:A), x = arbitrary -> x = arbitrary. +Proof. +move =>> H. + match goal with |- _ = _ => idtac end. +Abort. + +Lemma test_intro_temporary_1 : forall A (l1 l2:list A), l2 = nil -> l1 ++ l2 = l1. +Proof. +move => A + l2. + match goal with |- forall l1, l2 = nil -> l1 ++ l2 = l1 => idtac end. +Abort. + +Lemma test_intro_temporary_2 : forall A `{Inhab A} (l1 l2:list A), l2 = nil -> l1 ++ l2 = l1. +Proof. +move => > E. + match goal with |- _ = _ => idtac end. +Abort. + +Lemma test_dispatch : (forall x:nat, x= x )/\ (forall y:nat, y = y). +Proof. +intros. split => [ a | b ]. + match goal with |- a = a => by [] end. +match goal with |- b = b => by [] end. +Abort. + +Lemma test_tactics_as_view_1 : forall A (l1:list A), nil ++ l1 = l1. +Proof. +move => /ltac:(simpl). +Abort. + +Lemma test_tactics_as_view_2 : forall A, (forall (l1:list A), nil ++ l1 = l1) /\ (nil ++ nil = @nil A). +Proof. +move => A. +(* TODO: I want to do [split =>.] as a temporary step in setting up my script, + but this syntax does not seem to be supported. Can't we have an empty ipat? + Note that I can do [split => [ | ]]*) +split => [| /ltac:(simpl)]. +Abort. + +Notation "%%" := (ltac:(simpl)) : ssripat_scope. + +Lemma test_tactics_as_view_3 : forall A, (forall (l1:list A), nil ++ l1 = l1) /\ (nil ++ nil = @nil A). +Proof. +move => /ltac:(split) [ | /%% ]. +Abort. diff --git a/test-suite/ssr/misc_tc.v b/test-suite/ssr/misc_tc.v new file mode 100644 index 0000000000..4db45b743a --- /dev/null +++ b/test-suite/ssr/misc_tc.v @@ -0,0 +1,30 @@ +Require Import ssreflect List. + +Generalizable Variables A B. + +Class Inhab (A:Type) : Type := + { arbitrary : A }. + +Lemma test_intro_typeclass_1 : forall A `{Inhab A} (x:A), x = arbitrary -> x = arbitrary. +Proof. +move =>> H. (* introduces [H:x=arbitrary] because first non dependent hypothesis *) +Abort. + +Lemma test_intro_typeclass_2 : forall A `{Inhab A} (l1 l2:list A), l2 = nil -> l1 ++ l2 = l1. +Proof. +move =>> H. (* introduces [Inhab A] automatically because it is a typeclass instance *) +Abort. + +Lemma test_intro_typeclass_3 : forall `{Inhab A, Inhab B} (x:A) (y:B), True -> x = x. +Proof. (* Above types [A] and [B] are implicitly quantified *) +move =>> y H. (* introduces the two typeclass instances automatically *) +Abort. + +Class Foo `{Inhab A} : Type := + { foo : A }. + +Lemma test_intro_typeclass_4 : forall `{Foo A}, True -> True. +Proof. (* Above, [A] and [{Inhab A}] are implicitly quantified *) +move =>> H. (* introduces [A] and [Inhab A] because they are dependently used, + and introduce [Foo A] automatically because it is an instance. *) +Abort. diff --git a/test-suite/stm/classify_set_proof_mode_9093.v b/test-suite/stm/classify_set_proof_mode_9093.v new file mode 100644 index 0000000000..d3f73ff435 --- /dev/null +++ b/test-suite/stm/classify_set_proof_mode_9093.v @@ -0,0 +1,9 @@ +(* -*- coq-prog-args: ("-async-proofs" "on" "-noinit"); -*- *) + +Declare ML Module "ltac_plugin". + +Set Default Proof Mode "Classic". + +Goal Prop. + idtac. +Abort. diff --git a/test-suite/stm/delayed_restrict_univs_9093.v b/test-suite/stm/delayed_restrict_univs_9093.v new file mode 100644 index 0000000000..6ca36da4b0 --- /dev/null +++ b/test-suite/stm/delayed_restrict_univs_9093.v @@ -0,0 +1,10 @@ +(* -*- coq-prog-args: ("-async-proofs" "on"); -*- *) + +Unset Universe Polymorphism. + +Ltac exact0 := let x := constr:(Type) in exact 0. + +Lemma lemma_restrict_abstract@{} : (nat * nat)%type. +Proof. split;[exact 0|abstract exact0]. Qed. +(* Debug: 10237:proofworker:0:0 STM: sending back a fat state +Error: Universe {polymorphism.1} is unbound. *) diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index 52fe98ac07..232ac17cbf 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -1873,3 +1873,12 @@ Check match niln in listn O return O=O with niln => eq_refl end. (* (was failing up to May 2017) *) Check fun x => match x with (y,z) as t as w => (y+z,t) = (0,w) end. + +(* A test about binding variables of "in" clause of "match" *) +(* (was failing from 8.5 to Dec 2018) *) + +Check match O in nat return nat with O => O | _ => O end. + +(* Checking that aliases are substituted in the correct order *) + +Check match eq_refl (1,0) in _ = (y as z, y' as z) return z = z with eq_refl => eq_refl end : 0=0. diff --git a/test-suite/unit-tests/printing/proof_diffs_test.ml b/test-suite/unit-tests/printing/proof_diffs_test.ml index 7f9e6cc6e0..d0b8d21b69 100644 --- a/test-suite/unit-tests/printing/proof_diffs_test.ml +++ b/test-suite/unit-tests/printing/proof_diffs_test.ml @@ -51,23 +51,28 @@ let t () = assert_equal ~msg:"has `Removed" ~printer:string_of_bool true has_removed let _ = add_test "diff_str add/remove" t -(* example of a limitation, not really a test *) -let t () = - try - let _ = diff_str "a" ">" in - assert_failure "unlexable string gives an exception" - with _ -> () -let _ = add_test "diff_str unlexable" t - -(* problematic examples for tokenize_string: - comments omitted - quoted string loses quote marks (are escapes supported/handled?) - char constant split into 2 +(* lexer tweaks: + comments are lexed as multiple tokens + strings tokens include begin/end quotes and embedded "" + single multibyte characters returned even if they're not keywords + + inputs that give a lexer failure (but no use case needs them yet): + ".12" + unterminated string + invalid UTF-8 sequences *) let t () = - List.iter (fun x -> cprintf "'%s' " x) (tokenize_string "(* comment *) \"string\" 'c' xx"); - cprintf "\n" -let _ = add_test "tokenize_string examples" t + let str = "(* comment.field *) ?id () \"str\"\"ing\" \\ := Ж > ∃ 'c' xx" in + let toks = tokenize_string str in + (*List.iter (fun x -> cprintf "'%s' " x) toks;*) + (*cprintf "\n";*) + let str_no_white = String.concat "" (String.split_on_char ' ' str) in + assert_equal ~printer:(fun x -> x) str_no_white (String.concat "" toks); + List.iter (fun s -> + assert_equal ~msg:("'" ^ s ^ "' is a single token") ~printer:string_of_bool true (List.mem s toks)) + [ "(*"; "()"; ":="] + +let _ = add_test "tokenize_string/diff_mode in lexer" t open Pp diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 86a3a88be9..4b97d75cea 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -283,6 +283,7 @@ Local Open Scope list_scope. (** A compact representation of non-dependent arities, with the codomain singled-out. *) (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) +#[universes(template)] Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist. Local Infix "::" := Tcons. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 2673a11917..e6968bd6c2 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -27,6 +27,7 @@ Require Export Coq.Classes.Morphisms. (** A setoid wraps an equivalence. *) +#[universes(template)] Class Setoid A := { equiv : relation A ; setoid_equiv :> Equivalence equiv }. @@ -128,6 +129,7 @@ Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper ( (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) +#[universes(template)] Class PartialSetoid (A : Type) := { pequiv : relation A ; pequiv_prf :> PER pequiv }. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 8fc04d81e6..9a815d2a7e 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -53,6 +53,7 @@ Variable elt : Type. The fifth field of [Node] is the height of the tree *) +#[universes(template)] Inductive tree := | Leaf : tree | Node : tree -> key -> elt -> tree -> int -> tree. @@ -235,6 +236,7 @@ Fixpoint join l : key -> elt -> t -> t := - [o] is the result of [find x m]. *) +#[universes(template)] Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). @@ -291,6 +293,7 @@ Variable cmp : elt->elt->bool. (** ** Enumeration of the elements of a tree *) +#[universes(template)] Inductive enumeration := | End : enumeration | More : key -> elt -> t -> enumeration -> enumeration. @@ -1817,6 +1820,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Module Raw := Raw I X. Import Raw.Proofs. + #[universes(template)] Record bst (elt:Type) := Bst {this :> Raw.tree elt; is_bst : Raw.bst this}. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 950b30ee4d..7bc9edff8d 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -451,6 +451,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Import Raw. Import Raw.Proofs. + #[universes(template)] Record bbst (elt:Type) := Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 6ca158a277..4febd64842 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -1024,6 +1024,7 @@ Module E := X. Definition key := E.t. +#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. Definition t (elt:Type) : Type := slist elt. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 0fc68b1433..b47c99244b 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -73,6 +73,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Definition key := positive : Type. + #[universes(template)] Inductive tree (A : Type) := | Leaf : tree A | Node : tree A -> option A -> tree A -> tree A. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 03dce9666d..a923f4e6f9 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -869,6 +869,7 @@ Module Make (X: DecidableType) <: WS with Module E:=X. Module E := X. Definition key := E.t. +#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. Definition t (elt:Type) := slist elt. diff --git a/theories/Init/Byte.v b/theories/Init/Byte.v new file mode 100644 index 0000000000..eede9d5028 --- /dev/null +++ b/theories/Init/Byte.v @@ -0,0 +1,830 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** * Bytes *) + +Require Import Coq.Init.Datatypes. +Require Import Coq.Init.Logic. +Require Import Coq.Init.Specif. +Require Coq.Init.Nat. + +Declare ML Module "string_notation_plugin". + +(** We define an inductive for use with the [String Notation] command + which contains all ascii characters. We use 256 constructors for + efficiency and ease of conversion. *) + +Declare Scope byte_scope. +Delimit Scope byte_scope with byte. + +Inductive byte := +| x00 +| x01 +| x02 +| x03 +| x04 +| x05 +| x06 +| x07 +| x08 +| x09 +| x0a +| x0b +| x0c +| x0d +| x0e +| x0f +| x10 +| x11 +| x12 +| x13 +| x14 +| x15 +| x16 +| x17 +| x18 +| x19 +| x1a +| x1b +| x1c +| x1d +| x1e +| x1f +| x20 +| x21 +| x22 +| x23 +| x24 +| x25 +| x26 +| x27 +| x28 +| x29 +| x2a +| x2b +| x2c +| x2d +| x2e +| x2f +| x30 +| x31 +| x32 +| x33 +| x34 +| x35 +| x36 +| x37 +| x38 +| x39 +| x3a +| x3b +| x3c +| x3d +| x3e +| x3f +| x40 +| x41 +| x42 +| x43 +| x44 +| x45 +| x46 +| x47 +| x48 +| x49 +| x4a +| x4b +| x4c +| x4d +| x4e +| x4f +| x50 +| x51 +| x52 +| x53 +| x54 +| x55 +| x56 +| x57 +| x58 +| x59 +| x5a +| x5b +| x5c +| x5d +| x5e +| x5f +| x60 +| x61 +| x62 +| x63 +| x64 +| x65 +| x66 +| x67 +| x68 +| x69 +| x6a +| x6b +| x6c +| x6d +| x6e +| x6f +| x70 +| x71 +| x72 +| x73 +| x74 +| x75 +| x76 +| x77 +| x78 +| x79 +| x7a +| x7b +| x7c +| x7d +| x7e +| x7f +| x80 +| x81 +| x82 +| x83 +| x84 +| x85 +| x86 +| x87 +| x88 +| x89 +| x8a +| x8b +| x8c +| x8d +| x8e +| x8f +| x90 +| x91 +| x92 +| x93 +| x94 +| x95 +| x96 +| x97 +| x98 +| x99 +| x9a +| x9b +| x9c +| x9d +| x9e +| x9f +| xa0 +| xa1 +| xa2 +| xa3 +| xa4 +| xa5 +| xa6 +| xa7 +| xa8 +| xa9 +| xaa +| xab +| xac +| xad +| xae +| xaf +| xb0 +| xb1 +| xb2 +| xb3 +| xb4 +| xb5 +| xb6 +| xb7 +| xb8 +| xb9 +| xba +| xbb +| xbc +| xbd +| xbe +| xbf +| xc0 +| xc1 +| xc2 +| xc3 +| xc4 +| xc5 +| xc6 +| xc7 +| xc8 +| xc9 +| xca +| xcb +| xcc +| xcd +| xce +| xcf +| xd0 +| xd1 +| xd2 +| xd3 +| xd4 +| xd5 +| xd6 +| xd7 +| xd8 +| xd9 +| xda +| xdb +| xdc +| xdd +| xde +| xdf +| xe0 +| xe1 +| xe2 +| xe3 +| xe4 +| xe5 +| xe6 +| xe7 +| xe8 +| xe9 +| xea +| xeb +| xec +| xed +| xee +| xef +| xf0 +| xf1 +| xf2 +| xf3 +| xf4 +| xf5 +| xf6 +| xf7 +| xf8 +| xf9 +| xfa +| xfb +| xfc +| xfd +| xfe +| xff +. + +Bind Scope byte_scope with byte. + +Register byte as core.byte.type. + +Local Notation "0" := false. +Local Notation "1" := true. + +(** We pick a definition that matches with [Ascii.ascii] *) +Definition of_bits (b : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool))))))) : byte + := match b with + | (0,(0,(0,(0,(0,(0,(0,0))))))) => x00 + | (1,(0,(0,(0,(0,(0,(0,0))))))) => x01 + | (0,(1,(0,(0,(0,(0,(0,0))))))) => x02 + | (1,(1,(0,(0,(0,(0,(0,0))))))) => x03 + | (0,(0,(1,(0,(0,(0,(0,0))))))) => x04 + | (1,(0,(1,(0,(0,(0,(0,0))))))) => x05 + | (0,(1,(1,(0,(0,(0,(0,0))))))) => x06 + | (1,(1,(1,(0,(0,(0,(0,0))))))) => x07 + | (0,(0,(0,(1,(0,(0,(0,0))))))) => x08 + | (1,(0,(0,(1,(0,(0,(0,0))))))) => x09 + | (0,(1,(0,(1,(0,(0,(0,0))))))) => x0a + | (1,(1,(0,(1,(0,(0,(0,0))))))) => x0b + | (0,(0,(1,(1,(0,(0,(0,0))))))) => x0c + | (1,(0,(1,(1,(0,(0,(0,0))))))) => x0d + | (0,(1,(1,(1,(0,(0,(0,0))))))) => x0e + | (1,(1,(1,(1,(0,(0,(0,0))))))) => x0f + | (0,(0,(0,(0,(1,(0,(0,0))))))) => x10 + | (1,(0,(0,(0,(1,(0,(0,0))))))) => x11 + | (0,(1,(0,(0,(1,(0,(0,0))))))) => x12 + | (1,(1,(0,(0,(1,(0,(0,0))))))) => x13 + | (0,(0,(1,(0,(1,(0,(0,0))))))) => x14 + | (1,(0,(1,(0,(1,(0,(0,0))))))) => x15 + | (0,(1,(1,(0,(1,(0,(0,0))))))) => x16 + | (1,(1,(1,(0,(1,(0,(0,0))))))) => x17 + | (0,(0,(0,(1,(1,(0,(0,0))))))) => x18 + | (1,(0,(0,(1,(1,(0,(0,0))))))) => x19 + | (0,(1,(0,(1,(1,(0,(0,0))))))) => x1a + | (1,(1,(0,(1,(1,(0,(0,0))))))) => x1b + | (0,(0,(1,(1,(1,(0,(0,0))))))) => x1c + | (1,(0,(1,(1,(1,(0,(0,0))))))) => x1d + | (0,(1,(1,(1,(1,(0,(0,0))))))) => x1e + | (1,(1,(1,(1,(1,(0,(0,0))))))) => x1f + | (0,(0,(0,(0,(0,(1,(0,0))))))) => x20 + | (1,(0,(0,(0,(0,(1,(0,0))))))) => x21 + | (0,(1,(0,(0,(0,(1,(0,0))))))) => x22 + | (1,(1,(0,(0,(0,(1,(0,0))))))) => x23 + | (0,(0,(1,(0,(0,(1,(0,0))))))) => x24 + | (1,(0,(1,(0,(0,(1,(0,0))))))) => x25 + | (0,(1,(1,(0,(0,(1,(0,0))))))) => x26 + | (1,(1,(1,(0,(0,(1,(0,0))))))) => x27 + | (0,(0,(0,(1,(0,(1,(0,0))))))) => x28 + | (1,(0,(0,(1,(0,(1,(0,0))))))) => x29 + | (0,(1,(0,(1,(0,(1,(0,0))))))) => x2a + | (1,(1,(0,(1,(0,(1,(0,0))))))) => x2b + | (0,(0,(1,(1,(0,(1,(0,0))))))) => x2c + | (1,(0,(1,(1,(0,(1,(0,0))))))) => x2d + | (0,(1,(1,(1,(0,(1,(0,0))))))) => x2e + | (1,(1,(1,(1,(0,(1,(0,0))))))) => x2f + | (0,(0,(0,(0,(1,(1,(0,0))))))) => x30 + | (1,(0,(0,(0,(1,(1,(0,0))))))) => x31 + | (0,(1,(0,(0,(1,(1,(0,0))))))) => x32 + | (1,(1,(0,(0,(1,(1,(0,0))))))) => x33 + | (0,(0,(1,(0,(1,(1,(0,0))))))) => x34 + | (1,(0,(1,(0,(1,(1,(0,0))))))) => x35 + | (0,(1,(1,(0,(1,(1,(0,0))))))) => x36 + | (1,(1,(1,(0,(1,(1,(0,0))))))) => x37 + | (0,(0,(0,(1,(1,(1,(0,0))))))) => x38 + | (1,(0,(0,(1,(1,(1,(0,0))))))) => x39 + | (0,(1,(0,(1,(1,(1,(0,0))))))) => x3a + | (1,(1,(0,(1,(1,(1,(0,0))))))) => x3b + | (0,(0,(1,(1,(1,(1,(0,0))))))) => x3c + | (1,(0,(1,(1,(1,(1,(0,0))))))) => x3d + | (0,(1,(1,(1,(1,(1,(0,0))))))) => x3e + | (1,(1,(1,(1,(1,(1,(0,0))))))) => x3f + | (0,(0,(0,(0,(0,(0,(1,0))))))) => x40 + | (1,(0,(0,(0,(0,(0,(1,0))))))) => x41 + | (0,(1,(0,(0,(0,(0,(1,0))))))) => x42 + | (1,(1,(0,(0,(0,(0,(1,0))))))) => x43 + | (0,(0,(1,(0,(0,(0,(1,0))))))) => x44 + | (1,(0,(1,(0,(0,(0,(1,0))))))) => x45 + | (0,(1,(1,(0,(0,(0,(1,0))))))) => x46 + | (1,(1,(1,(0,(0,(0,(1,0))))))) => x47 + | (0,(0,(0,(1,(0,(0,(1,0))))))) => x48 + | (1,(0,(0,(1,(0,(0,(1,0))))))) => x49 + | (0,(1,(0,(1,(0,(0,(1,0))))))) => x4a + | (1,(1,(0,(1,(0,(0,(1,0))))))) => x4b + | (0,(0,(1,(1,(0,(0,(1,0))))))) => x4c + | (1,(0,(1,(1,(0,(0,(1,0))))))) => x4d + | (0,(1,(1,(1,(0,(0,(1,0))))))) => x4e + | (1,(1,(1,(1,(0,(0,(1,0))))))) => x4f + | (0,(0,(0,(0,(1,(0,(1,0))))))) => x50 + | (1,(0,(0,(0,(1,(0,(1,0))))))) => x51 + | (0,(1,(0,(0,(1,(0,(1,0))))))) => x52 + | (1,(1,(0,(0,(1,(0,(1,0))))))) => x53 + | (0,(0,(1,(0,(1,(0,(1,0))))))) => x54 + | (1,(0,(1,(0,(1,(0,(1,0))))))) => x55 + | (0,(1,(1,(0,(1,(0,(1,0))))))) => x56 + | (1,(1,(1,(0,(1,(0,(1,0))))))) => x57 + | (0,(0,(0,(1,(1,(0,(1,0))))))) => x58 + | (1,(0,(0,(1,(1,(0,(1,0))))))) => x59 + | (0,(1,(0,(1,(1,(0,(1,0))))))) => x5a + | (1,(1,(0,(1,(1,(0,(1,0))))))) => x5b + | (0,(0,(1,(1,(1,(0,(1,0))))))) => x5c + | (1,(0,(1,(1,(1,(0,(1,0))))))) => x5d + | (0,(1,(1,(1,(1,(0,(1,0))))))) => x5e + | (1,(1,(1,(1,(1,(0,(1,0))))))) => x5f + | (0,(0,(0,(0,(0,(1,(1,0))))))) => x60 + | (1,(0,(0,(0,(0,(1,(1,0))))))) => x61 + | (0,(1,(0,(0,(0,(1,(1,0))))))) => x62 + | (1,(1,(0,(0,(0,(1,(1,0))))))) => x63 + | (0,(0,(1,(0,(0,(1,(1,0))))))) => x64 + | (1,(0,(1,(0,(0,(1,(1,0))))))) => x65 + | (0,(1,(1,(0,(0,(1,(1,0))))))) => x66 + | (1,(1,(1,(0,(0,(1,(1,0))))))) => x67 + | (0,(0,(0,(1,(0,(1,(1,0))))))) => x68 + | (1,(0,(0,(1,(0,(1,(1,0))))))) => x69 + | (0,(1,(0,(1,(0,(1,(1,0))))))) => x6a + | (1,(1,(0,(1,(0,(1,(1,0))))))) => x6b + | (0,(0,(1,(1,(0,(1,(1,0))))))) => x6c + | (1,(0,(1,(1,(0,(1,(1,0))))))) => x6d + | (0,(1,(1,(1,(0,(1,(1,0))))))) => x6e + | (1,(1,(1,(1,(0,(1,(1,0))))))) => x6f + | (0,(0,(0,(0,(1,(1,(1,0))))))) => x70 + | (1,(0,(0,(0,(1,(1,(1,0))))))) => x71 + | (0,(1,(0,(0,(1,(1,(1,0))))))) => x72 + | (1,(1,(0,(0,(1,(1,(1,0))))))) => x73 + | (0,(0,(1,(0,(1,(1,(1,0))))))) => x74 + | (1,(0,(1,(0,(1,(1,(1,0))))))) => x75 + | (0,(1,(1,(0,(1,(1,(1,0))))))) => x76 + | (1,(1,(1,(0,(1,(1,(1,0))))))) => x77 + | (0,(0,(0,(1,(1,(1,(1,0))))))) => x78 + | (1,(0,(0,(1,(1,(1,(1,0))))))) => x79 + | (0,(1,(0,(1,(1,(1,(1,0))))))) => x7a + | (1,(1,(0,(1,(1,(1,(1,0))))))) => x7b + | (0,(0,(1,(1,(1,(1,(1,0))))))) => x7c + | (1,(0,(1,(1,(1,(1,(1,0))))))) => x7d + | (0,(1,(1,(1,(1,(1,(1,0))))))) => x7e + | (1,(1,(1,(1,(1,(1,(1,0))))))) => x7f + | (0,(0,(0,(0,(0,(0,(0,1))))))) => x80 + | (1,(0,(0,(0,(0,(0,(0,1))))))) => x81 + | (0,(1,(0,(0,(0,(0,(0,1))))))) => x82 + | (1,(1,(0,(0,(0,(0,(0,1))))))) => x83 + | (0,(0,(1,(0,(0,(0,(0,1))))))) => x84 + | (1,(0,(1,(0,(0,(0,(0,1))))))) => x85 + | (0,(1,(1,(0,(0,(0,(0,1))))))) => x86 + | (1,(1,(1,(0,(0,(0,(0,1))))))) => x87 + | (0,(0,(0,(1,(0,(0,(0,1))))))) => x88 + | (1,(0,(0,(1,(0,(0,(0,1))))))) => x89 + | (0,(1,(0,(1,(0,(0,(0,1))))))) => x8a + | (1,(1,(0,(1,(0,(0,(0,1))))))) => x8b + | (0,(0,(1,(1,(0,(0,(0,1))))))) => x8c + | (1,(0,(1,(1,(0,(0,(0,1))))))) => x8d + | (0,(1,(1,(1,(0,(0,(0,1))))))) => x8e + | (1,(1,(1,(1,(0,(0,(0,1))))))) => x8f + | (0,(0,(0,(0,(1,(0,(0,1))))))) => x90 + | (1,(0,(0,(0,(1,(0,(0,1))))))) => x91 + | (0,(1,(0,(0,(1,(0,(0,1))))))) => x92 + | (1,(1,(0,(0,(1,(0,(0,1))))))) => x93 + | (0,(0,(1,(0,(1,(0,(0,1))))))) => x94 + | (1,(0,(1,(0,(1,(0,(0,1))))))) => x95 + | (0,(1,(1,(0,(1,(0,(0,1))))))) => x96 + | (1,(1,(1,(0,(1,(0,(0,1))))))) => x97 + | (0,(0,(0,(1,(1,(0,(0,1))))))) => x98 + | (1,(0,(0,(1,(1,(0,(0,1))))))) => x99 + | (0,(1,(0,(1,(1,(0,(0,1))))))) => x9a + | (1,(1,(0,(1,(1,(0,(0,1))))))) => x9b + | (0,(0,(1,(1,(1,(0,(0,1))))))) => x9c + | (1,(0,(1,(1,(1,(0,(0,1))))))) => x9d + | (0,(1,(1,(1,(1,(0,(0,1))))))) => x9e + | (1,(1,(1,(1,(1,(0,(0,1))))))) => x9f + | (0,(0,(0,(0,(0,(1,(0,1))))))) => xa0 + | (1,(0,(0,(0,(0,(1,(0,1))))))) => xa1 + | (0,(1,(0,(0,(0,(1,(0,1))))))) => xa2 + | (1,(1,(0,(0,(0,(1,(0,1))))))) => xa3 + | (0,(0,(1,(0,(0,(1,(0,1))))))) => xa4 + | (1,(0,(1,(0,(0,(1,(0,1))))))) => xa5 + | (0,(1,(1,(0,(0,(1,(0,1))))))) => xa6 + | (1,(1,(1,(0,(0,(1,(0,1))))))) => xa7 + | (0,(0,(0,(1,(0,(1,(0,1))))))) => xa8 + | (1,(0,(0,(1,(0,(1,(0,1))))))) => xa9 + | (0,(1,(0,(1,(0,(1,(0,1))))))) => xaa + | (1,(1,(0,(1,(0,(1,(0,1))))))) => xab + | (0,(0,(1,(1,(0,(1,(0,1))))))) => xac + | (1,(0,(1,(1,(0,(1,(0,1))))))) => xad + | (0,(1,(1,(1,(0,(1,(0,1))))))) => xae + | (1,(1,(1,(1,(0,(1,(0,1))))))) => xaf + | (0,(0,(0,(0,(1,(1,(0,1))))))) => xb0 + | (1,(0,(0,(0,(1,(1,(0,1))))))) => xb1 + | (0,(1,(0,(0,(1,(1,(0,1))))))) => xb2 + | (1,(1,(0,(0,(1,(1,(0,1))))))) => xb3 + | (0,(0,(1,(0,(1,(1,(0,1))))))) => xb4 + | (1,(0,(1,(0,(1,(1,(0,1))))))) => xb5 + | (0,(1,(1,(0,(1,(1,(0,1))))))) => xb6 + | (1,(1,(1,(0,(1,(1,(0,1))))))) => xb7 + | (0,(0,(0,(1,(1,(1,(0,1))))))) => xb8 + | (1,(0,(0,(1,(1,(1,(0,1))))))) => xb9 + | (0,(1,(0,(1,(1,(1,(0,1))))))) => xba + | (1,(1,(0,(1,(1,(1,(0,1))))))) => xbb + | (0,(0,(1,(1,(1,(1,(0,1))))))) => xbc + | (1,(0,(1,(1,(1,(1,(0,1))))))) => xbd + | (0,(1,(1,(1,(1,(1,(0,1))))))) => xbe + | (1,(1,(1,(1,(1,(1,(0,1))))))) => xbf + | (0,(0,(0,(0,(0,(0,(1,1))))))) => xc0 + | (1,(0,(0,(0,(0,(0,(1,1))))))) => xc1 + | (0,(1,(0,(0,(0,(0,(1,1))))))) => xc2 + | (1,(1,(0,(0,(0,(0,(1,1))))))) => xc3 + | (0,(0,(1,(0,(0,(0,(1,1))))))) => xc4 + | (1,(0,(1,(0,(0,(0,(1,1))))))) => xc5 + | (0,(1,(1,(0,(0,(0,(1,1))))))) => xc6 + | (1,(1,(1,(0,(0,(0,(1,1))))))) => xc7 + | (0,(0,(0,(1,(0,(0,(1,1))))))) => xc8 + | (1,(0,(0,(1,(0,(0,(1,1))))))) => xc9 + | (0,(1,(0,(1,(0,(0,(1,1))))))) => xca + | (1,(1,(0,(1,(0,(0,(1,1))))))) => xcb + | (0,(0,(1,(1,(0,(0,(1,1))))))) => xcc + | (1,(0,(1,(1,(0,(0,(1,1))))))) => xcd + | (0,(1,(1,(1,(0,(0,(1,1))))))) => xce + | (1,(1,(1,(1,(0,(0,(1,1))))))) => xcf + | (0,(0,(0,(0,(1,(0,(1,1))))))) => xd0 + | (1,(0,(0,(0,(1,(0,(1,1))))))) => xd1 + | (0,(1,(0,(0,(1,(0,(1,1))))))) => xd2 + | (1,(1,(0,(0,(1,(0,(1,1))))))) => xd3 + | (0,(0,(1,(0,(1,(0,(1,1))))))) => xd4 + | (1,(0,(1,(0,(1,(0,(1,1))))))) => xd5 + | (0,(1,(1,(0,(1,(0,(1,1))))))) => xd6 + | (1,(1,(1,(0,(1,(0,(1,1))))))) => xd7 + | (0,(0,(0,(1,(1,(0,(1,1))))))) => xd8 + | (1,(0,(0,(1,(1,(0,(1,1))))))) => xd9 + | (0,(1,(0,(1,(1,(0,(1,1))))))) => xda + | (1,(1,(0,(1,(1,(0,(1,1))))))) => xdb + | (0,(0,(1,(1,(1,(0,(1,1))))))) => xdc + | (1,(0,(1,(1,(1,(0,(1,1))))))) => xdd + | (0,(1,(1,(1,(1,(0,(1,1))))))) => xde + | (1,(1,(1,(1,(1,(0,(1,1))))))) => xdf + | (0,(0,(0,(0,(0,(1,(1,1))))))) => xe0 + | (1,(0,(0,(0,(0,(1,(1,1))))))) => xe1 + | (0,(1,(0,(0,(0,(1,(1,1))))))) => xe2 + | (1,(1,(0,(0,(0,(1,(1,1))))))) => xe3 + | (0,(0,(1,(0,(0,(1,(1,1))))))) => xe4 + | (1,(0,(1,(0,(0,(1,(1,1))))))) => xe5 + | (0,(1,(1,(0,(0,(1,(1,1))))))) => xe6 + | (1,(1,(1,(0,(0,(1,(1,1))))))) => xe7 + | (0,(0,(0,(1,(0,(1,(1,1))))))) => xe8 + | (1,(0,(0,(1,(0,(1,(1,1))))))) => xe9 + | (0,(1,(0,(1,(0,(1,(1,1))))))) => xea + | (1,(1,(0,(1,(0,(1,(1,1))))))) => xeb + | (0,(0,(1,(1,(0,(1,(1,1))))))) => xec + | (1,(0,(1,(1,(0,(1,(1,1))))))) => xed + | (0,(1,(1,(1,(0,(1,(1,1))))))) => xee + | (1,(1,(1,(1,(0,(1,(1,1))))))) => xef + | (0,(0,(0,(0,(1,(1,(1,1))))))) => xf0 + | (1,(0,(0,(0,(1,(1,(1,1))))))) => xf1 + | (0,(1,(0,(0,(1,(1,(1,1))))))) => xf2 + | (1,(1,(0,(0,(1,(1,(1,1))))))) => xf3 + | (0,(0,(1,(0,(1,(1,(1,1))))))) => xf4 + | (1,(0,(1,(0,(1,(1,(1,1))))))) => xf5 + | (0,(1,(1,(0,(1,(1,(1,1))))))) => xf6 + | (1,(1,(1,(0,(1,(1,(1,1))))))) => xf7 + | (0,(0,(0,(1,(1,(1,(1,1))))))) => xf8 + | (1,(0,(0,(1,(1,(1,(1,1))))))) => xf9 + | (0,(1,(0,(1,(1,(1,(1,1))))))) => xfa + | (1,(1,(0,(1,(1,(1,(1,1))))))) => xfb + | (0,(0,(1,(1,(1,(1,(1,1))))))) => xfc + | (1,(0,(1,(1,(1,(1,(1,1))))))) => xfd + | (0,(1,(1,(1,(1,(1,(1,1))))))) => xfe + | (1,(1,(1,(1,(1,(1,(1,1))))))) => xff + end. + +Definition to_bits (b : byte) : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) + := match b with + | x00 => (0,(0,(0,(0,(0,(0,(0,0))))))) + | x01 => (1,(0,(0,(0,(0,(0,(0,0))))))) + | x02 => (0,(1,(0,(0,(0,(0,(0,0))))))) + | x03 => (1,(1,(0,(0,(0,(0,(0,0))))))) + | x04 => (0,(0,(1,(0,(0,(0,(0,0))))))) + | x05 => (1,(0,(1,(0,(0,(0,(0,0))))))) + | x06 => (0,(1,(1,(0,(0,(0,(0,0))))))) + | x07 => (1,(1,(1,(0,(0,(0,(0,0))))))) + | x08 => (0,(0,(0,(1,(0,(0,(0,0))))))) + | x09 => (1,(0,(0,(1,(0,(0,(0,0))))))) + | x0a => (0,(1,(0,(1,(0,(0,(0,0))))))) + | x0b => (1,(1,(0,(1,(0,(0,(0,0))))))) + | x0c => (0,(0,(1,(1,(0,(0,(0,0))))))) + | x0d => (1,(0,(1,(1,(0,(0,(0,0))))))) + | x0e => (0,(1,(1,(1,(0,(0,(0,0))))))) + | x0f => (1,(1,(1,(1,(0,(0,(0,0))))))) + | x10 => (0,(0,(0,(0,(1,(0,(0,0))))))) + | x11 => (1,(0,(0,(0,(1,(0,(0,0))))))) + | x12 => (0,(1,(0,(0,(1,(0,(0,0))))))) + | x13 => (1,(1,(0,(0,(1,(0,(0,0))))))) + | x14 => (0,(0,(1,(0,(1,(0,(0,0))))))) + | x15 => (1,(0,(1,(0,(1,(0,(0,0))))))) + | x16 => (0,(1,(1,(0,(1,(0,(0,0))))))) + | x17 => (1,(1,(1,(0,(1,(0,(0,0))))))) + | x18 => (0,(0,(0,(1,(1,(0,(0,0))))))) + | x19 => (1,(0,(0,(1,(1,(0,(0,0))))))) + | x1a => (0,(1,(0,(1,(1,(0,(0,0))))))) + | x1b => (1,(1,(0,(1,(1,(0,(0,0))))))) + | x1c => (0,(0,(1,(1,(1,(0,(0,0))))))) + | x1d => (1,(0,(1,(1,(1,(0,(0,0))))))) + | x1e => (0,(1,(1,(1,(1,(0,(0,0))))))) + | x1f => (1,(1,(1,(1,(1,(0,(0,0))))))) + | x20 => (0,(0,(0,(0,(0,(1,(0,0))))))) + | x21 => (1,(0,(0,(0,(0,(1,(0,0))))))) + | x22 => (0,(1,(0,(0,(0,(1,(0,0))))))) + | x23 => (1,(1,(0,(0,(0,(1,(0,0))))))) + | x24 => (0,(0,(1,(0,(0,(1,(0,0))))))) + | x25 => (1,(0,(1,(0,(0,(1,(0,0))))))) + | x26 => (0,(1,(1,(0,(0,(1,(0,0))))))) + | x27 => (1,(1,(1,(0,(0,(1,(0,0))))))) + | x28 => (0,(0,(0,(1,(0,(1,(0,0))))))) + | x29 => (1,(0,(0,(1,(0,(1,(0,0))))))) + | x2a => (0,(1,(0,(1,(0,(1,(0,0))))))) + | x2b => (1,(1,(0,(1,(0,(1,(0,0))))))) + | x2c => (0,(0,(1,(1,(0,(1,(0,0))))))) + | x2d => (1,(0,(1,(1,(0,(1,(0,0))))))) + | x2e => (0,(1,(1,(1,(0,(1,(0,0))))))) + | x2f => (1,(1,(1,(1,(0,(1,(0,0))))))) + | x30 => (0,(0,(0,(0,(1,(1,(0,0))))))) + | x31 => (1,(0,(0,(0,(1,(1,(0,0))))))) + | x32 => (0,(1,(0,(0,(1,(1,(0,0))))))) + | x33 => (1,(1,(0,(0,(1,(1,(0,0))))))) + | x34 => (0,(0,(1,(0,(1,(1,(0,0))))))) + | x35 => (1,(0,(1,(0,(1,(1,(0,0))))))) + | x36 => (0,(1,(1,(0,(1,(1,(0,0))))))) + | x37 => (1,(1,(1,(0,(1,(1,(0,0))))))) + | x38 => (0,(0,(0,(1,(1,(1,(0,0))))))) + | x39 => (1,(0,(0,(1,(1,(1,(0,0))))))) + | x3a => (0,(1,(0,(1,(1,(1,(0,0))))))) + | x3b => (1,(1,(0,(1,(1,(1,(0,0))))))) + | x3c => (0,(0,(1,(1,(1,(1,(0,0))))))) + | x3d => (1,(0,(1,(1,(1,(1,(0,0))))))) + | x3e => (0,(1,(1,(1,(1,(1,(0,0))))))) + | x3f => (1,(1,(1,(1,(1,(1,(0,0))))))) + | x40 => (0,(0,(0,(0,(0,(0,(1,0))))))) + | x41 => (1,(0,(0,(0,(0,(0,(1,0))))))) + | x42 => (0,(1,(0,(0,(0,(0,(1,0))))))) + | x43 => (1,(1,(0,(0,(0,(0,(1,0))))))) + | x44 => (0,(0,(1,(0,(0,(0,(1,0))))))) + | x45 => (1,(0,(1,(0,(0,(0,(1,0))))))) + | x46 => (0,(1,(1,(0,(0,(0,(1,0))))))) + | x47 => (1,(1,(1,(0,(0,(0,(1,0))))))) + | x48 => (0,(0,(0,(1,(0,(0,(1,0))))))) + | x49 => (1,(0,(0,(1,(0,(0,(1,0))))))) + | x4a => (0,(1,(0,(1,(0,(0,(1,0))))))) + | x4b => (1,(1,(0,(1,(0,(0,(1,0))))))) + | x4c => (0,(0,(1,(1,(0,(0,(1,0))))))) + | x4d => (1,(0,(1,(1,(0,(0,(1,0))))))) + | x4e => (0,(1,(1,(1,(0,(0,(1,0))))))) + | x4f => (1,(1,(1,(1,(0,(0,(1,0))))))) + | x50 => (0,(0,(0,(0,(1,(0,(1,0))))))) + | x51 => (1,(0,(0,(0,(1,(0,(1,0))))))) + | x52 => (0,(1,(0,(0,(1,(0,(1,0))))))) + | x53 => (1,(1,(0,(0,(1,(0,(1,0))))))) + | x54 => (0,(0,(1,(0,(1,(0,(1,0))))))) + | x55 => (1,(0,(1,(0,(1,(0,(1,0))))))) + | x56 => (0,(1,(1,(0,(1,(0,(1,0))))))) + | x57 => (1,(1,(1,(0,(1,(0,(1,0))))))) + | x58 => (0,(0,(0,(1,(1,(0,(1,0))))))) + | x59 => (1,(0,(0,(1,(1,(0,(1,0))))))) + | x5a => (0,(1,(0,(1,(1,(0,(1,0))))))) + | x5b => (1,(1,(0,(1,(1,(0,(1,0))))))) + | x5c => (0,(0,(1,(1,(1,(0,(1,0))))))) + | x5d => (1,(0,(1,(1,(1,(0,(1,0))))))) + | x5e => (0,(1,(1,(1,(1,(0,(1,0))))))) + | x5f => (1,(1,(1,(1,(1,(0,(1,0))))))) + | x60 => (0,(0,(0,(0,(0,(1,(1,0))))))) + | x61 => (1,(0,(0,(0,(0,(1,(1,0))))))) + | x62 => (0,(1,(0,(0,(0,(1,(1,0))))))) + | x63 => (1,(1,(0,(0,(0,(1,(1,0))))))) + | x64 => (0,(0,(1,(0,(0,(1,(1,0))))))) + | x65 => (1,(0,(1,(0,(0,(1,(1,0))))))) + | x66 => (0,(1,(1,(0,(0,(1,(1,0))))))) + | x67 => (1,(1,(1,(0,(0,(1,(1,0))))))) + | x68 => (0,(0,(0,(1,(0,(1,(1,0))))))) + | x69 => (1,(0,(0,(1,(0,(1,(1,0))))))) + | x6a => (0,(1,(0,(1,(0,(1,(1,0))))))) + | x6b => (1,(1,(0,(1,(0,(1,(1,0))))))) + | x6c => (0,(0,(1,(1,(0,(1,(1,0))))))) + | x6d => (1,(0,(1,(1,(0,(1,(1,0))))))) + | x6e => (0,(1,(1,(1,(0,(1,(1,0))))))) + | x6f => (1,(1,(1,(1,(0,(1,(1,0))))))) + | x70 => (0,(0,(0,(0,(1,(1,(1,0))))))) + | x71 => (1,(0,(0,(0,(1,(1,(1,0))))))) + | x72 => (0,(1,(0,(0,(1,(1,(1,0))))))) + | x73 => (1,(1,(0,(0,(1,(1,(1,0))))))) + | x74 => (0,(0,(1,(0,(1,(1,(1,0))))))) + | x75 => (1,(0,(1,(0,(1,(1,(1,0))))))) + | x76 => (0,(1,(1,(0,(1,(1,(1,0))))))) + | x77 => (1,(1,(1,(0,(1,(1,(1,0))))))) + | x78 => (0,(0,(0,(1,(1,(1,(1,0))))))) + | x79 => (1,(0,(0,(1,(1,(1,(1,0))))))) + | x7a => (0,(1,(0,(1,(1,(1,(1,0))))))) + | x7b => (1,(1,(0,(1,(1,(1,(1,0))))))) + | x7c => (0,(0,(1,(1,(1,(1,(1,0))))))) + | x7d => (1,(0,(1,(1,(1,(1,(1,0))))))) + | x7e => (0,(1,(1,(1,(1,(1,(1,0))))))) + | x7f => (1,(1,(1,(1,(1,(1,(1,0))))))) + | x80 => (0,(0,(0,(0,(0,(0,(0,1))))))) + | x81 => (1,(0,(0,(0,(0,(0,(0,1))))))) + | x82 => (0,(1,(0,(0,(0,(0,(0,1))))))) + | x83 => (1,(1,(0,(0,(0,(0,(0,1))))))) + | x84 => (0,(0,(1,(0,(0,(0,(0,1))))))) + | x85 => (1,(0,(1,(0,(0,(0,(0,1))))))) + | x86 => (0,(1,(1,(0,(0,(0,(0,1))))))) + | x87 => (1,(1,(1,(0,(0,(0,(0,1))))))) + | x88 => (0,(0,(0,(1,(0,(0,(0,1))))))) + | x89 => (1,(0,(0,(1,(0,(0,(0,1))))))) + | x8a => (0,(1,(0,(1,(0,(0,(0,1))))))) + | x8b => (1,(1,(0,(1,(0,(0,(0,1))))))) + | x8c => (0,(0,(1,(1,(0,(0,(0,1))))))) + | x8d => (1,(0,(1,(1,(0,(0,(0,1))))))) + | x8e => (0,(1,(1,(1,(0,(0,(0,1))))))) + | x8f => (1,(1,(1,(1,(0,(0,(0,1))))))) + | x90 => (0,(0,(0,(0,(1,(0,(0,1))))))) + | x91 => (1,(0,(0,(0,(1,(0,(0,1))))))) + | x92 => (0,(1,(0,(0,(1,(0,(0,1))))))) + | x93 => (1,(1,(0,(0,(1,(0,(0,1))))))) + | x94 => (0,(0,(1,(0,(1,(0,(0,1))))))) + | x95 => (1,(0,(1,(0,(1,(0,(0,1))))))) + | x96 => (0,(1,(1,(0,(1,(0,(0,1))))))) + | x97 => (1,(1,(1,(0,(1,(0,(0,1))))))) + | x98 => (0,(0,(0,(1,(1,(0,(0,1))))))) + | x99 => (1,(0,(0,(1,(1,(0,(0,1))))))) + | x9a => (0,(1,(0,(1,(1,(0,(0,1))))))) + | x9b => (1,(1,(0,(1,(1,(0,(0,1))))))) + | x9c => (0,(0,(1,(1,(1,(0,(0,1))))))) + | x9d => (1,(0,(1,(1,(1,(0,(0,1))))))) + | x9e => (0,(1,(1,(1,(1,(0,(0,1))))))) + | x9f => (1,(1,(1,(1,(1,(0,(0,1))))))) + | xa0 => (0,(0,(0,(0,(0,(1,(0,1))))))) + | xa1 => (1,(0,(0,(0,(0,(1,(0,1))))))) + | xa2 => (0,(1,(0,(0,(0,(1,(0,1))))))) + | xa3 => (1,(1,(0,(0,(0,(1,(0,1))))))) + | xa4 => (0,(0,(1,(0,(0,(1,(0,1))))))) + | xa5 => (1,(0,(1,(0,(0,(1,(0,1))))))) + | xa6 => (0,(1,(1,(0,(0,(1,(0,1))))))) + | xa7 => (1,(1,(1,(0,(0,(1,(0,1))))))) + | xa8 => (0,(0,(0,(1,(0,(1,(0,1))))))) + | xa9 => (1,(0,(0,(1,(0,(1,(0,1))))))) + | xaa => (0,(1,(0,(1,(0,(1,(0,1))))))) + | xab => (1,(1,(0,(1,(0,(1,(0,1))))))) + | xac => (0,(0,(1,(1,(0,(1,(0,1))))))) + | xad => (1,(0,(1,(1,(0,(1,(0,1))))))) + | xae => (0,(1,(1,(1,(0,(1,(0,1))))))) + | xaf => (1,(1,(1,(1,(0,(1,(0,1))))))) + | xb0 => (0,(0,(0,(0,(1,(1,(0,1))))))) + | xb1 => (1,(0,(0,(0,(1,(1,(0,1))))))) + | xb2 => (0,(1,(0,(0,(1,(1,(0,1))))))) + | xb3 => (1,(1,(0,(0,(1,(1,(0,1))))))) + | xb4 => (0,(0,(1,(0,(1,(1,(0,1))))))) + | xb5 => (1,(0,(1,(0,(1,(1,(0,1))))))) + | xb6 => (0,(1,(1,(0,(1,(1,(0,1))))))) + | xb7 => (1,(1,(1,(0,(1,(1,(0,1))))))) + | xb8 => (0,(0,(0,(1,(1,(1,(0,1))))))) + | xb9 => (1,(0,(0,(1,(1,(1,(0,1))))))) + | xba => (0,(1,(0,(1,(1,(1,(0,1))))))) + | xbb => (1,(1,(0,(1,(1,(1,(0,1))))))) + | xbc => (0,(0,(1,(1,(1,(1,(0,1))))))) + | xbd => (1,(0,(1,(1,(1,(1,(0,1))))))) + | xbe => (0,(1,(1,(1,(1,(1,(0,1))))))) + | xbf => (1,(1,(1,(1,(1,(1,(0,1))))))) + | xc0 => (0,(0,(0,(0,(0,(0,(1,1))))))) + | xc1 => (1,(0,(0,(0,(0,(0,(1,1))))))) + | xc2 => (0,(1,(0,(0,(0,(0,(1,1))))))) + | xc3 => (1,(1,(0,(0,(0,(0,(1,1))))))) + | xc4 => (0,(0,(1,(0,(0,(0,(1,1))))))) + | xc5 => (1,(0,(1,(0,(0,(0,(1,1))))))) + | xc6 => (0,(1,(1,(0,(0,(0,(1,1))))))) + | xc7 => (1,(1,(1,(0,(0,(0,(1,1))))))) + | xc8 => (0,(0,(0,(1,(0,(0,(1,1))))))) + | xc9 => (1,(0,(0,(1,(0,(0,(1,1))))))) + | xca => (0,(1,(0,(1,(0,(0,(1,1))))))) + | xcb => (1,(1,(0,(1,(0,(0,(1,1))))))) + | xcc => (0,(0,(1,(1,(0,(0,(1,1))))))) + | xcd => (1,(0,(1,(1,(0,(0,(1,1))))))) + | xce => (0,(1,(1,(1,(0,(0,(1,1))))))) + | xcf => (1,(1,(1,(1,(0,(0,(1,1))))))) + | xd0 => (0,(0,(0,(0,(1,(0,(1,1))))))) + | xd1 => (1,(0,(0,(0,(1,(0,(1,1))))))) + | xd2 => (0,(1,(0,(0,(1,(0,(1,1))))))) + | xd3 => (1,(1,(0,(0,(1,(0,(1,1))))))) + | xd4 => (0,(0,(1,(0,(1,(0,(1,1))))))) + | xd5 => (1,(0,(1,(0,(1,(0,(1,1))))))) + | xd6 => (0,(1,(1,(0,(1,(0,(1,1))))))) + | xd7 => (1,(1,(1,(0,(1,(0,(1,1))))))) + | xd8 => (0,(0,(0,(1,(1,(0,(1,1))))))) + | xd9 => (1,(0,(0,(1,(1,(0,(1,1))))))) + | xda => (0,(1,(0,(1,(1,(0,(1,1))))))) + | xdb => (1,(1,(0,(1,(1,(0,(1,1))))))) + | xdc => (0,(0,(1,(1,(1,(0,(1,1))))))) + | xdd => (1,(0,(1,(1,(1,(0,(1,1))))))) + | xde => (0,(1,(1,(1,(1,(0,(1,1))))))) + | xdf => (1,(1,(1,(1,(1,(0,(1,1))))))) + | xe0 => (0,(0,(0,(0,(0,(1,(1,1))))))) + | xe1 => (1,(0,(0,(0,(0,(1,(1,1))))))) + | xe2 => (0,(1,(0,(0,(0,(1,(1,1))))))) + | xe3 => (1,(1,(0,(0,(0,(1,(1,1))))))) + | xe4 => (0,(0,(1,(0,(0,(1,(1,1))))))) + | xe5 => (1,(0,(1,(0,(0,(1,(1,1))))))) + | xe6 => (0,(1,(1,(0,(0,(1,(1,1))))))) + | xe7 => (1,(1,(1,(0,(0,(1,(1,1))))))) + | xe8 => (0,(0,(0,(1,(0,(1,(1,1))))))) + | xe9 => (1,(0,(0,(1,(0,(1,(1,1))))))) + | xea => (0,(1,(0,(1,(0,(1,(1,1))))))) + | xeb => (1,(1,(0,(1,(0,(1,(1,1))))))) + | xec => (0,(0,(1,(1,(0,(1,(1,1))))))) + | xed => (1,(0,(1,(1,(0,(1,(1,1))))))) + | xee => (0,(1,(1,(1,(0,(1,(1,1))))))) + | xef => (1,(1,(1,(1,(0,(1,(1,1))))))) + | xf0 => (0,(0,(0,(0,(1,(1,(1,1))))))) + | xf1 => (1,(0,(0,(0,(1,(1,(1,1))))))) + | xf2 => (0,(1,(0,(0,(1,(1,(1,1))))))) + | xf3 => (1,(1,(0,(0,(1,(1,(1,1))))))) + | xf4 => (0,(0,(1,(0,(1,(1,(1,1))))))) + | xf5 => (1,(0,(1,(0,(1,(1,(1,1))))))) + | xf6 => (0,(1,(1,(0,(1,(1,(1,1))))))) + | xf7 => (1,(1,(1,(0,(1,(1,(1,1))))))) + | xf8 => (0,(0,(0,(1,(1,(1,(1,1))))))) + | xf9 => (1,(0,(0,(1,(1,(1,(1,1))))))) + | xfa => (0,(1,(0,(1,(1,(1,(1,1))))))) + | xfb => (1,(1,(0,(1,(1,(1,(1,1))))))) + | xfc => (0,(0,(1,(1,(1,(1,(1,1))))))) + | xfd => (1,(0,(1,(1,(1,(1,(1,1))))))) + | xfe => (0,(1,(1,(1,(1,(1,(1,1))))))) + | xff => (1,(1,(1,(1,(1,(1,(1,1))))))) + end. + +Lemma of_bits_to_bits (b : byte) : of_bits (to_bits b) = b. +Proof. destruct b; exact eq_refl. Qed. + +Lemma to_bits_of_bits (b : _) : to_bits (of_bits b) = b. +Proof. + repeat match goal with + | p : prod _ _ |- _ => destruct p + | b : bool |- _ => destruct b + end; + exact eq_refl. +Qed. + +Definition byte_of_byte (b : byte) : byte := b. + +Module Export ByteSyntaxNotations. + String Notation byte byte_of_byte byte_of_byte : byte_scope. +End ByteSyntaxNotations. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 7f0387dd12..3603604a71 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -167,6 +167,7 @@ Register S as num.nat.S. (** [option A] is the extension of [A] with an extra element [None] *) +#[universes(template)] Inductive option (A:Type) : Type := | Some : A -> option A | None : option A. @@ -186,6 +187,7 @@ Definition option_map (A B:Type) (f:A->B) (o : option A) : option B := (** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *) +#[universes(template)] Inductive sum (A B:Type) : Type := | inl : A -> sum A B | inr : B -> sum A B. @@ -198,6 +200,7 @@ Arguments inr {A B} _ , A [B] _. (** [prod A B], written [A * B], is the product of [A] and [B]; the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *) +#[universes(template)] Inductive prod (A B:Type) : Type := pair : A -> B -> A * B @@ -256,6 +259,7 @@ Defined. (** Polymorphic lists and some operations *) +#[universes(template)] Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. @@ -384,6 +388,7 @@ Proof. intros. apply CompareSpec2Type; assumption. Defined. member is the singleton datatype [identity A a a] whose sole inhabitant is denoted [identity_refl A a] *) +#[universes(template)] Inductive identity (A:Type) (a:A) : A -> Type := identity_refl : identity a a. Hint Resolve identity_refl: core. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 6d98bcb34a..5e29f854e8 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -13,6 +13,7 @@ Require Export Logic. Require Export Logic_Type. Require Export Datatypes. Require Export Specif. +Require Coq.Init.Byte. Require Coq.Init.Decimal. Require Coq.Init.Nat. Require Export Peano. @@ -26,6 +27,7 @@ Require Export Coq.Init.Tauto. Declare ML Module "cc_plugin". Declare ML Module "ground_plugin". Declare ML Module "numeral_notation_plugin". +Declare ML Module "string_notation_plugin". (* Parsing / printing of decimal numbers *) Arguments Nat.of_uint d%dec_uint_scope. @@ -38,5 +40,8 @@ Numeral Notation Decimal.int Decimal.int_of_int Decimal.int_of_int (* Parsing / printing of [nat] numbers *) Numeral Notation nat Nat.of_uint Nat.to_uint : nat_scope (abstract after 5000). +(* Printing/Parsing of bytes *) +Export Byte.ByteSyntaxNotations. + (* Default substrings not considered by queries like SearchAbout *) Add Search Blacklist "_subproof" "_subterm" "Private_". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index e4796a8059..cfba2bae69 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -24,6 +24,7 @@ Require Import Logic. Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset of elements of the type [A] which satisfy both [P] and [Q]. *) +#[universes(template)] Inductive sig (A:Type) (P:A -> Prop) : Type := exist : forall x:A, P x -> sig P. @@ -31,12 +32,14 @@ Register sig as core.sig.type. Register exist as core.sig.intro. Register sig_rect as core.sig.rect. +#[universes(template)] Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := exist2 : forall x:A, P x -> Q x -> sig2 P Q. (** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *) +#[universes(template)] Inductive sigT (A:Type) (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P. @@ -44,6 +47,7 @@ Register sigT as core.sigT.type. Register existT as core.sigT.intro. Register sigT_rect as core.sigT.rect. +#[universes(template)] Inductive sigT2 (A:Type) (P Q:A -> Type) : Type := existT2 : forall x:A, P x -> Q x -> sigT2 P Q. @@ -700,6 +704,7 @@ Register sumbool as core.sumbool.type. (** [sumor] is an option type equipped with the justification of why it may not be a regular value *) +#[universes(template)] Inductive sumor (A:Type) (B:Prop) : Type := | inleft : A -> A + {B} | inright : B -> A + {B} diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index 57f558de50..d93816e9ff 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -78,6 +78,7 @@ Section DependentMemoFunction. Variable A: nat -> Type. Variable f: forall n, A n. +#[universes(template)] Inductive memo_val: Type := memo_mval: forall n, A n -> memo_val. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 8a01b8fb19..a03799959e 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -16,6 +16,7 @@ Section Streams. Variable A : Type. +#[universes(template)] CoInductive Stream : Type := Cons : A -> Stream -> Stream. diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v index 02c8998a8d..a70bd92329 100644 --- a/theories/Logic/ExtensionalityFacts.v +++ b/theories/Logic/ExtensionalityFacts.v @@ -40,6 +40,7 @@ Definition is_inverse A B f g := (forall a:A, g (f a) = a) /\ (forall b:B, f (g (** The diagonal over A and the one-one correspondence with A *) +#[universes(template)] Record Delta A := { pi1:A; pi2:A; eq:pi1=pi2 }. Definition delta {A} (a:A) := {|pi1 := a; pi2 := a; eq := eq_refl a |}. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index ac2a143472..13e1dad361 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -208,6 +208,7 @@ Definition concat s1 s2 := - [present] is [true] if and only if [s] contains [x]. *) +#[universes(template)] Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 888f9850c1..a3dcca7dfd 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -48,6 +48,7 @@ Module Type Ops (X:OrderedType)(Info:InfoTyp). Definition elt := X.t. Hint Transparent elt : core. +#[universes(template)] Inductive tree : Type := | Leaf : tree | Node : Info.t -> tree -> X.t -> tree -> tree. @@ -167,6 +168,7 @@ end. (** Enumeration of the elements of a tree. This corresponds to the "samefringe" notion in the litterature. *) +#[universes(template)] Inductive enumeration := | End : enumeration | More : elt -> tree -> enumeration -> enumeration. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index a4bbaef52d..0ba2799bfb 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -439,6 +439,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Definition elt := E.t. +#[universes(template)] Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. Definition t := t_. Arguments Mkt this {is_ok}. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 951a4ef2b0..9f718cba65 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -28,6 +28,7 @@ Local Open Scope Z_scope. Module ZnZ. + #[universes(template)] Class Ops (t:Type) := MkOps { (* Conversion functions with Z *) diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index fe0476e4de..b6441bb76a 100644 --- a/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -22,6 +22,7 @@ Section Carry. Variable A : Type. + #[universes(template)] Inductive carry := | C0 : A -> carry | C1 : A -> carry. @@ -44,6 +45,7 @@ Section Zn2Z. first. *) + #[universes(template)] Inductive zn2z := | W0 : zn2z | WW : znz -> znz -> zn2z. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index cf42ed18db..5ae933d433 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -257,6 +257,7 @@ Ltac blocked t := block_goal ; t ; unblock_goal. be used by the [equations] resolver. It is especially useful to register the dependent elimination principles for things in [Prop] which are not automatically generated. *) +#[universes(template)] Class DependentEliminationPackage (A : Type) := { elim_type : Type ; elim : elim_type }. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index ceac021ef2..49a485c741 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -137,6 +137,7 @@ Definition IsStepFun (f:R -> R) (a b:R) : Type := { l:Rlist & is_subdivision f a b l }. (** ** Class of step functions *) +#[universes(template)] Record StepFun (a b:R) : Type := mkStepFun {fe :> R -> R; pre : IsStepFun fe a b}. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index e3e995d201..b6b72de889 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -116,6 +116,7 @@ Qed. (*******************************) (*********) +#[universes(template)] Record Metric_Space : Type := {Base : Type; dist : Base -> Base -> R; diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index 171dba5522..f94b5cab65 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -380,6 +380,7 @@ Proof. apply Rinv_0_lt_compat; prove_sup0. Qed. +#[universes(template)] Record family : Type := mkfamily {ind : R -> Prop; f :> R -> R -> Prop; diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 61fe55770b..2ed422ffe9 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -100,9 +100,11 @@ Hint Resolve Totally_ordered_definition Upper_Bound_definition Section Specific_orders. Variable U : Type. + #[universes(template)] Record Cpo : Type := Definition_of_cpo {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}. + #[universes(template)] Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index a79ddead20..6a8a3014c3 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -22,6 +22,7 @@ Section multiset_defs. Hypothesis eqA_equiv : Equivalence eqA. Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}. + #[universes(template)] Inductive multiset : Type := Bag : (A -> nat) -> multiset. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 17fc0ed25e..5b51c7b953 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -36,6 +36,7 @@ Section Partial_orders. Definition Rel := Relation U. + #[universes(template)] Record PO : Type := Definition_of_PO { Carrier_of : Ensemble U; Rel_of : Relation U; diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 6a22501afa..f5cda792ce 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -42,6 +42,7 @@ Section defs. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. + #[universes(template)] Inductive Tree := | Tree_Leaf : Tree | Tree_Node : A -> Tree -> Tree -> Tree. @@ -128,6 +129,7 @@ Section defs. (** ** Merging two sorted lists *) + #[universes(template)] Inductive merge_lem (l1 l2:list A) : Type := merge_exist : forall l:list A, @@ -201,6 +203,7 @@ Section defs. (** ** Specification of heap insertion *) + #[universes(template)] Inductive insert_spec (a:A) (T:Tree) : Type := insert_exist : forall T1:Tree, @@ -234,6 +237,7 @@ Section defs. (** ** Building a heap from a list *) + #[universes(template)] Inductive build_heap (l:list A) : Type := heap_exist : forall T:Tree, @@ -258,6 +262,7 @@ Section defs. (** ** Building the sorted list *) + #[universes(template)] Inductive flat_spec (T:Tree) : Type := flat_exist : forall l:list A, diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index b7c1eaa788..6a0c5f066e 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -12,7 +12,7 @@ (** Contributed by Laurent Théry (INRIA); Adapted to Coq V8 by the Coq Development Team *) -Require Import Bool BinPos BinNat PeanoNat Nnat. +Require Import Bool BinPos BinNat PeanoNat Nnat Coq.Strings.Byte. (** * Definition of ascii characters *) @@ -20,10 +20,7 @@ Require Import Bool BinPos BinNat PeanoNat Nnat. Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool). -Register Ascii as plugins.syntax.Ascii. - Declare Scope char_scope. -Module Export AsciiSyntax. Declare ML Module "ascii_syntax_plugin". End AsciiSyntax. Delimit Scope char_scope with char. Bind Scope char_scope with ascii. @@ -140,6 +137,12 @@ do 8 (destruct p; [ | | intros; vm_compute; reflexivity ]); intro H; vm_compute in H; destruct p; discriminate. Qed. +Theorem N_ascii_bounded : + forall a : ascii, (N_of_ascii a < 256)%N. +Proof. + destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. +Qed. + Theorem ascii_nat_embedding : forall a : ascii, ascii_of_nat (nat_of_ascii a) = a. Proof. @@ -158,6 +161,15 @@ Proof. now apply Nat.compare_lt_iff. Qed. +Theorem nat_ascii_bounded : + forall a : ascii, nat_of_ascii a < 256. +Proof. + intro a; unfold nat_of_ascii. + change 256 with (N.to_nat 256). + rewrite <- Nat.compare_lt_iff, <- N2Nat.inj_compare, N.compare_lt_iff. + apply N_ascii_bounded. +Qed. + (** * Concrete syntax *) @@ -175,7 +187,53 @@ Qed. stand-alone utf8 characters so that only the notation "nnn" is available for them (unless your terminal is able to represent them, which is typically not the case in coqide). -*) + *) + +Definition ascii_of_byte (b : byte) : ascii + := let '(b0, (b1, (b2, (b3, (b4, (b5, (b6, b7))))))) := Byte.to_bits b in + Ascii b0 b1 b2 b3 b4 b5 b6 b7. + +Definition byte_of_ascii (a : ascii) : byte + := let (b0, b1, b2, b3, b4, b5, b6, b7) := a in + Byte.of_bits (b0, (b1, (b2, (b3, (b4, (b5, (b6, b7))))))). + +Lemma ascii_of_byte_of_ascii x : ascii_of_byte (byte_of_ascii x) = x. +Proof. + cbv [ascii_of_byte byte_of_ascii]. + destruct x; rewrite to_bits_of_bits; reflexivity. +Qed. + +Lemma byte_of_ascii_of_byte x : byte_of_ascii (ascii_of_byte x) = x. +Proof. + cbv [ascii_of_byte byte_of_ascii]. + repeat match goal with + | [ |- context[match ?x with pair _ _ => _ end] ] + => rewrite (surjective_pairing x) + | [ |- context[(fst ?x, snd ?x)] ] + => rewrite <- (surjective_pairing x) + end. + rewrite of_bits_to_bits; reflexivity. +Qed. + +Lemma ascii_of_byte_via_N x : ascii_of_byte x = ascii_of_N (Byte.to_N x). +Proof. destruct x; reflexivity. Qed. + +Lemma ascii_of_byte_via_nat x : ascii_of_byte x = ascii_of_nat (Byte.to_nat x). +Proof. destruct x; reflexivity. Qed. + +Lemma byte_of_ascii_via_N x : Some (byte_of_ascii x) = Byte.of_N (N_of_ascii x). +Proof. + rewrite <- (ascii_of_byte_of_ascii x); destruct (byte_of_ascii x); reflexivity. +Qed. + +Lemma byte_of_ascii_via_nat x : Some (byte_of_ascii x) = Byte.of_nat (nat_of_ascii x). +Proof. + rewrite <- (ascii_of_byte_of_ascii x); destruct (byte_of_ascii x); reflexivity. +Qed. + +Module Export AsciiSyntax. + String Notation ascii ascii_of_byte byte_of_ascii : char_scope. +End AsciiSyntax. Local Open Scope char_scope. diff --git a/theories/Strings/BinaryString.v b/theories/Strings/BinaryString.v index 6df0a9170a..a2bb1763f5 100644 --- a/theories/Strings/BinaryString.v +++ b/theories/Strings/BinaryString.v @@ -48,7 +48,7 @@ Module Raw. end end. - Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) {struct p} : to_N (of_pos p rest) base = to_N rest match base with | N0 => N.pos p diff --git a/theories/Strings/Byte.v b/theories/Strings/Byte.v new file mode 100644 index 0000000000..2759ea60cb --- /dev/null +++ b/theories/Strings/Byte.v @@ -0,0 +1,1214 @@ +(************************************************************************) +(* * 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.Arith.EqNat. +Require Import Coq.NArith.BinNat. +Require Import Coq.NArith.Nnat. +Require Export Coq.Init.Byte. + +Local Set Implicit Arguments. + +Definition eqb (a b : byte) : bool + := let '(a0, (a1, (a2, (a3, (a4, (a5, (a6, a7))))))) := to_bits a in + let '(b0, (b1, (b2, (b3, (b4, (b5, (b6, b7))))))) := to_bits b in + (Bool.eqb a0 b0 && Bool.eqb a1 b1 && Bool.eqb a2 b2 && Bool.eqb a3 b3 && + Bool.eqb a4 b4 && Bool.eqb a5 b5 && Bool.eqb a6 b6 && Bool.eqb a7 b7)%bool. + +Module Export ByteNotations. + Export ByteSyntaxNotations. + Infix "=?" := eqb (at level 70) : byte_scope. +End ByteNotations. + +Lemma byte_dec_lb x y : x = y -> eqb x y = true. +Proof. intro; subst y; destruct x; reflexivity. Defined. + +Lemma byte_dec_bl x y (H : eqb x y = true) : x = y. +Proof. + rewrite <- (of_bits_to_bits x), <- (of_bits_to_bits y). + cbv [eqb] in H; revert H. + generalize (to_bits x) (to_bits y); clear x y; intros x y H. + repeat match goal with + | [ H : and _ _ |- _ ] => destruct H + | [ H : prod _ _ |- _ ] => destruct H + | [ H : context[andb _ _ = true] |- _ ] => rewrite Bool.andb_true_iff in H + | [ H : context[Bool.eqb _ _ = true] |- _ ] => rewrite Bool.eqb_true_iff in H + | _ => progress subst + | _ => reflexivity + end. +Qed. + +Lemma eqb_false x y : eqb x y = false -> x <> y. +Proof. intros H H'; pose proof (byte_dec_lb H'); congruence. Qed. + +Definition byte_eq_dec (x y : byte) : {x = y} + {x <> y} + := (if eqb x y as beq return eqb x y = beq -> _ + then fun pf => left (byte_dec_bl x y pf) + else fun pf => right (eqb_false pf)) + eq_refl. + +Section nat. + Definition to_nat (x : byte) : nat + := match x with + | x00 => 0 + | x01 => 1 + | x02 => 2 + | x03 => 3 + | x04 => 4 + | x05 => 5 + | x06 => 6 + | x07 => 7 + | x08 => 8 + | x09 => 9 + | x0a => 10 + | x0b => 11 + | x0c => 12 + | x0d => 13 + | x0e => 14 + | x0f => 15 + | x10 => 16 + | x11 => 17 + | x12 => 18 + | x13 => 19 + | x14 => 20 + | x15 => 21 + | x16 => 22 + | x17 => 23 + | x18 => 24 + | x19 => 25 + | x1a => 26 + | x1b => 27 + | x1c => 28 + | x1d => 29 + | x1e => 30 + | x1f => 31 + | x20 => 32 + | x21 => 33 + | x22 => 34 + | x23 => 35 + | x24 => 36 + | x25 => 37 + | x26 => 38 + | x27 => 39 + | x28 => 40 + | x29 => 41 + | x2a => 42 + | x2b => 43 + | x2c => 44 + | x2d => 45 + | x2e => 46 + | x2f => 47 + | x30 => 48 + | x31 => 49 + | x32 => 50 + | x33 => 51 + | x34 => 52 + | x35 => 53 + | x36 => 54 + | x37 => 55 + | x38 => 56 + | x39 => 57 + | x3a => 58 + | x3b => 59 + | x3c => 60 + | x3d => 61 + | x3e => 62 + | x3f => 63 + | x40 => 64 + | x41 => 65 + | x42 => 66 + | x43 => 67 + | x44 => 68 + | x45 => 69 + | x46 => 70 + | x47 => 71 + | x48 => 72 + | x49 => 73 + | x4a => 74 + | x4b => 75 + | x4c => 76 + | x4d => 77 + | x4e => 78 + | x4f => 79 + | x50 => 80 + | x51 => 81 + | x52 => 82 + | x53 => 83 + | x54 => 84 + | x55 => 85 + | x56 => 86 + | x57 => 87 + | x58 => 88 + | x59 => 89 + | x5a => 90 + | x5b => 91 + | x5c => 92 + | x5d => 93 + | x5e => 94 + | x5f => 95 + | x60 => 96 + | x61 => 97 + | x62 => 98 + | x63 => 99 + | x64 => 100 + | x65 => 101 + | x66 => 102 + | x67 => 103 + | x68 => 104 + | x69 => 105 + | x6a => 106 + | x6b => 107 + | x6c => 108 + | x6d => 109 + | x6e => 110 + | x6f => 111 + | x70 => 112 + | x71 => 113 + | x72 => 114 + | x73 => 115 + | x74 => 116 + | x75 => 117 + | x76 => 118 + | x77 => 119 + | x78 => 120 + | x79 => 121 + | x7a => 122 + | x7b => 123 + | x7c => 124 + | x7d => 125 + | x7e => 126 + | x7f => 127 + | x80 => 128 + | x81 => 129 + | x82 => 130 + | x83 => 131 + | x84 => 132 + | x85 => 133 + | x86 => 134 + | x87 => 135 + | x88 => 136 + | x89 => 137 + | x8a => 138 + | x8b => 139 + | x8c => 140 + | x8d => 141 + | x8e => 142 + | x8f => 143 + | x90 => 144 + | x91 => 145 + | x92 => 146 + | x93 => 147 + | x94 => 148 + | x95 => 149 + | x96 => 150 + | x97 => 151 + | x98 => 152 + | x99 => 153 + | x9a => 154 + | x9b => 155 + | x9c => 156 + | x9d => 157 + | x9e => 158 + | x9f => 159 + | xa0 => 160 + | xa1 => 161 + | xa2 => 162 + | xa3 => 163 + | xa4 => 164 + | xa5 => 165 + | xa6 => 166 + | xa7 => 167 + | xa8 => 168 + | xa9 => 169 + | xaa => 170 + | xab => 171 + | xac => 172 + | xad => 173 + | xae => 174 + | xaf => 175 + | xb0 => 176 + | xb1 => 177 + | xb2 => 178 + | xb3 => 179 + | xb4 => 180 + | xb5 => 181 + | xb6 => 182 + | xb7 => 183 + | xb8 => 184 + | xb9 => 185 + | xba => 186 + | xbb => 187 + | xbc => 188 + | xbd => 189 + | xbe => 190 + | xbf => 191 + | xc0 => 192 + | xc1 => 193 + | xc2 => 194 + | xc3 => 195 + | xc4 => 196 + | xc5 => 197 + | xc6 => 198 + | xc7 => 199 + | xc8 => 200 + | xc9 => 201 + | xca => 202 + | xcb => 203 + | xcc => 204 + | xcd => 205 + | xce => 206 + | xcf => 207 + | xd0 => 208 + | xd1 => 209 + | xd2 => 210 + | xd3 => 211 + | xd4 => 212 + | xd5 => 213 + | xd6 => 214 + | xd7 => 215 + | xd8 => 216 + | xd9 => 217 + | xda => 218 + | xdb => 219 + | xdc => 220 + | xdd => 221 + | xde => 222 + | xdf => 223 + | xe0 => 224 + | xe1 => 225 + | xe2 => 226 + | xe3 => 227 + | xe4 => 228 + | xe5 => 229 + | xe6 => 230 + | xe7 => 231 + | xe8 => 232 + | xe9 => 233 + | xea => 234 + | xeb => 235 + | xec => 236 + | xed => 237 + | xee => 238 + | xef => 239 + | xf0 => 240 + | xf1 => 241 + | xf2 => 242 + | xf3 => 243 + | xf4 => 244 + | xf5 => 245 + | xf6 => 246 + | xf7 => 247 + | xf8 => 248 + | xf9 => 249 + | xfa => 250 + | xfb => 251 + | xfc => 252 + | xfd => 253 + | xfe => 254 + | xff => 255 + end. + + Definition of_nat (x : nat) : option byte + := match x with + | 0 => Some x00 + | 1 => Some x01 + | 2 => Some x02 + | 3 => Some x03 + | 4 => Some x04 + | 5 => Some x05 + | 6 => Some x06 + | 7 => Some x07 + | 8 => Some x08 + | 9 => Some x09 + | 10 => Some x0a + | 11 => Some x0b + | 12 => Some x0c + | 13 => Some x0d + | 14 => Some x0e + | 15 => Some x0f + | 16 => Some x10 + | 17 => Some x11 + | 18 => Some x12 + | 19 => Some x13 + | 20 => Some x14 + | 21 => Some x15 + | 22 => Some x16 + | 23 => Some x17 + | 24 => Some x18 + | 25 => Some x19 + | 26 => Some x1a + | 27 => Some x1b + | 28 => Some x1c + | 29 => Some x1d + | 30 => Some x1e + | 31 => Some x1f + | 32 => Some x20 + | 33 => Some x21 + | 34 => Some x22 + | 35 => Some x23 + | 36 => Some x24 + | 37 => Some x25 + | 38 => Some x26 + | 39 => Some x27 + | 40 => Some x28 + | 41 => Some x29 + | 42 => Some x2a + | 43 => Some x2b + | 44 => Some x2c + | 45 => Some x2d + | 46 => Some x2e + | 47 => Some x2f + | 48 => Some x30 + | 49 => Some x31 + | 50 => Some x32 + | 51 => Some x33 + | 52 => Some x34 + | 53 => Some x35 + | 54 => Some x36 + | 55 => Some x37 + | 56 => Some x38 + | 57 => Some x39 + | 58 => Some x3a + | 59 => Some x3b + | 60 => Some x3c + | 61 => Some x3d + | 62 => Some x3e + | 63 => Some x3f + | 64 => Some x40 + | 65 => Some x41 + | 66 => Some x42 + | 67 => Some x43 + | 68 => Some x44 + | 69 => Some x45 + | 70 => Some x46 + | 71 => Some x47 + | 72 => Some x48 + | 73 => Some x49 + | 74 => Some x4a + | 75 => Some x4b + | 76 => Some x4c + | 77 => Some x4d + | 78 => Some x4e + | 79 => Some x4f + | 80 => Some x50 + | 81 => Some x51 + | 82 => Some x52 + | 83 => Some x53 + | 84 => Some x54 + | 85 => Some x55 + | 86 => Some x56 + | 87 => Some x57 + | 88 => Some x58 + | 89 => Some x59 + | 90 => Some x5a + | 91 => Some x5b + | 92 => Some x5c + | 93 => Some x5d + | 94 => Some x5e + | 95 => Some x5f + | 96 => Some x60 + | 97 => Some x61 + | 98 => Some x62 + | 99 => Some x63 + | 100 => Some x64 + | 101 => Some x65 + | 102 => Some x66 + | 103 => Some x67 + | 104 => Some x68 + | 105 => Some x69 + | 106 => Some x6a + | 107 => Some x6b + | 108 => Some x6c + | 109 => Some x6d + | 110 => Some x6e + | 111 => Some x6f + | 112 => Some x70 + | 113 => Some x71 + | 114 => Some x72 + | 115 => Some x73 + | 116 => Some x74 + | 117 => Some x75 + | 118 => Some x76 + | 119 => Some x77 + | 120 => Some x78 + | 121 => Some x79 + | 122 => Some x7a + | 123 => Some x7b + | 124 => Some x7c + | 125 => Some x7d + | 126 => Some x7e + | 127 => Some x7f + | 128 => Some x80 + | 129 => Some x81 + | 130 => Some x82 + | 131 => Some x83 + | 132 => Some x84 + | 133 => Some x85 + | 134 => Some x86 + | 135 => Some x87 + | 136 => Some x88 + | 137 => Some x89 + | 138 => Some x8a + | 139 => Some x8b + | 140 => Some x8c + | 141 => Some x8d + | 142 => Some x8e + | 143 => Some x8f + | 144 => Some x90 + | 145 => Some x91 + | 146 => Some x92 + | 147 => Some x93 + | 148 => Some x94 + | 149 => Some x95 + | 150 => Some x96 + | 151 => Some x97 + | 152 => Some x98 + | 153 => Some x99 + | 154 => Some x9a + | 155 => Some x9b + | 156 => Some x9c + | 157 => Some x9d + | 158 => Some x9e + | 159 => Some x9f + | 160 => Some xa0 + | 161 => Some xa1 + | 162 => Some xa2 + | 163 => Some xa3 + | 164 => Some xa4 + | 165 => Some xa5 + | 166 => Some xa6 + | 167 => Some xa7 + | 168 => Some xa8 + | 169 => Some xa9 + | 170 => Some xaa + | 171 => Some xab + | 172 => Some xac + | 173 => Some xad + | 174 => Some xae + | 175 => Some xaf + | 176 => Some xb0 + | 177 => Some xb1 + | 178 => Some xb2 + | 179 => Some xb3 + | 180 => Some xb4 + | 181 => Some xb5 + | 182 => Some xb6 + | 183 => Some xb7 + | 184 => Some xb8 + | 185 => Some xb9 + | 186 => Some xba + | 187 => Some xbb + | 188 => Some xbc + | 189 => Some xbd + | 190 => Some xbe + | 191 => Some xbf + | 192 => Some xc0 + | 193 => Some xc1 + | 194 => Some xc2 + | 195 => Some xc3 + | 196 => Some xc4 + | 197 => Some xc5 + | 198 => Some xc6 + | 199 => Some xc7 + | 200 => Some xc8 + | 201 => Some xc9 + | 202 => Some xca + | 203 => Some xcb + | 204 => Some xcc + | 205 => Some xcd + | 206 => Some xce + | 207 => Some xcf + | 208 => Some xd0 + | 209 => Some xd1 + | 210 => Some xd2 + | 211 => Some xd3 + | 212 => Some xd4 + | 213 => Some xd5 + | 214 => Some xd6 + | 215 => Some xd7 + | 216 => Some xd8 + | 217 => Some xd9 + | 218 => Some xda + | 219 => Some xdb + | 220 => Some xdc + | 221 => Some xdd + | 222 => Some xde + | 223 => Some xdf + | 224 => Some xe0 + | 225 => Some xe1 + | 226 => Some xe2 + | 227 => Some xe3 + | 228 => Some xe4 + | 229 => Some xe5 + | 230 => Some xe6 + | 231 => Some xe7 + | 232 => Some xe8 + | 233 => Some xe9 + | 234 => Some xea + | 235 => Some xeb + | 236 => Some xec + | 237 => Some xed + | 238 => Some xee + | 239 => Some xef + | 240 => Some xf0 + | 241 => Some xf1 + | 242 => Some xf2 + | 243 => Some xf3 + | 244 => Some xf4 + | 245 => Some xf5 + | 246 => Some xf6 + | 247 => Some xf7 + | 248 => Some xf8 + | 249 => Some xf9 + | 250 => Some xfa + | 251 => Some xfb + | 252 => Some xfc + | 253 => Some xfd + | 254 => Some xfe + | 255 => Some xff + | _ => None + end. + + Lemma of_to_nat x : of_nat (to_nat x) = Some x. + Proof. destruct x; reflexivity. Qed. + + Lemma to_of_nat x y : of_nat x = Some y -> to_nat y = x. + Proof. + do 256 try destruct x as [|x]; cbv [of_nat]; intro. + all: repeat match goal with + | _ => reflexivity + | _ => progress subst + | [ H : Some ?a = Some ?b |- _ ] => assert (a = b) by refine match H with eq_refl => eq_refl end; clear H + | [ H : None = Some _ |- _ ] => solve [ inversion H ] + end. + Qed. + + Lemma to_of_nat_iff x y : of_nat x = Some y <-> to_nat y = x. + Proof. split; intro; subst; (apply of_to_nat || apply to_of_nat); assumption. Qed. + + Lemma to_of_nat_option_map x : option_map to_nat (of_nat x) = if Nat.leb x 255 then Some x else None. + Proof. do 256 try destruct x as [|x]; reflexivity. Qed. + + Lemma to_nat_bounded x : to_nat x <= 255. + Proof. + generalize (to_of_nat_option_map (to_nat x)). + rewrite of_to_nat; cbn [option_map]. + destruct (Nat.leb (to_nat x) 255) eqn:H; [ | congruence ]. + rewrite (PeanoNat.Nat.leb_le (to_nat x) 255) in H. + intro; assumption. + Qed. + + Lemma of_nat_None_iff x : of_nat x = None <-> 255 < x. + Proof. + generalize (to_of_nat_option_map x). + destruct (of_nat x), (Nat.leb x 255) eqn:H; cbn [option_map]; try congruence. + { rewrite PeanoNat.Nat.leb_le in H; split; [ congruence | ]. + rewrite PeanoNat.Nat.lt_nge; intro H'; exfalso; apply H'; assumption. } + { rewrite PeanoNat.Nat.leb_nle in H; split; [ | reflexivity ]. + rewrite PeanoNat.Nat.lt_nge; intro; assumption. } + Qed. +End nat. + +Section N. + Local Open Scope N_scope. + + Definition to_N (x : byte) : N + := match x with + | x00 => 0 + | x01 => 1 + | x02 => 2 + | x03 => 3 + | x04 => 4 + | x05 => 5 + | x06 => 6 + | x07 => 7 + | x08 => 8 + | x09 => 9 + | x0a => 10 + | x0b => 11 + | x0c => 12 + | x0d => 13 + | x0e => 14 + | x0f => 15 + | x10 => 16 + | x11 => 17 + | x12 => 18 + | x13 => 19 + | x14 => 20 + | x15 => 21 + | x16 => 22 + | x17 => 23 + | x18 => 24 + | x19 => 25 + | x1a => 26 + | x1b => 27 + | x1c => 28 + | x1d => 29 + | x1e => 30 + | x1f => 31 + | x20 => 32 + | x21 => 33 + | x22 => 34 + | x23 => 35 + | x24 => 36 + | x25 => 37 + | x26 => 38 + | x27 => 39 + | x28 => 40 + | x29 => 41 + | x2a => 42 + | x2b => 43 + | x2c => 44 + | x2d => 45 + | x2e => 46 + | x2f => 47 + | x30 => 48 + | x31 => 49 + | x32 => 50 + | x33 => 51 + | x34 => 52 + | x35 => 53 + | x36 => 54 + | x37 => 55 + | x38 => 56 + | x39 => 57 + | x3a => 58 + | x3b => 59 + | x3c => 60 + | x3d => 61 + | x3e => 62 + | x3f => 63 + | x40 => 64 + | x41 => 65 + | x42 => 66 + | x43 => 67 + | x44 => 68 + | x45 => 69 + | x46 => 70 + | x47 => 71 + | x48 => 72 + | x49 => 73 + | x4a => 74 + | x4b => 75 + | x4c => 76 + | x4d => 77 + | x4e => 78 + | x4f => 79 + | x50 => 80 + | x51 => 81 + | x52 => 82 + | x53 => 83 + | x54 => 84 + | x55 => 85 + | x56 => 86 + | x57 => 87 + | x58 => 88 + | x59 => 89 + | x5a => 90 + | x5b => 91 + | x5c => 92 + | x5d => 93 + | x5e => 94 + | x5f => 95 + | x60 => 96 + | x61 => 97 + | x62 => 98 + | x63 => 99 + | x64 => 100 + | x65 => 101 + | x66 => 102 + | x67 => 103 + | x68 => 104 + | x69 => 105 + | x6a => 106 + | x6b => 107 + | x6c => 108 + | x6d => 109 + | x6e => 110 + | x6f => 111 + | x70 => 112 + | x71 => 113 + | x72 => 114 + | x73 => 115 + | x74 => 116 + | x75 => 117 + | x76 => 118 + | x77 => 119 + | x78 => 120 + | x79 => 121 + | x7a => 122 + | x7b => 123 + | x7c => 124 + | x7d => 125 + | x7e => 126 + | x7f => 127 + | x80 => 128 + | x81 => 129 + | x82 => 130 + | x83 => 131 + | x84 => 132 + | x85 => 133 + | x86 => 134 + | x87 => 135 + | x88 => 136 + | x89 => 137 + | x8a => 138 + | x8b => 139 + | x8c => 140 + | x8d => 141 + | x8e => 142 + | x8f => 143 + | x90 => 144 + | x91 => 145 + | x92 => 146 + | x93 => 147 + | x94 => 148 + | x95 => 149 + | x96 => 150 + | x97 => 151 + | x98 => 152 + | x99 => 153 + | x9a => 154 + | x9b => 155 + | x9c => 156 + | x9d => 157 + | x9e => 158 + | x9f => 159 + | xa0 => 160 + | xa1 => 161 + | xa2 => 162 + | xa3 => 163 + | xa4 => 164 + | xa5 => 165 + | xa6 => 166 + | xa7 => 167 + | xa8 => 168 + | xa9 => 169 + | xaa => 170 + | xab => 171 + | xac => 172 + | xad => 173 + | xae => 174 + | xaf => 175 + | xb0 => 176 + | xb1 => 177 + | xb2 => 178 + | xb3 => 179 + | xb4 => 180 + | xb5 => 181 + | xb6 => 182 + | xb7 => 183 + | xb8 => 184 + | xb9 => 185 + | xba => 186 + | xbb => 187 + | xbc => 188 + | xbd => 189 + | xbe => 190 + | xbf => 191 + | xc0 => 192 + | xc1 => 193 + | xc2 => 194 + | xc3 => 195 + | xc4 => 196 + | xc5 => 197 + | xc6 => 198 + | xc7 => 199 + | xc8 => 200 + | xc9 => 201 + | xca => 202 + | xcb => 203 + | xcc => 204 + | xcd => 205 + | xce => 206 + | xcf => 207 + | xd0 => 208 + | xd1 => 209 + | xd2 => 210 + | xd3 => 211 + | xd4 => 212 + | xd5 => 213 + | xd6 => 214 + | xd7 => 215 + | xd8 => 216 + | xd9 => 217 + | xda => 218 + | xdb => 219 + | xdc => 220 + | xdd => 221 + | xde => 222 + | xdf => 223 + | xe0 => 224 + | xe1 => 225 + | xe2 => 226 + | xe3 => 227 + | xe4 => 228 + | xe5 => 229 + | xe6 => 230 + | xe7 => 231 + | xe8 => 232 + | xe9 => 233 + | xea => 234 + | xeb => 235 + | xec => 236 + | xed => 237 + | xee => 238 + | xef => 239 + | xf0 => 240 + | xf1 => 241 + | xf2 => 242 + | xf3 => 243 + | xf4 => 244 + | xf5 => 245 + | xf6 => 246 + | xf7 => 247 + | xf8 => 248 + | xf9 => 249 + | xfa => 250 + | xfb => 251 + | xfc => 252 + | xfd => 253 + | xfe => 254 + | xff => 255 + end. + + Definition of_N (x : N) : option byte + := match x with + | 0 => Some x00 + | 1 => Some x01 + | 2 => Some x02 + | 3 => Some x03 + | 4 => Some x04 + | 5 => Some x05 + | 6 => Some x06 + | 7 => Some x07 + | 8 => Some x08 + | 9 => Some x09 + | 10 => Some x0a + | 11 => Some x0b + | 12 => Some x0c + | 13 => Some x0d + | 14 => Some x0e + | 15 => Some x0f + | 16 => Some x10 + | 17 => Some x11 + | 18 => Some x12 + | 19 => Some x13 + | 20 => Some x14 + | 21 => Some x15 + | 22 => Some x16 + | 23 => Some x17 + | 24 => Some x18 + | 25 => Some x19 + | 26 => Some x1a + | 27 => Some x1b + | 28 => Some x1c + | 29 => Some x1d + | 30 => Some x1e + | 31 => Some x1f + | 32 => Some x20 + | 33 => Some x21 + | 34 => Some x22 + | 35 => Some x23 + | 36 => Some x24 + | 37 => Some x25 + | 38 => Some x26 + | 39 => Some x27 + | 40 => Some x28 + | 41 => Some x29 + | 42 => Some x2a + | 43 => Some x2b + | 44 => Some x2c + | 45 => Some x2d + | 46 => Some x2e + | 47 => Some x2f + | 48 => Some x30 + | 49 => Some x31 + | 50 => Some x32 + | 51 => Some x33 + | 52 => Some x34 + | 53 => Some x35 + | 54 => Some x36 + | 55 => Some x37 + | 56 => Some x38 + | 57 => Some x39 + | 58 => Some x3a + | 59 => Some x3b + | 60 => Some x3c + | 61 => Some x3d + | 62 => Some x3e + | 63 => Some x3f + | 64 => Some x40 + | 65 => Some x41 + | 66 => Some x42 + | 67 => Some x43 + | 68 => Some x44 + | 69 => Some x45 + | 70 => Some x46 + | 71 => Some x47 + | 72 => Some x48 + | 73 => Some x49 + | 74 => Some x4a + | 75 => Some x4b + | 76 => Some x4c + | 77 => Some x4d + | 78 => Some x4e + | 79 => Some x4f + | 80 => Some x50 + | 81 => Some x51 + | 82 => Some x52 + | 83 => Some x53 + | 84 => Some x54 + | 85 => Some x55 + | 86 => Some x56 + | 87 => Some x57 + | 88 => Some x58 + | 89 => Some x59 + | 90 => Some x5a + | 91 => Some x5b + | 92 => Some x5c + | 93 => Some x5d + | 94 => Some x5e + | 95 => Some x5f + | 96 => Some x60 + | 97 => Some x61 + | 98 => Some x62 + | 99 => Some x63 + | 100 => Some x64 + | 101 => Some x65 + | 102 => Some x66 + | 103 => Some x67 + | 104 => Some x68 + | 105 => Some x69 + | 106 => Some x6a + | 107 => Some x6b + | 108 => Some x6c + | 109 => Some x6d + | 110 => Some x6e + | 111 => Some x6f + | 112 => Some x70 + | 113 => Some x71 + | 114 => Some x72 + | 115 => Some x73 + | 116 => Some x74 + | 117 => Some x75 + | 118 => Some x76 + | 119 => Some x77 + | 120 => Some x78 + | 121 => Some x79 + | 122 => Some x7a + | 123 => Some x7b + | 124 => Some x7c + | 125 => Some x7d + | 126 => Some x7e + | 127 => Some x7f + | 128 => Some x80 + | 129 => Some x81 + | 130 => Some x82 + | 131 => Some x83 + | 132 => Some x84 + | 133 => Some x85 + | 134 => Some x86 + | 135 => Some x87 + | 136 => Some x88 + | 137 => Some x89 + | 138 => Some x8a + | 139 => Some x8b + | 140 => Some x8c + | 141 => Some x8d + | 142 => Some x8e + | 143 => Some x8f + | 144 => Some x90 + | 145 => Some x91 + | 146 => Some x92 + | 147 => Some x93 + | 148 => Some x94 + | 149 => Some x95 + | 150 => Some x96 + | 151 => Some x97 + | 152 => Some x98 + | 153 => Some x99 + | 154 => Some x9a + | 155 => Some x9b + | 156 => Some x9c + | 157 => Some x9d + | 158 => Some x9e + | 159 => Some x9f + | 160 => Some xa0 + | 161 => Some xa1 + | 162 => Some xa2 + | 163 => Some xa3 + | 164 => Some xa4 + | 165 => Some xa5 + | 166 => Some xa6 + | 167 => Some xa7 + | 168 => Some xa8 + | 169 => Some xa9 + | 170 => Some xaa + | 171 => Some xab + | 172 => Some xac + | 173 => Some xad + | 174 => Some xae + | 175 => Some xaf + | 176 => Some xb0 + | 177 => Some xb1 + | 178 => Some xb2 + | 179 => Some xb3 + | 180 => Some xb4 + | 181 => Some xb5 + | 182 => Some xb6 + | 183 => Some xb7 + | 184 => Some xb8 + | 185 => Some xb9 + | 186 => Some xba + | 187 => Some xbb + | 188 => Some xbc + | 189 => Some xbd + | 190 => Some xbe + | 191 => Some xbf + | 192 => Some xc0 + | 193 => Some xc1 + | 194 => Some xc2 + | 195 => Some xc3 + | 196 => Some xc4 + | 197 => Some xc5 + | 198 => Some xc6 + | 199 => Some xc7 + | 200 => Some xc8 + | 201 => Some xc9 + | 202 => Some xca + | 203 => Some xcb + | 204 => Some xcc + | 205 => Some xcd + | 206 => Some xce + | 207 => Some xcf + | 208 => Some xd0 + | 209 => Some xd1 + | 210 => Some xd2 + | 211 => Some xd3 + | 212 => Some xd4 + | 213 => Some xd5 + | 214 => Some xd6 + | 215 => Some xd7 + | 216 => Some xd8 + | 217 => Some xd9 + | 218 => Some xda + | 219 => Some xdb + | 220 => Some xdc + | 221 => Some xdd + | 222 => Some xde + | 223 => Some xdf + | 224 => Some xe0 + | 225 => Some xe1 + | 226 => Some xe2 + | 227 => Some xe3 + | 228 => Some xe4 + | 229 => Some xe5 + | 230 => Some xe6 + | 231 => Some xe7 + | 232 => Some xe8 + | 233 => Some xe9 + | 234 => Some xea + | 235 => Some xeb + | 236 => Some xec + | 237 => Some xed + | 238 => Some xee + | 239 => Some xef + | 240 => Some xf0 + | 241 => Some xf1 + | 242 => Some xf2 + | 243 => Some xf3 + | 244 => Some xf4 + | 245 => Some xf5 + | 246 => Some xf6 + | 247 => Some xf7 + | 248 => Some xf8 + | 249 => Some xf9 + | 250 => Some xfa + | 251 => Some xfb + | 252 => Some xfc + | 253 => Some xfd + | 254 => Some xfe + | 255 => Some xff + | _ => None + end. + + Lemma of_to_N x : of_N (to_N x) = Some x. + Proof. destruct x; reflexivity. Qed. + + Lemma to_of_N x y : of_N x = Some y -> to_N y = x. + Proof. + cbv [of_N]; + repeat match goal with + | [ |- context[match ?x with _ => _ end] ] => is_var x; destruct x + | _ => intro + | _ => reflexivity + | _ => progress subst + | [ H : Some ?a = Some ?b |- _ ] => assert (a = b) by refine match H with eq_refl => eq_refl end; clear H + | [ H : None = Some _ |- _ ] => solve [ inversion H ] + end. + Qed. + + Lemma to_of_N_iff x y : of_N x = Some y <-> to_N y = x. + Proof. split; intro; subst; (apply of_to_N || apply to_of_N); assumption. Qed. + + Lemma to_of_N_option_map x : option_map to_N (of_N x) = if N.leb x 255 then Some x else None. + Proof. + cbv [of_N]; + repeat match goal with + | [ |- context[match ?x with _ => _ end] ] => is_var x; destruct x + end; + reflexivity. + Qed. + + Lemma to_N_bounded x : to_N x <= 255. + Proof. + generalize (to_of_N_option_map (to_N x)). + rewrite of_to_N; cbn [option_map]. + destruct (N.leb (to_N x) 255) eqn:H; [ | congruence ]. + rewrite (N.leb_le (to_N x) 255) in H. + intro; assumption. + Qed. + + Lemma of_N_None_iff x : of_N x = None <-> 255 < x. + Proof. + generalize (to_of_N_option_map x). + destruct (of_N x), (N.leb x 255) eqn:H; cbn [option_map]; try congruence. + { rewrite N.leb_le in H; split; [ congruence | ]. + rewrite N.lt_nge; intro H'; exfalso; apply H'; assumption. } + { rewrite N.leb_nle in H; split; [ | reflexivity ]. + rewrite N.lt_nge; intro; assumption. } + Qed. + + Lemma to_N_via_nat x : to_N x = N.of_nat (to_nat x). + Proof. destruct x; reflexivity. Qed. + + Lemma to_nat_via_N x : to_nat x = N.to_nat (to_N x). + Proof. destruct x; reflexivity. Qed. + + Lemma of_N_via_nat x : of_N x = of_nat (N.to_nat x). + Proof. + destruct (of_N x) as [b|] eqn:H1. + { rewrite to_of_N_iff in H1; subst. + destruct b; reflexivity. } + { rewrite of_N_None_iff, <- N.compare_lt_iff in H1. + symmetry; rewrite of_nat_None_iff, <- PeanoNat.Nat.compare_lt_iff. + rewrite Nat2N.inj_compare, N2Nat.id; assumption. } + Qed. + + Lemma of_nat_via_N x : of_nat x = of_N (N.of_nat x). + Proof. + destruct (of_nat x) as [b|] eqn:H1. + { rewrite to_of_nat_iff in H1; subst. + destruct b; reflexivity. } + { rewrite of_nat_None_iff, <- PeanoNat.Nat.compare_lt_iff in H1. + symmetry; rewrite of_N_None_iff, <- N.compare_lt_iff. + rewrite N2Nat.inj_compare, Nat2N.id; assumption. } + Qed. +End N. diff --git a/theories/Strings/HexString.v b/theories/Strings/HexString.v index 9ea93c909e..9fa8e0ccf2 100644 --- a/theories/Strings/HexString.v +++ b/theories/Strings/HexString.v @@ -120,7 +120,7 @@ Module Raw. end end. - Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) {struct p} : to_N (of_pos p rest) base = to_N rest match base with | N0 => N.pos p diff --git a/theories/Strings/OctalString.v b/theories/Strings/OctalString.v index fe8cc9aae9..78e98e451b 100644 --- a/theories/Strings/OctalString.v +++ b/theories/Strings/OctalString.v @@ -78,7 +78,7 @@ Module Raw. end end. - Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) {struct p} : to_N (of_pos p rest) base = to_N rest match base with | N0 => N.pos p diff --git a/theories/Strings/String.v b/theories/Strings/String.v index a09d518892..08ccfac877 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -15,6 +15,7 @@ Require Import Arith. Require Import Ascii. Require Import Bool. +Require Import Coq.Strings.Byte. (** *** Definition of strings *) @@ -25,7 +26,6 @@ Inductive string : Set := | String : ascii -> string -> string. Declare Scope string_scope. -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. @@ -114,12 +114,12 @@ Theorem get_correct : Proof. intros s1; elim s1; simpl. intros s2; case s2; simpl; split; auto. -intros H; generalize (H 0); intros H1; inversion H1. +intros H; generalize (H O); intros H1; inversion H1. intros; discriminate. intros a s1' Rec s2; case s2; simpl; split; auto. -intros H; generalize (H 0); intros H1; inversion H1. +intros H; generalize (H O); intros H1; inversion H1. intros; discriminate. -intros H; generalize (H 0); simpl; intros H1; inversion H1. +intros H; generalize (H O); simpl; intros H1; inversion H1. case (Rec s). intros H0; rewrite H0; auto. intros n; exact (H (S n)). @@ -150,7 +150,7 @@ Proof. intros s1; elim s1; simpl; auto. intros s2 n; rewrite plus_comm; simpl; auto. intros a s1' Rec s2 n; case n; simpl; auto. -generalize (Rec s2 0); simpl; auto. intros. +generalize (Rec s2 O); simpl; auto. intros. rewrite <- Plus.plus_Snm_nSm; auto. Qed. @@ -162,9 +162,9 @@ Qed. Fixpoint substring (n m : nat) (s : string) : string := match n, m, s with - | 0, 0, _ => EmptyString - | 0, S m', EmptyString => s - | 0, S m', String c s' => String c (substring 0 m' s') + | O, O, _ => EmptyString + | O, S m', EmptyString => s + | O, S m', String c s' => String c (substring 0 m' s') | S n', _, EmptyString => s | S n', _, String c s' => substring n' m s' end. @@ -257,16 +257,16 @@ Qed. Fixpoint index (n : nat) (s1 s2 : string) : option nat := match s2, n with - | EmptyString, 0 => + | EmptyString, O => match s1 with - | EmptyString => Some 0 + | EmptyString => Some O | String a s1' => None end | EmptyString, S n' => None - | String b s2', 0 => - if prefix s1 s2 then Some 0 + | String b s2', O => + if prefix s1 s2 then Some O else - match index 0 s1 s2' with + match index O s1 s2' with | Some n => Some (S n) | None => None end @@ -300,8 +300,8 @@ generalize (prefix_correct s1 (String b s2')); intros H0 H; injection H as <-; auto. case H0; simpl; auto. case m; simpl; auto. -case (index 0 s1 s2'); intros; discriminate. -intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto. +case (index O s1 s2'); intros; discriminate. +intros m'; generalize (Rec O m' s1); case (index O s1 s2'); auto. intros x H H0 H1; apply H; injection H1; auto. intros; discriminate. intros n'; case m; simpl; auto. @@ -335,7 +335,7 @@ intros H0 H; injection H as <-; auto. intros p H2 H3; inversion H3. case m; simpl; auto. case (index 0 s1 s2'); intros; discriminate. -intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto. +intros m'; generalize (Rec O m' s1); case (index 0 s1 s2'); auto. intros x H H0 H1 p; try case p; simpl; auto. intros H2 H3; red; intros H4; case H0. intros H5 H6; absurd (false = true); auto with bool. @@ -383,7 +383,7 @@ intros H4 H5; absurd (false = true); auto with bool. case s1; simpl; auto. intros a s n0 H H0 H1 H2; change (substring n0 (length (String a s)) s2' <> String a s); - apply (Rec 0); auto. + apply (Rec O); auto. generalize H0; case (index 0 (String a s) s2'); simpl; auto; intros; discriminate. apply Le.le_O_n. @@ -423,9 +423,53 @@ Qed. Definition findex n s1 s2 := match index n s1 s2 with | Some n => n - | None => 0 + | None => O end. +(** *** Conversion to/from [list ascii] and [list byte] *) + +Fixpoint string_of_list_ascii (s : list ascii) : string + := match s with + | nil => EmptyString + | cons ch s => String ch (string_of_list_ascii s) + end. + +Fixpoint list_ascii_of_string (s : string) : list ascii + := match s with + | EmptyString => nil + | String ch s => cons ch (list_ascii_of_string s) + end. + +Lemma string_of_list_ascii_of_string s : string_of_list_ascii (list_ascii_of_string s) = s. +Proof. + induction s as [|? ? IHs]; [ reflexivity | cbn; apply f_equal, IHs ]. +Defined. + +Lemma list_ascii_of_string_of_list_ascii s : list_ascii_of_string (string_of_list_ascii s) = s. +Proof. + induction s as [|? ? IHs]; [ reflexivity | cbn; apply f_equal, IHs ]. +Defined. + +Definition string_of_list_byte (s : list byte) : string + := string_of_list_ascii (List.map ascii_of_byte s). + +Definition list_byte_of_string (s : string) : list byte + := List.map byte_of_ascii (list_ascii_of_string s). + +Lemma string_of_list_byte_of_string s : string_of_list_byte (list_byte_of_string s) = s. +Proof. + cbv [string_of_list_byte list_byte_of_string]. + erewrite List.map_map, List.map_ext, List.map_id, string_of_list_ascii_of_string; [ reflexivity | intro ]. + apply ascii_of_byte_of_ascii. +Qed. + +Lemma list_byte_of_string_of_list_byte s : list_byte_of_string (string_of_list_byte s) = s. +Proof. + cbv [string_of_list_byte list_byte_of_string]. + erewrite list_ascii_of_string_of_list_ascii, List.map_map, List.map_ext, List.map_id; [ reflexivity | intro ]. + apply byte_of_ascii_of_byte. +Qed. + (** *** Concrete syntax *) (** @@ -438,7 +482,11 @@ Definition findex n s1 s2 := part of a valid utf8 sequence of characters are not representable using the Coq string notation (use explicitly the String constructor with the ascii codes of the characters). -*) + *) + +Module Export StringSyntax. + String Notation string string_of_list_byte list_byte_of_string : string_scope. +End StringSyntax. Example HelloWorld := " ""Hello world!"" ". diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 7f96aa6b87..906cf79ca9 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -28,6 +28,7 @@ Local Open Scope nat_scope. (** A vector is a list of size n whose elements belong to a set A. *) +#[universes(template)] Inductive t A : nat -> Type := |nil : t A 0 |cons : forall (h:A) (n:nat), t A n -> t A (S n). diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index fd363d02ca..cf46657d36 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -18,6 +18,7 @@ Section WellOrdering. Variable A : Type. Variable B : A -> Type. + #[universes(template)] Inductive WO : Type := sup : forall (a:A) (f:B a -> WO), WO. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 1e35370d29..0b0ed48d51 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -212,6 +212,7 @@ Module MoreInt (Import I:Int). | EZofI : ExprI -> ExprZ | EZraw : Z -> ExprZ. + #[universes(template)] Inductive ExprP : Type := | EPeq : ExprZ -> ExprZ -> ExprP | EPlt : ExprZ -> ExprZ -> ExprP diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 4372ac72ae..f8f10b34ae 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -126,6 +126,8 @@ TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line +TGTS ?= + ########## End of parameters ################################################## # What follows may be relevant to you only if you need to # extend this Makefile. If so, look for 'Extension point' here and @@ -237,6 +239,11 @@ vo_to_obj = $(addsuffix .o,\ $(filter-out Warning: Error:,\ $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) strip_dotslash = $(patsubst ./%,%,$(1)) + +# without this we get undefined variables in the expansion for the +# targets of the [deprecated,use-mllib-or-mlpack] rule +with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) + VO = vo VOFILES = $(VFILES:.v=.$(VO)) @@ -269,14 +276,14 @@ CMXSFILES = \ PACKEDFILES = \ $(call strip_dotslash, \ $(foreach lib, \ - $(call strip_dotslash, \ - $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$($(lib)))) + $(call strip_dotslash, \ + $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$(call with_undef,$(lib)))) # files that are archived into a .cma (mllib) LIBEDFILES = \ $(call strip_dotslash, \ $(foreach lib, \ - $(call strip_dotslash, \ - $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$($(lib)))) + $(call strip_dotslash, \ + $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$(call with_undef,$(lib)))) CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) OBJFILES = $(call vo_to_obj,$(VOFILES)) @@ -681,11 +688,11 @@ $(GHTMLFILES): %.g.html: %.v %.glob # Dependency files ############################################################ -ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) - -include $(ALLDFILES) -else - ifeq ($(MAKECMDGOALS),) +ifndef MAKECMDGOALS -include $(ALLDFILES) +else + ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) + -include $(ALLDFILES) endif endif @@ -784,3 +791,7 @@ debug: .PHONY: debug .DEFAULT_GOAL := all + +# Local Variables: +# mode: makefile-gmake +# End: diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 226a19678f..4e80caa4cc 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -233,7 +233,7 @@ struct let rem = NSet.fold push next rem in aux rem seen | Some false -> - (** The path we took encountered x -> y but not the one in seen *) + (* The path we took encountered x -> y but not the one in seen *) if through then aux (NMap.add n true rem) (NMap.add n true seen) else aux rem seen | Some true -> aux rem seen @@ -357,7 +357,7 @@ let treat_coq_file chan = | None -> acc | Some file_str -> (canonize file_str, ".v") :: acc else acc - | AddLoadPath _ | AddRecLoadPath _ -> acc (** TODO *) + | AddLoadPath _ | AddRecLoadPath _ -> acc (* TODO *) in loop acc in diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index db2031c64b..e3dd32fb63 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -132,7 +132,7 @@ let add_mllib_known, _, search_mllib_known = mkknown () let add_mlpack_known, _, search_mlpack_known = mkknown () let vKnown = (Hashtbl.create 19 : (string list, string * bool) Hashtbl.t) -(** The associated boolean is true if this is a root path. *) +(* The associated boolean is true if this is a root path. *) let coqlibKnown = (Hashtbl.create 19 : (string list, unit) Hashtbl.t) let get_prefix p l = diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 6c4ea9afa1..0a32879764 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -176,7 +176,7 @@ let set_batch_mode opts = let add_compile opts verbose s = let opts = set_batch_mode opts in if not opts.glob_opt then Dumpglob.dump_to_dotglob (); - (** make the file name explicit; needed not to break up Coq loadpath stuff. *) + (* make the file name explicit; needed not to break up Coq loadpath stuff. *) let s = let open Filename in if is_implicit s diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 5cf2157044..e58b9ccac7 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -323,7 +323,8 @@ let loop_flush_all () = let pequal cmp1 cmp2 (a1,a2) (b1,b2) = cmp1 a1 b1 && cmp2 a2 b2 let evleq e1 e2 = CList.equal Evar.equal e1 e2 let cproof p1 p2 = - let (a1,a2,a3,a4,_),(b1,b2,b3,b4,_) = Proof.proof p1, Proof.proof p2 in + let Proof.{goals=a1;stack=a2;shelf=a3;given_up=a4} = Proof.data p1 in + let Proof.{goals=b1;stack=b2;shelf=b3;given_up=b4} = Proof.data p2 in evleq a1 b1 && CList.equal (pequal evleq evleq) a2 b2 && CList.equal Evar.equal a3 b3 && diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index edef741ca6..56622abc92 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -95,9 +95,9 @@ let init_color opts = if has_color then begin let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in match colors with - | None -> Topfmt.default_styles (); true (** Default colors *) - | Some "" -> false (** No color output *) - | Some s -> Topfmt.parse_color_config s; true (** Overwrite all colors *) + | None -> Topfmt.default_styles (); true (* Default colors *) + | Some "" -> false (* No color output *) + | Some s -> Topfmt.parse_color_config s; true (* Overwrite all colors *) end else false @@ -144,7 +144,7 @@ let init_gc () = * In this case, we put in place our preferred configuration. *) Gc.set { (Gc.get ()) with - Gc.minor_heap_size = 33554432; (** 4M *) + Gc.minor_heap_size = 33554432; (* 4M *) Gc.space_overhead = 120} (** Main init routine *) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index c914bbecff..d8465aac27 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -37,34 +37,6 @@ let vernac_echo ?loc in_chan = let open Loc in Feedback.msg_notice @@ str @@ really_input_string in_chan len ) loc -(* For coqtop -time, we display the position in the file, - and a glimpse of the executed command *) - -let pp_cmd_header {CAst.loc;v=com} = - let shorten s = - if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s - in - let noblank s = String.map (fun c -> - match c with - | ' ' | '\n' | '\t' | '\r' -> '~' - | x -> x - ) s - in - let (start,stop) = Option.cata Loc.unloc (0,0) loc in - let safe_pr_vernac x = - try Ppvernac.pr_vernac x - with e -> str (Printexc.to_string e) in - let cmd = noblank (shorten (string_of_ppcmds (safe_pr_vernac com))) - in str "Chars " ++ int start ++ str " - " ++ int stop ++ - str " [" ++ str cmd ++ str "] " - -(* This is a special case where we assume we are in console batch mode - and take control of the console. - *) -let print_cmd_header com = - Pp.pp_with !Topfmt.std_ft (pp_cmd_header com); - Format.pp_print_flush !Topfmt.std_ft () - (* Reenable when we get back to feedback printing *) (* let is_end_of_input any = match any with *) (* Stm.End_of_input -> true *) @@ -88,7 +60,6 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = due to the way it prints. *) let com = if state.time then begin - print_cmd_header com; CAst.make ?loc @@ VernacTime(state.time,com) end else com in let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) com in diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 3ca2a4ad6b..b5cc74b594 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -294,7 +294,7 @@ let traverse current t = let type_of_constant cb = cb.Declarations.const_type let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = - (** Only keep the transitive dependencies *) + (* Only keep the transitive dependencies *) let (_, graph, ax2ty) = traverse (label_of gr) t in let fold obj _ accu = match obj with | VarRef id -> diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 6a32960a9d..66e10f94cd 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -119,6 +119,7 @@ val vernac_monomorphic_flag : vernac_flag (** For the stm, do not use! *) val polymorphic_nowarn : bool attribute + (** For internal use, avoid warning if not qualified as eg [universes(polymorphic)]. *) val universe_polymorphism_option_name : string list val is_universe_polymorphism : unit -> bool diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index fa1b8eeb3e..d9787bc73c 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -335,8 +335,8 @@ let build_beq_scheme mode kn = | Finite -> mkFix (((Array.make nb_ind 0),i),(names,types,cores)) | BiFinite -> - (** If the inductive type is not recursive, the fixpoint is not - used, so let's replace it with garbage *) + (* If the inductive type is not recursive, the fixpoint is + not used, so let's replace it with garbage *) let subst = List.init nb_ind (fun _ -> mkProp) in Vars.substl subst cores.(i) in diff --git a/vernac/class.ml b/vernac/class.ml index ab43d5c8ff..8374a5c84f 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -66,7 +66,7 @@ let explain_coercion_error g = function let check_reference_arity ref = let env = Global.env () in let c, _ = Typeops.type_of_global_in_context env ref in - if not (Reductionops.is_arity env (Evd.from_env env) (EConstr.of_constr c)) (** FIXME *) then + if not (Reductionops.is_arity env (Evd.from_env env) (EConstr.of_constr c)) (* FIXME *) then raise (CoercionError (NotAClass ref)) let check_arity = function @@ -260,7 +260,7 @@ let add_new_coercion_core coef stre poly source target isid = raise (CoercionError (NoSource source)) in check_source (Some cls); - if not (uniform_cond Evd.empty (** FIXME - for when possibly called with unresolved evars in the future *) + if not (uniform_cond Evd.empty (* FIXME - for when possibly called with unresolved evars in the future *) ctx lvs) then warn_uniform_inheritance coef; let clt = diff --git a/vernac/classes.ml b/vernac/classes.ml index d0cf1c6bee..a342f5bf98 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -301,10 +301,10 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) ~ if generalize then CAst.make @@ CGeneralization (Implicit, Some AbsPi, tclass) else tclass in - let sigma, k, u, cty, ctx', ctx, len, imps, subst = + let sigma, k, u, cty, ctx', ctx, imps, subst = let sigma, (impls, ((env', ctx), imps)) = interp_context_evars env sigma ctx in let sigma, (c', imps') = interp_type_evars_impls ~impls env' sigma tclass in - let len = List.length ctx in + let len = Context.Rel.nhyps ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum sigma c' in let ctx'' = ctx' @ ctx in @@ -320,7 +320,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) ~ | LocalDef (_,b,_) -> (args, Vars.substl args' b :: args')) cl_context (args, []) in - sigma, cl, u, c', ctx', ctx, len, imps, args + sigma, cl, u, c', ctx', ctx, imps, args in let id = match instid with @@ -373,7 +373,7 @@ let context poly l = | [] -> assert false | [_] -> Evd.const_univ_entry ~poly sigma | _::_::_ -> - (** TODO: explain this little belly dance *) + (* TODO: explain this little belly dance *) if Lib.sections_are_opened () then begin diff --git a/vernac/classes.mli b/vernac/classes.mli index bb70334342..eb6c0c92e1 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -27,22 +27,22 @@ val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit val declare_instance_constant : typeclass -> - Hints.hint_info_expr -> (** priority *) - bool -> (** globality *) - Impargs.manual_explicitation list -> (** implicits *) + Hints.hint_info_expr (** priority *) -> + bool (** globality *) -> + Impargs.manual_explicitation list (** implicits *) -> ?hook:(GlobRef.t -> unit) -> - Id.t -> (** name *) + Id.t (** name *) -> UState.universe_decl -> - bool -> (* polymorphic *) - Evd.evar_map -> (* Universes *) - Constr.t -> (** body *) - Constr.types -> (** type *) + bool (** polymorphic *) -> + Evd.evar_map (** Universes *) -> + Constr.t (** body *) -> + Constr.types (** type *) -> unit val new_instance : - ?abstract:bool -> (** Not abstract by default. *) - ?global:bool -> (** Not global by default. *) - ?refine:bool -> (** Allow refinement *) + ?abstract:bool (** Not abstract by default. *) -> + ?global:bool (** Not global by default. *) -> + ?refine:bool (** Allow refinement *) -> program_mode:bool -> Decl_kinds.polymorphic -> local_binder_expr list -> diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index f4569ed3e2..338dfa5ef5 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -78,6 +78,7 @@ val interp_fixpoint : (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) + (** [Not used so far] *) val declare_fixpoint : locality -> polymorphic -> diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 8b9cf7d269..348e76da62 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -34,6 +34,13 @@ module RelDecl = Context.Rel.Declaration (* 3b| Mutual inductive definitions *) +let warn_auto_template = + CWarnings.create ~name:"auto-template" ~category:"vernacular" + (fun id -> + Pp.(strbrk "Automatically declaring " ++ Id.print id ++ + strbrk " as template polymorphic. Use attributes or " ++ + strbrk "disable Auto Template Polymorphism to avoid this warning.")) + let should_auto_template = let open Goptions in let auto = ref true in @@ -44,7 +51,10 @@ let should_auto_template = optread = (fun () -> !auto); optwrite = (fun b -> auto := b); } in - fun () -> !auto + fun id would_auto -> + let b = !auto && would_auto in + if b then warn_auto_template id; + b let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) @@ -265,7 +275,7 @@ let inductive_levels env evd poly arities inds = else minlev in let minlev = - (** Indices contribute. *) + (* Indices contribute. *) if indices_matter env && List.length ctx > 0 then ( let ilev = sign_level env evd ctx in Univ.sup ilev minlev) @@ -282,15 +292,15 @@ let inductive_levels env evd poly arities inds = let evd, arities = CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> if is_impredicative env du then - (** Any product is allowed here. *) + (* Any product is allowed here. *) evd, arity :: arities - else (** If in a predicative sort, or asked to infer the type, - we take the max of: - - indices (if in indices-matter mode) - - constructors - - Type(1) if there is more than 1 constructor + else (* If in a predicative sort, or asked to infer the type, + we take the max of: + - indices (if in indices-matter mode) + - constructors + - Type(1) if there is more than 1 constructor *) - (** Constructors contribute. *) + (* Constructors contribute. *) let evd = if Sorts.is_set du then if not (Evd.check_leq evd cu Univ.type0_univ) then @@ -301,7 +311,7 @@ let inductive_levels env evd poly arities inds = in let evd = if len >= 2 && Univ.is_type0m_univ cu then - (** "Polymorphic" type constraint and more than one constructor, + (* "Polymorphic" type constraint and more than one constructor, should not land in Prop. Add constraint only if it would land in Prop directly (no informative arguments as well). *) Evd.set_leq_sort env evd Set du @@ -431,8 +441,8 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); template | None -> - should_auto_template () && not poly && - Option.cata (fun s -> not (Sorts.is_small s)) false concl + should_auto_template ind.ind_name (not poly && + Option.cata (fun s -> not (Sorts.is_small s)) false concl) in { mind_entry_typename = ind.ind_name; mind_entry_arity = arity; @@ -510,7 +520,7 @@ let is_recursive mie = let rec is_recursive_constructor lift typ = match Constr.kind typ with | Prod (_,arg,rest) -> - not (EConstr.Vars.noccurn Evd.empty (** FIXME *) lift (EConstr.of_constr arg)) || + not (EConstr.Vars.noccurn Evd.empty (* FIXME *) lift (EConstr.of_constr arg)) || is_recursive_constructor (lift+1) rest | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest | _ -> false diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index f23085a538..1d6f652385 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -39,14 +39,17 @@ val do_mutual_inductive : associated schemes *) type one_inductive_impls = - Impargs.manual_implicits (** for inds *)* - Impargs.manual_implicits list (** for constrs *) + Impargs.manual_implicits (* for inds *) * + Impargs.manual_implicits list (* for constrs *) val declare_mutual_inductive_with_eliminations : mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> MutInd.t -val should_auto_template : unit -> bool +val should_auto_template : Id.t -> bool -> bool +(** [should_auto_template x b] is [true] when [b] is [true] and we + automatically use template polymorphism. [x] is the name of the + inductive under consideration. *) (** Exported for Funind *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index e62ae99159..edce8e255c 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -211,7 +211,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let univs = Evd.check_univ_decl ~poly sigma decl in (*FIXME poly? *) let ce = definition_entry ~types:ty ~univs (EConstr.to_constr sigma body) in - (** FIXME: include locality *) + (* FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in if Impargs.is_implicit_args () || not (List.is_empty impls) then diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 898de7b166..41057f8ab2 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -27,7 +27,7 @@ let warn_local_declaration = let get_locality id ~kind = function | Discharge -> - (** If a Let is defined outside a section, then we consider it as a local definition *) + (* If a Let is defined outside a section, then we consider it as a local definition *) warn_local_declaration (id,kind); true | Local -> true diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index befb4d7ccf..e1496e58d7 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -64,8 +64,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) - | Notation.NumeralNotationError(ctx,sigma,te) -> - wrap_vernac_error exn (Himsg.explain_numeral_notation_error ctx sigma te) + | Notation.PrimTokenNotationError(kind,ctx,sigma,te) -> + wrap_vernac_error exn (Himsg.explain_prim_token_notation_error kind ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> wrap_vernac_error exn (Himsg.explain_typeclass_error env te) | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) -> diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 6c7117b513..f3e1e1fc49 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -125,12 +125,12 @@ let display_eq ~flags env sigma t1 t2 = printed alike. *) let rec pr_explicit_aux env sigma t1 t2 = function | [] -> - (** no specified flags: default. *) + (* no specified flags: default. *) (quote (Printer.pr_leconstr_env env sigma t1), quote (Printer.pr_leconstr_env env sigma t2)) | flags :: rem -> let equal = display_eq ~flags env sigma t1 t2 in if equal then - (** The two terms are the same from the user point of view *) + (* The two terms are the same from the user point of view *) pr_explicit_aux env sigma t1 t2 rem else let open Constrextern in @@ -142,12 +142,12 @@ let rec pr_explicit_aux env sigma t1 t2 = function let explicit_flags = let open Constrextern in - [ []; (** First, try with the current flags *) - [print_implicits]; (** Then with implicit *) - [print_universes]; (** Then with universes *) - [print_universes; print_implicits]; (** With universes AND implicits *) - [print_implicits; print_coercions; print_no_symbol]; (** Then more! *) - [print_universes; print_implicits; print_coercions; print_no_symbol] (** and more! *) ] + [ []; (* First, try with the current flags *) + [print_implicits]; (* Then with implicit *) + [print_universes]; (* Then with universes *) + [print_universes; print_implicits]; (* With universes AND implicits *) + [print_implicits; print_coercions; print_no_symbol]; (* Then more! *) + [print_universes; print_implicits; print_coercions; print_no_symbol] (* and more! *) ] let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags @@ -328,7 +328,7 @@ let explain_actual_type env sigma j t reason = let env = make_all_name_different env sigma in let j = j_nf_betaiotaevar env sigma j in let t = Reductionops.nf_betaiota env sigma t in - (** Actually print *) + (* Actually print *) let pe = pr_ne_context_of (str "In environment") env sigma in let pc = pr_leconstr_env env sigma (Environ.j_val j) in let (pt, pct) = pr_explicit env sigma t (Environ.j_type j) in @@ -511,7 +511,7 @@ let pr_trailing_ne_context_of env sigma = if List.is_empty (Environ.rel_context env) && List.is_empty (Environ.named_context env) then str "." - else (str " in environment:"++ pr_context_unlimited env sigma) + else (strbrk " in environment:" ++ pr_context_unlimited env sigma) let rec explain_evar_kind env sigma evk ty = let open Evar_kinds in @@ -551,21 +551,21 @@ let rec explain_evar_kind env sigma evk ty = strbrk "an instance of type " ++ ty ++ str " for the variable " ++ Id.print id | Evar_kinds.SubEvar (where,evk') -> - let evi = Evd.find sigma evk' in + let rec find_source evk = + let evi = Evd.find sigma evk in + match snd evi.evar_source with + | Evar_kinds.SubEvar (_,evk) -> find_source evk + | src -> evi,src in + let evi,src = find_source evk' in let pc = match evi.evar_body with | Evar_defined c -> pr_leconstr_env env sigma c | Evar_empty -> assert false in let ty' = evi.evar_concl in - (match where with - | Some Evar_kinds.Body -> str "the body of " - | Some Evar_kinds.Domain -> str "the domain of " - | Some Evar_kinds.Codomain -> str "the codomain of " - | None -> - pr_existential_key sigma evk ++ str " of type " ++ ty ++ - str " in the partial instance " ++ pc ++ - str " found for ") ++ - explain_evar_kind env sigma evk' - (pr_leconstr_env env sigma ty') (snd evi.evar_source) + pr_existential_key sigma evk ++ + strbrk " in the partial instance " ++ pc ++ + strbrk " found for " ++ + explain_evar_kind env sigma evk + (pr_leconstr_env env sigma ty') src let explain_typeclass_resolution env sigma evi k = match Typeclasses.class_of_constr sigma evi.evar_concl with @@ -774,7 +774,7 @@ let explain_unsatisfiable_constraints env sigma constr comp = let (_, constraints) = Evd.extract_all_conv_pbs sigma in let tcs = Evd.get_typeclass_evars sigma in let undef = Evd.undefined_map sigma in - (** Only keep evars that are subject to resolution and members of the given + (* Only keep evars that are subject to resolution and members of the given component. *) let is_kept evk _ = match comp with | None -> Evar.Set.mem evk tcs @@ -1112,7 +1112,7 @@ let error_ill_formed_inductive env c v = let error_ill_formed_constructor env id c v nparams nargs = let pv = pr_lconstr_env env (Evd.from_env env) v in - let atomic = Int.equal (nb_prod Evd.empty (EConstr.of_constr c)) (** FIXME *) 0 in + let atomic = Int.equal (nb_prod Evd.empty (EConstr.of_constr c)) (* FIXME *) 0 in str "The type of constructor" ++ brk(1,1) ++ Id.print id ++ brk(1,1) ++ str "is not valid;" ++ brk(1,1) ++ strbrk (if atomic then "it must be " else "its conclusion must be ") ++ @@ -1326,12 +1326,12 @@ let explain_reduction_tactic_error = function spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' (Evd.from_env env') e -let explain_numeral_notation_error env sigma = function +let explain_prim_token_notation_error kind env sigma = function | Notation.UnexpectedTerm c -> (strbrk "Unexpected term " ++ pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") + strbrk (" while parsing a "^kind^" notation.")) | Notation.UnexpectedNonOptionTerm c -> (strbrk "Unexpected non-option term " ++ pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") + strbrk (" while parsing a "^kind^" notation.")) diff --git a/vernac/himsg.mli b/vernac/himsg.mli index db05aaa125..bab66b2af4 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -47,4 +47,4 @@ val explain_module_internalization_error : val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error -val explain_numeral_notation_error : env -> Evd.evar_map -> Notation.numeral_notation_error -> Pp.t +val explain_prim_token_notation_error : string -> env -> Evd.evar_map -> Notation.prim_token_notation_error -> Pp.t diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 9bd095aa52..d29f66f81f 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -307,7 +307,7 @@ let warn_cannot_build_congruence = strbrk "Cannot build congruence scheme because eq is not found") let declare_congr_scheme ind = - if Hipattern.is_equality_type Evd.empty (EConstr.of_constr (mkInd ind)) (** FIXME *) then begin + if Hipattern.is_equality_type Evd.empty (EConstr.of_constr (mkInd ind)) (* FIXME *) then begin if try Coqlib.check_required_library Coqlib.logic_module_name; true with e when CErrors.noncritical e -> false diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 1a6eda446c..8f155adb8a 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -483,7 +483,7 @@ let save_proof ?proof = function let pftree = Proof_global.give_me_the_proof () in let id, k, typ = Pfedit.current_proof_statement () in let typ = EConstr.Unsafe.to_constr typ in - let universes = Proof.initial_euctx pftree in + let universes = Proof.((data pftree).initial_euctx) in (* This will warn if the proof is complete *) let pproofs, _univs = Proof_global.return_proof ~allow_partial:true () in diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 82434afbbd..3da12e7714 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -33,11 +33,9 @@ open Nameops let cache_token (_,s) = CLexer.add_keyword s let inToken : string -> obj = - declare_object {(default_object "TOKEN") with - open_function = (fun i o -> if Int.equal i 1 then cache_token o); - cache_function = cache_token; - subst_function = Libobject.ident_subst_function; - classify_function = (fun o -> Substitute o)} + declare_object @@ global_object_nodischarge "TOKEN" + ~cache:cache_token + ~subst:(Some Libobject.ident_subst_function) let add_token_obj s = Lib.add_anonymous_leaf (inToken s) @@ -1361,7 +1359,7 @@ let inNotation : notation_obj -> obj = (**********************************************************************) let with_lib_stk_protection f x = - let fs = Lib.freeze ~marshallable:`No in + let fs = Lib.freeze ~marshallable:false in try let a = f x in Lib.unfreeze fs; a with reraise -> let reraise = CErrors.push reraise in @@ -1467,7 +1465,7 @@ let add_notation_in_scope local df env c mods scope = notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); - (** Order is important here! *) + (* Order is important here! *) notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = sd.only_printing; @@ -1486,7 +1484,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ let level, i_typs, onlyprint = if not (is_numeral symbs) then begin let sy = recover_notation_syntax (make_notation_key InConstrEntrySomeLevel symbs) in let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy)) in - (** If the only printing flag has been explicitly requested, put it back *) + (* If the only printing flag has been explicitly requested, put it back *) let onlyprint = onlyprint || sy.synext_notgram.notgram_onlyprinting in let _,_,_,typs = sy.synext_level in Some sy.synext_level, typs, onlyprint @@ -1507,7 +1505,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); - (** Order is important here! *) + (* Order is important here! *) notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = onlyprint; @@ -1565,14 +1563,17 @@ let add_notation_extra_printing_rule df k v = (* Infix notations *) -let inject_var x = CAst.make @@ CRef (qualid_of_ident (Id.of_string x),None) +let inject_var x = CAst.make @@ CRef (qualid_of_ident x,None) let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = check_infix_modifiers modifiers; (* check the precedence *) - let metas = [inject_var "x"; inject_var "y"] in + let vars = names_of_constr_expr pr in + let x = Namegen.next_ident_away (Id.of_string "x") vars in + let y = Namegen.next_ident_away (Id.of_string "y") vars in + let metas = [inject_var x; inject_var y] in let c = mkAppC (pr,metas) in - let df = CAst.make ?loc @@ "x "^(quote_notation_token inf)^" y" in + let df = CAst.make ?loc @@ Id.to_string x ^" "^(quote_notation_token inf)^" "^Id.to_string y in add_notation local env c (df,modifiers) sc (**********************************************************************) diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 3620e177fe..8d6268753e 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -394,7 +394,7 @@ let unfreeze_ml_modules x = let _ = Summary.declare_ml_modules_summary - { Summary.freeze_function = (fun _ -> get_loaded_modules ()); + { Summary.freeze_function = (fun ~marshallable -> get_loaded_modules ()); Summary.unfreeze_function = unfreeze_ml_modules; Summary.init_function = reset_loaded_modules } diff --git a/vernac/obligations.ml b/vernac/obligations.ml index f18227039f..6642d04c98 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -381,7 +381,7 @@ let subst_deps expand obls deps t = (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) let rec prod_app t n = - match Constr.kind (EConstr.Unsafe.to_constr (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) (** FIXME *) with + match Constr.kind (EConstr.Unsafe.to_constr (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) (* FIXME *) with | Prod (_,_,b) -> subst1 n b | LetIn (_, b, t, b') -> prod_app (subst1 b b') n | _ -> @@ -503,7 +503,7 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype = but doing it properly involves delta-reduction, and it finally doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) - let m = Termops.nb_prod Evd.empty (EConstr.of_constr fixtype) (** FIXME *) in + let m = Termops.nb_prod Evd.empty (EConstr.of_constr fixtype) (* FIXME *) in let ctx = fst (decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx @@ -649,7 +649,7 @@ let declare_obligation prg obl body ty uctx = const_entry_inline_code = false; const_entry_feedback = None; } in - (** ppedrot: seems legit to have obligations as local *) + (* ppedrot: seems legit to have obligations as local *) let constant = Declare.declare_constant obl.obl_name ~local:true (DefinitionEntry ce,IsProof Property) in @@ -857,9 +857,9 @@ let obligation_terminator ?univ_hook name num guard auto pf = let sigma = Evd.from_ctx uctx in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); - (** Declare the obligation ourselves and drop the hook *) + (* Declare the obligation ourselves and drop the hook *) let prg = get_info (ProgMap.find name !from_prg) in - (** Ensure universes are substituted properly in body and type *) + (* Ensure universes are substituted properly in body and type *) let body = EConstr.to_constr sigma (EConstr.of_constr body) in let ty = Option.map (fun x -> EConstr.to_constr sigma (EConstr.of_constr x)) ty in let ctx = Evd.evar_universe_context sigma in @@ -885,14 +885,14 @@ let obligation_terminator ?univ_hook name num guard auto pf = let () = obls.(num) <- obl in let prg_ctx = if pi2 (prg.prg_kind) then (* Polymorphic *) - (** We merge the new universes and constraints of the - polymorphic obligation with the existing ones *) + (* We merge the new universes and constraints of the + polymorphic obligation with the existing ones *) UState.union prg.prg_ctx ctx else - (** The first obligation, if defined, - declares the univs of the constant, - each subsequent obligation declares its own additional - universes and constraints if any *) + (* The first obligation, if defined, + declares the univs of the constant, + each subsequent obligation declares its own additional + universes and constraints if any *) if defined then UState.make (Global.universes ()) else ctx in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index e7c1e29beb..e0dd3380f9 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -363,7 +363,7 @@ open Pputils match factorize l with | (xl,((c', t') as r))::l' when (c : bool) == c' && Pervasives.(=) t t' -> - (** FIXME: we need equality on constr_expr *) + (* FIXME: we need equality on constr_expr *) (idl@xl,r)::l' | l' -> (idl,(c,t))::l' @@ -700,7 +700,7 @@ open Pputils | None -> mt() | Some r -> keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ + Ppred.pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ keyword " in" ++ spc() in let pr_def_body = function @@ -1134,7 +1134,7 @@ open Pputils let pr_mayeval r c = match r with | Some r0 -> hov 2 (keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ + Ppred.pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ spc() ++ keyword "in" ++ spc () ++ pr_lconstr c) | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c) in @@ -1146,7 +1146,7 @@ open Pputils | VernacDeclareReduction (s,r) -> return ( keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r + Ppred.pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r ) | VernacPrint p -> return (pr_printable p) diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index f26e0d0885..a647b2ef73 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -52,4 +52,4 @@ let set_command_entry e = Vernac_.command_entry_ref := e let get_command_entry () = !Vernac_.command_entry_ref let () = - register_grammar Stdarg.wit_red_expr (Vernac_.red_expr); + register_grammar Genredexpr.wit_red_expr (Vernac_.red_expr); diff --git a/vernac/record.ml b/vernac/record.ml index f6dbcb5291..2867ad1437 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -321,7 +321,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f ~proj_arg:i (Label.of_id fid) in - (** Already defined by declare_mind silently *) + (* Already defined by declare_mind silently *) let kn = Projection.Repr.constant p in Declare.definition_message fid; kn, mkProj (Projection.make p false,mkRel 1) @@ -415,9 +415,9 @@ let declare_structure finite ubinders univs paramimpls params template ?(kind=St template | None, template -> (* auto detect template *) - ComInductive.should_auto_template () && template && not poly && + ComInductive.should_auto_template id (template && not poly && let _, s = Reduction.dest_arity (Global.env()) arity in - not (Sorts.is_small s) + not (Sorts.is_small s)) in { mind_entry_typename = id; mind_entry_arity = arity; diff --git a/vernac/search.ml b/vernac/search.ml index 1fac28358a..6610789626 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -172,8 +172,8 @@ let prioritize_search seq fn = (** Filters *) -(** This function tries to see whether the conclusion matches a pattern. *) -(** FIXME: this is quite dummy, we may find a more efficient algorithm. *) +(** This function tries to see whether the conclusion matches a pattern. + FIXME: this is quite dummy, we may find a more efficient algorithm. *) let rec pattern_filter pat ref env sigma typ = let typ = Termops.strip_outer_cast sigma typ in if Constr_matching.is_matching env sigma pat typ then true diff --git a/vernac/search.mli b/vernac/search.mli index 0dc82c1c3f..ecbb02bc68 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -49,16 +49,16 @@ val search_about : int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = - (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) | Name_Pattern of Str.regexp - (** Whether the object type satisfies a pattern *) + (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) | Type_Pattern of Pattern.constr_pattern - (** Whether some subtype of object type satisfies a pattern *) + (** Whether the object type satisfies a pattern *) | SubType_Pattern of Pattern.constr_pattern - (** Whether the object pertains to a module *) + (** Whether some subtype of object type satisfies a pattern *) | In_Module of Names.DirPath.t - (** Bypass the Search blacklist *) + (** Whether the object pertains to a module *) | Include_Blacklist + (** Bypass the Search blacklist *) type 'a coq_object = { coq_object_prefix : string list; diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 4bf76dae51..b4b893a3fd 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -222,20 +222,21 @@ let diff_tag_stack = ref [] (* global, just like std_ft *) (** Not thread-safe. We should put a lock somewhere if we print from different threads. Do we? *) let make_style_stack () = - (** Default tag is to reset everything *) + (* Default tag is to reset everything *) let style_stack = ref [] in let peek () = match !style_stack with - | [] -> default_style (** Anomalous case, but for robustness *) + | [] -> default_style (* Anomalous case, but for robustness *) | st :: _ -> st in let open_tag tag = let (tpfx, ttag) = split_tag tag in if tpfx = end_pfx then "" else let style = get_style ttag in - (** Merge the current settings and the style being pushed. This allows - restoring the previous settings correctly in a pop when both set the same - attribute. Example: current settings have red FG, the pushed style has - green FG. When popping the style, we should set red FG, not default FG. *) + (* Merge the current settings and the style being pushed. This + allows restoring the previous settings correctly in a pop + when both set the same attribute. Example: current settings + have red FG, the pushed style has green FG. When popping the + style, we should set red FG, not default FG. *) let style = Terminal.merge (peek ()) style in let diff = Terminal.diff (peek ()) style in style_stack := style :: !style_stack; @@ -247,7 +248,7 @@ let make_style_stack () = if tpfx = start_pfx then "" else begin if tpfx = end_pfx then diff_tag_stack := (try List.tl !diff_tag_stack with tl -> []); match !style_stack with - | [] -> (** Something went wrong, we fallback *) + | [] -> (* Something went wrong, we fallback *) Terminal.eval default_style | cur :: rem -> style_stack := rem; if cur = (peek ()) then "" else @@ -405,3 +406,24 @@ let with_output_to_file fname func input = deep_ft := Util.pi3 old_fmt; close_out channel; Exninfo.iraise reraise + +(* For coqtop -time, we display the position in the file, + and a glimpse of the executed command *) + +let pr_cmd_header {CAst.loc;v=com} = + let shorten s = + if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s + in + let noblank s = String.map (fun c -> + match c with + | ' ' | '\n' | '\t' | '\r' -> '~' + | x -> x + ) s + in + let (start,stop) = Option.cata Loc.unloc (0,0) loc in + let safe_pr_vernac x = + try Ppvernac.pr_vernac x + with e -> str (Printexc.to_string e) in + let cmd = noblank (shorten (string_of_ppcmds (safe_pr_vernac com))) + in str "Chars " ++ int start ++ str " - " ++ int stop ++ + str " [" ++ str cmd ++ str "] " diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 0ddf474970..5f84c5edee 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -71,3 +71,4 @@ val print_err_exn : exn -> unit redirected to a file [file] *) val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b +val pr_cmd_header : Vernacexpr.vernac_control CAst.t -> Pp.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index f5d68a2199..dbccea1117 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -82,12 +82,12 @@ let show_proof () = let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = Proof_global.give_me_the_proof () in - let gls,_,shelf,givenup,sigma = Proof.proof pfts in - pr_evars_int sigma ~shelf ~givenup 1 (Evd.undefined_map sigma) + let Proof.{goals;shelf;given_up;sigma} = Proof.data pfts in + pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) let show_universes () = let pfts = Proof_global.give_me_the_proof () in - let gls,_,_,_,sigma = Proof.proof pfts in + let Proof.{goals;sigma} = Proof.data pfts in let ctx = Evd.universe_context_set (Evd.minimize_universes sigma) in Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++ str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx @@ -96,9 +96,9 @@ let show_universes () = let show_intro all = let open EConstr in let pf = Proof_global.give_me_the_proof() in - let gls,_,_,_,sigma = Proof.proof pf in - if not (List.is_empty gls) then begin - let gl = {Evd.it=List.hd gls ; sigma = sigma; } in + let Proof.{goals;sigma} = Proof.data pf in + if not (List.is_empty goals) then begin + let gl = {Evd.it=List.hd goals ; sigma = sigma; } in let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (pf_concl gl)) in if all then let lid = Tactics.find_intro_names l gl in @@ -681,14 +681,14 @@ let vernac_inductive ~atts cum lo finite indl = | _ -> None in if Option.has_some is_defclass then - (** Definitional class case *) + (* Definitional class case *) let (id, bl, c, l) = Option.get is_defclass in let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in let f = (((coe', AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce)), None), []) in vernac_record ~template udecl cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] else if List.for_all is_record indl then - (** Mutual record case *) + (* Mutual record case *) let check_kind ((_, _, _, kind, _), _) = match kind with | Variant -> user_err (str "The Variant keyword does not support syntax { ... }.") @@ -704,14 +704,14 @@ let vernac_inductive ~atts cum lo finite indl = let unpack ((id, bl, c, _, decl), _) = match decl with | RecordDecl (oc, fs) -> (id, bl, c, oc, fs) - | Constructors _ -> assert false (** ruled out above *) + | Constructors _ -> assert false (* ruled out above *) in let ((_, _, _, kind, _), _) = List.hd indl in let kind = match kind with Class _ -> Class false | _ -> kind in let recordl = List.map unpack indl in vernac_record ~template udecl cum kind atts.polymorphic finite recordl else if List.for_all is_constructor indl then - (** Mutual inductive case *) + (* Mutual inductive case *) let check_kind ((_, _, _, kind, _), _) = match kind with | (Record | Structure) -> user_err (str "The Record keyword is for types defined using the syntax { ... }.") @@ -1047,8 +1047,9 @@ let vernac_set_end_tac tac = let vernac_set_used_variables e = let env = Global.env () in + let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in let tys = - List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in + List.map snd (initial_goals (Proof_global.give_me_the_proof ())) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in @@ -1221,11 +1222,9 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red let rec check_extra_args extra_args = match extra_args with | [] -> () - | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args) - | { name = Anonymous; notation_scope = Some _ } :: args -> - check_extra_args args - | _ -> - user_err Pp.(str "Extra notation scopes can be set on anonymous and explicit arguments only.") + | { notation_scope = None } :: _ -> + user_err Pp.(str"Extra arguments should specify a scope.") + | { notation_scope = Some _ } :: args -> check_extra_args args in let args, scopes = @@ -1817,8 +1816,8 @@ let vernac_global_check c = let get_nth_goal n = let pf = Proof_global.give_me_the_proof() in - let gls,_,_,_,sigma = Proof.proof pf in - let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in + let Proof.{goals;sigma} = Proof.data pf in + let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl exception NoHyp @@ -1992,7 +1991,7 @@ let vernac_search ~atts s gopt r = let vernac_locate = function | LocateAny {v=AN qid} -> print_located_qualid qid | LocateTerm {v=AN qid} -> print_located_term qid - | LocateAny {v=ByNotation (ntn, sc)} (** TODO : handle Ltac notations *) + | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> let _, env = Pfedit.get_current_context () in Notation.locate_notation @@ -2389,8 +2388,9 @@ let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = control v | VernacRedirect (s, {v}) -> Topfmt.with_output_to_file s control v - | VernacTime (batch, {v}) -> - System.with_time ~batch control v; + | VernacTime (batch, com) -> + let header = if batch then Topfmt.pr_cmd_header com else Pp.mt () in + System.with_time ~batch ~header control com.CAst.v; and aux ~atts : _ -> unit = function @@ -2437,7 +2437,7 @@ let interp ?verbosely ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; try interp ?verbosely ?proof ~st cmd; - Vernacstate.freeze_interp_state `No + Vernacstate.freeze_interp_state ~marshallable:false with exn -> let exn = CErrors.push exn in Vernacstate.invalidate_cache (); diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 1e6c40c829..417c9ebfbd 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -247,11 +247,11 @@ type vernac_argument_status = { } type extend_name = - (** Name of the vernac entry where the tactic is defined, typically found - after the VERNAC EXTEND statement in the source. *) + (* 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. *) + (* Index of the extension in the VERNAC EXTEND statement. Each parsing branch + is given an offset, starting from zero. *) int type nonrec vernac_expr = diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 2541f73582..05687afd8b 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -42,8 +42,11 @@ 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 = diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 8b07be8b16..0d43eb1ee8 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -58,8 +58,11 @@ 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 = @@ -86,7 +89,7 @@ type (_, _) ty_sig = ('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 +type ty_ml = TyML : bool (* deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml (** Wrapper to dynamically extend vernacular commands. *) val vernac_extend : diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index aa8bcdc328..61540024ef 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -33,11 +33,19 @@ let do_if_not_cached rf f v = | Some _ -> () -let freeze_interp_state marshallable = +let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); proof = update_cache s_proof (Proof_global.freeze ~marshallable); - shallow = marshallable = `Shallow } + shallow = false; + } let unfreeze_interp_state { system; proof } = do_if_not_cached s_cache States.unfreeze system; do_if_not_cached s_proof Proof_global.unfreeze proof + +let make_shallow st = + let lib = States.lib_of_state st.system in + { st with + system = States.replace_lib st.system @@ Lib.drop_objects lib; + shallow = true; + } diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index b4d478d12d..ed20cb935a 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -14,8 +14,10 @@ type t = { shallow : bool (* is the state trimmed down (libstack) *) } -val freeze_interp_state : Summary.marshallable -> t +val freeze_interp_state : marshallable:bool -> t val unfreeze_interp_state : t -> unit +val make_shallow : t -> t + (* WARNING: Do not use, it will go away in future releases *) val invalidate_cache : unit -> unit |